ikarus/scheme/ikarus.compiler.source-optimizer.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


;;; Work in progress

;;; Oscar Waddell. "Extending the Scope of Syntactic Abstraction". PhD.
;;; Thesis. Indiana University Computer Science Department. August 1999.
;;; Available online: 
;;;   http://www.cs.indiana.edu/~owaddell/papers/thesis.ps.gz

(module (source-optimize optimize-level cp0-effort-limit cp0-size-limit)
  (define who 'source-optimize)
  ;;;
  (define-structure (app rand* ctxt)
    ([inlined #f]))
  ;;;
  (define-structure (operand expr env ec)
    ([value                  #f]
     [residualize-for-effect #f]
     [size                    0]
     [inner-pending          #f]
     [outer-pending          #f]))
  ;;;
  (define-structure (counter value ctxt k))
  ;;;
  (define (passive-counter)
    (make-counter (greatest-fixnum) #f
      (lambda args 
        (error 'passive-counter "invalid abort"))))
  ;;;
  (define (passive-counter-value x)
    (- (greatest-fixnum) (counter-value x)))
  ;;;
  (define (active-counter? x)
    (and (counter? x) (counter-ctxt x)))
  ;;;
  (define (decrement x amt)
    (let ([n (- (counter-value x) amt)])
      (set-counter-value! x n)
      (when (< n 0)
        (reset-integrated! (counter-ctxt x))
        ((counter-k x) #f))))
  ;;;
  (define (abort-counter! x)
    (reset-integrated! (counter-ctxt x))
    ((counter-k x) #f))
  ;;;
  (define (reset-integrated! ctxt)
    (set-app-inlined! ctxt #f)
    (let ([ctxt (app-ctxt ctxt)])
      (when (app? ctxt)
        (reset-integrated! ctxt))))
  ;;;
  ;;;
  (module (with-extended-env copy-var)
    (define (copy-var x)
      (let ([y (make-prelex (prelex-name x) #f)])
        (set-prelex-source-referenced?! y
          (prelex-source-referenced? x))
        (set-prelex-source-assigned?! y
          (prelex-source-assigned? x))
        (let ([loc (prelex-global-location x)])
          (when loc
            (set-prelex-global-location! y loc)
            (set-prelex-source-referenced?! y #t)
            (set-prelex-residual-referenced?! y #t)))
        y))
    (define (extend env lhs* rands) 
      (if (null? lhs*)
          (values env '())
          (let ([nlhs* (map copy-var lhs*)])
            (when rands 
              (for-each 
                (lambda (lhs rhs) 
                  (set-prelex-operand! lhs rhs))
                nlhs* rands))
            (values (vector lhs* nlhs* env) nlhs*))))
    (define (copy-back ls)
      (for-each 
        (lambda (x)
          (set-prelex-source-assigned?! x 
             (prelex-residual-assigned? x))
          (set-prelex-source-referenced?! x 
             (prelex-residual-referenced? x)))
        ls))
    (define-syntax with-extended-env
      (syntax-rules ()
        [(_ ((e2 args2) (e1 args1 rands)) b b* ...)
         (let-values ([(e2 args2) (extend e1 args1 rands)])
           (let ([v (let () b b* ...)])
             (copy-back args2)
             v))])))

  (define cp0-effort-limit (make-parameter 50))
  (define cp0-size-limit (make-parameter 8))

  (define primitive-info-list
    '(
      [(cons _ _)                           effect-free result-true]
      [(cons* _)                   foldable effect-free            ]
      [(cons* _ . _)                        effect-free result-true]
      [(list)                      foldable effect-free result-true]
      [(list . _)                           effect-free result-true]
      [(reverse ())                foldable effect-free result-true]
      [(string)                    foldable effect-free result-true]
      [(string . _)                                     result-true]
      [(make-string 0)             foldable effect-free result-true]
      [(make-string 0 _)           foldable effect-free result-true]
      [(make-string . _)                                result-true]
      [(make-bytevector 0)         foldable effect-free result-true]
      [(make-bytevector 0 _)       foldable             result-true]
      [(make-bytevector . _)                            result-true]
      [(string-length _)           foldable             result-true]
      [(string-ref _ _)            foldable             result-true]
      [(vector)                    foldable effect-free result-true]
      [(vector . _)                         effect-free result-true]
      [(make-vector 0)             foldable effect-free result-true]
      [(make-vector 0 _)           foldable effect-free result-true]
      [(make-vector . _)                                result-true]
      [(vector-length _)           foldable             result-true]
      [(vector-ref _ _)            foldable                        ]
      [(eq? _ _)                   foldable effect-free            ]
      [(eqv? _ _)                  foldable effect-free            ]
      [(assq _ _)                  foldable                        ]
      [(assv _ _)                  foldable                        ]
      [(assoc _ _)                 foldable                        ]
      [(not _)                     foldable effect-free            ]
      [(null? _)                   foldable effect-free            ]
      [(pair? _)                   foldable effect-free            ]
      [(fixnum? _)                 foldable effect-free            ]
      [(vector? _)                 foldable effect-free            ]
      [(string? _)                 foldable effect-free            ]
      [(char? _)                   foldable effect-free            ]
      [(symbol? _)                 foldable effect-free            ]
      [(procedure? _)              foldable effect-free            ]
      [(eof-object? _)             foldable effect-free            ]
      [(flonum? _)                 foldable effect-free            ]
      [(cflonum? _)                foldable effect-free            ]
      [(compnum? _)                foldable effect-free            ]
      [(integer? _)                foldable effect-free            ]
      [(bignum? _)                 foldable effect-free            ]
      [(ratnum? _)                 foldable effect-free            ]
      [(void)                      foldable effect-free result-true]
      [(car _)                     foldable                        ]
      [(cdr _)                     foldable                        ]
      [(caar _)                    foldable                        ]
      [(cadr _)                    foldable                        ]
      [(cdar _)                    foldable                        ]
      [(cddr _)                    foldable                        ]
      [(caaar _)                   foldable                        ]
      [(caadr _)                   foldable                        ]
      [(cadar _)                   foldable                        ]
      [(caddr _)                   foldable                        ]
      [(cdaar _)                   foldable                        ]
      [(cdadr _)                   foldable                        ]
      [(cddar _)                   foldable                        ]
      [(cdddr _)                   foldable                        ]
      [(caaaar _)                  foldable                        ]
      [(caaadr _)                  foldable                        ]
      [(caadar _)                  foldable                        ]
      [(caaddr _)                  foldable                        ]
      [(cadaar _)                  foldable                        ]
      [(cadadr _)                  foldable                        ]
      [(caddar _)                  foldable                        ]
      [(cadddr _)                  foldable                        ]
      [(cdaaar _)                  foldable                        ]
      [(cdaadr _)                  foldable                        ]
      [(cdadar _)                  foldable                        ]
      [(cdaddr _)                  foldable                        ]
      [(cddaar _)                  foldable                        ]
      [(cddadr _)                  foldable                        ]
      [(cdddar _)                  foldable                        ]
      [(cddddr _)                  foldable                        ]
      [(memq _ _)                  foldable                        ]
      [(memv _ _)                  foldable                        ]
      [(length _)                  foldable             result-true]
      [(+ . _)                     foldable             result-true]
      [(* . _)                     foldable             result-true]
      [(/ _ . _)                   foldable             result-true]
      [(- _ . _)                   foldable             result-true]
      [(fx+ _ _)                   foldable             result-true]
      [(fx- _ _)                   foldable             result-true]
      [(fx* _ _)                   foldable             result-true]
      [(fxior . _)                 foldable             result-true]
      [(fxlogor . _)               foldable             result-true]
      [(fxnot _)                   foldable             result-true]
      [(fxadd1 _)                  foldable             result-true]
      [(fxsub1 _)                  foldable             result-true]
      [(fxzero? _)                 foldable                        ]
      [(fx=? _ . _)                foldable                        ] 
      [(fx<? _ . _)                foldable                        ] 
      [(fx<=? _ . _)               foldable                        ] 
      [(fx>? _ . _)                foldable                        ] 
      [(fx>=? _ . _)               foldable                        ]
      [(fx= _ . _)                 foldable                        ] 
      [(fx< _ . _)                 foldable                        ] 
      [(fx<= _ . _)                foldable                        ] 
      [(fx> _ . _)                 foldable                        ] 
      [(fx>= _ . _)                foldable                        ]
      [(real-part _)               foldable             result-true]
      [(imag-part _)               foldable             result-true]
      [(fxsll _ _)                 foldable             result-true]
      [(fxsra _ _)                 foldable             result-true]
      [(fxremainder _ _)           foldable             result-true]
      [(fxquotient _ _)            foldable             result-true]
      [(greatest-fixnum)           foldable effect-free result-true]
      [(least-fixnum)              foldable effect-free result-true]
      [(fixnum-width)              foldable effect-free result-true]
      [(char->integer _)           foldable             result-true]
      [(integer->char _)           foldable             result-true]
      [(eof-object)                foldable effect-free result-true]
      [(zero? _)                   foldable                        ]
      [(= _ . _)                   foldable                        ] 
      [(< _ . _)                   foldable                        ] 
      [(<= _ . _)                  foldable                        ] 
      [(> _ . _)                   foldable                        ] 
      [(>= _ . _)                  foldable                        ]
      [(expt _ _)                  foldable             result-true]
      [(log _)                     foldable             result-true]
      [(sll _ _)                   foldable             result-true]
      [(sra _ _)                   foldable             result-true]
      [(inexact _)                 foldable             result-true]
      [(exact _)                   foldable             result-true]
      [(add1 _)                    foldable             result-true]
      [(sub1 _)                    foldable             result-true]
      [(bitwise-and _ _)           foldable             result-true]
      [(make-rectangular _ _)      foldable             result-true]
      [(sin _)                     foldable             result-true]
      [(cos _)                     foldable             result-true]
      [(tan _)                     foldable             result-true]
      [(asin _)                    foldable             result-true]
      [(acos _)                    foldable             result-true]
      [(atan _)                    foldable             result-true]
      [(make-eq-hashtable)                  effect-free result-true]
      [(string->number _)          foldable                        ]
      [(string->number _ _)        foldable                        ]
      [($fixnum->flonum _)         foldable effect-free result-true]
      [($char->fixnum _)           foldable effect-free result-true]
      [($fixnum->char _)           foldable effect-free result-true]
      [($fxzero? _)                foldable effect-free            ]
      [($fx+ _ _)                  foldable effect-free result-true]
      [($fx* _ _)                  foldable effect-free result-true]
      [($fx- _ _)                  foldable effect-free result-true]
      [($fx= _ _)                  foldable effect-free            ]
      [($fx>= _ _)                 foldable effect-free            ]
      [($fx> _ _)                  foldable effect-free            ]
      [($fx<= _ _)                 foldable effect-free            ]
      [($fx< _ _)                  foldable effect-free            ]
      [($car _)                    foldable effect-free            ]
      [($cdr _)                    foldable effect-free            ]
      [($struct-ref _ _)           foldable effect-free            ]
      [($struct/rtd? _ _)          foldable effect-free            ]
      [($fxsll _ _)                foldable effect-free result-true]
      [($fxsra _ _)                foldable effect-free result-true]
      [($fxlogor _ _)              foldable effect-free result-true]
      [($fxlogand _ _)             foldable effect-free result-true]
      [($fxadd1 _)                 foldable effect-free result-true]
      [($fxsub1 _)                 foldable effect-free result-true]
      [($vector-length _)          foldable effect-free result-true]
      [($vector-ref _ _)           foldable effect-free result-true]
      [($make-bytevector 0)        foldable effect-free result-true]
      [($make-bytevector 0 _)      foldable effect-free result-true]
      [($make-bytevector . _)               effect-free result-true]
      [($bytevector-u8-ref _ _)    foldable effect-free result-true]
      [($bytevector-length _)      foldable effect-free result-true]
      ;;;
      [(annotation? #f)             foldable effect-free result-false]
      [(annotation-stripped #f)     foldable effect-free result-false]
      ;;; unoptimizable
      [(condition . _)]
      [($make-flonum . _)]
      [(top-level-value . _)]
      [($struct . _)]
      [(make-message-condition . _)]
      [(make-lexical-violation . _)]
      [(make-who-condition . _)]
      [(make-error . _)]
      [(make-i/o-error . _)]
      [(make-i/o-write-error . _)]
      [(make-i/o-read-error . _)]
      [(make-i/o-file-already-exists-error . _)]
      [(make-i/o-file-is-read-only-error . _)]
      [(make-i/o-file-protection-error . _)]
      [(make-i/o-file-does-not-exist-error . _)]
      [(make-undefined-violation . _)]
      [(die . _)]
      [(gensym . _)]
      [(values . _)]
      [(error . _)]
      [(assertion-violation . _)]
      [(console-input-port . _)]
      [(console-output-port . _)]
      [(console-error-port . _)]
      [(printf . _)] ;;; FIXME: reduce to display
      [(newline . _)]
      [(native-transcoder . _)]
      [(open-string-output-port . _)]
      [(open-string-input-port . _)]
      [(environment . _)]
      [(print-gensym . _)]
      [(exit . _)]
      [(interrupt-handler . _)]
      [(display . _)]
      [(write-char . _)]
      [(current-input-port . _)]
      [(current-output-port . _)]
      [(current-error-port . _)]
      [(standard-input-port . _)]
      [(standard-output-port . _)]
      [(standard-error-port . _)]
      [($current-frame . _)]
      [(pretty-width . _)]
      [($fp-at-base . _)]
      [(read-annotated . _)]
      [($collect-key . _)]
      [(make-non-continuable-violation . _)]
      [(format . _)] ;;; FIXME, reduce to string-copy
      [(uuid . _)]
      [(print-graph . _)]
      [(interaction-environment . _)]
      [(make-guardian)]
      [(command-line-arguments)]
      [(make-record-type-descriptor . _)] ;;; FIXME
      [(make-assertion-violation . _)]
      [(new-cafe . _)]
      [(getenv . _)]
      [(gensym-prefix . _)]
      [($arg-list . _)]
      [($make-symbol . _)]
      [(string->utf8 . _)]
      [($make-call-with-values-procedure . _)]
      [($make-values-procedure . _)]
      [($unset-interrupted! . _)]
      [(make-interrupted-condition . _)]
      [($interrupted? . _)]
      [($symbol-value . _)]
      [(library-extensions . _)]
      [(base-rtd . _)]
      [($data->transcoder . _)]
      [(current-time . _)]
    ))
 
  (module (primprop)
    (define-syntax ct-gensym
      (lambda (x)
        (with-syntax ([g (datum->syntax #'here (gensym))])
          #'(quote g))))
    (define g (ct-gensym))
    (define (primprop p)
      (or (getprop p g) '()))
    (define (get prim ls)
      (cond
        [(null? ls) (values '() '())]
        [else
         (let ([a (car ls)])
           (let ([cc (car a)])
             (cond
               [(eq? (car cc) prim)
                (let-values ([(p* ls) (get prim (cdr ls))])
                  (values (cons (cons (cdr cc) (cdr a)) p*) ls))]
               [else (values '() ls)])))]))
    (let f ([ls primitive-info-list])
      (unless (null? ls)
        (let ([a (car ls)])
          (let ([cc (car a)] [cv (cdr a)])
            (let ([prim (car cc)] [args (cdr cc)])
              (let-values ([(p* ls) (get prim (cdr ls))])
                (putprop prim g 
                  (cons (cons args cv) p*))
                (f ls))))))))
  (define (primitive-info op args)
    (define (matches? x)
      (let f ([args args] [params (car x)])
        (cond
          [(pair? params)
           (and (pair? args)
                (case (car params)
                  [(_) (f (cdr args) (cdr params))]
                  [(#f 0 ()) 
                   (let ([v (value-visit-operand! (car args))])
                     (and (constant? v)
                          (equal? (constant-value v) (car params))
                          (f (cdr args) (cdr params))))]
                  [else
                   (error 'primitive-info "cannot happen" op (car params))]))]
          [(eq? params '_) #t]
          [(null? params) (null? args)]
          [else (error 'primitive-info "cannot happen" op params)])))
    (cond
      [(find matches? (primprop op))]
      [else '()]))

  (define (info-foldable? info) (memq 'foldable info))
  (define (info-effect-free? info) (memq 'effect-free info))
  (define (info-result-true? info) (memq 'result-true info))
  (define (info-result-false? info) (memq 'result-false info))

  (define-syntax ctxt-case
    (lambda (stx)
      (define (test x)
        (case (syntax->datum x)
          [(p)   #'(eq? t 'p)]
          [(v)   #'(eq? t 'v)]
          [(e)   #'(eq? t 'e)]
          [(app) #'(app? t)]
          [else (syntax-violation stx "invalid ctxt" x)]))
      (define (extract cls*)
        (syntax-case cls* (else)
          [() #'(error 'extract "unmatched ctxt" t)]
          [([else e e* ...]) #'(begin e e* ...)]
          [([(t* ...) e e* ...] rest ...) 
           (with-syntax ([(t* ...) (map test #'(t* ...))]
                         [body (extract #'(rest ...))])
             #'(if (or t* ...) 
                   (begin e e* ...)
                   body))]))
      (syntax-case stx ()
        [(_ expr cls* ...)
         (with-syntax ([body (extract #'(cls* ...))])
           #'(let ([t expr])
               body))])))
  (define (mkseq e0 e1)
    ;;; returns a (seq e0 e1) with a seq-less e1 if both 
    ;;; e0 and e1 are constructed properly.
    (if (simple? e0)
        e1
        (let ([e0 (struct-case e0
                    [(seq e0a e0b) (if (simple? e0b) e0a e0)]
                    [else e0])])
          (struct-case e1
            [(seq e1a e1b) (make-seq (make-seq e0 e1a) e1b)]
            [else (make-seq e0 e1)]))))
  ;;; simple?: check quickly whether something is effect-free
  (define (simple? x) 
    (struct-case x
      [(constant) #t]
      [(prelex)   #t]
      [(primref)  #t]
      [(clambda)  #t]
      [else       #f]))
  ;;; result returns the "last" value of an expression
  (define (result-expr x)
    (struct-case x
      [(seq e0 e1) e1]
      [else        x]))
  ;;;
  (define (records-equal? x y ctxt)
    (struct-case x
      [(constant kx)
       (struct-case y
         [(constant ky)
          (ctxt-case ctxt
            [(e) #t]
            [(p) (if kx ky (not ky))]
            [else (eq? kx ky)])]
         [else #f])]
      [else #f]))
  ;;;
  (define (residualize-operands e rand* sc)
    (cond
      [(null? rand*) e]
      [(not (operand-residualize-for-effect (car rand*)))
       (residualize-operands e (cdr rand*) sc)]
      [else
       (let ([opnd (car rand*)])
         (let ([e1 (or (operand-value opnd)
                       (struct-case opnd
                         [(operand expr env ec)
                          (E expr 'e env ec sc)]))])
           (if (simple? e1)
               (residualize-operands e (cdr rand*) sc)
               (begin
                 (decrement sc (operand-size opnd))
                 (mkseq e1 (residualize-operands e (cdr rand*) sc))))))]))
  (define (value-visit-operand! rand)
    (or (operand-value rand)
        (let ([sc (passive-counter)])
          (let ([e (struct-case rand
                     [(operand expr env ec) 
                      (E expr 'v env sc ec)])])
            (set-operand-value! rand e)
            (set-operand-size! rand (passive-counter-value sc))
            e))))
  (define (score-value-visit-operand! rand sc)
    (let ([val (value-visit-operand! rand)])
      (let ([score (operand-size rand)])
        (decrement sc score))
      val))
  (define (E-call rator rand* env ctxt ec sc)
    (let ([ctxt (make-app rand* ctxt)])
      (let ([rator (E rator ctxt env ec sc)])
        (if (app-inlined ctxt)
            (residualize-operands rator rand* sc)
            (begin
              (decrement sc (if (primref? rator) 1 3))
              (make-funcall rator
                (map (lambda (x) (score-value-visit-operand! x sc))
                     rand*)))))))
  ;;;
  (define (E-var x ctxt env ec sc)
    (ctxt-case ctxt
      [(e) (make-constant (void))]
      [else 
       (let ([x (lookup x env)])
         (let ([opnd (prelex-operand x)])
           (if (and opnd (not (operand-inner-pending opnd)))
               (begin
                 (dynamic-wind
                   (lambda () (set-operand-inner-pending! opnd #t))
                   (lambda () (value-visit-operand! opnd))
                   (lambda () (set-operand-inner-pending! opnd #f)))
                 (if (prelex-source-assigned? x)
                     (residualize-ref x sc)
                     (copy x opnd ctxt ec sc)))
               (residualize-ref x sc))))]))
  ;;;
  (define (copy x opnd ctxt ec sc)
    (let ([rhs (result-expr (operand-value opnd))])
      (struct-case rhs
        [(constant) rhs]
        [(prelex)
         (if (prelex-source-assigned? rhs)
             (residualize-ref x sc)
             (let ([opnd (prelex-operand rhs)])
               (if (and opnd (operand-value opnd))
                   (copy2 rhs opnd ctxt ec sc)
                   (residualize-ref rhs sc))))]
        [else (copy2 x opnd ctxt ec sc)])))
  ;;;
  (define (copy2 x opnd ctxt ec sc)
    (let ([rhs (result-expr (operand-value opnd))])
      (struct-case rhs
        [(clambda) 
         (ctxt-case ctxt
           [(v) (residualize-ref x sc)]
           [(p) (make-constant #t)]
           [(e) (make-constant (void))]
           [(app) 
            (or (and (not (operand-outer-pending opnd))
                     (dynamic-wind
                       (lambda () (set-operand-outer-pending! opnd #t))
                       (lambda ()
                         (call/cc
                           (lambda (abort)
                             (inline rhs ctxt empty-env 
                               (if (active-counter? ec)
                                   ec
                                   (make-counter
                                     (cp0-effort-limit)
                                     ctxt abort))
                               (make-counter 
                                 (if (active-counter? sc)
                                     (counter-value sc)
                                     (cp0-size-limit))
                                 ctxt abort)))))
                       (lambda () (set-operand-outer-pending! opnd #f))))
                (residualize-ref x sc))])]
        [(primref p)
         (ctxt-case ctxt
           [(v) rhs]
           [(p) (make-constant #t)]
           [(e) (make-constant (void))]
           [(app) (fold-prim p ctxt ec sc)])]
        [else (residualize-ref x sc)])))
  (define (inline proc ctxt env ec sc)
    (define (get-case cases rand*)
      (define (compatible? x)
        (struct-case (clambda-case-info x) 
          [(case-info label args proper)
           (cond
             [proper (= (length rand*) (length args))]
             [else (>= (length rand*) (- (length args) 1))])]))
      (cond
        [(memp compatible? cases) => car]
        [else #f]))
    (define (partition args rand*)
      (cond
        [(null? (cdr args))
         (let ([r (car args)])
           (let ([t* (map (lambda (x) (copy-var r)) rand*)])
             (values '() t* r)))]
        [else
         (let ([x (car args)])
           (let-values ([(x* t* r) (partition (cdr args) (cdr rand*))])
             (values (cons x x*) t* r)))]))
    (struct-case proc
      [(clambda g cases cp free name)
       (let ([rand* (app-rand* ctxt)])
         (struct-case (get-case cases rand*)
           [(clambda-case info body)
            (struct-case info
              [(case-info label args proper) 
               (cond
                 [proper
                  (with-extended-env ((env args) (env args rand*))
                    (let ([body (E body (app-ctxt ctxt) env ec sc)])
                      (let ([result (make-let-binding args rand* body sc)])
                        (set-app-inlined! ctxt #t)
                        result)))]
                 [else 
                  (let-values ([(x* t* r) (partition args rand*)])
                    (with-extended-env ((env a*)
                                        (env (append x* t*) rand*))
                      (let ([rarg (make-operand 
                                    (make-funcall (make-primref 'list) t*)
                                    env ec)])
                        (with-extended-env ((env b*)
                                            (env (list r) (list rarg)))
                          (let ([result
                                 (make-let-binding a* rand*
                                   (make-let-binding b* (list rarg)
                                     (E body (app-ctxt ctxt) env ec sc)
                                     sc)
                                   sc)])
                            (set-app-inlined! ctxt #t)
                            result)))))])])]
           [else
             (E proc 'v env ec sc)]))]))
  ;;;
  (define (do-bind lhs* rhs* body ctxt env ec sc)
    (let ([rand* (map (lambda (x) (make-operand x env ec)) rhs*)])
      (with-extended-env ((env lhs*) (env lhs* rand*))
        (residualize-operands
          (make-let-binding lhs* rand*
            (E body ctxt env ec sc)
            sc)
          rand* sc))))
  ;;;
  (define (make-let-binding var* rand* body sc)
    (define (process1 var rand lhs* rhs*)
      (cond
        [(prelex-residual-referenced? var)
         (values
            (cons var lhs*)
            (cons (score-value-visit-operand! rand sc) rhs*))]
        [(prelex-residual-assigned? var)
         (set-operand-residualize-for-effect! rand #t)
         (values 
            (cons var lhs*)
            (cons (make-constant (void)) rhs*))]
        [else
         (set-operand-residualize-for-effect! rand #t)
         (values lhs* rhs*)]))
    (define (process var* rand*)
      (cond
        [(null? var*) (values '() '())]
        [else
         (let ([var (car var*)] [rand (car rand*)])
           (let-values ([(lhs* rhs*) (process (cdr var*) (cdr rand*))])
             (process1 var rand lhs* rhs*)))]))
    (let-values ([(lhs* rhs*) (process var* rand*)])
       (if (null? lhs*) body (make-bind lhs* rhs* body))))
  ;;;
  (define (fold-prim p ctxt ec sc)
    (define (get-value p ls)
      (call/cc
        (lambda (k)
          (with-exception-handler 
            (lambda (con) 
              (decrement ec 10)
              (k #f))
            (lambda () 
              (make-constant (apply (system-value p) ls)))))))
    (let ([rand* (app-rand* ctxt)])
      (let ([info (primitive-info p rand*)])
        (let ([result
               (or (and (info-effect-free? info)
                        (ctxt-case (app-ctxt ctxt)
                          [(e) (make-constant (void))]
                          [(p) 
                           (cond
                             [(info-result-true? info)
                              (make-constant #t)]
                             [(info-result-false? info)
                              (make-constant #f)]
                             [else #f])]
                          [else #f]))
                   (and (info-foldable? info)
                        (let ([val*
                               (map (lambda (x) (value-visit-operand! x)) rand*)])
                          (cond
                            [(andmap constant? val*)
                             (get-value p (map constant-value val*))]
                            [else #f]))))])
          (if result
              (begin
                (decrement ec 1)
                (for-each
                  (lambda (x)
                    (set-operand-residualize-for-effect! x #t))
                  rand*)
                (set-app-inlined! ctxt #t)
                result)
              (begin
                (decrement sc 1)
                (make-primref p)))))))
  ;;;
  (define (residualize-ref x sc)
    (decrement sc 1)
    (set-prelex-residual-referenced?! x #t)
    x)
  ;;;
  (define (build-conditional e0 e1 e2)
    (or (struct-case e0
          [(funcall rator rand*) 
           (struct-case rator 
             [(primref op) 
              (and (eq? op 'not)
                   (= (length rand*) 1)
                   (build-conditional (car rand*) e2 e1))]
             [else #f])]
          [else #f])
        (make-conditional e0 e1 e2)))
         
  (define (E x ctxt env ec sc)
    (decrement ec 1)
    (struct-case x
      [(constant) (decrement sc 1) x]
      [(prelex) (E-var x ctxt env ec sc)]
      [(seq e0 e1)
       (mkseq (E e0 'e env ec sc) (E e1 ctxt env ec sc))]
      [(conditional e0 e1 e2)
       (let ([e0 (E e0 'p env ec sc)])
         (struct-case (result-expr e0)
           [(constant k) 
            (mkseq e0 (E (if k e1 e2) ctxt env ec sc))]
           [else 
            (let ([ctxt (ctxt-case ctxt [(app) 'v] [else ctxt])])
              (let ([e1 (E e1 ctxt env ec sc)]
                    [e2 (E e2 ctxt env ec sc)])
                (if (records-equal? e1 e2 ctxt)
                    (mkseq e0 e1)
                    (begin 
                      (decrement sc 1)
                      (build-conditional e0 e1 e2)))))]))]
      [(assign x v)
       (mkseq
         (let ([x (lookup x env)])
           (cond
             [(not (prelex-source-referenced? x))
              ;;; dead on arrival
              (E v 'e env ec sc)]
             [else
              (decrement sc 1)
              (set-prelex-residual-assigned?! x
                (prelex-source-assigned? x))
              (make-assign x (E v 'v env ec sc))]))
         (make-constant (void)))]
      [(funcall rator rand*)
       (E-call rator 
         (map (lambda (x) (make-operand x env ec)) rand*)
         env ctxt ec sc)]
      [(forcall name rand*)
       (decrement sc 1)
       (make-forcall name (map (lambda (x) (E x 'v env ec sc)) rand*))]
      [(primref name)
       (ctxt-case ctxt
         [(app) (fold-prim name ctxt ec sc)]
         [(v) (decrement sc 1) x]
         [else (make-constant #t)])]
      [(clambda g cases cp free name) 
       (ctxt-case ctxt
         [(app) (inline x ctxt env ec sc)]
         [(p e) (make-constant #t)]
         [else
          (decrement sc 2)
          (make-clambda (gensym)
            (map 
              (lambda (x)
                (struct-case x
                  [(clambda-case info body)
                   (struct-case info
                     [(case-info label args proper) 
                      (with-extended-env ((env args) (env args #f))
                        (make-clambda-case 
                          (make-case-info (gensym) args proper)
                          (E body 'v env ec sc)))])]))
              cases)
            cp free name)])]
      [(bind lhs* rhs* body) 
       (do-bind lhs* rhs* body ctxt env ec sc)]
      [(fix lhs* rhs* body)
       (with-extended-env ((env lhs*) (env lhs* #f))
         (for-each
           (lambda (lhs rhs)
             (set-prelex-operand! lhs (make-operand rhs env ec)))
            lhs* rhs*)
         (let ([body (E body ctxt env ec sc)])
           (let ([lhs* (remp 
                         (lambda (x)
                           (not (prelex-residual-referenced? x)))
                         lhs*)])
             (cond
               [(null? lhs*) body]
               [else
                (decrement sc 1)
                (make-fix lhs* 
                  (map (lambda (x)
                         (let ([opnd (prelex-operand x)])
                           (decrement sc (+ (operand-size opnd) 1))
                           (value-visit-operand! opnd)))
                       lhs*)
                  body)]))))]
      [else
       (error who "invalid expression" x)]))
  (define empty-env '())
  (define (lookup x env)
    (cond
      [(vector? env)
       (let f ([lhs* (vector-ref env 0)] [rhs* (vector-ref env 1)])
         (cond
           [(null? lhs*) (lookup x (vector-ref env 2))]
           [(eq? x (car lhs*)) (car rhs*)]
           [else (f (cdr lhs*) (cdr rhs*))]))]
      [else x]))
  (define optimize-level 
    (make-parameter 1
      (lambda (x)
        (if (memv x '(0 1 2))
            x
            (die 'optimize-level "valid levels are 0, 1, and 2")))))
  (define (source-optimize expr)
    (define (source-optimize expr)
      (E expr 'v empty-env (passive-counter) (passive-counter)))
    (case (optimize-level)
      [(2) (source-optimize expr)]
      [(1) 
       (parameterize ([cp0-size-limit 0])
         (source-optimize expr))]
      [else expr]))
)