ikarus/lib/libcompile.ss

;;; 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 cond-expand
  (lambda (x)
    (syntax-case x ()
      [(_ test conseq altern)
       (if (eval (syntax-object->datum #'test))
           #'conseq
           #'altern)])))

(cond-expand (eq? "" "")
  (include "record-case.chez.ss")
  (include "record-case.ss"))


(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]
    [$vector-memq       2   value]
    ;;; 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]
    [$tcbucket-dlink-next       1   value]
    [$tcbucket-dlink-prev       1   value]
    [$set-tcbucket-val!   2  effect]
    [$set-tcbucket-next!  2  effect]
    [$set-tcbucket-dlink-next!  2  effect]
    [$set-tcbucket-dlink-prev!  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]
    ;;; 
    ;;; 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]
    [$install-underflow-handler 0 effect]
   ))

(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 rp-convention base-idx arg-count live-mask))
(define-record tailcall-cp (convention arg-count))
(define-record primcall (op arg*))
(define-record primref (name))
(define-record conditional (test conseq altern))
(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 clambda-case (arg* proper body))
(define-record clambda (label cases))
(define-record clambda-code (label cases free))
(define-record closure (code free*))
(define-record funcall (op rand*))
(define-record appcall (op rand*))
(define-record forcall (op rand*))
(define-record codes (list body))
(define-record assign (lhs rhs))

(define (unique-var x)
  (make-var (gensym x) #f #f))


(define (recordize x)
  (define (gen-fml* fml*)
    (cond
      [(pair? fml*)
       (cons (unique-var (car fml*))
             (gen-fml* (cdr fml*)))]
      [(symbol? fml*)
       (unique-var fml*)]
      [else '()]))
  (define (properize fml*)
    (cond
      [(pair? fml*)
       (cons (car fml*) (properize (cdr fml*)))]
      [(null? fml*) '()]
      [else (list fml*)]))
  (define (extend-env fml* nfml* env)
    (cons (cons fml* nfml*) env))
  (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 (lookup^ x lhs* rhs*)
    (cond
      [(pair? lhs*)
       (if (eq? x (car lhs*))
           (car rhs*)
           (lookup^ x (cdr lhs*) (cdr rhs*)))]
      [(eq? x lhs*) rhs*]
      [else #f]))
  (define (lookup x env)
    (cond
      [(pair? env)
       (or (lookup^ x (caar env) (cdar env))
           (lookup x (cdr env)))]
      [else #f]))
  (define (E x env)
    (cond
      [(pair? x)
       (case (car x)
         [(quote)  (make-constant (cadr x))]
         [(if) 
          (make-conditional 
            (E (cadr x) env)
            (E (caddr x) env)
            (E (cadddr x) env))]
         [(set!)
          (let ([lhs (cadr x)] [rhs (caddr x)])
            (make-assign
              (or (lookup lhs env) 
                  (error 'recordize "invalid assignment ~s" x))
              (E rhs env)))]
         [(begin)
          (let f ([a (cadr x)] [d (cddr x)])
            (cond
              [(null? d) (E a env)]
              [else
               (make-seq 
                 (E a env)
                 (f (car d) (cdr d)))]))]
         [(letrec)
          (unless (fx= (length x) 3) (syntax-error x))
          (let ([bind* (cadr x)] [body (caddr x)])
            (let ([lhs* (map car bind*)]
                  [rhs* (map cadr bind*)])
              (let ([nlhs* (gen-fml* lhs*)])
                (let ([env (extend-env lhs* nlhs* env)])
                  (make-recbind nlhs* 
                                (map (lambda (rhs) (E rhs env)) rhs*)
                                (E body env))))))]
         [(letrec)
          (unless (fx= (length x) 3) (syntax-error x))
          (let ([bind* (cadr x)] [body (caddr x)])
            (let ([lhs* (map car bind*)]
                  [rhs* (map cadr bind*)]
                  [v* (map (lambda (x) '(void)) bind*)]
                  [t* (map (lambda (x) (gensym)) bind*)])
              (E `((case-lambda 
                     [,lhs* 
                       ((case-lambda 
                          [,t* 
                           (begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*)
                                  ,body)])
                        ,@rhs*)])
                   ,@v*)
                 env)))]
         [(case-lambda)
          (let ([cls*
                 (map
                   (lambda (cls)
                     (let ([fml* (car cls)] [body (cadr cls)])
                       (let ([nfml* (gen-fml* fml*)])
                         (let ([body (E body (extend-env fml* nfml* env))])
                           (make-clambda-case 
                             (properize nfml*) 
                             (list? fml*) 
                             body)))))
                   (cdr x))])
            (make-clambda (gensym) cls*))]
         [(foreign-call)
          (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
            (make-forcall name
              (map (lambda (x) (E x env)) arg*)))]
         [(|#primitive|)
          (let ([var (cadr x)])
            (make-primref var))]
         ;;; [(|#primitive|)
         ;;;  (let ([var (cadr x)])
         ;;;    (if (primitive? var)
         ;;;        (make-primref var)
         ;;;        (error 'recordize "invalid primitive ~s" 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-primref var)
                (make-funcall
                  (make-primref 'top-level-value)
                  (list (make-constant var)))))]
         ;;; [(top-level-value)
         ;;;  (let ([var (quoted-sym (cadr x))])
         ;;;    (if (eq? (expand-mode) 'bootstrap)
         ;;;        (if (primitive? var)
         ;;;            (make-primref var)
         ;;;            (error 'compile "invalid primitive ~s" 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 (lambda (x) (E x env)) (cdr x)))]
         [(memv) 
          (make-funcall
             (make-primref 'memq)
             (map (lambda (x) (E x env)) (cdr x)))]
         [($apply)
          (let ([proc (cadr x)] [arg* (cddr x)])
            (make-appcall
              (E proc env)
              (map (lambda (x) (E x env)) arg*)))]
         [(void) 
          (make-constant (void))]
         [else
          (make-funcall 
            (E (car x) env)
            (map (lambda (x) (E x env)) (cdr x)))])]
      [(symbol? x)
       (or (lookup x env)
           (error 'recordize "invalid reference in ~s" 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))]
      [(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) `(begin ,(E e0) ,(E e1))]
      [(clambda-case args proper body)
       `(clambda-case ,(E-args proper args) ,(E body))]
      [(clambda g cls*)
       `(case-lambda . ,(map E cls*))]
      [(clambda-code 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*))]
      [(appcall rator rand*) `(appcall ,(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 rp-convention base-idx arg-count live-mask)
       `(call-cp [conv: ,call-convention]
                 [rpconv: ,rp-convention]
                 [base-idx: ,base-idx]
                 [arg-count: ,arg-count]
                 [live-mask: ,live-mask])]
      [(foreign-label x) `(foreign-label ,x)]
      [else (error 'unparse "invalid record ~s" x)]))
  (E x))

(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 fml* proper body)
       (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*)
    (record-case rator
      [(clambda g cls*)
       (try-inline cls* rand*
          (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 fml* proper body)
                   (make-clambda-case fml* proper (Expr body))]))
              cls*))]
      [(primcall rator rand*) 
       (make-primcall rator (map Expr rand*))]
      [(funcall rator rand*)
       (inline (Expr rator) (map Expr rand*))]
      [(appcall rator rand*)
       (make-appcall (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 fml* proper 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 fml* proper 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*)))]
      [(appcall rator rand*)
       (E rator) (for-each E 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 fml* proper body)
                   (let ([h (make-hash-table)])
                     (let ([body (E body (extend-hash fml* h ref) void)])
                       (make-clambda-case fml* proper body)))]))
              cls*))]
      [(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*))]
      [(appcall 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-appcall rator rand*))]
      [(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 fml* proper body)
                   (make-clambda-case fml* proper (Expr body))]))
              cls*))]
      [(primcall rator rand*) 
       (make-primcall rator (map Expr rand*))]
      [(funcall rator rand*)
       (make-funcall (Expr rator) (map Expr rand*))]
      [(appcall rator rand*)
       (make-appcall (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)
           (for-each init-var (clambda-case-arg* cls))
           (Expr (clambda-case-body cls)))
         cls*)]
      [(primcall rator rand*) (Expr* rand*)]
      [(funcall rator rand*)
       (begin (Expr rator) (Expr* rand*))]
      [(appcall rator rand*)
       (begin (Expr rator) (Expr* rand*))]
      [(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)

(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 (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-arg* 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 arg* proper body)
                (make-clambda-case arg* proper 
                   (Value body))]))
           cls*)))
  (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 test conseq altern)
       (make-conditional (Pred test) (Effect conseq) (Effect altern))]
      [(seq e0 e1) (mk-seq (Effect e0) (Effect e1))]
      [(clambda g cls*) the-void]
      [(primcall rator rand*) ; remove effect-free primcalls
       (make-primcall rator (map Value rand*))]
      [(funcall rator rand*)
       (make-funcall (Value rator) (map Value rand*))]
      [(appcall rator rand*)
       (make-appcall (Value rator) (map Value rand*))]
      [(forcall rator rand*) 
       (make-forcall rator (map Value rand*))]
      [(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 test conseq altern)
       (make-conditional (Pred test) (Pred conseq) (Pred altern))]
      [(seq e0 e1) (mk-seq (Effect e0) (Pred e1))]
      [(clambda g cls*) (make-constant #t)]
      [(primcall rator rand*) ;;; check for some effect-free/known prims
       (make-primcall rator (map Value rand*))]
      [(funcall rator rand*)
       (make-funcall (Value rator) (map Value rand*))]
      [(appcall rator rand*)
       (make-appcall (Value rator) (map Value rand*))]
      [(forcall rator rand*) 
       (make-forcall rator (map Value rand*))]
      [(assign lhs rhs)
       (mk-seq (Effect x) (make-constant #t))]
      [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 test conseq altern)
       (make-conditional (Pred test) (Value conseq) (Value altern))]
      [(seq e0 e1) (mk-seq (Effect e0) (Value e1))]
      [(clambda g cls*) (do-clambda g cls*)]
      [(primcall rator rand*)
       (make-primcall rator (map Value rand*))]
      [(funcall rator rand*)
       (make-funcall (Value rator) (map Value rand*))]
      [(appcall rator rand*)
       (make-appcall (Value rator) (map Value rand*))]
      [(forcall rator rand*) 
       (make-forcall rator (map Value rand*))]
      [(assign lhs rhs)
       (mk-seq (Effect x) (make-primcall 'void '()))]
      [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))))]