;;; cpcommonize.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;; 
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;; http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(begin
(define-who commonization-level
  ($make-thread-parameter
    0
    (lambda (x)
      (unless (and (fixnum? x) (<= 0 x 9))
        ($oops who "invalid level ~s" x))
      x)))

(define $cpcommonize
  (let ()
    (import (nanopass))
    (include "base-lang.ss")

    (define-record-type binding
      (nongenerative)
      (sealed #t)
      (fields x (mutable e) size helper-box (mutable helper-b) (mutable helper-arg*))
      (protocol
        (lambda (new)
          (lambda (x e size helper-box)
            (new x e size helper-box #f #f)))))

    (define-language Lcommonize1 (extends Lsrc)
      (terminals
        (+ (fixnum (size))))
      (Expr (e body rtd-expr)
        (- (letrec ([x* e*] ...) body))
        (+ (letrec ([x* e* size] ...) body))))

    (define-language Lcommonize2 (extends Lcommonize1)
      (terminals
        (- (fixnum (size)))
        (+ (binding (b helper-b))))
      (Expr (e body rtd-expr)
        (- (letrec ([x* e* size] ...) body))
        (+ (letrec (helper-b* ...) (b* ...) body))))

    (define-syntax iffalse
      (syntax-rules ()
        [(_ e1 e2) e1 #;(or e1 (begin e2 #f))]))

    (define-syntax iftrue
      (syntax-rules ()
        [(_ e1 e2) e1 #;(let ([t e1]) (and t (begin e2 t)))]))

    (define Lcommonize1-lambda?
      (lambda (e)
        (nanopass-case (Lcommonize1 Expr) e
          [(case-lambda ,preinfo ,cl* ...) #t]
          [else #f])))

    (define-pass cpcommonize0 : Lsrc (ir) -> Lcommonize1 ()
      (Expr : Expr (ir) -> Expr (1)
        [(set! ,maybe-src ,x ,[e size])
         (values `(set! ,maybe-src ,x ,e) (fx+ 1 size))]
        [(seq ,[e1 size1] ,[e2 size2])
         (values `(seq ,e1 ,e2) (fx+ size1 size2))]
        [(if ,[e1 size1] ,[e2 size2] ,[e3 size3])
         (values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))]
        [(foreign (,conv* ...) ,name ,[e size] (,arg-type* ...) ,result-type)
         (values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
        [(fcallable (,conv* ...) ,[e size] (,arg-type* ...) ,result-type)
         (values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
        ; ($top-level-value 'x) adds just 1 to the size
        [(call ,preinfo ,pr (quote ,d))
         (guard (eq? (primref-name pr) '$top-level-value))
         (values `(call ,preinfo ,pr (quote ,d)) 1)]
        ; (let ([x* e*] ...) body) splits into letrec binding unassigned variables to lambdas plus a let for the remaining bindings
        [(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,[body size])) ,[e* -> e* size*] ...)
         (guard (fx= (length e*) interface))
         (define-record-type fudge (nongenerative) (sealed #t) (fields x e size))
         (let-values ([(lb* ob*) (partition
                                   (lambda (b)
                                     (and (not (prelex-assigned (fudge-x b)))
                                          (Lcommonize1-lambda? (fudge-e b))))
                                   (map make-fudge x* e* size*))])
           (values
             (let ([body (if (null? ob*)
                             body
                             `(call ,preinfo1
                                (case-lambda ,preinfo2
                                  (clause (,(map fudge-x ob*) ...) ,(length ob*) ,body))
                                ,(map fudge-e ob*) ...))])
               (if (null? lb*)
                   body
                   `(letrec ([,(map fudge-x lb*) ,(map fudge-e lb*) ,(map fudge-size lb*)] ...) ,body)))
             (apply fx+ size size*)))]
        [(call ,preinfo ,[e size] ,[e* size*] ...)
         (values `(call ,preinfo ,e ,e* ...) (apply fx+ size size*))]
        [(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* size*]) ...)
         (values `(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...) (apply fx+ 1 size*))]
        [(letrec ([,x* ,[e* size*]] ...) ,[body size])
         (values `(letrec ([,x* ,e* ,size*] ...) ,body) (apply fx+ size size*))]
        [(record-ref ,rtd ,type ,index ,[e size])
         (values `(record-ref ,rtd ,type ,index ,e) (fx+ size 1))]
        [(record-set! ,rtd ,type ,index ,[e1 size1] ,[e2 size2])
         (values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))]
        [(record ,rtd ,[rtd-expr size] ,[e* size*] ...)
         (values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))]
        [(cte-optimization-loc ,box ,[e size])
         (values `(cte-optimization-loc ,box ,e) size)]
        [(immutable-list (,[e* size*] ...) ,[e size])
         (values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))]
        [(quote ,d) (values `(quote ,d) 1)]
        [(ref ,maybe-src ,x) (values `(ref ,maybe-src ,x) 1)]
        [,pr (values pr 1)]
        [(moi) (values `(moi) 1)]
        [(pariah) (values `(pariah) 0)]
        [(profile ,src) (values `(profile ,src) 0)]
        [else (sorry! who "unhandled record ~s" ir)])
      (let-values ([(e size) (Expr ir)]) e))

    (define-pass cpcommonize1 : Lcommonize1 (ir worthwhile-size) -> Lcommonize2 ()
      (definitions
        (define worthwhile-size?
          (lambda (expr-size)
            (fx>= expr-size worthwhile-size)))
        (define worthwhile-ratio?
          (lambda (expr-size subst-count)
            (or (fx= subst-count 0)
                (fx>= (div expr-size subst-count) 4))))
        (define-record-type subst
          (nongenerative)
          (sealed #t)
          (fields t e1 e2))
        (define-record-type frob
          (nongenerative)
          (sealed #t)
          (fields subst* e b))
        (define ht (make-hashtable values fx=))
        (define make-sym
          (lambda x*
            (string->symbol (apply string-append (map (lambda (x) (if (prelex? x) (symbol->string (prelex-name x)) x)) x*)))))
        (define same-preinfo?
          (lambda (p1 p2)
            ; ignore differences in src and sexpr
            #t))
        (define same-preinfo-lambda?
          (lambda (p1 p2)
            ; ignore differences src, sexpr, and name
            (eq? (preinfo-lambda-libspec p1) (preinfo-lambda-libspec p2))))
        (define-who same-type?
          (lambda (ty1 ty2)
            (nanopass-case (Ltype Type) ty1
              [(fp-integer ,bits1)
               (nanopass-case (Ltype Type) ty2
                 [(fp-integer ,bits2) (= bits1 bits2)]
                 [else #f])]
              [(fp-unsigned ,bits1)
               (nanopass-case (Ltype Type) ty2
                 [(fp-unsigned ,bits2) (= bits1 bits2)]
                 [else #f])]
              [(fp-void)
               (nanopass-case (Ltype Type) ty2
                 [(fp-void) #t]
                 [else #f])]
              [(fp-scheme-object)
               (nanopass-case (Ltype Type) ty2
                 [(fp-scheme-object) #t]
                 [else #f])]
              [(fp-u8*)
               (nanopass-case (Ltype Type) ty2
                 [(fp-u8*) #t]
                 [else #f])]
              [(fp-u16*)
               (nanopass-case (Ltype Type) ty2
                 [(fp-u16*) #t]
                 [else #f])]
              [(fp-u32*)
               (nanopass-case (Ltype Type) ty2
                 [(fp-u32*) #t]
                 [else #f])]
              [(fp-fixnum)
               (nanopass-case (Ltype Type) ty2
                 [(fp-fixnum) #t]
                 [else #f])]
              [(fp-double-float)
               (nanopass-case (Ltype Type) ty2
                 [(fp-double-float) #t]
                 [else #f])]
              [(fp-single-float)
               (nanopass-case (Ltype Type) ty2
                 [(fp-single-float) #t]
                 [else #f])]
              [(fp-ftd ,ftd1)
               (nanopass-case (Ltype Type) ty2
                 [(fp-ftd ,ftd2) (eq? ftd1 ftd2)]
                 [else #f])]
              [else (sorry! who "unhandled foreign type ~s" ty1)])))
        (define okay-to-subst?
          (lambda (e)
            (define free?
              (lambda (x)
                (and (not (prelex-operand x)) #t)))
            (nanopass-case (Lcommonize1 Expr) e
              [(ref ,maybe-src1 ,x1) (and (not (prelex-assigned x1)) (free? x1))]
              [(quote ,d) #t]
              [,pr (all-set? (prim-mask proc) (primref-flags pr))]
              [else #f])))
        (define constant-equal?
          (lambda (x y)
            (define record-equal?
              (lambda (x y e?)
                (let ([rtd ($record-type-descriptor x)])
                  (and (eq? ($record-type-descriptor y) rtd)
                       (let f ([field-name* (csv7:record-type-field-names rtd)] [i 0])
                         (or (null? field-name*)
                             (and (let ([accessor (csv7:record-field-accessor rtd i)])
                                    (e? (accessor x) (accessor y)))
                                  (f (cdr field-name*) (fx+ i 1)))))))))
            (parameterize ([default-record-equal-procedure record-equal?])
              ; equal? should be okay since even mutable constants aren't supposed to be mutated
              (equal? x y))))
        (define same?
          (lambda (e1 e2)
            (nanopass-case (Lcommonize1 Expr) e1
              [(ref ,maybe-src1 ,x1)
               (nanopass-case (Lcommonize1 Expr) e2
                 [(ref ,maybe-src2 ,x2)
                  (or (eq? x1 x2)
                      (eq? (prelex-operand x1) x2))]
                 [else #f])]
              [(quote ,d1)
               (nanopass-case (Lcommonize1 Expr) e2
                 [(quote ,d2) (constant-equal? d1 d2)]
                 [else #f])]
              [,pr1
                (nanopass-case (Lcommonize1 Expr) e2
                  [,pr2 (eq? pr1 pr2)]
                  [else #f])]
              [(moi)
               (nanopass-case (Lcommonize1 Expr) e2
                 [(moi) #t]
                 [else #f])]
              [(pariah)
               (nanopass-case (Lcommonize1 Expr) e2
                 [(pariah) #t]
                 [else #f])]
              [(profile ,src1)
               (nanopass-case (Lcommonize1 Expr) e2
                 [(profile ,src2) (eq? src1 src2)]
                 [else #f])]
              [(call ,preinfo1 ,pr1 (quote ,d1))
               (guard (eq? (primref-name pr1) '$top-level-value))
               (nanopass-case (Lcommonize1 Expr) e2
                 [(call ,preinfo2 ,pr2 (quote ,d2))
                  (guard (eq? (primref-name pr2) '$top-level-value))
                  (and (same-preinfo? preinfo1 preinfo2) (eq? d1 d2))]
                 [else #f])]
              [else #f])))
        (define-who unify
          (lambda (e1 e2)
            (module (with-env)
              (define $with-env
                (lambda (x1* x2* th)
                  (dynamic-wind
                    (lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 x2) (prelex-operand-set! x2 #t)) x1* x2*))
                    th
                    (lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 #f) (prelex-operand-set! x2 #f)) x1* x2*)))))
              (define-syntax with-env
                (syntax-rules ()
                  [(_ x1* x2* e) ($with-env x1* x2* (lambda () e))])))
            (call/cc
              (lambda (return)
                (let ([subst* '()])
                  (define lookup-subst
                    (lambda (e1 e2)
                      (define same-subst?
                        (lambda (x)
                          (and (same? (subst-e1 x) e1) (same? (subst-e2 x) e2))))
                      (cond
                        [(find same-subst? subst*) =>
                         (lambda (subst)
                           (let ([t (subst-t subst)])
                             (set-prelex-multiply-referenced! t #t)
                             t))]
                        [else #f])))
                  (let ([e (with-output-language (Lcommonize1 Expr)
                             (let ()
                               (define fclause
                                 (lambda (cl1 cl2)
                                   (nanopass-case (Lcommonize1 CaseLambdaClause) cl1
                                     [(clause (,x1* ...) ,interface1 ,body1)
                                      (nanopass-case (Lcommonize1 CaseLambdaClause) cl2
                                        [(clause (,x2* ...) ,interface2 ,body2)
                                         (if (fx= interface1 interface2)
                                             (with-env x1* x2*
                                               (with-output-language (Lcommonize1 CaseLambdaClause)
                                                 `(clause (,x1* ...) ,interface1 ,(f body1 body2))))
                                             (return (iffalse #f (printf "lambda interfaces don't match\n")) '()))])])))
                               (define f
                                 (case-lambda
                                   [(e1 e2) (f e1 e2 #f)]
                                   [(e1 e2 call-position?)
                                    (or (cond
                                          [(same? e1 e2) e1]
                                          [(and (not call-position?) (okay-to-subst? e1) (okay-to-subst? e2))
                                           `(ref #f ,(or (lookup-subst e1 e2)
                                                         (let ([t (make-prelex*)])
                                                           (set-prelex-referenced! t #t)
                                                           (set! subst* (cons (make-subst t e1 e2) subst*))
                                                           t)))]
                                          [else
                                            (nanopass-case (Lcommonize1 Expr) e1
                                              [(ref ,maybe-src1 ,x1) #f]
                                              [(quote ,d) #f]
                                              [,pr #f]
                                              [(moi) #f]
                                              [(profile ,src1) #f]
                                              ; reject non-same top-level-value calls with constant symbol so they
                                              ; don't end up being abstracted over the symbol in the residual code
                                              [(call ,preinfo ,pr (quote ,d))
                                               (guard (eq? (primref-name pr) '$top-level-value))
                                               #f]
                                              ; don't allow abstraction of first (type) argument to $object-ref, foreign-ref, etc.,
                                              ; since they can't be inlined without a constant type.
                                              ; ditto for $tc-field's first (field) argument.
                                              ; there are many other primitives we don't catch here for which the compiler generates
                                              ; more efficient code when certain arguments  are constant.
                                              [(call ,preinfo1 ,pr1 (quote ,d1) ,e1* ...)
                                               (guard (memq (primref-name pr1) '($object-ref $swap-object-ref $object-set foreign-ref foreign-set! $tc-field)))
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(call ,preinfo2 ,pr2 (quote ,d2) ,e2* ...)
                                                  (guard (eq? pr2 pr1) (eq? d1 d2))
                                                  (and (same-preinfo? preinfo1 preinfo2)
                                                       (fx= (length e1*) (length e2*))
                                                       `(call ,preinfo1 ,pr1 (quote ,d1) ,(map f e1* e2*) ...))]
                                                 [else #f])]
                                              [(call ,preinfo1 ,e1 ,e1* ...)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(call ,preinfo2 ,e2 ,e2* ...)
                                                  (and (fx= (length e1*) (length e2*))
                                                       (same-preinfo? preinfo1 preinfo2)
                                                       `(call ,preinfo1 ,(f e1 e2 #t) ,(map f e1* e2*) ...))]
                                                 [else #f])]
                                              [(if ,e10 ,e11 ,e12)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(if ,e20 ,e21 ,e22)
                                                  `(if ,(f e10 e20) ,(f e11 e21) ,(f e12 e22))]
                                                 [else #f])]
                                              [(case-lambda ,preinfo1 ,cl1* ...)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(case-lambda ,preinfo2 ,cl2* ...)
                                                  (and (fx= (length cl1*) (length cl2*))
                                                       (same-preinfo-lambda? preinfo1 preinfo2)
                                                       `(case-lambda ,preinfo1 ,(map fclause cl1* cl2*) ...))]
                                                 [else #f])]
                                              [(seq ,e11 ,e12)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(seq ,e21 ,e22) `(seq ,(f e11 e21) ,(f e12 e22))]
                                                 [else #f])]
                                              [(set! ,maybe-src1 ,x1 ,e1)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(set! ,maybe-src2 ,x2 ,e2)
                                                  (and (eq? x1 x2)
                                                       `(set! ,maybe-src1 ,x1 ,(f e1 e2)))]
                                                 [else #f])]
                                              [(letrec ([,x1* ,e1* ,size1*] ...) ,body1)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(letrec ([,x2* ,e2* ,size2*] ...) ,body2)
                                                  (and (fx= (length x2*) (length x1*))
                                                       (andmap fx= size1* size2*)
                                                       (with-env x1* x2*
                                                         `(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))]
                                                 [else #f])]
                                              [(foreign (,conv1* ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(foreign (,conv2* ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2)
                                                  (and (equal? conv1* conv2*)
                                                       (equal? name1 name2)
                                                       (fx= (length arg-type1*) (length arg-type2*))
                                                       (andmap same-type? arg-type1* arg-type2*)
                                                       (same-type? result-type1 result-type2)
                                                       `(foreign (,conv1* ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
                                                 [else #f])]
                                              [(fcallable (,conv1* ...) ,e1 (,arg-type1* ...) ,result-type1)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(fcallable (,conv2* ...) ,e2 (,arg-type2* ...) ,result-type2)
                                                  (and (equal? conv1* conv2*)
                                                       (fx= (length arg-type1*) (length arg-type2*))
                                                       (andmap same-type? arg-type1* arg-type2*)
                                                       (same-type? result-type1 result-type2)
                                                       `(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
                                                 [else #f])]
                                              [(cte-optimization-loc ,box1 ,e1)
                                               (nanopass-case (Lcommonize1 Expr) e2
                                                 [(cte-optimization-loc ,box2 ,e2)
                                                  (and (eq? box1 box2)
                                                       `(cte-optimization-loc ,box1 ,(f e1 e2)))]
                                                 [else #f])]
                                              [else (sorry! who "unhandled record ~s" e1)])])
                                        (return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))]))
                               (f e1 e2)))])
                    (values e subst*)))))))
        (define sort-substs
          ; reestablish original argument order for substituted variables where possible
          ; so the arguments to an abstracted procedure aren't shuffled around in the
          ; call to the generated helper.
          (lambda (subst0* x1* x2*)
            (define (this? x x*) (and (not (null? x*)) (eq? x (car x*))))
            (define (next x*) (if (null? x*) x* (cdr x*)))
            (let-values ([(new-subst* subst*) (let f ([x1* x1*] [x2* x2*] [subst* subst0*] [n (length subst0*)])
                                                (cond
                                                  [(fx= n 0) (values '() subst*)]
                                                  [(find (lambda (subst)
                                                           (define (is-this-arg? e x*)
                                                             (nanopass-case (Lcommonize1 Expr) e
                                                               [(ref ,maybe-src ,x) (this? x x*)]
                                                               [else #f]))
                                                           (or (is-this-arg? (subst-e1 subst) x1*)
                                                               (is-this-arg? (subst-e2 subst) x2*)))
                                                     subst*) =>
                                                   (lambda (subst)
                                                     (let-values ([(new-subst* subst*) (f (next x1*) (next x2*) (remq subst subst*) (fx- n 1))])
                                                       (values (cons subst new-subst*) subst*)))]
                                                  [else
                                                    (let-values ([(new-subst* subst*) (f (next x1*) (next x2*) subst* (fx- n 1))])
                                                      (values (cons (car subst*) new-subst*) (cdr subst*)))]))])
              (safe-assert (null? subst*))
              (safe-assert (fx= (length new-subst*) (length subst0*)))
              new-subst*)))
        (define find-match
          (lambda (b1 ht)
            (and (iffalse (worthwhile-size? (binding-size b1)) (printf "skipping b1: under worthwhile size ~s ~s\n" (binding-size b1) worthwhile-size))
                 (ormap (lambda (b2)
                          (iffalse #f (printf "checking ~s & ~s:" (prelex-name (binding-x b1)) (prelex-name (binding-x b2))))
                          (nanopass-case (Lcommonize1 Expr) (binding-e b1)
                            ; NB: restricting to one clause for now...handling multiple
                            ; NB: clauses should be straightforward with a helper per
                            ; NB: common clause.
                            [(case-lambda ,preinfo1 (clause (,x1* ...) ,interface1 ,body1))
                             ; NB: no rest interface for now.  should be straightforward
                             (guard (fxnonnegative? interface1))
                             (and 
                               (nanopass-case (Lcommonize1 Expr) (binding-e b2)
                                 [(case-lambda ,preinfo2 (clause (,x2* ...) ,interface2 ,body2))
                                  (guard (fxnonnegative? interface2))
                                  (let-values ([(e subst*) (unify body1 body2)])
                                    (and e
                                         (iffalse (worthwhile-ratio? (binding-size b1) (length subst*)) (printf " no, not worthwhile ratio ~s ~s\n" (binding-size b1) (length subst*)))
                                         (let ([subst* (sort-substs subst* x1* x2*)])
                                           (iffalse #f (printf " yes\n"))
                                           (make-frob subst* e b2))))]
                                 [else (iffalse #f (printf " no, b2 does not meet lambda restrictions\n"))]))]
                            [else (iffalse #f (printf " no, b1 does not meet lambda restrictions\n"))]))
                   (hashtable-ref ht (binding-size b1) '())))))
        (define record-helper!
          (lambda (b next e*)
            (binding-helper-b-set! b next)
            (binding-helper-arg*-set! b e*)))
        (define build-helper
          (lambda (t t* body size helper-box)
            (make-binding t
              (with-output-language (Lcommonize1 Expr)
                `(case-lambda ,(make-preinfo-lambda) (clause (,t* ...) ,(length t*) ,body)))
              size
              helper-box)))
        (define commonize-letrec
          (lambda (x* e* size* body) ; e* and body have not been processed
            (define (prune-and-process! b)
              (let ([b* (remq b (hashtable-ref ht (binding-size b) '()))])
                (if (null? b*)
                    (hashtable-delete! ht (binding-size b))
                    (hashtable-set! ht (binding-size b) b*)))
              (unless (binding-helper-b b) (binding-e-set! b (Expr (binding-e b)))))
            (if (null? x*)
                body
                (let ([helper-box (box '())])
                  (let ([b* (map (lambda (x e size) (make-binding x e size helper-box)) x* e* size*)])
                    (let ([body (let f ([b* b*])
                                  (if (null? b*)
                                      (Expr body)
                                      (let ([b (car b*)])
                                        (let ([frob (find-match b ht)])
                                          (if frob
                                              (let* ([outer-b (frob-b frob)]
                                                     [helper-box (binding-helper-box outer-b)]
                                                     [helper-b (let ([t (make-prelex* (make-sym (binding-x b) "&" (binding-x outer-b)))])
                                                                 (build-helper t (map subst-t (frob-subst* frob)) (frob-e frob) (binding-size outer-b) helper-box))])
                                                (set-box! helper-box (cons helper-b (unbox helper-box)))
                                                (record-helper! b helper-b (map subst-e1 (frob-subst* frob)))
                                                (record-helper! outer-b helper-b (map subst-e2 (frob-subst* frob)))
                                                (hashtable-update! ht (binding-size outer-b) (lambda (b*) (cons helper-b (remq outer-b b*))) '())
                                                (f (cdr b*)))
                                              (begin
                                                (hashtable-update! ht (binding-size b) (lambda (b*) (cons b b*)) '())
                                                (let ([body (f (cdr b*))])
                                                  (prune-and-process! b)
                                                  body)))))))])
                      (let ([helper-b* (unbox helper-box)])
                        (for-each prune-and-process! helper-b*)
                        (with-output-language (Lcommonize2 Expr)
                          `(letrec (,helper-b* ...) (,b* ...) ,body))))))))))
      (Expr : Expr (ir) -> Expr ()
        [(letrec ([,x* ,e* ,size*] ...) ,body)
         ; only unassigned lambda bindings post-cpletrec
         (safe-assert (andmap (lambda (x) (not (prelex-assigned x))) x*))
         (safe-assert (andmap (lambda (e) (Lcommonize1-lambda? e)) e*))
         (commonize-letrec x* e* size* body)]
        [(letrec* ([,x* ,e*] ...) ,body)
         ; no letrec* run post-cpletrec
         (assert #f)]))

    (define-pass cpcommonize2 : Lcommonize2 (ir) -> Lsrc ()
      (definitions
        (define build-caller
          (lambda (e helper-b helper-arg*)
            (define-who Arg
              (lambda (e)
               (with-output-language (Lsrc Expr)
                 (nanopass-case (Lcommonize1 Expr) e
                   [(ref ,maybe-src ,x) `(ref ,maybe-src ,x)]
                   [(quote ,d) `(quote ,d)]
                   [else (sorry! who "unexpected helper arg ~s" e)]))))
            (define propagate
              (lambda (alist)
                (lambda (e)
                  (nanopass-case (Lsrc Expr) e
                    [(ref ,maybe-src ,x)
                     (cond
                       [(assq x alist) => cdr]
                       [else e])]
                    [else e]))))
            (nanopass-case (Lcommonize1 Expr) e
              [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
               (with-output-language (Lsrc Expr)
                 `(case-lambda ,preinfo
                    (clause (,x* ...) ,interface
                      ,(let loop ([helper-b helper-b] [e* (map Arg helper-arg*)])
                         (if (binding-helper-b helper-b)
                             (nanopass-case (Lcommonize1 Expr) (binding-e helper-b)
                               [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
                                (loop (binding-helper-b helper-b) (map (propagate (map cons x* e*)) (map Arg (binding-helper-arg* helper-b))))])
                             `(call ,(make-preinfo)
                                ,(let ([t (binding-x helper-b)])
                                   (if (prelex-referenced t)
                                       (set-prelex-multiply-referenced! t #t)
                                       (set-prelex-referenced! t #t))
                                   `(ref #f ,t))
                                ,e* ...))))))])))
        (define maybe-build-caller
          (lambda (b)
            (let ([helper-b (binding-helper-b b)] [e (binding-e b)])
              (if helper-b
                  (build-caller e helper-b (binding-helper-arg* b))
                  (Expr e))))))
      (Expr : Expr (ir) -> Expr ()
        [(letrec (,helper-b* ...) (,b* ...) ,[body])
         (let loop ([rb* (reverse helper-b*)] [x* (map binding-x b*)] [e* (map maybe-build-caller b*)])
           (if (null? rb*)
               `(letrec ([,x* ,e*] ...) ,body)
               (let ([b (car rb*)] [rb* (cdr rb*)])
                 (if (prelex-referenced (binding-x b))
                     (loop rb* (cons (binding-x b) x*) (cons (maybe-build-caller b) e*))
                     (loop rb* x* e*)))))]))

    (lambda (x)
      (let ([level (commonization-level)])
        (if (fx= level 0)
            x
            (let ([worthwhile-size (expt 2 (fx- 10 level))])
              (cpcommonize2 (cpcommonize1 (cpcommonize0 x) worthwhile-size))))))))
)