ikarus/src/libcompile.ss

5236 lines
188 KiB
Scheme

;;; 9.0: * calls (gensym <symbol>) instead of
;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing
;;; gensym-count.
;;; 6.7: * open-coded top-level-value, car, cdr
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(let ()
(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))])))
(include "set-operations.ss")
(define open-coded-primitives
;;; these primitives, when found in operator position with the correct
;;; number of arguments, will be open-coded by the generator. If an
;;; incorrect number of args is detected, or if they appear in non-operator
;;; position, then they cannot be open-coded, and the pcb-primitives table
;;; is consulted for a reference of the pcb slot containing the primitive.
;;; If it's not found there, an error is signalled.
;;;
;;; prim-name args
'([$constant-ref 1 value]
[$constant-set! 2 effect]
[$pcb-ref 1 value]
[$pcb-set! 2 effect]
;;; type predicates
[fixnum? 1 pred]
[immediate? 1 pred]
[boolean? 1 pred]
[char? 1 pred]
[pair? 1 pred]
[symbol? 1 pred]
[vector? 1 pred]
[string? 1 pred]
[procedure? 1 pred]
[null? 1 pred]
[eof-object? 1 pred]
[bwp-object? 1 pred]
[$unbound-object? 1 pred]
[$forward-ptr? 1 pred]
[not 1 pred]
[pointer-value 1 value]
[eq? 2 pred]
;;; fixnum primitives
[$fxadd1 1 value]
[$fxsub1 1 value]
[$fx+ 2 value]
[$fx- 2 value]
[$fx* 2 value]
[$fxsll 2 value]
[$fxsra 2 value]
[$fxlogand 2 value]
[$fxlogor 2 value]
[$fxlogxor 2 value]
[$fxlognot 1 value]
[$fxquotient 2 value]
[$fxmodulo 2 value]
;;; fixnum predicates
[$fxzero? 1 pred]
[$fx= 2 pred]
[$fx< 2 pred]
[$fx<= 2 pred]
[$fx> 2 pred]
[$fx>= 2 pred]
;;; character predicates
[$char= 2 pred]
[$char< 2 pred]
[$char<= 2 pred]
[$char> 2 pred]
[$char>= 2 pred]
;;; character conversion
[$fixnum->char 1 value]
[$char->fixnum 1 value]
;;; lists/pairs
[cons 2 value]
[list* positive value]
[list any value]
[car 1 value]
[cdr 1 value]
[$car 1 value]
[$cdr 1 value]
[$set-car! 2 effect]
[$set-cdr! 2 effect]
;;; vectors
[$make-vector 1 value]
[vector any value]
[$vector-length 1 value]
[$vector-ref 2 value]
[$vector-set! 3 effect]
;;; strings
[$make-string 1 value]
[$string any value]
[$string-length 1 value]
[$string-ref 2 value]
[$string-set! 3 effect]
;;; symbols
[$make-symbol 1 value]
[$symbol-value 1 value]
[$symbol-string 1 value]
[$symbol-unique-string 1 value]
[$set-symbol-value! 2 effect]
[$set-symbol-string! 2 effect]
[$set-symbol-unique-string! 2 effect]
[$symbol-plist 1 value]
[$set-symbol-plist! 2 effect]
[primitive-ref 1 value]
[primitive-set! 2 effect]
[top-level-value 1 value]
;;; ports
[port? 1 pred]
[input-port? 1 pred]
[output-port? 1 pred]
[$make-port/input 7 value]
[$make-port/output 7 value]
[$make-port/both 7 value]
[$port-handler 1 value]
[$port-input-buffer 1 value]
[$port-input-index 1 value]
[$port-input-size 1 value]
[$port-output-buffer 1 value]
[$port-output-index 1 value]
[$port-output-size 1 value]
[$set-port-input-index! 2 effect]
[$set-port-input-size! 2 effect]
[$set-port-output-index! 2 effect]
[$set-port-output-size! 2 effect]
;;; tcbuckets
[$make-tcbucket 4 value]
[$tcbucket-key 1 value]
[$tcbucket-val 1 value]
[$tcbucket-next 1 value]
[$set-tcbucket-val! 2 effect]
[$set-tcbucket-next! 2 effect]
[$set-tcbucket-tconc! 2 effect]
;;; misc
[eof-object 0 value]
[void 0 value]
[$exit 1 effect]
[$fp-at-base 0 pred]
[$current-frame 0 value]
[$arg-list 0 value]
[$seal-frame-and-call 1 tail]
[$frame->continuation 1 value]
[$interrupted? 0 pred]
[$unset-interrupted! 0 effect]
;;;
;;; records
;;;
[$make-record 2 value]
[$record? 1 pred]
[$record/rtd? 2 pred]
[$record-rtd 1 value]
[$record-ref 2 value]
[$record-set! 3 effect]
[$record any value]
;;;
;;; asm
;;;
[$code? 1 pred]
[$code-size 1 value]
[$code-reloc-vector 1 value]
[$code-freevars 1 value]
[$code-ref 2 value]
[$code-set! 3 value]
[$code->closure 1 value]
[$closure-code 1 value]
;;;
[$make-call-with-values-procedure 0 value]
[$make-values-procedure 0 value]
))
(define (primitive-context x)
(cond
[(assq x open-coded-primitives) => caddr]
[else (error 'primitive-context "unknown prim ~s" x)]))
(define (open-codeable? x)
(cond
[(assq x open-coded-primitives) #t]
[else #f]))
(define (open-coded-primitive-args x)
(cond
[(assq x open-coded-primitives) => cadr]
[else (error 'open-coded-primitive-args "invalid ~s" x)]))
;;; end of primitives table section
(define-record constant (value))
(define-record code-loc (label))
(define-record foreign-label (label))
(define-record var (name assigned referenced))
(define-record cp-var (idx))
(define-record frame-var (idx))
(define-record new-frame (base-idx size body))
(define-record save-cp (loc))
(define-record eval-cp (check body))
(define-record return (value))
(define-record call-cp
(call-convention label save-cp? rp-convention base-idx arg-count live-mask))
(define-record tailcall-cp (convention label arg-count))
(define-record primcall (op arg*))
(define-record primref (name))
(define-record conditional (test conseq altern))
(define-record interrupt-call (test handler))
(define-record bind (lhs* rhs* body))
(define-record recbind (lhs* rhs* body))
(define-record fix (lhs* rhs* body))
(define-record seq (e0 e1))
(define-record case-info (label args proper))
(define-record clambda-case (info body))
(define-record clambda (label cases free))
(define-record closure (code free*))
(define-record funcall (op rand*))
(define-record jmpcall (label op rand*))
(define-record forcall (op rand*))
(define-record codes (list body))
(define-record assign (lhs rhs))
(define-record mvcall (producer consumer))
(define-record fvar (idx))
(define-record set (lhs rhs))
(define-record object (val))
(define-record locals (vars body))
(define-record nframe (vars live body))
(define-record nfvar (conf loc))
(define-record ntcall (target value args mask size))
(define-record asm-instr (op dst src))
(define-record disp (s0 s1))
(define mkfvar
(let ([cache '()])
(lambda (i)
(cond
[(fixnum? i)
(cond
[(assv i cache) => cdr]
[else
(let ([fv (make-fvar i)])
(set! cache (cons (cons i fv) cache))
fv)])]
[else (error 'mkfvar "~s is not a fixnum" i)]))))
(define (unique-var x)
(make-var (gensym x) #f #f))
(define (recordize x)
(define *cookie* (gensym))
(define (gen-fml* fml*)
(cond
[(pair? fml*)
(let ([v (unique-var (car fml*))])
(putprop (car fml*) *cookie* v)
(cons v (gen-fml* (cdr fml*))))]
[(symbol? fml*)
(let ([v (unique-var fml*)])
(putprop fml* *cookie* v)
v)]
[else '()]))
(define (ungen-fml* fml*)
(cond
[(pair? fml*)
(remprop (car fml*) *cookie*)
(ungen-fml* (cdr fml*))]
[(symbol? fml*)
(remprop fml* *cookie*)]))
(define (properize fml*)
(cond
[(pair? fml*)
(cons (car fml*) (properize (cdr fml*)))]
[(null? fml*) '()]
[else (list fml*)]))
(define (quoted-sym x)
(if (and (list? x)
(fx= (length x) 2)
(eq? 'quote (car x))
(symbol? (cadr x)))
(cadr x)
(error 'quoted-sym "not a quoted symbol ~s" x)))
(define (quoted-string x)
(if (and (list? x)
(fx= (length x) 2)
(eq? 'quote (car x))
(string? (cadr x)))
(cadr x)
(error 'quoted-string "not a quoted string ~s" x)))
(define (Var x)
(or (getprop x *cookie*)
(error 'recordize "unbound ~s" x)))
(define (E x)
(cond
[(pair? x)
(case (car x)
[(quote) (make-constant (cadr x))]
[(if)
(make-conditional
(E (cadr x))
(E (caddr x))
(E (cadddr x)))]
[(set!)
(let ([lhs (cadr x)] [rhs (caddr x)])
(make-assign (Var lhs) (E rhs)))]
[(begin)
(let f ([a (E (cadr x))] [d (cddr x)])
(cond
[(null? d) a]
[else
(f (make-seq a (E (car d))) (cdr d))]))]
[(letrec)
(let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)])
(let ([nlhs* (gen-fml* lhs*)])
(let ([expr (make-recbind nlhs* (map E rhs*) (E body ))])
(ungen-fml* lhs*)
expr))))]
[(case-lambda)
(let ([cls*
(map
(lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)])
(let ([body (E body)])
(ungen-fml* fml*)
(make-clambda-case
(make-case-info
(gensym)
(properize nfml*)
(list? fml*))
body)))))
(cdr x))])
(make-clambda (gensym) cls* #f))]
[(foreign-call)
(let ([name (quoted-string (cadr x))] [arg* (cddr x)])
(make-forcall name (map E arg*)))]
[(|#primitive|)
(let ([var (cadr x)])
(make-primref var))]
[(top-level-value)
(let ([var (quoted-sym (cadr x))])
(if (eq? (expand-mode) 'bootstrap)
(error 'compile "reference to ~s in bootstrap mode" var)
(make-funcall
(make-primref 'top-level-value)
(list (make-constant var)))))]
[(set-top-level-value!)
(make-funcall (make-primref 'set-top-level-value!)
(map E (cdr x)))]
[(void)
(make-constant (void))]
[else
(make-funcall (E (car x)) (map E (cdr x)))])]
[(symbol? x) (Var x)]
[else (error 'recordize "invalid expression ~s" x)]))
(E x))
(define (unparse x)
(define (E-args proper x)
(if proper
(map E x)
(let f ([a (car x)] [d (cdr x)])
(cond
[(null? d) (E a)]
[else (cons (E a) (f (car d) (cdr d)))]))))
(define (E x)
(record-case x
[(constant c) `(quote ,c)]
[(code-loc x) `(code-loc ,x)]
[(var x) (string->symbol (format "v:~a" x))]
[(primref x) x]
[(conditional test conseq altern)
`(if ,(E test) ,(E conseq) ,(E altern))]
[(interrupt-call e0 e1)
`(interrupt-call ,(E e0) ,(E e1))]
[(primcall op arg*) `(,op . ,(map E arg*))]
[(bind lhs* rhs* body)
`(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))]
[(recbind lhs* rhs* body)
`(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))]
[(fix lhs* rhs* body)
`(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))]
[(seq e0 e1)
(let ()
(define (f x ac)
(record-case x
[(seq e0 e1) (f e0 (f e1 ac))]
[else (cons (E x) ac)]))
(cons 'begin (f e0 (f e1 '()))))]
[(clambda-case info body)
`(,(E-args (case-info-proper info)
(case-info-args info))
,(E body))]
[(clambda g cls* free)
`(,g (case-lambda . ,(map E cls*)))]
[(clambda label clauses free)
`(code ,label . ,(map E clauses))]
[(closure code free*)
`(closure ,(E code) ,(map E free*))]
[(codes list body)
`(codes ,(map E list)
,(E body))]
[(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
[(jmpcall label rator rand*)
`(jmpcall ,label ,(E rator) . ,(map E rand*))]
[(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
[(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
[(return x) `(return ,(E x))]
[(new-frame base-idx size body)
`(new-frame [base: ,base-idx]
[size: ,size]
,(E body))]
[(frame-var idx)
(string->symbol (format "fv.~a" idx))]
[(cp-var idx)
(string->symbol (format "cp.~a" idx))]
[(save-cp expr)
`(save-cp ,(E expr))]
[(eval-cp check body)
`(eval-cp ,check ,(E body))]
[(call-cp call-convention label save-cp? rp-convention base-idx arg-count live-mask)
`(call-cp [conv: ,call-convention]
[label: ,label]
[rpconv: ,(if (symbol? rp-convention)
rp-convention
(E rp-convention))]
[base-idx: ,base-idx]
[arg-count: ,arg-count]
[live-mask: ,live-mask])]
[(tailcall-cp convention label arg-count)
`(tailcall-cp ,convention ,label ,arg-count)]
[(foreign-label x) `(foreign-label ,x)]
[(mvcall prod cons) `(mvcall ,(E prod) ,(E cons))]
[(set lhs rhs) `(set ,(E lhs) ,(E rhs))]
[(fvar idx) (string->symbol (format "fv.~a" idx))]
[(locals vars body) `(locals ,(map E vars) ,(E body))]
[(nframe vars live body) `(nframe [vars: ,(map E vars)]
[live: ,(map E live)]
,(E body))]
[else x]))
(E x))
(define open-mvcalls (make-parameter #t))
(define (optimize-direct-calls x)
(define who 'optimize-direct-calls)
(define (make-conses ls)
(cond
[(null? ls) (make-constant '())]
[else
(make-primcall 'cons
(list (car ls) (make-conses (cdr ls))))]))
(define (properize lhs* rhs*)
(cond
[(null? lhs*) (error who "improper improper")]
[(null? (cdr lhs*))
(list (make-conses rhs*))]
[else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
(define (inline-case cls rand*)
(record-case cls
[(clambda-case info body)
(record-case info
[(case-info label fml* proper)
(if proper
(and (fx= (length fml*) (length rand*))
(make-bind fml* rand* body))
(and (fx<= (length fml*) (length rand*))
(make-bind fml* (properize fml* rand*) body)))])]))
(define (try-inline cls* rand* default)
(cond
[(null? cls*) default]
[(inline-case (car cls*) rand*)]
[else (try-inline (cdr cls*) rand* default)]))
(define (inline rator rand*)
(define (valid-mv-consumer? x)
(record-case x
[(clambda L cases F)
(and (fx= (length cases) 1)
(record-case (car cases)
[(clambda-case info body)
(record-case info
[(case-info L args proper) proper])]))]
[else #f]))
(define (single-value-consumer? x)
(record-case x
[(clambda L cases F)
(and (fx= (length cases) 1)
(record-case (car cases)
[(clambda-case info body)
(record-case info
[(case-info L args proper)
(and proper (fx= (length args) 1))])]))]
[else #f]))
(define (valid-mv-producer? x)
(record-case x
[(funcall) #t]
[(conditional) #f]
[(bind lhs* rhs* body) (valid-mv-producer? body)]
[else (error 'valid-mv-producer? "unhandles ~s"
(unparse x))]))
(record-case rator
[(clambda g cls*)
(try-inline cls* rand*
(make-funcall rator rand*))]
[(primref op)
(case op
;;; FIXME HERE
[(call-with-values)
(cond
[(and (open-mvcalls) (fx= (length rand*) 2))
(let ([producer (inline (car rand*) '())]
[consumer (cadr rand*)])
(cond
[(single-value-consumer? consumer)
(inline consumer (list producer))]
[(and (valid-mv-consumer? consumer)
(valid-mv-producer? producer))
(make-mvcall producer consumer)]
[else
(make-funcall rator rand*)]))]
[else
(make-funcall rator rand*)])]
[else
(make-funcall rator rand*)])]
[else (make-funcall rator rand*)]))
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(recbind lhs* rhs* body)
(make-recbind lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional
(Expr test)
(Expr conseq)
(Expr altern))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(clambda g cls*)
(make-clambda g
(map (lambda (x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]))
cls*)
#f)]
[(primcall rator rand*)
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(inline (Expr rator) (map Expr rand*))]
[(forcall rator rand*)
(make-forcall rator (map Expr rand*))]
[(assign lhs rhs)
(make-assign lhs (Expr rhs))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define lambda-both 0)
(define lambda-producer 0)
(define lambda-consumer 0)
(define lambda-none 0)
(define branching-producer 0)
(define (analyze-cwv x)
(define who 'analyze-cwv)
(define (lambda? x)
(record-case x
[(clambda) #t]
[else #f]))
(define (branching-producer? x)
(define (bt? x)
(record-case x
[(bind lhs* rhs* body) (bt? body)]
[(recbind lhs* rhs* body) (bt? body)]
[(conditional test conseq altern) #t]
[(seq e0 e1) (bt? e1)]
[else #f]))
(define (branching-clause? x)
(record-case x
[(clambda-case info body)
(bt? body)]))
(record-case x
[(clambda g cls*)
(ormap branching-clause? cls*)]
[else #f]))
(define (analyze producer consumer)
(cond
[(and (lambda? producer) (lambda? consumer))
(set! lambda-both (fxadd1 lambda-both))]
[(lambda? producer)
(set! lambda-producer (fxadd1 lambda-producer))]
[(lambda? consumer)
(set! lambda-consumer (fxadd1 lambda-consumer))]
[else
(set! lambda-none (fxadd1 lambda-none))])
(when (branching-producer? producer)
(set! branching-producer (fxadd1 branching-producer)))
(printf "both=~s p=~s c=~s none=~s branching-prod=~s\n"
lambda-both lambda-producer lambda-consumer lambda-none
branching-producer))
(define (E x)
(record-case x
[(constant) (void)]
[(var) (void)]
[(primref) (void)]
[(bind lhs* rhs* body)
(for-each E rhs*) (E body)]
[(recbind lhs* rhs* body)
(for-each E rhs*) (E body)]
[(conditional test conseq altern)
(E test)
(E conseq)
(E altern)]
[(seq e0 e1) (E e0) (E e1)]
[(clambda g cls*)
(for-each
(lambda (x)
(record-case x
[(clambda-case info body) (E body)]))
cls*)]
[(primcall rator rand*)
(for-each E rand*)
(when (and (eq? rator 'call-with-values) (fx= (length rand*) 2))
(analyze (car rand*) (cadr rand*)))]
[(funcall rator rand*)
(E rator) (for-each E rand*)
(when (and (record-case rator
[(primref op) (eq? op 'call-with-values)]
[else #f])
(fx= (length rand*) 2))
(analyze (car rand*) (cadr rand*)))]
[(forcall rator rand*)
(for-each E rand*)]
[(assign lhs rhs)
(E rhs)]
[else (error who "invalid expression ~s" (unparse x))]))
(E x))
(define (optimize-letrec x)
(define who 'optimize-letrec)
(define (extend-hash lhs* h ref)
(for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*)
(lambda (x)
(unless (get-hash-table h x #f)
(put-hash-table! h x #t)
(ref x))))
(define (E* x* ref comp)
(cond
[(null? x*) '()]
[else
(cons (E (car x*) ref comp)
(E* (cdr x*) ref comp))]))
(define (do-rhs* i lhs* rhs* ref comp vref vcomp)
(cond
[(null? rhs*) '()]
[else
(let ([h (make-hash-table)])
(let ([ref
(lambda (x)
(unless (get-hash-table h x #f)
(put-hash-table! h x #t)
(ref x)
(when (memq x lhs*)
(vector-set! vref i #t))))]
[comp
(lambda ()
(vector-set! vcomp i #t)
(comp))])
(cons (E (car rhs*) ref comp)
(do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
(define (partition-rhs* i lhs* rhs* vref vcomp)
(cond
[(null? lhs*) (values '() '() '() '() '() '())]
[else
(let-values
([(slhs* srhs* llhs* lrhs* clhs* crhs*)
(partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
[(lhs rhs) (values (car lhs*) (car rhs*))])
(cond
[(var-assigned lhs)
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
[(clambda? rhs)
(values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
[(or (vector-ref vref i) (vector-ref vcomp i))
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
[else
(values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
))]))
(define (do-recbind lhs* rhs* body ref comp)
(let ([h (make-hash-table)]
[vref (make-vector (length lhs*) #f)]
[vcomp (make-vector (length lhs*) #f)])
(let* ([ref (extend-hash lhs* h ref)]
[body (E body ref comp)])
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
(partition-rhs* 0 lhs* rhs* vref vcomp)])
(let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)]
[t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
(make-bind slhs* srhs*
(make-bind clhs* v*
(make-fix llhs* lrhs*
(make-bind t* crhs*
(build-assign* clhs* t* body)))))))))))
(define (build-assign* lhs* rhs* body)
(cond
[(null? lhs*) body]
[else
(make-seq
(make-assign (car lhs*) (car rhs*))
(build-assign* (cdr lhs*) (cdr rhs*) body))]))
(define (E x ref comp)
(record-case x
[(constant) x]
[(var) (ref x) x]
[(assign lhs rhs)
(set-var-assigned! lhs #t)
(ref lhs)
(make-assign lhs (E rhs ref comp))]
[(primref) x]
[(bind lhs* rhs* body)
(let ([rhs* (E* rhs* ref comp)])
(let ([h (make-hash-table)])
(let ([body (E body (extend-hash lhs* h ref) comp)])
(make-bind lhs* rhs* body))))]
[(recbind lhs* rhs* body)
(if (null? lhs*)
(E body ref comp)
(do-recbind lhs* rhs* body ref comp))]
[(conditional e0 e1 e2)
(make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
[(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
[(clambda g cls*)
(make-clambda g
(map (lambda (x)
(record-case x
[(clambda-case info body)
(let ([h (make-hash-table)])
(let ([body (E body (extend-hash (case-info-args info) h ref) void)])
(make-clambda-case info body)))]))
cls*)
#f)]
[(primcall rator rand*)
(when (memq rator '(call/cc call/cf))
(comp))
(make-primcall rator (E* rand* ref comp))]
[(funcall rator rand*)
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
(record-case rator
[(primref op)
(when (memq op '(call/cc call/cf))
(comp))]
[else
(comp)])
(make-funcall rator rand*))]
[(mvcall p c)
(let ([p (E p ref comp)] [c (E c ref comp)])
(comp)
(make-mvcall p c))]
[(forcall rator rand*)
(make-forcall rator (E* rand* ref comp))]
[else (error who "invalid expression ~s" (unparse x))]))
(E x (lambda (x) (error who "free var ~s found" x))
void))
;;; This pass was here before optimize-letrec was implemented.
(define (remove-letrec x)
(define who 'remove-letrec)
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(recbind lhs* rhs* body)
(let ([t* (map (lambda (lhs) (unique-var 'tmp)) lhs*)]
[v* (map (lambda (lhs) (make-primcall 'void '())) lhs*)])
(make-bind lhs* v*
(make-bind t* (map Expr rhs*)
(let f ([lhs* lhs*] [t* t*])
(cond
[(null? lhs*) (Expr body)]
[else
(make-seq
(make-assign (car lhs*) (car t*))
(f (cdr lhs*) (cdr t*)))])))))]
;[(fix lhs* rhs* body)
; (Expr (make-recbind lhs* rhs* body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional
(Expr test)
(Expr conseq)
(Expr altern))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(clambda g cls*)
(make-clambda g
(map (lambda (x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]))
cls*)
#f)]
[(primcall rator rand*)
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(forcall rator rand*)
(make-forcall rator (map Expr rand*))]
[(assign lhs rhs)
(make-assign lhs (Expr rhs))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define (uncover-assigned/referenced x)
(define who 'uncover-assigned/referenced)
(define (Expr* x*)
(for-each Expr x*))
(define (init-var x)
(set-var-assigned! x #f)
(set-var-referenced! x #f))
(define (Expr x)
(record-case x
[(constant) (void)]
[(var) (set-var-referenced! x #t)]
[(primref) (void)]
[(bind lhs* rhs* body)
(for-each init-var lhs*)
(begin (Expr body) (Expr* rhs*))]
[(fix lhs* rhs* body)
(for-each init-var lhs*)
(Expr* rhs*)
(Expr body)
(when (ormap var-assigned lhs*)
(error who "a fix lhs is assigned"))]
[(conditional test conseq altern)
(begin (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (begin (Expr e0) (Expr e1))]
[(clambda g cls*)
(for-each
(lambda (cls)
(record-case cls
[(clambda-case info body)
(for-each init-var (case-info-args info))
(Expr body)]))
cls*)]
[(primcall rator rand*) (Expr* rand*)]
[(funcall rator rand*)
(begin (Expr rator) (Expr* rand*))]
[(mvcall p c) (begin (Expr p) (Expr c))]
[(forcall rator rand*) (Expr* rand*)]
[(assign lhs rhs)
(set-var-assigned! lhs #t)
(Expr rhs)]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x)
x)
(module (tally-giveup)
(define giveup-list '())
(define (tally-giveup op)
(cond
[(getprop op '*compiler-giveup-tally*) =>
(lambda (n)
(putprop op '*compiler-giveup-tally* (add1 n)))]
[else
(set! giveup-list (cons op giveup-list))
(putprop op '*compiler-giveup-tally* 1)]))
(define (print-tally)
(for-each
(lambda (x)
(let ([n (getprop x '*compiler-giveup-tally*)])
(when (>= n 30)
(printf "~s ~s\n" n x))))
giveup-list))
(primitive-set! 'compiler-giveup-tally print-tally))
#|FIXME:missing-optimizations
128 list*
111 cadr
464 $record/rtd?
404 memq
249 map
114 not
451 car
224 syntax-error
248 $syntax-dispatch
237 pair?
125 length
165 $cdr
137 $car
805 $record-ref
181 fixnum?
328 null?
136 fx-
207 eq?
153 call-with-values
165 values
336 apply
384 cdr
898 cons
747 error
331 primitive-set!
555 void
645 list
|#
(module (optimize-primcall)
(define (optimize-primcall ctxt op rand*)
(cond
[(getprop op *cookie*) =>
(lambda (proc)
(proc ctxt op rand*
(lambda ()
(make-funcall (make-primref op) rand*))))]
[else
(tally-giveup op)
(make-funcall (make-primref op) rand*)]))
(define (constant-value x k)
(record-case x
[(constant t) (k t)] ; known
[(bind lhs* rhs* body) (constant-value body k)]
[(fix lhs* rhs* body) (constant-value body k)]
[(seq e0 e1) (constant-value e1 k)]
[else #f]))
(define (mk-seq e0 e1) ;;; keep e1 seq-free.
(cond
[(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
[(seq? e1)
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
[else
(make-seq e0 e1)]))
(define (equable? x)
(if (number? x) (fixnum? x) #t))
(define *cookie* (gensym "optimizer-cookie"))
(define-syntax set-cases
(syntax-rules ()
[(_ ctxt op rand* giveup
[(op** ...) b* b** ...] ...)
(begin
(let ([p (lambda (ctxt op rand* giveup) b* b** ...)])
(putprop 'op** *cookie* p) ...
(void)) ...)]))
(set-cases ctxt op rand* giveup
[(eq?)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(or
(constant-value a0
(lambda (x0)
(constant-value a1
(lambda (x1)
(mk-seq (mk-seq a0 a1)
(make-constant (eq? x0 x1)))))
(and (eq? ctxt 'e)
(mk-seq a0 a1)))))))
(giveup))]
[(eqv?)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(or
(constant-value a0
(lambda (x0)
(or (constant-value a1
(lambda (x1)
(mk-seq (mk-seq a0 a1)
(make-constant (eqv? x0 x1)))))
(and (equable? x0)
(optimize-primcall ctxt 'eq? rand*)))))
(constant-value a1
(lambda (x1)
(and (equable? x1)
(optimize-primcall ctxt 'eq? rand*))))
(and (eq? ctxt 'e)
(mk-seq a0 a1)))))
(giveup))]
[(memv)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(constant-value a1
(lambda (ls)
(cond
[(not (list? ls)) #f]
[(eq? ctxt 'e) (mk-seq a0 a1)]
[(constant-value a0
(lambda (x)
(mk-seq (mk-seq a0 a1)
(case ctxt
[(v) (make-constant (memv x ls))]
[else (make-constant
(if (memv x ls) #t #f))]))))]
[(andmap equable? ls)
(optimize-primcall ctxt 'memq rand*)]
[(fx= (length ls) 1)
(mk-seq a1
(optimize-primcall ctxt 'eqv?
(list a0 (make-constant (car ls)))))]
[else #f])))))
(giveup))]
[(memq)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(constant-value a1
(lambda (ls)
(cond
[(not (list? ls)) #f]
[(eq? ctxt 'e) (make-seq a0 a1)]
[(constant-value a0
(lambda (x)
(mk-seq (mk-seq a0 a1)
(case ctxt
[(v) (make-constant (memq x ls))]
[else (make-constant
(if (memq x ls) #t #f))]))))]
[(fx= (length ls) 1)
(mk-seq a1
(optimize-primcall ctxt 'eq?
(list a0 (make-constant (car ls)))))]
[else (make-primcall '$memq rand*)])))))
(giveup))]
[(list)
(case ctxt
[(v) (if (null? rand*) (make-constant '()) (giveup))]
[else
(if (null? rand*)
(make-constant #t)
(let f ([a (car rand*)] [d (cdr rand*)])
(cond
[(null? d) (make-seq a (make-constant #t))]
[else
(f (make-seq a (car d)) (cdr d))])))])]
[(list*)
(case ctxt
[(e)
(cond
[(null? rand*) (giveup)]
[else
(let f ([a (car rand*)] [d (cdr rand*)])
(cond
[(null? d) a]
[else (f (mk-seq a (car d)) (cdr d))]))])]
[(p)
(cond
[(null? rand*) (giveup)]
[(null? (cdr rand*))
(let ([a (car rand*)])
(or (constant-value a
(lambda (v)
(mk-seq a (make-constant (if v #t #f)))))
a))]
[else
(let f ([a (car rand*)] [d (cdr rand*)])
(cond
[(null? d) (mk-seq a (make-constant #t))]
[else (f (mk-seq a (car d)) (cdr d))]))])]
[else
(cond
[(null? rand*) (giveup)]
[(null? (cdr rand*)) (car rand*)]
[else (giveup)])])]
[(cons)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(case ctxt
[(e) (mk-seq a0 a1)]
[(p) (mk-seq (mk-seq a0 a1) (make-constant #t))]
[else (giveup)])))
(giveup))]
[($record-ref $record/rtd?)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(case ctxt
[(e) (mk-seq a0 a1)]
[else
(or (constant-value a1
(lambda (n1)
(mk-seq a1
(make-primcall op
(list a0 (make-constant n1))))))
(make-primcall op rand*))])))
(error 'optimize "~s rands to ~s" (map unparse rand*) op))]
[(void)
(or (and (null? rand*)
(case ctxt
[(p) (make-constant #t)]
[else (make-constant (void))]))
(giveup))]
[(car cdr)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(constant-value a
(lambda (v)
(and (pair? v)
(mk-seq a
(make-constant
(case op
[(car) (car v)]
[else (cdr v)]))))))))
(giveup))]
[(cadr)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(or (constant-value a
(lambda (v)
(and (pair? v)
(pair? (cdr v))
(mk-seq a
(make-constant
(cadr v))))))
(make-primcall op rand*))))
(giveup))]
[(not null? pair? fixnum? vector? string? char? symbol?
eof-object?)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(case ctxt
[(e) a]
[else
(or (constant-value a
(lambda (v)
(mk-seq a
(make-constant
(case op
[(not) (not v)]
[(null?) (null? v)]
[(pair?) (pair? v)]
[(fixnum?) (fixnum? v)]
[(vector?) (vector? v)]
[(string?) (string? v)]
[(char?) (char? v)]
[(symbol?) (symbol? v)]
[(eof-object?) (eof-object? v)]
[else
(error 'optimize
"huh ~s" op)])))))
(make-primcall op rand*))])))
(giveup))]
[($car $cdr)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(or (constant-value a
(lambda (v)
(if (pair? v)
(make-seq a
(make-constant
(case op
[($car) (car v)]
[else (cdr v)])))
(error 'optimize
"incorrect arg ~s to ~s"
v op))))
(giveup))))
(error 'optimize "incorrect args ~s to ~s"
(map unparse rand*) op))]
[(fxadd1 fxsub1)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(or (constant-value a
(lambda (v)
(and (fixnum? v)
(let ([t
(case op
[(fxadd1) (add1 v)]
[else (sub1 v)])])
(and (fixnum? t)
(mk-seq a
(make-constant t)))))))
(make-primcall op rand*))))
(giveup))]
[(fx+)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(or (constant-value a1
(lambda (v1)
(and (fixnum? v1)
(or (constant-value a0
(lambda (v0)
(and (fixnum? v0)
(let ([r (+ v0 v1)])
(and (fixnum? r)
(mk-seq (mk-seq a0 a1)
(make-constant r)))))))
(mk-seq a1
(make-primcall op
(list a0 (make-constant v1))))))))
(constant-value a0
(lambda (v0)
(and (fixnum? v0)
(mk-seq a0
(make-primcall op
(list (make-constant v0) a1))))))
(make-primcall op rand*))))
(giveup))]
;X; [(fx- fx+ fx*)
;X; (or (and (fx= (length rand*) 2)
;X; (let ([a0 (car rand*)] [a1 (cadr rand*)])
;X; (or (constant-value a1
;X; (lambda (v1)
;X; (and (fixnum? v1)
;X; (or (constant-value a0
;X; (lambda (v0)
;X; (and (fixnum? v0)
;X; (let ([r (case op
;X; [(fx+) (+ v0 v1)]
;X; [(fx-) (- v0 v1)]
;X; [(fx*) (* v0 v1)]
;X; [else (error 'compile "BOO")])])
;X; (and (fixnum? r)
;X; (mk-seq (mk-seq a0 a1)
;X; (make-constant r)))))))
;X; (mk-seq a1 (make-primcall op (list a0 v1)))))))
;X; (constant-value a0
;X; (lambda (v0)
;X; (and (fixnum? v0)
;X; (mk-seq a0 (make-primcall op (list v0 a1))))))
;X; (make-primcall op (list a0 a1)))))
;X; (giveup))]
;;; unoptimizables
[(error syntax-error $syntax-dispatch $sc-put-cte
primitive-set! apply)
(giveup)]
))
(define (mk-mvcall p c)
(record-case p
[(funcall) (make-mvcall p c)]
[(seq e0 e1)
(make-seq e0 (mk-mvcall e1 c))]
[(bind lhs* rhs* body)
(make-bind lhs* rhs* (mk-mvcall body c))]
[else (error 'mk-mvcall "invalid producer ~s" (unparse p))]))
(define (copy-propagate x)
(define who 'copy-propagate)
(define the-void (make-primcall 'void '()))
(define (known-value x)
(record-case x
[(constant) x] ; known
[(primref) x] ; known
[(bind lhs* rhs* body) (known-value body)]
[(fix lhs* rhs* body) (known-value body)]
[(seq e0 e1) (known-value e1)]
[else #f]))
(define (same-values? x y)
(cond
[(constant? x)
(and (constant? y)
(eq? (constant-value x)
(constant-value y)))]
[(primref? x)
(and (primref? y)
(eq? (primref-name x)
(primref-name y)))]
[else #f]))
(define (predicate-value x)
(record-case x
[(constant t) (if t 't 'f)]
[(bind lhs rhs body) (predicate-value body)]
[(fix lhs rhs body) (predicate-value body)]
[(seq e0 e1) (predicate-value e1)]
[else #f]))
(define (do-conditional e0 e1 e2 k)
(let ([e0 (Pred e0)])
(cond
[(predicate-value e0) =>
(lambda (v)
(if (eq? v 't) (k e1) (k e2)))]
[else
(make-conditional e0 (k e1) (k e2))])))
(define (partition-referenced lhs* rhs*)
(cond
[(null? lhs*) (values '() '() the-void)]
[else
(let ([lhs (car lhs*)] [rhs (car rhs*)])
(let-values ([(lhs* rhs* eff*)
(partition-referenced
(cdr lhs*) (cdr rhs*))])
(cond
[(var-referenced lhs)
(values (cons lhs lhs*) (cons rhs rhs*) eff*)]
[else
(values lhs* rhs* (mk-seq eff* (Effect rhs)))])))]))
(define (partition/assign-known lhs* rhs*)
(cond
[(null? lhs*) (values '() '() the-void)]
[else
(let ([lhs (car lhs*)] [rhs (car rhs*)])
(let-values ([(lhs* rhs* eff*)
(partition/assign-known
(cdr lhs*) (cdr rhs*))])
(cond
[(and (not (var-assigned lhs)) (known-value rhs)) =>
(lambda (v)
(set-var-referenced! lhs v)
(values lhs* rhs* (mk-seq eff* rhs)))]
[else
(values (cons lhs lhs*) (cons rhs rhs*) eff*)])))]))
(define (do-bind lhs* rhs* body k)
(let-values ([(lhs* rhs* eff0)
(partition-referenced lhs* rhs*)])
(let ([rhs* (map Value rhs*)])
(let-values ([(lhs* rhs* eff1)
(partition/assign-known lhs* rhs*)])
(let ([body
(cond
[(null? lhs*) (k body)]
[else
(make-bind lhs* rhs* (k body))])])
(mk-seq (mk-seq eff0 eff1) body))))))
(define (do-fix lhs* rhs* body k)
(let-values ([(lhs* rhs* eff*)
(partition-referenced lhs* rhs*)])
(cond
[(null? lhs*) (k body)]
[else
(make-fix lhs* (map Value rhs*) (k body))])))
(define (mk-seq e0 e1) ;;; keep e1 seq-free.
(cond
[(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
[(seq? e1)
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
[else
(make-seq e0 e1)]))
(define (do-clambda g cls*)
(make-clambda g
(map (lambda (cls)
(record-case cls
[(clambda-case info body)
(make-clambda-case info (Value body))]))
cls*)
#f))
(define (Effect x)
(record-case x
[(constant) the-void]
[(var) the-void]
[(primref) the-void]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body Effect)]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* body Effect)]
[(conditional e0 e1 e2)
(let ([e0 (Pred e0)])
(cond
[(predicate-value e0) =>
(lambda (v)
(mk-seq e0 (if (eq? v 't) (Effect e1) (Effect e2))))]
[else
(make-conditional e0 (Effect e1) (Effect e2))]))]
[(seq e0 e1) (mk-seq (Effect e0) (Effect e1))]
[(clambda g cls*) the-void]
[(primcall rator rand*)
(optimize-primcall 'e rator (map Value rand*))]
[(funcall rator rand*)
(let ([rator (Value rator)])
(cond
[(known-value rator) =>
(lambda (v)
(record-case v
[(primref op)
(mk-seq rator
(optimize-primcall 'e op (map Value rand*)))]
[else
(make-funcall rator (map Value rand*))]))]
[else (make-funcall rator (map Value rand*))]))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(mvcall p c)
(mk-mvcall (Value p) (Value c))]
[(assign lhs rhs)
(unless (var-assigned lhs)
(error who "var ~s is not assigned" lhs))
(if (var-referenced lhs)
(make-assign lhs (Value rhs))
(Effect rhs))]
[else (error who "invalid effect expression ~s" (unparse x))]))
(define (Pred x)
(record-case x
[(constant) x]
[(var)
(let ([r (var-referenced x)])
(if (constant? r) r x))]
[(primref) (make-constant #t)]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body Pred)]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* body Pred)]
[(conditional e0 e1 e2)
(let ([e0 (Pred e0)])
(cond
[(predicate-value e0) =>
(lambda (t0)
(mk-seq e0 (if (eq? t0 't) (Pred e1) (Pred e2))))]
[else
(let ([e1 (Pred e1)] [e2 (Pred e2)])
(cond
[(predicate-value e1) =>
(lambda (t1)
(cond
[(predicate-value e2) =>
(lambda (t2)
(if (eq? t1 t2)
(mk-seq (make-conditional e0 e1 e2)
(make-constant (if (eq? t1 't) #t #f)))
(make-conditional e0 e1 e2)))]
[else (make-conditional e0 e1 e2)]))]
[else (make-conditional e0 e1 e2)]))]))]
[(seq e0 e1) (mk-seq (Effect e0) (Pred e1))]
[(clambda g cls*) (make-constant #t)]
[(primcall rator rand*)
(optimize-primcall 'p rator (map Value rand*))]
[(funcall rator rand*)
(let ([rator (Value rator)])
(cond
[(known-value rator) =>
(lambda (v)
(record-case v
[(primref op)
(mk-seq rator
(optimize-primcall 'p op (map Value rand*)))]
[else
(make-funcall rator (map Value rand*))]))]
[else (make-funcall rator (map Value rand*))]))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
(mk-seq (Effect x) (make-constant #t))]
[(mvcall p c)
(mk-mvcall (Value p) (Value c))]
[else (error who "invalid pred expression ~s" (unparse x))]))
(define (Value x)
(record-case x
[(constant) x]
[(var)
(let ([r (var-referenced x)])
(case r
[(#t) x]
[(#f) (error who "Reference to a var ~s that should not be" x)]
[else r]))]
[(primref) x]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body Value)]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* body Value)]
[(conditional e0 e1 e2)
(let ([e0 (Pred e0)])
(cond
[(predicate-value e0) =>
(lambda (t0)
(mk-seq e0 (if (eq? t0 't) (Value e1) (Value e2))))]
[else
(let ([e1 (Value e1)] [e2 (Value e2)])
(let ([t1 (known-value e1)] [t2 (known-value e2)])
(cond
[(and t1 t2)
(if (same-values? t1 t2)
(mk-seq (make-conditional e0 e1 e2) t1)
(make-conditional e0 e1 e2))]
[else (make-conditional e0 e1 e2)])))]))]
[(seq e0 e1) (mk-seq (Effect e0) (Value e1))]
[(clambda g cls*) (do-clambda g cls*)]
[(primcall rator rand*)
(optimize-primcall 'v rator (map Value rand*))]
[(funcall rator rand*)
(let ([rator (Value rator)])
(cond
[(known-value rator) =>
(lambda (v)
(record-case v
[(primref op)
(mk-seq rator
(optimize-primcall 'v op (map Value rand*)))]
[else
(make-funcall rator (map Value rand*))]))]
[else (make-funcall rator (map Value rand*))]))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
(mk-seq (Effect x) the-void)]
[(mvcall p c)
(mk-mvcall (Value p) (Value c))]
[else (error who "invalid value expression ~s" (unparse x))]))
(let ([x (Value x)])
;;; since we messed up the references and assignments here, we
;;; redo them
(uncover-assigned/referenced x)))
(define (rewrite-assignments x)
(define who 'rewrite-assignments)
(define (fix-lhs* lhs*)
(cond
[(null? lhs*) (values '() '() '())]
[else
(let ([x (car lhs*)])
(let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))])
(cond
[(var-assigned x)
(let ([t (unique-var 'assignment-tmp)])
(values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))]
[else
(values (cons x lhs*) a-lhs* a-rhs*)])))]))
(define (bind-assigned lhs* rhs* body)
(cond
[(null? lhs*) body]
[else
(make-bind lhs*
(map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*)
body)]))
(define (Expr x)
(record-case x
[(constant) x]
[(var)
(cond
[(var-assigned x)
(make-primcall '$vector-ref (list x (make-constant 0)))]
[else x])]
[(primref) x]
[(bind lhs* rhs* body)
(let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* lhs*)])
(make-bind lhs* (map Expr rhs*)
(bind-assigned a-lhs* a-rhs* (Expr body))))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(clambda g cls*)
(make-clambda g
(map (lambda (cls)
(record-case cls
[(clambda-case info body)
(record-case info
[(case-info label fml* proper)
(let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
(make-clambda-case
(make-case-info label fml* proper)
(bind-assigned a-lhs* a-rhs* (Expr body))))])]))
cls*)
#f)]
[(primcall op rand*)
(make-primcall op (map Expr rand*))]
[(forcall op rand*)
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(assign lhs rhs)
(unless (var-assigned lhs)
(error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
(make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define (optimize-for-direct-jumps x)
(define who 'optimize-for-direct-jumps)
(define (init-var x)
(set-var-referenced! x #f))
(define (set-var x v)
(record-case v
[(clambda) (set-var-referenced! x v)]
[(var)
(cond
[(bound-var v) => (lambda (v) (set-var-referenced! x v))]
[else (void)])]
[else (void)]))
(define (bound-var x)
(var-referenced x))
(define (optimize c rator rand*)
(let ([n (length rand*)])
(record-case c
[(clambda main-label cls*)
(let f ([cls* cls*])
(cond
[(null? cls*)
;;; none matching?
(make-funcall rator rand*)]
[else
(record-case (clambda-case-info (car cls*))
[(case-info label fml* proper)
(cond
[proper
(if (fx= n (length fml*))
(make-jmpcall label rator rand*)
(f (cdr cls*)))]
[else
(if (fx<= (length (cdr fml*)) n)
(make-jmpcall label rator
(let f ([fml* (cdr fml*)] [rand* rand*])
(cond
[(null? fml*)
(list (make-primcall 'list rand*))]
[else
(cons (car rand*)
(f (cdr fml*) (cdr rand*)))])))
(f (cdr cls*)))])])]))])))
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(for-each init-var lhs*)
(let ([rhs* (map Expr rhs*)])
(for-each set-var lhs* rhs*)
(make-bind lhs* rhs* (Expr body)))]
[(fix lhs* rhs* body)
(for-each set-var lhs* rhs*)
(make-fix lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(clambda g cls*)
(make-clambda g
(map (lambda (cls)
(record-case cls
[(clambda-case info body)
(for-each init-var (case-info-args info))
(make-clambda-case info (Expr body))]))
cls*)
#f)]
[(primcall op rand*)
(make-primcall op (map Expr rand*))]
[(forcall op rand*)
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(let ([rator (Expr rator)])
(cond
[(and (var? rator) (bound-var rator)) =>
(lambda (c)
(optimize c rator (map Expr rand*)))]
[(and (primref? rator)
(eq? (primref-name rator) '$$apply))
(make-jmpcall SL_apply
(Expr (car rand*))
(map Expr (cdr rand*)))]
[else
(make-funcall rator (map Expr rand*))]))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define (convert-closures prog)
(define who 'convert-closures)
(define (Expr* x*)
(cond
[(null? x*) (values '() '())]
[else
(let-values ([(a a-free) (Expr (car x*))]
[(d d-free) (Expr* (cdr x*))])
(values (cons a d) (union a-free d-free)))]))
(define (do-clambda* x*)
(cond
[(null? x*) (values '() '())]
[else
(let-values ([(a a-free) (do-clambda (car x*))]
[(d d-free) (do-clambda* (cdr x*))])
(values (cons a d) (union a-free d-free)))]))
(define (do-clambda x)
(record-case x
[(clambda g cls*)
(let-values ([(cls* free)
(let f ([cls* cls*])
(cond
[(null? cls*) (values '() '())]
[else
(record-case (car cls*)
[(clambda-case info body)
(let-values ([(body body-free) (Expr body)]
[(cls* cls*-free) (f (cdr cls*))])
(values
(cons (make-clambda-case info body) cls*)
(union (difference body-free (case-info-args info))
cls*-free)))])]))])
(values (make-closure (make-clambda g cls* free) free)
free))]))
(define (Expr ex)
(record-case ex
[(constant) (values ex '())]
[(var) (values ex (singleton ex))]
[(primref) (values ex '())]
[(bind lhs* rhs* body)
(let-values ([(rhs* rhs-free) (Expr* rhs*)]
[(body body-free) (Expr body)])
(values (make-bind lhs* rhs* body)
(union rhs-free (difference body-free lhs*))))]
[(fix lhs* rhs* body)
(let-values ([(rhs* rfree) (do-clambda* rhs*)]
[(body bfree) (Expr body)])
(values (make-fix lhs* rhs* body)
(difference (union bfree rfree) lhs*)))]
[(conditional test conseq altern)
(let-values ([(test test-free) (Expr test)]
[(conseq conseq-free) (Expr conseq)]
[(altern altern-free) (Expr altern)])
(values (make-conditional test conseq altern)
(union test-free (union conseq-free altern-free))))]
[(seq e0 e1)
(let-values ([(e0 e0-free) (Expr e0)]
[(e1 e1-free) (Expr e1)])
(values (make-seq e0 e1) (union e0-free e1-free)))]
[(clambda)
(do-clambda ex)]
[(primcall op rand*)
(let-values ([(rand* rand*-free) (Expr* rand*)])
(values (make-primcall op rand*) rand*-free))]
[(forcall op rand*)
(let-values ([(rand* rand*-free) (Expr* rand*)])
(values (make-forcall op rand*) rand*-free))]
[(funcall rator rand*)
(let-values ([(rator rat-free) (Expr rator)]
[(rand* rand*-free) (Expr* rand*)])
(values (make-funcall rator rand*)
(union rat-free rand*-free)))]
[(jmpcall label rator rand*)
(let-values ([(rator rat-free) (Expr rator)]
[(rand* rand*-free) (Expr* rand*)])
(values (make-jmpcall label rator rand*)
(union rat-free rand*-free)))]
[(mvcall p c)
(let-values ([(p p-free) (Expr p)]
[(c c-free) (Expr c)])
(record-case c
[(closure code free^)
(values (make-mvcall p code)
(union p-free c-free))]
[else (error who "invalid mvcall consumer ~s"
(unparse c))]))]
[else (error who "invalid expression ~s" (unparse ex))]))
(let-values ([(prog free) (Expr prog)])
(unless (null? free)
(error 'convert-closures "free vars ~s encountered in ~a"
free (unparse prog)))
prog))
(define (optimize-closures/lift-codes x)
(define who 'optimize-closures/lift-codes)
(define all-codes '())
(define (init-non-thunk var)
(set-var-assigned! var #f)
(set-var-referenced! var #f))
(define (var-thunk var)
(var-referenced var))
(define (make-thunk-var var thunk)
(set-var-referenced! var thunk))
(define (thunk? x)
(record-case x
[(closure code free*)
(null? free*)]
[else #f]))
(define (trim/lift-code code free*)
(record-case code
[(clambda label cls* free*/dropped)
(let ([cls* (map
(lambda (x)
(record-case x
[(clambda-case info body)
(for-each init-non-thunk
(case-info-args info))
(make-clambda-case info (E body))]))
cls*)])
(let ([g (make-code-loc label)])
(set! all-codes
(cons (make-clambda label cls* free*) all-codes))
g))]))
(define (optimize-one-closure code free)
(let ([free (trim-vars free)])
(make-closure (trim/lift-code code free) free)))
(define (trim p? ls)
(cond
[(null? ls) '()]
[(p? (car ls)) (trim p? (cdr ls))]
[else
(cons (car ls) (trim p? (cdr ls)))]))
(define (trim-vars ls)
(trim var-thunk ls))
(define (trim-thunks ls)
(trim thunk? ls))
(define (do-bind lhs* rhs* body)
(for-each init-non-thunk lhs*)
(let ([rhs* (map E rhs*)])
(for-each (lambda (x v)
(when (thunk? v) (make-thunk-var x v)))
lhs* rhs*)
(make-bind (trim-vars lhs*) (trim-thunks rhs*) (E body))))
(define (do-fix lhs* rhs* body)
(for-each init-non-thunk lhs*)
(let ([free** ;;; trim the free lists first; after init.
(map (lambda (x) (trim-vars (closure-free* x))) rhs*)])
(define-record node (name code deps whacked free))
(let ([node* (map (lambda (lhs rhs)
(let ([n (make-node lhs (closure-code rhs) '() #f '())])
(make-thunk-var lhs n)
n))
lhs* rhs*)])
;;; if x is free in y, then whenever x becomes a non-thunk,
;;; y also becomes a non-thunk. Here, we mark these
;;; dependencies.
(for-each
(lambda (my-node free*)
(for-each (lambda (fvar)
(cond
[(var-thunk fvar) => ;;; one of ours
(lambda (her-node)
(set-node-deps! her-node
(cons my-node (node-deps her-node))))]
[else ;;; not one of ours
(set-node-free! my-node
(cons fvar (node-free my-node)))]))
free*))
node* free**)
;;; Next, we go over the list of nodes, and if we find one
;;; that has any free variables, we know it's a non-thunk,
;;; so we whack it and add it to all of its dependents.
(let ()
(define (process-node x)
(unless (null? (node-free x))
(unless (node-whacked x)
(set-node-whacked! x #t)
(for-each
(lambda (y)
(set-node-free! y
(cons (node-name x) (node-free y)))
(process-node y))
(node-deps x)))))
(for-each process-node node*))
;;; Now those that have free variables are actual closures.
;;; Those with no free variables are actual thunks.
(let ([rhs*
(map
(lambda (node)
(let ([free (node-free node)])
(let ([closure
(make-closure (node-code node) free)])
(if (null? free)
(make-thunk-var (node-name node) closure)
(init-non-thunk (node-name node)))
closure)))
node*)])
(for-each
(lambda (x)
(set-closure-code! x
(trim/lift-code
(closure-code x)
(closure-free* x))))
rhs*)
;;;
(make-fix (trim-vars lhs*)
(trim-thunks rhs*)
(E body))))))
(define (E x)
(record-case x
[(constant) x]
[(var) (or (var-thunk x) x)]
[(primref) x]
[(bind lhs* rhs* body) (do-bind lhs* rhs* body)]
[(fix lhs* rhs* body) (do-fix lhs* rhs* body)]
[(conditional test conseq altern)
(make-conditional (E test) (E conseq) (E altern))]
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(closure c free) (optimize-one-closure c free)]
[(primcall op rand*) (make-primcall op (map E rand*))]
[(forcall op rand*) (make-forcall op (map E rand*))]
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
[(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))]
[(mvcall p c)
(record-case c
[(clambda label cases free)
(make-mvcall (E p)
(make-clambda label
(map (lambda (x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (E body))]))
cases)
free))])]
[else (error who "invalid expression ~s" (unparse x))]))
(let ([x (E x)])
(make-codes all-codes x)))
(include "libcogen1.ss")
(define (lift-codes x) ;;; NOT USED
(define who 'lift-codes)
(define all-codes '())
(define (do-code x)
(record-case x
[(clambda label cls* free)
(let ([cls* (map
(lambda (x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (E body))]))
cls*)])
(let ([g (make-code-loc label)])
(set! all-codes
(cons (make-clambda label cls* free) all-codes))
g))]))
(define (E x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map E rhs*) (E body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map E rhs*) (E body))]
[(conditional test conseq altern)
(make-conditional (E test) (E conseq) (E altern))]
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(closure c free) (make-closure (do-code c) free)]
[(primcall op rand*) (make-primcall op (map E rand*))]
[(forcall op rand*) (make-forcall op (map E rand*))]
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
[else (error who "invalid expression ~s" (unparse x))]))
(let ([x (E x)])
(make-codes all-codes x)))
(define (syntactically-valid? op rand*)
(define (valid-arg-count? op rand*)
(let ([n (open-coded-primitive-args op)] [m (length rand*)])
(cond
[(eq? n 'any) #t]
[(eq? n 'positive) (fx> m 1)]
[(eq? n 'no-code)
(error 'syntactically-valid
"should not primcall non codable prim ~s" op)]
[(fixnum? n)
(cond
[(fx= n m) #t]
[else
(error 'compile
"Possible incorrect number of args in ~s"
(cons op (map unparse rand*)))
#f])]
[else (error 'do-primcall "BUG: what ~s" n)])))
(define (check op pred?)
(lambda (arg)
(record-case arg
[(constant c)
(cond
[(pred? c) #t]
[else
(error 'compile "Possible argument error to primitive ~s" op)
#f])]
[(primref)
(cond
[(pred? (lambda (x) x)) #t]
[else
(error 'compile "Possible argument error to primitive ~s" op)
#f])]
[else #t])))
(define (nonnegative-fixnum? n)
(and (fixnum? n) (fx>= n 0)))
(define (byte? n)
(and (fixnum? n) (fx<= 0 n) (fx<= n 127)))
(define (valid-arg-types? op rand*)
(case op
[(fixnum? immediate? boolean? char? vector? string? procedure?
null? pair? not cons eq? vector symbol? error eof-object eof-object?
void $unbound-object? $code? $forward-ptr? bwp-object?
pointer-value top-level-value car cdr list* list $record
port? input-port? output-port?
$make-port/input $make-port/output $make-port/both
$port-handler
$port-input-buffer $port-input-index $port-input-size
$port-output-buffer $port-output-index $port-output-size
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size! )
'#t]
[($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx*
$fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit)
(andmap (check op fixnum?) rand*)]
[($fixnum->char)
(andmap (check op byte?) rand*)]
[($char->fixnum $char= $char< $char<= $char> $char>= $string)
(andmap (check op char?) rand*)]
[($make-vector $make-string)
(andmap (check op nonnegative-fixnum?) rand*)]
[($car $cdr)
(andmap (check op pair?) rand*)]
[($vector-length)
(andmap (check op vector?) rand*)]
[($string-length)
(andmap (check op string?) rand*)]
[($set-car! $set-cdr!)
((check op pair?) (car rand*))]
[($vector-ref $vector-set!)
(and ((check op vector?) (car rand*))
((check op nonnegative-fixnum?) (cadr rand*)))]
[($string-ref $string-set!
$string-ref-16+0 $string-ref-16+1 $string-ref-8+0 $string-ref-8+2)
(and ((check op string?) (car rand*))
((check op nonnegative-fixnum?) (cadr rand*)))]
[($symbol-string $symbol-unique-string)
(andmap (check op symbol?) rand*)]
[($constant-ref $set-constant! $intern $pcb-set! $pcb-ref $make-symbol
$symbol-value $set-symbol-value! $symbol-plist $set-symbol-plist!
$set-symbol-system-value! $set-symbol-system-value!
$set-symbol-unique-string!
$set-symbol-string!
$seal-frame-and-call $frame->continuation $code->closure
$closure-code
$code-size $code-reloc-vector $code-freevars
$code-ref $code-set!
$make-record $record? $record/rtd? $record-rtd $record-ref $record-set!
primitive-set! primitive-ref
$make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next
$set-tcbucket-val!
$set-tcbucket-next! $set-tcbucket-tconc!)
#t]
[else (error 'valid-arg-types? "unhandled op ~s" op)]))
(and (valid-arg-count? op rand*)
(or (null? rand*)
(valid-arg-types? op rand*))))
(begin ;;; UNINLINED ANALYSIS
;;; the output of simplify-operands differs from the input in that the
;;; operands to primcalls are all simple (variables, primrefs, or constants).
;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to
;;; primcalls.
(define uninlined '())
(define (mark-uninlined x)
(cond
[(assq x uninlined) =>
(lambda (p) (set-cdr! p (fxadd1 (cdr p))))]
[else (set! uninlined (cons (cons x 1) uninlined))]))
(module ()
(primitive-set! 'uninlined-stats
(lambda ()
(let f ([ls uninlined] [ac '()])
(cond
[(null? ls) ac]
[(fx> (cdar ls) 15)
(f (cdr ls) (cons (car ls) ac))]
[else (f (cdr ls) ac)]))))))
(define (introduce-primcalls x)
(define who 'introduce-primcalls)
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(closure) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*)
(case op
;[(values)
; (if (fx= (length arg*) 1)
; (Expr (car arg*))
; (begin
; (warning 'compile "possible incorrect number of values")
; (make-funcall (make-primref 'values) (map Expr arg*))))]
[else
(make-primcall op (map Expr arg*))])]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator rand*)
(cond
[(and (primref? rator)
(open-codeable? (primref-name rator))
(syntactically-valid? (primref-name rator) rand*))
(Expr (make-primcall (primref-name rator) rand*))]
[else
(when (primref? rator)
(mark-uninlined (primref-name rator)))
(make-funcall (Expr rator) (map Expr rand*))])]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(mvcall p c)
(record-case c
[(clambda label cases free)
(make-mvcall (Expr p)
(make-clambda label
(map (lambda (x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]))
cases)
free))])]
[else (error who "invalid expression ~s" (unparse x))]))
(define (Tail x)
(record-case x
[(constant) (make-return x)]
[(var) (make-return x)]
[(primref) (make-return x)]
[(closure) (make-return x)]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Tail body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Tail body))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Tail conseq) (Tail altern))]
[(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
[(primcall op arg*)
(case op
;[(values)
; (if (fx= (length arg*) 1)
; (make-return (Expr (car arg*)))
; (make-return* (map Expr arg*)))]
[else
(make-return (make-primcall op (map Expr arg*)))])]
[(forcall op arg*)
(make-return (make-forcall op (map Expr arg*)))]
[(funcall rator rand*)
(cond
[(and (primref? rator)
(open-codeable? (primref-name rator))
(syntactically-valid? (primref-name rator) rand*))
(Tail (make-primcall (primref-name rator) rand*))]
[else
(make-funcall (Expr rator) (map Expr rand*))])]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(mvcall p c)
(record-case c
[(clambda label cases free)
(make-mvcall (Expr p)
(make-clambda label
(map (lambda (x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Tail body))]))
cases)
free))])]
[else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Tail body))]))
(define (CodeExpr x)
(record-case x
[(clambda L cases free)
(make-clambda L (map CaseExpr cases) free)]))
(define (CodesExpr x)
(record-case x
[(codes list body)
(make-codes (map CodeExpr list) (Tail body))]))
(CodesExpr x))
(define (simplify-operands x)
(define who 'simplify-operands)
(define (simple? x)
(or (constant? x) (var? x) (primref? x)
(and (closure? x) (null? (closure-free* x)))))
(define (simplify arg lhs* rhs* k)
(if (simple? arg)
(k arg lhs* rhs*)
(let ([v (unique-var 'tmp)])
(k v (cons v lhs*) (cons (Expr arg) rhs*)))))
(define (simplify* arg* lhs* rhs* k)
(cond
[(null? arg*) (k '() lhs* rhs*)]
[else
(simplify (car arg*) lhs* rhs*
(lambda (a lhs* rhs*)
(simplify* (cdr arg*) lhs* rhs*
(lambda (d lhs* rhs*)
(k (cons a d) lhs* rhs*)))))]))
(define (make-bind^ lhs* rhs* body)
(if (null? lhs*)
body
(make-bind lhs* rhs* body)))
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(closure) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Expr body))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*)
(cond
[(memq op '(not car cdr cadr fxadd1 fxsub1
null? pair? fixnum? vector? string?
char? symbol? eof-object?
)) ;;; SIMPLIFY
(make-primcall op (map Expr arg*))]
[(memq op '(fx+))
(cond
[(simple? (cadr arg*))
(make-primcall op
(list (Expr (car arg*)) (cadr arg*)))]
[(simple? (car arg*))
(make-primcall op
(list (car arg*) (Expr (cadr arg*))))]
[else
(simplify* (cdr arg*) '() '()
(lambda (a* lhs* rhs*)
(make-bind^ lhs* rhs*
(make-primcall op
(cons (Expr (car arg*)) a*)))))])]
[else
(simplify* arg* '() '()
(lambda (arg* lhs* rhs*)
(make-bind^ lhs* rhs*
(make-primcall op arg*))))])]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(mvcall p c)
(make-mvcall (Expr p) (CodeExpr c))]
[else (error who "invalid expression ~s" (unparse x))]))
(define (Tail x)
(record-case x
[(return v) (make-return (Expr v))]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Tail body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Expr rhs*) (Tail body))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Tail conseq) (Tail altern))]
[(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(mvcall p c)
(make-mvcall (Expr p) (CodeExpr c))]
[else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Tail body))]))
(define (CodeExpr x)
(record-case x
[(clambda L clauses free)
(make-clambda L (map CaseExpr clauses) free)]))
(define (CodesExpr x)
(record-case x
[(codes list body)
(make-codes (map CodeExpr list) (Tail body))]))
(CodesExpr x))
(define (insert-stack-overflow-checks x)
(define who 'insert-stack-overflow-checks)
(define (insert-check body)
(make-seq
(make-interrupt-call
(make-primcall '$fp-overflow '())
(make-funcall (make-primref 'do-stack-overflow) '()))
body))
(define (Expr x)
(record-case x
[(constant) #f]
[(var) #f]
[(primref) #f]
[(closure code free*) #f]
[(bind lhs* rhs* body)
(or (ormap Expr rhs*) (Expr body))]
[(fix lhs* rhs* body) (Expr body)]
[(conditional test conseq altern)
(or (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (or (Expr e0) (Expr e1))]
[(primcall op arg*) (ormap Expr arg*)]
[(forcall op arg*) (ormap Expr arg*)]
[(funcall rator arg*) #t]
[(jmpcall label rator arg*) #t]
[(mvcall p c) #t]
[else (error who "invalid expression ~s" (unparse x))]))
(define (Tail x)
(record-case x
[(return v) (Expr v)]
[(bind lhs* rhs* body)
(or (ormap Expr rhs*) (Tail body))]
[(fix lhs* rhs* body) (Tail body)]
[(conditional test conseq altern)
(or (Expr test) (Tail conseq) (Tail altern))]
[(seq e0 e1) (or (Expr e0) (Tail e1))]
[(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
[(jmpcall label rator arg*) (or (Expr rator) (ormap Expr arg*))]
[(mvcall p c) #t]
[else (error who "invalid tail expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case info body)
(if (Tail body)
(make-clambda-case info (insert-check body))
x)]))
(define (CodeExpr x)
(record-case x
[(clambda L cases free)
(make-clambda L (map CaseExpr cases) free)]))
(define (CodesExpr x)
(record-case x
[(codes list body)
(make-codes (map CodeExpr list)
(if (Tail body)
(insert-check body)
body))]))
(CodesExpr x))
(define (insert-allocation-checks x)
(define who 'insert-allocation-checks)
(define (check-bytes n var body)
(make-seq
(make-interrupt-call
(make-primcall '$ap-check-bytes
(list (make-constant n) var))
(make-forcall "ik_collect"
(list
(make-primcall '$fx+
(list (make-constant (fx+ n 4096)) var)))))
body))
(define (check-words n var body)
(make-seq
(make-interrupt-call
(make-primcall '$ap-check-words
(list (make-constant n) var))
(make-forcall "ik_collect" ; (make-primref 'do-overflow-words)
(list
(make-primcall '$fx+
(list (make-constant (fx+ n 4096)) var)))))
body))
(define (check-const n body)
(cond
[(fxzero? n) body]
[else
(make-seq
(make-interrupt-call
(make-primcall '$ap-check-const
(list (make-constant n)))
(make-forcall "ik_collect" ;(make-primref 'do-overflow)
(list (make-constant (fx+ n 4096)))))
body)]))
(define (closure-size x)
(record-case x
[(closure code free*)
(if (null? free*)
0
(align (fx+ disp-closure-data (fx* (length free*) wordsize))))]
[else (error 'closure-size "~s is not a closure" x)]))
(define (sum ac ls)
(cond
[(null? ls) ac]
[else (sum (fx+ ac (car ls)) (cdr ls))]))
(define (Expr x) </