* made assembler accept integers (instead of fixnums) as immediates.
This commit is contained in:
Abdulaziz Ghuloum
parent
d04dd79b81
commit
f5d870f23b
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
510
src/libcogen1.ss
510
src/libcogen1.ss
|
|
@ -172,6 +172,7 @@
|
|||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (Expr rator) (map Expr arg*))]
|
||||
[(appcall rator arg*)
|
||||
(error 'new-cogen "appcall not supported yet")
|
||||
(make-appcall (Expr rator) (map Expr arg*))]
|
||||
[(mvcall rator k)
|
||||
(make-mvcall (Expr rator) (Clambda k))]
|
||||
|
|
@ -197,336 +198,214 @@
|
|||
;;;
|
||||
(Program x))
|
||||
|
||||
;;;
|
||||
;;; So, what do we want to do here?
|
||||
;;; 1. we eliminate all variables:
|
||||
;;; bind should become a sequence of (setfv i <value>) statements
|
||||
;;; variable refs should befome (fv i) where i is the index of
|
||||
;;; the var on the stack.
|
||||
;;; 2. we need to keep track of the maximum stack size used; and
|
||||
;;; whether we made a procedure call so that we can insert a
|
||||
;;; stack overflow check with an appropriate size check.
|
||||
;;; 3. as we generate code, we need to keep track of which stack
|
||||
;;; locations contain pointers so that procedure calls can
|
||||
;;; set an appropriate mask.
|
||||
;;; 4. primitives that allocate, as well as closures and fixes
|
||||
;;; should insert an appropriate alloc-check marks as well as
|
||||
;;; keep the live masks for the later generation of trap handlers
|
||||
;;; 5. primcalls should also keep track of liveness information
|
||||
;;; and frame size just in case the primitive needs to make a
|
||||
;;; procedure call.
|
||||
|
||||
|
||||
(define-record move (src dst))
|
||||
(define-record alloc-check (n si live))
|
||||
(define-record fvar (idx))
|
||||
(define acr '%acr)
|
||||
(define-record cpvar (idx))
|
||||
(define-record cmp (op v0 v1))
|
||||
(define false-object 'false-object)
|
||||
|
||||
(define (new-cogen-pass1 x)
|
||||
(define (eliminate-fix x)
|
||||
;;;
|
||||
(define who 'new-cogen-pass-1)
|
||||
(define who 'eliminate-fix)
|
||||
;;;
|
||||
(define (fxeven? x)
|
||||
(if (fixnum? x)
|
||||
($fxzero? ($fxlogand x 1))
|
||||
(error 'fxeven? "~s is not a fixnum" x)))
|
||||
;;;
|
||||
(define (sum ls)
|
||||
(let f ([ls ls] [n 0])
|
||||
(cond
|
||||
[(null? ls) n]
|
||||
[else (f (cdr ls) (fx+ (car ls) n))])))
|
||||
;;;
|
||||
(define fxmax
|
||||
(case-lambda
|
||||
[(x y) (if (fx> x y) x y)]
|
||||
[(x y z) (fxmax x (fxmax y z))]
|
||||
[_ (error 'fxmax "unhandled")]))
|
||||
;;;
|
||||
(define (do-seq e0 si live env e1 k)
|
||||
(let-values ([(e0 msi0 call0?)
|
||||
(Effect e0 si live env)])
|
||||
(let-values ([(e1 msi1 call1?)
|
||||
(k e1 si live env)])
|
||||
(values (make-seq e0 e1)
|
||||
(fxmax msi0 msi1)
|
||||
(or call0? call1?)))))
|
||||
;;;
|
||||
(define (do-cond e0 si live env e1 e2 k)
|
||||
(let-values ([(e0 msi0 call0?)
|
||||
(Pred e0 si live env)])
|
||||
(let-values ([(e1 msi1 call1?)
|
||||
(k e1 si live env)]
|
||||
[(e2 msi2 call2?)
|
||||
(k e2 si live env)])
|
||||
(values (make-conditional e0 e1 e2)
|
||||
(fxmax msi0 msi1 msi2)
|
||||
(or call0? call1? call2?)))))
|
||||
;;;
|
||||
(define (do-move-to-mem loc expr si live env)
|
||||
(record-case expr
|
||||
[(constant)
|
||||
(values (make-move expr loc) 0 #f)]
|
||||
[else
|
||||
(let-values ([(x msi call?)
|
||||
(Value expr si live env)])
|
||||
(values (make-seq x (make-move acr loc)) msi call?))]))
|
||||
;;;
|
||||
(define (do-bind lhs* rhs* si live env0 env body k)
|
||||
(cond
|
||||
[(null? lhs*)
|
||||
(k body si live env)]
|
||||
[else
|
||||
(let ([fv (make-fvar si)])
|
||||
(let-values ([(e0 msi0 call0?)
|
||||
(do-move-to-mem fv (car rhs*) si live env0)])
|
||||
(let-values ([(e1 msi1 call1?)
|
||||
(do-bind (cdr lhs*) (cdr rhs*)
|
||||
(fxadd1 si)
|
||||
(cons si live)
|
||||
env0
|
||||
(cons (cons (car lhs*) fv) env)
|
||||
body
|
||||
k)])
|
||||
(values (make-seq e0 e1)
|
||||
(fxmax msi0 msi1)
|
||||
(or call0? call1?)))))]))
|
||||
;;;
|
||||
(define (align n)
|
||||
(cond
|
||||
[(fxeven? n) n]
|
||||
[else (fxadd1 n)]))
|
||||
;;;
|
||||
(define (extend-env* lhs* si live env)
|
||||
(let f ([lhs* lhs*] [si si] [live live] [env env] [nlhs* '()])
|
||||
(cond
|
||||
[(null? lhs*)
|
||||
(values nlhs* si live env)]
|
||||
[else
|
||||
(let ([fv (make-fvar si)])
|
||||
(f (cdr lhs*) (fxadd1 si) (cons si live)
|
||||
(cons (cons (car lhs*) fv) env)
|
||||
(cons fv nlhs*)))])))
|
||||
;;;
|
||||
(define (insert-const-alloc-check n si live rest)
|
||||
(cond
|
||||
[(fxzero? n) rest]
|
||||
[else
|
||||
(make-seq
|
||||
(make-alloc-check n si live)
|
||||
rest)]))
|
||||
;;;
|
||||
(define (construct-closures n* lhs* nlhs* rhs* body)
|
||||
(cond
|
||||
[(null? lhs*) body]
|
||||
[else
|
||||
(make-seq 'FIXME:construct-closures body)]))
|
||||
;;;
|
||||
(define (do-fix lhs* rhs* si live env body k)
|
||||
(define (compute-closure-size x)
|
||||
(record-case x
|
||||
[(closure label free*)
|
||||
(align (fxadd1 (length free*)))]))
|
||||
(let ([n* (map compute-closure-size rhs*)])
|
||||
(let ([n (sum n*)])
|
||||
(let-values ([(nlhs* si live env)
|
||||
(extend-env* lhs* si live env)])
|
||||
(let-values ([(x msi call?)
|
||||
(k body si live env)])
|
||||
(values (insert-const-alloc-check n si live
|
||||
(construct-closures n* lhs* nlhs* rhs* x))
|
||||
msi call?))))))
|
||||
;;;
|
||||
(define (constant-rep x)
|
||||
'FIXME:constant-rep)
|
||||
;;;
|
||||
(define (do-closure label free* si live env)
|
||||
'FIXME:do-closure)
|
||||
;;;
|
||||
(define (do-forcall x si live env)
|
||||
(values 'FIXME:do-forcall si #f))
|
||||
;;;
|
||||
(define (do-tail-funcall x si live env)
|
||||
(values 'FIXME:do-tail-funcall si #f))
|
||||
;;;
|
||||
(define (do-tail-appcall x si live env)
|
||||
(values 'FIXME:do-tail-appcall si #f))
|
||||
;;;
|
||||
(define (do-tail-jmpcall x si live env)
|
||||
(values 'FIXME:do-tail-jmpcall si #f))
|
||||
;;;
|
||||
(define (do-effect-funcall x si live env)
|
||||
(values 'FIXME:do-effect-funcall si #f))
|
||||
;;;
|
||||
(define (do-effect-appcall x si live env)
|
||||
(values 'FIXME:do-effect-appcall si #f))
|
||||
;;;
|
||||
(define (do-effect-jmpcall x si live env)
|
||||
(values 'FIXME:do-effect-jmpcall si #f))
|
||||
;;;
|
||||
(define (do-value-funcall x si live env)
|
||||
(values 'FIXME:do-value-funcall si #f))
|
||||
;;;
|
||||
(define (do-value-appcall x si live env)
|
||||
(values 'FIXME:do-value-appcall si #f))
|
||||
;;;
|
||||
(define (do-value-jmpcall x si live env)
|
||||
(values 'FIXME:do-value-jmpcall si #f))
|
||||
;;;
|
||||
(define (do-mvcall x si live env k)
|
||||
(values 'FIXME:do-mvcall si #t))
|
||||
;;;
|
||||
(define (Var x env)
|
||||
(cond
|
||||
[(assq x env) => cdr]
|
||||
[else (error who "unbound var ~s" x)]))
|
||||
;;;
|
||||
(define (Primref x)
|
||||
'FIXME:primref)
|
||||
;;;
|
||||
(define (Value x si live env)
|
||||
(define (make-closure x)
|
||||
(record-case x
|
||||
[(constant t)
|
||||
(values (make-move (constant-rep t) acr) 0 #f)]
|
||||
[(var)
|
||||
(values (make-move (Var x env) acr) 0 #f)]
|
||||
[(primref)
|
||||
(values (make-move (Primref x) acr) 0 #f)]
|
||||
[(bind lhs* rhs* body)
|
||||
(do-bind lhs* rhs* si live env env body Value)]
|
||||
[(fix lhs* rhs* body)
|
||||
(do-fix lhs* rhs* si live env body Value)]
|
||||
[(conditional e0 e1 e2)
|
||||
(do-cond e0 si live env e1 e2 Value)]
|
||||
[(seq e0 e1) (do-seq e0 si live env e1 Value)]
|
||||
[(closure label free*)
|
||||
(values (do-closure label free* si live env) 0 #f)]
|
||||
[(forcall) (do-forcall x si live env)]
|
||||
[(funcall) (do-value-funcall x si live env)]
|
||||
[(jmpcall) (do-value-jmpcall x si live env)]
|
||||
[(appcall) (do-value-appcall x si live env)]
|
||||
[(mvcall) (do-mvcall x si live env Value)]
|
||||
[else (error who "invalid value expr ~s" x)]))
|
||||
[(closure code free*)
|
||||
(cond
|
||||
[(null? free*) x]
|
||||
[else
|
||||
(make-prim 'make-closure
|
||||
(list code (make-constant (length free*))))])]))
|
||||
;;;
|
||||
(define (Pred x si live env)
|
||||
(record-case x
|
||||
[(constant t)
|
||||
(values (if t #t #f) 0 #f)]
|
||||
[(var) (values (make-cmp 'neq (Var x env) false-object) 0 #f)]
|
||||
[(primref) (values #t 0 #f)]
|
||||
[(bind lhs* rhs* body)
|
||||
(do-bind lhs* rhs* si live env env body Pred)]
|
||||
[(fix lhs* rhs* body)
|
||||
(do-fix lhs* rhs* si live env body Pred)]
|
||||
[(conditional e0 e1 e2)
|
||||
(do-cond e0 si live env e1 e2 Pred)]
|
||||
[(seq e0 e1) (do-seq e0 si live env e1 Pred)]
|
||||
[(closure label free*) (values #t 0 #f)]
|
||||
[(forcall)
|
||||
(let-values ([(x msi call?) (Value x si live env)])
|
||||
(values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
|
||||
[(funcall)
|
||||
(let-values ([(x msi call?) (Value x si live env)])
|
||||
(values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
|
||||
[(jmpcall)
|
||||
(let-values ([(x msi call?) (Value x si live env)])
|
||||
(values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
|
||||
[(appcall)
|
||||
(let-values ([(x msi call?) (Value x si live env)])
|
||||
(values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
|
||||
[(mvcall) (do-mvcall x si live env Pred)]
|
||||
[else (error who "invalid pred expr ~s" x)]))
|
||||
(define (closure-sets var x)
|
||||
(record-case x
|
||||
[(closure code free*)
|
||||
(let f ([i 0] [free* free*])
|
||||
(cond
|
||||
[(null? free*) (make-primcall 'void '())]
|
||||
[else
|
||||
(make-seq
|
||||
(make-primcall 'closure-set!
|
||||
(list var (make-constant i) (car free*)))
|
||||
(f (fxadd1 i) (cdr free*)))]))]))
|
||||
;;;
|
||||
(define (Effect x si live env)
|
||||
(record-case x
|
||||
[(constant) (values 'nop 0 #f)]
|
||||
[(var) (values 'nop 0 #f)]
|
||||
[(primref) (values 'nop 0 #f)]
|
||||
[(bind lhs* rhs* body)
|
||||
(do-bind lhs* rhs* si live env env body Effect)]
|
||||
[(fix lhs* rhs* body)
|
||||
(do-fix lhs* rhs* si live env body Effect)]
|
||||
[(conditional e0 e1 e2)
|
||||
(do-cond e0 si live env e1 e2 Effect)]
|
||||
[(seq e0 e1) (do-seq e0 si live env e1 Effect)]
|
||||
[(closure label free*) (values 'nop 0 #f)]
|
||||
[(forcall) (do-forcall x si live env)]
|
||||
[(funcall) (do-effect-funcall x si live env)]
|
||||
[(jmpcall) (do-effect-jmpcall x si live env)]
|
||||
[(appcall) (do-effect-appcall x si live env)]
|
||||
[(mvcall) (do-mvcall x si live env Tail)]
|
||||
[else (error who "invalid effect expr ~s" x)]))
|
||||
;;;
|
||||
(define (Tail x si live env)
|
||||
(record-case x
|
||||
[(constant) (values x si #f)]
|
||||
[(var) (values (Var x env) si #f)]
|
||||
[(primref) (values x si #f)]
|
||||
[(bind lhs* rhs* body)
|
||||
(do-bind lhs* rhs* si live env env body Tail)]
|
||||
[(fix lhs* rhs* body)
|
||||
(do-fix lhs* rhs* si live env body Tail)]
|
||||
[(conditional e0 e1 e2)
|
||||
(do-cond e0 si live env e1 e2 Tail)]
|
||||
[(seq e0 e1) (do-seq e0 si live env e1 Tail)]
|
||||
[(closure label free*)
|
||||
(values (do-closure label free* si live env) si #f)]
|
||||
[(forcall)
|
||||
(let-values ([(x msi call?) (do-forcall x si live env)])
|
||||
(values x msi call?))]
|
||||
[(funcall) (do-tail-funcall x si live env)]
|
||||
[(jmpcall) (do-tail-jmpcall x si live env)]
|
||||
[(appcall) (do-tail-appcall x si live env)]
|
||||
[(mvcall) (do-mvcall x si live env Tail)]
|
||||
[else (error who "invalid tail expr ~s" x)]))
|
||||
;;;
|
||||
(define (MainTail x si live env)
|
||||
(let-values ([(x msi call?)
|
||||
(Tail x si live env)])
|
||||
(if call?
|
||||
(make-seq 'FIXME:stack-overflow-check x)
|
||||
x)))
|
||||
(define (ClambdaCase free*)
|
||||
(define (bind-free ls)
|
||||
(let f ([ls ls] [i 0] [env '()])
|
||||
(define (do-fix lhs* rhs* body)
|
||||
(make-bind lhs*
|
||||
(map make-closure rhs*)
|
||||
(let f ([lhs* lhs*] [rhs* rhs*])
|
||||
(cond
|
||||
[(null? ls) env]
|
||||
[(null? lhs*) body]
|
||||
[else
|
||||
(f (cdr ls) (fxadd1 i)
|
||||
(cons (cons (car ls) (make-cpvar i)) env))])))
|
||||
(define (do-info x env)
|
||||
(record-case x
|
||||
[(case-info label args proper)
|
||||
(let f ([ls args] [env env] [si 0] [live '()])
|
||||
(cond
|
||||
[(null? ls) (values env si live)]
|
||||
[else
|
||||
(let ([fv (make-fvar si)])
|
||||
(f (cdr ls)
|
||||
(cons (cons (car ls) fv) env)
|
||||
(fxadd1 si)
|
||||
(cons si live)))]))]))
|
||||
(let ([env (bind-free free*)])
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
[(clambda-case info body)
|
||||
(let-values ([(env si live) (do-info info env)])
|
||||
(make-clambda-case info (MainTail body si live env)))]
|
||||
[else (error who "invalid clambda-case ~s" x)]))))
|
||||
(make-seq
|
||||
(closure-sets (car lhs*) (car rhs*))
|
||||
(f (cdr lhs*) (cdr rhs*)))]))))
|
||||
;;;
|
||||
(define (Expr x)
|
||||
(record-case x
|
||||
[(constant) x]
|
||||
[(var) x]
|
||||
[(primref) x]
|
||||
[(bind lhs* rhs* body)
|
||||
(make-bind lhs* (map Expr rhs*) (Expr body))]
|
||||
[(fix lhs* rhs* body)
|
||||
(do-fix lhs* rhs* (Expr body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (Expr e0) (Expr e1) (Expr e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (Expr e0) (Expr e1))]
|
||||
[(closure)
|
||||
(let ([t (unique-var 'tmp)])
|
||||
(Expr (make-fix (list t) (list x) t)))]
|
||||
[(primcall op arg*)
|
||||
(make-appcall (make-primref op) (map Expr arg*))]
|
||||
[(forcall op arg*)
|
||||
(make-forcall op (map Expr arg*))]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (Expr rator) (map Expr arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (Expr rator) (map Expr arg*))]
|
||||
[(appcall rator arg*)
|
||||
(error who "appcall not supported yet")
|
||||
(make-appcall (Expr rator) (map Expr arg*))]
|
||||
[(mvcall rator k)
|
||||
(make-mvcall (Expr rator) (Clambda k))]
|
||||
[else (error who "invalid expr ~s" x)]))
|
||||
;;;
|
||||
(define (ClambdaCase x)
|
||||
(record-case x
|
||||
[(clambda-case info body)
|
||||
(make-clambda-case info (Expr body))]
|
||||
[else (error who "invalid clambda-case ~s" x)]))
|
||||
;;;
|
||||
(define (Clambda x)
|
||||
(record-case x
|
||||
[(clambda label case* free*)
|
||||
(make-clambda label (map (ClambdaCase free*) case*) free*)]
|
||||
(make-clambda label (map ClambdaCase case*) free*)]
|
||||
[else (error who "invalid clambda ~s" x)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(record-case x
|
||||
[(codes code* body)
|
||||
(make-codes (map Clambda code*) (MainTail body 0 '() '()))]
|
||||
(make-codes (map Clambda code*) (Expr body))]
|
||||
[else (error who "invalid program ~s" x)]))
|
||||
;;;
|
||||
(Program x))
|
||||
|
||||
|
||||
(define (specify-representation x)
|
||||
(define who 'specify-representation)
|
||||
;;;
|
||||
(define nop (make-primcall 'nop '()))
|
||||
;;;
|
||||
(define (constant-rep x)
|
||||
(let ([c (constant-value x)])
|
||||
(cond
|
||||
[(fixnum? c) (* c fixnum-scale)]
|
||||
[(boolean? c) (if c bool-t bool-f)]
|
||||
[(void? c) void-object]
|
||||
[(bwp? c) bwp-object]
|
||||
[(char? c) (fxlogor (fxsll (char->integer c) char-shift)
|
||||
char-tag)]
|
||||
[(null? c) nil]
|
||||
[else x])))
|
||||
;;;
|
||||
(define (Effect x)
|
||||
(record-case x
|
||||
[(constant c) nop]
|
||||
[(var) nop]
|
||||
[(primref) nop]
|
||||
[(closure code free*) nop]
|
||||
[(bind lhs* rhs* body)
|
||||
(make-bind lhs* (map Value rhs*) (Effect body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (Pred e0) (Effect e1) (Effect e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (Effect e0) (Effect e1))]
|
||||
[(primcall op arg*)
|
||||
(error who "effect prim ~a not supported" op)]
|
||||
[(forcall op arg*)
|
||||
(error who "effect forcall not supported" op)]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (Value rator) (map Value arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (Value rator) (map Value arg*))]
|
||||
[(appcall rator arg*)
|
||||
(error who "appcall not supported yet")]
|
||||
[(mvcall rator x)
|
||||
(make-mvcall (Value rator) (Clambda x Effect))]
|
||||
[else (error who "invalid pred expr ~s" x)]))
|
||||
;;;
|
||||
(define (Pred x)
|
||||
(record-case x
|
||||
[(constant c) (if c #t #f)]
|
||||
[(var) (mkprm '!= (list x bool-f))]
|
||||
[(primref) #t]
|
||||
[(closure code free*) #t]
|
||||
[(bind lhs* rhs* body)
|
||||
(make-bind lhs* (map Value rhs*) (Pred body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (Pred e0) (Pred e1) (Pred e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (Effect e0) (Pred e1))]
|
||||
[(primcall op arg*)
|
||||
(error who "pred prim ~a not supported" op)]
|
||||
[(forcall op arg*)
|
||||
(error who "pred forcall not supported" op)]
|
||||
[(funcall rator arg*)
|
||||
(mkprm '!=
|
||||
(list (make-funcall (Value rator) (map Value arg*))
|
||||
bool-f))]
|
||||
[(jmpcall label rator arg*)
|
||||
(mkprm '!=
|
||||
(list (make-jmpcall label (Value rator) (map Value arg*))
|
||||
bool-f))]
|
||||
[(appcall rator arg*)
|
||||
(error who "appcall not supported yet")]
|
||||
[(mvcall rator x)
|
||||
(make-mvcall (Value rator) (Clambda x Pred))]
|
||||
[else (error who "invalid pred expr ~s" x)]))
|
||||
;;;
|
||||
(define (Value x)
|
||||
(record-case x
|
||||
[(constant) (constant-rep x)]
|
||||
[(var) x]
|
||||
[(primref) x]
|
||||
[(bind lhs* rhs* body)
|
||||
(make-bind lhs* (map Value rhs*) (Value body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (Pred e0) (Value e1) (Value e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (Effect e0) (Value e1))]
|
||||
[(primcall op arg*)
|
||||
(error who "value prim ~a not supported" op)]
|
||||
[(forcall op arg*)
|
||||
(error who "value forcall not supported" op)]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (Value rator) (map Value arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (Value rator) (map Value arg*))]
|
||||
[(appcall rator arg*)
|
||||
(error who "appcall not supported yet")]
|
||||
[(mvcall rator x)
|
||||
(make-mvcall (Value rator) (Clambda x Value))]
|
||||
[else (error who "invalid value expr ~s" x)]))
|
||||
;;;
|
||||
(define (ClambdaCase x k)
|
||||
(record-case x
|
||||
[(clambda-case info body)
|
||||
(make-clambda-case info (k body))]
|
||||
[else (error who "invalid clambda-case ~s" x)]))
|
||||
;;;
|
||||
(define (Clambda x k)
|
||||
(record-case x
|
||||
[(clambda label case* free*)
|
||||
(make-clambda label
|
||||
(map (lambda (x) (ClambdaCase x k)) case*)
|
||||
free*)]
|
||||
[else (error who "invalid clambda ~s" x)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(record-case x
|
||||
[(codes code* body)
|
||||
(make-codes
|
||||
(map (lambda (x) (Clambda x Value)) code*)
|
||||
(Value body))]
|
||||
[else (error who "invalid program ~s" x)]))
|
||||
;;;
|
||||
(Program x))
|
||||
|
|
@ -534,11 +413,12 @@
|
|||
|
||||
|
||||
|
||||
|
||||
(define (new-cogen x)
|
||||
(verify-new-cogen-input x)
|
||||
(let ([x (remove-primcalls x)])
|
||||
(new-cogen-pass1 x)))
|
||||
(let* ([x (remove-primcalls x)]
|
||||
[x (eliminate-fix x)]
|
||||
[x (specify-representation x)])
|
||||
x))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -263,7 +263,7 @@
|
|||
(define label-name
|
||||
(lambda (x) (cadr x)))
|
||||
|
||||
(define int? fixnum?)
|
||||
(define int? integer?)
|
||||
|
||||
(define obj?
|
||||
(lambda (x)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,153 @@
|
|||
#!/usr/bin/env ikarus --script
|
||||
(define (racompile x)
|
||||
;;;
|
||||
(define-syntax record-case
|
||||
(lambda (x)
|
||||
(define (enumerate fld* i)
|
||||
(syntax-case fld* ()
|
||||
[() #'()]
|
||||
[(x . x*)
|
||||
(with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
|
||||
#'(i . i*))]))
|
||||
(define (generate-body ctxt cls*)
|
||||
(syntax-case cls* (else)
|
||||
[() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v #'x))]
|
||||
[([else b b* ...]) #'(begin b b* ...)]
|
||||
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
|
||||
(with-syntax ([altern (generate-body ctxt #'rest)]
|
||||
[(id* ...) (enumerate #'(rec-field* ...) 0)]
|
||||
[rtd #'(type-descriptor rec-name)])
|
||||
#'(if (#%$record/rtd? v rtd)
|
||||
(let ([rec-field* (#%$record-ref v id*)] ...)
|
||||
b b* ...)
|
||||
altern))]))
|
||||
(syntax-case x ()
|
||||
[(_ expr cls* ...)
|
||||
(with-syntax ([body (generate-body #'_ #'(cls* ...))])
|
||||
#'(let ([v expr]) body))])))
|
||||
;;;
|
||||
(define-record constant (val))
|
||||
(define (mkconst v) (make-constant v))
|
||||
(define-record int (val))
|
||||
(define (mkint v) (make-int v))
|
||||
(define-record set (lhs rhs))
|
||||
(define (mkset x v) (make-set x v))
|
||||
(define-record reg (name))
|
||||
(define (mkreg x) (make-reg x))
|
||||
(define-record primcall (op rand*))
|
||||
(define (mkprm op . rand*) (make-primcall op rand*))
|
||||
(define-record seq (e0 e1))
|
||||
(define (mkseq e0 e1) (make-seq e0 e1))
|
||||
;;;
|
||||
(define (recordize x)
|
||||
(define who 'recordize)
|
||||
;;;
|
||||
(define (E x r)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(case (car x)
|
||||
[(quote) (mkconst (cadr x))]
|
||||
[else (error who "invalid expression ~s" x)])]
|
||||
[else (error who "invalid expression ~s" x)]))
|
||||
;;;
|
||||
(E x '()))
|
||||
;;;
|
||||
(define (specify-representation x)
|
||||
(define who 'specify-representation)
|
||||
;;;
|
||||
(define fixnum-scale 4)
|
||||
;;;
|
||||
(define (immediate? c)
|
||||
(or (fixnum? c)))
|
||||
;;;
|
||||
(define (immediate-rep c)
|
||||
(cond
|
||||
[(fixnum? c) (mkint (* c fixnum-scale))]
|
||||
[else (error 'immediate-rep "invalid ~s" c)]))
|
||||
;;;
|
||||
(define (Tail x)
|
||||
(record-case x
|
||||
[(constant c)
|
||||
(if (immediate? c)
|
||||
(immediate-rep c)
|
||||
x)]
|
||||
[else (error who "invalid tail ~s" x)]))
|
||||
;;;
|
||||
(Tail x))
|
||||
;;;
|
||||
(define (impose-calling-convention x)
|
||||
(define who 'impose-calling-convention)
|
||||
;;;
|
||||
(define rv-register (mkreg '%eax))
|
||||
;;;
|
||||
(define (Tail x)
|
||||
(record-case x
|
||||
[(constant c)
|
||||
(mkseq (mkset rv-register x)
|
||||
(mkprm 'return rv-register))]
|
||||
[else (error who "invalid tail ~s" x)]))
|
||||
;;;
|
||||
(Tail x))
|
||||
;;;
|
||||
(define (linearize x)
|
||||
(define who 'linearize)
|
||||
;;;
|
||||
(define (op x)
|
||||
(record-case x
|
||||
[(register r) r]
|
||||
[(constant c) `(obj ,c)]
|
||||
[(int i) `(int ,i)]
|
||||
;;;
|
||||
(define (Effect x ac)
|
||||
(record-case x
|
||||
[(seq e0 e1)
|
||||
(Effect e0 (Effect e1 ac))]
|
||||
[(set targ v)
|
||||
(cons `(movl ,(op v) ,(op targ)) ac)]
|
||||
[else (error who "invalid effect ~s" x)]))
|
||||
;;;
|
||||
(define (Tail x ac)
|
||||
(record-case x
|
||||
[(seq e0 e1)
|
||||
(Effect e0 (Tail e1 ac))]
|
||||
[(primcall op rands)
|
||||
(case op
|
||||
[(return)
|
||||
(cons '(ret) ac)]
|
||||
[else (error who "invalid tail prim ~s" op)])]
|
||||
[else (error who "invalid tail ~s" x)]))
|
||||
;;;
|
||||
(list (Tail x '())))
|
||||
;;;
|
||||
(define (compile x)
|
||||
(let* ([x (expand x)]
|
||||
[x (recordize x)]
|
||||
[x (specify-representation x)]
|
||||
[x (impose-calling-convention x)]
|
||||
[x* (linearize x)]
|
||||
[code (car (#%list*->code*
|
||||
(lambda (x) #f)
|
||||
x*))])
|
||||
((#%$code->closure code))))
|
||||
(compile x))
|
||||
|
||||
|
||||
|
||||
(define-syntax add-tests-with-string-output
|
||||
(syntax-rules (=>)
|
||||
[(_ name [expr* => str*] ...)
|
||||
(begin
|
||||
(printf "SECTION ~a ...\n" 'name)
|
||||
(let ([str str*]
|
||||
[expr 'expr*])
|
||||
(printf "testing ~s\n" expr)
|
||||
(let ([r (with-output-to-string
|
||||
(lambda ()
|
||||
(write (racompile expr))
|
||||
(newline)))])
|
||||
(unless (string=? r str)
|
||||
(error #f "expected ~s, got ~s\n" str r))))
|
||||
...)]))
|
||||
|
||||
(load "tests/tests-1.1-req.scm")
|
||||
|
||||
Loading…
Reference in New Issue