;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details

(library (tests compiler)
  (export
    ;; languages
    LP L0 L1 L2 L3 L4 L5 L6 L7 L8 L9 L10 L11 L12 L13 L14 L15 L16 L17 L18

    ;; parsers
    parse-LP parse-L0 parse-L1 parse-L2 parse-L3 parse-L4 parse-L5 parse-L6
    parse-L7 parse-L8 parse-L9 parse-L10 parse-L11 parse-L13 parse-L14
    parse-L15 parse-L16 parse-L17 parse-L18

    ;; unparsers
    unparse-LP unparse-L0 unparse-L1 unparse-L2 unparse-L3 unparse-L4
    unparse-L5 unparse-L6 unparse-L7 unparse-L8 unparse-L9 unparse-L10
    unparse-L11 unparse-L12 unparse-L13 unparse-L14 unparse-L15 unparse-L16
    unparse-L17 unparse-L18

    ;; passes
    verify-scheme remove-implicit-begin remove-unquoted-constant
    remove-one-armed-if uncover-settable remove-impure-letrec remove-set!
    sanitize-binding remove-anonymous-lambda uncover-free convert-closure
    lift-letrec explicit-closure normalize-context remove-complex-opera*
    remove-anonymous-call introduce-dummy-rp remove-nonunary-let
    return-of-set! explicit-labels
    
    ;; preprocessor
    rename-vars/verify-legal)
  (import (rnrs) (nanopass) (tests helpers) (tests synforms) (nanopass nano-syntax-dispatch))

  (define-language LP
    (terminals
      (variable (x))
      (datum (d))
      (user-primitive (pr)))
    (Expr (e body)
      d
      x
      pr
      (set! x e)
      (if e1 e2)
      (if e1 e2 e3)
      (begin e1 ... e2)
      (lambda (x ...) body1 ... body2)
      (let ((x e) ...) body1 ... body2)
      (letrec ((x e) ...) body1 ... body2)
      (e0 e1 ...)))

  (define-parser parse-LP LP)

  (define-language L0 (extends LP)
    (Expr (e body)
      (- d
         x
         pr
         (e0 e1 ...))
      (+ (datum d)
         (var x)
         (primapp pr e ...)
         (app e0 e1 ...))))

  (define-parser parse-L0 L0)

  (define-who rename-vars/verify-legal
    (lambda (expr)
      (define keywords '(quote set! if begin let letrec lambda))
      (define extend-env*
        (lambda (x* env)
          (let f ([x* x*] [rx* '()] [env env])
            (if (null? x*)
                (values (reverse rx*) env)
                (let ([x (car x*)])
                  (let ([rx (gen-symbol x)])
                    (f (cdr x*) (cons rx rx*) (cons (cons x rx) env))))))))
      (let f ([expr expr] [env '()])
        (define f* (lambda (e* env) (map (lambda (e) (f e env)) e*)))
        (with-output-language (L0 Expr)
          (syncase expr
            [,const (guard (constant? const)) `(datum ,const)]
            [(quote ,lit) (guard (not (assq 'quote env))) `(datum ,lit)]
            [,var
             (guard (symbol? var))
             (cond
               [(assq var env) => (lambda (a) `(var ,(cdr a)))]
               [(memq var keywords) (error who "invalid reference to keyword" var)]
               [else (error who "reference to unbound var" var)])]
            [(set! ,var ,rhs)
             (guard (not (assq 'set! env)) (symbol? var))
             (cond
               [(assq var env) => (lambda (a) `(set! ,(cdr a) ,(f rhs env)))]
               [(memq var keywords) (error who "set! of keyword" expr)]
               [else (error who "set! of unbound var" expr)])]
            [(if ,e0 ,e1)
             (guard (not (assq 'if env)))
             `(if ,(f e0 env) ,(f e1 env))]
            [(if ,e0 ,e1 ,e2)
             (guard (not (assq 'if env)))
             `(if ,(f e0 env) ,(f e1 env) ,(f e2 env))]
            [(begin ,e* ... ,e)
             (guard (not (assq 'begin env)))
             `(begin ,(f* e* env) ... ,(f e env))]
            [(let ([,x* ,rhs*] ...) ,e* ... ,e)
             (guard (for-all symbol? x*) (set? x*))
             (let-values ([(x* new-env) (extend-env* x* env)])
               `(let ([,x* ,(f* rhs* env)] ...)
                  ,(f* e* new-env) ... ,(f e new-env)))]
            [(letrec ([,x* ,rhs*] ...) ,e* ... ,e)
             (guard (for-all symbol? x*) (set? x*))
             (let-values ([(x* env) (extend-env* x* env)])
               `(letrec ([,x* ,(f* rhs* env)] ...)
                  ,(f* e* env) ... ,(f e env)))]
            [(lambda (,x* ...) ,e* ... ,e)
             (guard (not (assq 'lambda env)) (for-all symbol? x*) (set? x*))
             (let-values ([(x* env) (extend-env* x* env)])
               `(lambda (,x* ...) ,(f* e* env) ... ,(f e env)))]
            [(,prim ,rand* ...)
             (guard (not (assq prim env)) (user-primitive? prim)
               (= (cadr (assq prim list-of-user-primitives)) (length rand*)))
             `(primapp ,prim ,(f* rand* env) ...)]
            [(,rator ,rand* ...) `(app ,(f rator env) ,(f* rand* env) ...)]
            [else (error who "invalid expression" expr)])))))

  (define-pass verify-scheme : LP (ir) -> L0 ()
    (definitions
      (define invalid-var?
        (lambda (x env)
          (cond
            [(memq x env) #f]
            [(keyword? x) "keyword"]
            [(user-primitive? x) "user-primitive"]
            [else "unbound variable"])))

      (define valid-bindings?
        (lambda (ls)
          (for-all variable? ls)))

      (define duplicate-names?
        (lambda (var*)
          (let f ([ls var*] [dups '()])
            (cond
              [(null? ls) (if (null? dups) #f dups)]
              [(and (memq (car ls) (cdr ls)) (not (memq (car ls) dups)))
               (f (cdr ls) (cons (car ls) dups))]
              [else (f (cdr ls) dups)]))))
     (define format-list
        (lambda (ls)
          (case (length ls)
            [(0) ""]
            [(1) (format "~s" (car ls))]
            [(2) (format "~s and ~s" (car ls) (cadr ls))]
            [else (let f ([a (car ls)] [ls (cdr ls)])
                    (if (null? ls)
                        (format "and ~s" a)
                        (format "~s, ~a" a (f (car ls) (cdr ls)))))]))))
    (Expr : Expr (ir [env '()]) -> Expr ()
      [,d `(datum ,d)]
      [,x (let ([invalid? (invalid-var? x env)])
            (if invalid?
                (error 'verify-scheme (format "reference to ~a ~s" invalid? x))
                `(var ,x)))]
      [(set! ,x ,e)
       (let ([invalid? (invalid-var? x env)])
         (if invalid?
             (error 'verify-scheme (format "assignment to ~a ~s" invalid? x))
             (let ([e (Expr e env)])
               `(set! ,x ,e))))]
      [(lambda (,x ...) ,body1 ... ,body2)
       (cond
         [(not (valid-bindings? x))
          (error 'verify-scheme
                 (format "invalid binding list ~a in lambda form" x))]
         [(duplicate-names? x)
          =>
          (lambda (x)
            (error 'verify-scheme
                   (format "duplicate bindings ~a in lambda form"
                           (format-list x))))]
         [else
           (let ([env (append env x)])
             (let ([body1 (map (lambda (x) (Expr x env)) body1)]
                   [body2 (Expr body2 env)])
               `(lambda (,x ...) ,body1 ... ,body2)))])]
      [(let ((,x ,e) ...) ,body1 ... ,body2) ;; track variables
       (cond
         [(not (valid-bindings? x))
          (error 'verify-scheme
                 (format "invalid binding list ~a in let form" x))]
         [(duplicate-names? x)
          =>
          (lambda (x)
            (error 'verify-scheme
                   (format "duplicate bindings ~a in let form"
                           (format-list x))))]
         [else
           (let ([e (map (lambda (x) (Expr x env)) e)])
             (let ([env (append env x)])
               (let ([body1 (map (lambda (x) (Expr x env)) body1)]
                     [body2 (Expr body2 env)])
                 `(let ((,x ,e) ...) ,body1 ... ,body2))))])]
      [(letrec ((,x ,e) ...) ,body1 ... ,body2) ;; track variables
       (cond
         [(not (valid-bindings? x))
          (error 'verify-scheme
                 (format "invalid binding list ~a in letrec form" x))]
         [(duplicate-names? x)
          =>
          (lambda (x)
            (error 'verify-scheme
                   (format "duplicate bindings ~a in letrec form"
                           (format-list x))))]
         [else
           (let ([env (append env x)])
             (let ([e (map (lambda (x) (Expr x env)) e)])
               (let ([body1 (map (lambda (x) (Expr x env)) body1)]
                     [body2 (Expr body2 env)])
                 `(letrec ((,x ,e) ...) ,body1 ... ,body2))))])]
      [(,e0 ,e1 ...)
       (let ([e1 (map (lambda (x) (Expr x env)) e1)])
         (if (and (symbol? e0) (user-primitive? e0))
             `(primapp ,e0 ,e1 ...)
             `(app ,(Expr e0 env) ,e1 ...)))]))

  (define-language L1 (extends L0)
    (Expr (e body)
      (- (lambda (x ...) body1 ... body2)
         (let ((x e) ...) body1 ... body2)
         (letrec ((x e) ...) body1 ... body2))
      (+ (lambda (x ...) body)
         (let ((x e) ...) body)
         (letrec ((x e) ...) body))))

  (define-parser parse-L1 L1)

  (define-pass remove-implicit-begin : L0 (ir) -> L1 ()
    (process-expr-expr : Expr (ir) -> Expr ()
      [(lambda (,x ...) ,[body1] ... ,[body2])
       `(lambda (,x ...) (begin ,body1 ... ,body2))]
      [(let ((,x ,[e]) ...) ,[body1] ... ,[body2])
       `(let ((,x ,e) ...) (begin ,body1 ... ,body2))]
      [(letrec ((,x ,[e]) ...) ,[body1] ... ,[body2])
       `(letrec ((,x ,e) ...) (begin ,body1 ... ,body2))]))

  (define-language L2 (extends L1)
    (Expr (e body)
      (- (datum d))
      (+ (quoted-const d))))

  (define-parser parse-L2 L2)

  (define-pass remove-unquoted-constant : L1 (ir) -> L2 ()
    (process-expr-expr : Expr (ir) -> Expr ()
      [(datum ,d) `(quoted-const ,d)]))

  (define-language L3 (extends L2) (Expr (e body) (- (if e1 e2))))

  (define-parser parse-L3 L3)

  (define-pass remove-one-armed-if : L2 (ir) -> L3 ()
    (process-expr-expr : Expr (ir) -> Expr ()
      [(if ,[e1] ,[e2]) `(if ,e1 ,e2 (primapp void))]))

  (define-language L4 (extends L3)
    (Expr (e body)
      (- (lambda (x ...) body)
         (let ((x e) ...) body)
         (letrec ((x e) ...) body))
      (+ (lambda (x ...) sbody)
         (let ((x e) ...) sbody)
         (letrec ((x e) ...) sbody)))
    (SetBody (sbody) (+ (settable (x ...) body) => body)))

  (define-parser parse-L4 L4)

  (define-pass uncover-settable : L3 (ir) -> L4 ()
    (definitions
      (define Expr*
        (lambda (e* asgn-var*)
          (if (null? e*)
              (values '() asgn-var*)
              (let-values ([(e asgn-var*) (Expr (car e*) asgn-var*)])
                (let-values ([(e* asgn-var*) (Expr* (cdr e*) asgn-var*)])
                  (values (cons e e*) asgn-var*)))))))
    (Expr : Expr (ir asgn-var*) -> Expr (asgn-var*)
      [(set! ,x ,[e asgn-var*]) (values `(set! ,x ,e) (set-cons x asgn-var*))]
      [(lambda (,x* ...) ,[body asgn-var*])
       (let ([set-x* (intersection asgn-var* x*)])
         (values `(lambda (,x* ...) (settable (,set-x* ...) ,body))
           (difference asgn-var* set-x*)))]
      [(let ([,x* ,e*]...) ,[body asgn-var*])
       (let ([set-x* (intersection asgn-var* x*)])
         (let-values ([(e* asgn-var*) (Expr* e* (difference asgn-var* set-x*))])
           (values `(let ([,x* ,e*] ...) (settable (,set-x* ...) ,body)) asgn-var*)))]
      [(letrec ([,x* ,e*]...) ,[body asgn-var*])
       (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)])
         (let ([set-x* (intersection asgn-var* x*)])
           (values `(letrec ((,x* ,e*) ...) (settable (,set-x* ...) ,body))
             (difference asgn-var* set-x*))))]
     ; TODO: this code used to be supported by the automatic combiners, we've
     ; abandoned this in favor of threading, but we've not added threading yet
      [(app ,[e asgn-var*] ,e* ...)
       (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)])
         (values `(app ,e ,e* ...) asgn-var*))]
      [(primapp ,pr ,e* ...)
       (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)])
         (values `(primapp ,pr ,e* ...) asgn-var*))]
      [(if ,[e0 asgn-var*] ,e1 ,e2)
       (let-values ([(e1 asgn-var*) (Expr e1 asgn-var*)])
         (let-values ([(e2 asgn-var*) (Expr e2 asgn-var*)])
           (values `(if ,e0 ,e1 ,e2) asgn-var*)))]
      [(begin ,e* ... ,[e asgn-var*])
       (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)])
         (values `(begin ,e* ... ,e) asgn-var*))])
    (let-values ([(e asgn-var*) (Expr ir '())]) e))

  (define-language L5 (extends L4)
    (Expr (e body)
      (+ lexpr
         (letrec ((x lexpr) ...) body))
      (- (lambda (x ...) sbody)
         (letrec ((x e) ...) sbody)))
    (LambdaExpr (lexpr) (+ (lambda (x ...) sbody))))

  (define-parser parse-L5 L5)

  (define-pass remove-impure-letrec : L4 (ir) -> L5 ()
    (process-expr-expr : Expr (ir) -> Expr ()
      [(lambda (,x ...) ,[sbody])
       (in-context LambdaExpr `(lambda (,x ...) ,sbody))]
      [(letrec ((,x1 (lambda (,x2 ...) ,[sbody1])) ...) (settable () ,[body2]))
       (let ([lambdabody (map
                           (lambda (x sbody)
                             (in-context LambdaExpr `(lambda (,x ...) ,sbody)))
                           x2 sbody1)])
         `(letrec ((,x1 ,lambdabody) ...) ,body2))]
      [(letrec ((,x1 ,[e]) ...) (settable (,x2 ...) ,[body]))
       (let ()
         (define void-maker
           (lambda (ids)
             (letrec ((helper (lambda (ls)
                                (if (null? (cdr ls))
                                    (list (in-context Expr `(primapp void)))
                                    (cons (in-context Expr `(primapp void))
                                          (helper (cdr ls)))))))
               (helper (iota (length ids))))))
         (let* ([new-ids (map gen-symbol x1)]
                [voids (void-maker x1)]
                [bodies (map (lambda (lhs id)
                               `(set! ,lhs (var ,id))) x1 new-ids)]
                [rbodies (reverse bodies)]
                [new-body (cdr rbodies)]
                [rest-bodies (car rbodies)])
           `(let ([,x1 ,voids] ...)
              (settable (,x1 ...)
                (begin
                  (primapp void)
                  (let ([,new-ids ,e] ...)
                    ;;**** this need not be from the output nonterminal ****
                    (settable ()
                      (begin ,new-body ...  ,rest-bodies)))
                  ,body)))))])
    (process-setbody-setbody : SetBody (ir) -> SetBody ()
      [(settable (,x ...) ,[body]) `(settable (,x ...) ,body)])
    (process-expr-lexpr : Expr (ir) -> LambdaExpr ()
      [(lambda (,x ...) ,[sbody]) `(lambda (,x ...) ,sbody)])
    (process-setbody-expr : SetBody (ir) -> Expr ()
      [(settable (,x ...) ,[body]) `,body]))

  (define-language L6 (extends L5)
    (Expr (e body)
      (- (let ((x e) ...) sbody)
         (set! x e))
      (+ (let ((x e) ...) body)))
    (LambdaExpr (lexpr)
      (- (lambda (x ...) sbody))
      (+ (lambda (x ...) body)))
    (SetBody (sbody) (- (settable (x ...) body))))

  (define-parser parse-L6 L6)

  (define-pass remove-set! : L5 (ir) -> L6 ()
    (Expr : Expr (ir [set* '()]) -> Expr ()
      [(var ,x) (if (memq x set*) `(primapp car (var ,x)) `(var ,x))]
      [(set! ,x ,[e set* -> e]) `(primapp set-car! (var ,x) ,e)]
      [(let ((,x ,[e set* -> e]) ...) ,sbody)
       (let ([body (SetBody sbody x e set*)])
         `,body)])
    (LambdaExpr : LambdaExpr (ir set*) -> LambdaExpr ()
      [(lambda (,x ...) ,[sbody x '() set* -> body]) `,body])
    (SetBody : SetBody (ir x* e* set*) -> Expr ()
      [(settable () ,[body set* -> body])
       (if (null? e*)
           `(lambda (,x* ...) ,body)
           `(let ([,x* ,e*] ...) ,body))]
      [(settable (,x ...) ,[body (append x set*) -> body])
       (let ()
         (define settable-bindings
           (lambda (var* set*)
             (if (null? var*) (values '() '() '())
               (let ([var (car var*)])
                 (let-values ([(var* lhs* rhs*)
                               (settable-bindings (cdr var*) set*)])
                   (if (memq var set*)
                       (let ([tmp (gen-symbol var)])
                         (values (cons tmp var*)
                                 (cons var lhs*)
                                 (cons (in-context
                                         Expr
                                         `(primapp cons (var ,tmp)
                                                   (primapp void))) rhs*)))
                       ;; **** (primapp void) is still a problem here ****
                       (values (cons var var*) lhs* rhs*)))))))
         (let-values ([(x* lhs* rhs*) (settable-bindings x* x)])
           ;; **** cannot have (let (,(apply append bindings*)) ---) or
           ;;      some such, due to nano-syntax-dispatch
           ;;      the problem is not that we don't allow ,(arbitrary
           ;;      function call) in the metaparser
           (if (null? e*)
               `(lambda (,x* ...) (let ([,lhs* ,rhs*] ...) ,body))
               `(let ([,x* ,e*] ...) (let ([,lhs* ,rhs*] ...) ,body)))))]))

  (define-pass sanitize-binding : L6 (ir) -> L6 ()
    (Expr : Expr (ir [rhs? #f]) -> Expr (#f)
      [(var ,x) (values `(var ,x) #f)]
      [(if ,[e1 #f -> e1 ig1] ,[e2 #f -> e2 ig2] ,[e3 #f -> e3 ig3])
       (values `(if ,e1 ,e2 ,e3) #f)]
      [(begin ,[e1 #f -> e1 ig1] ... ,[e2 #f -> e2 ig2])
       (values `(begin ,e1 ... ,e2) #f)]
      [(primapp ,pr ,[e #f -> e ig] ...) (values `(primapp ,pr ,e ...) #f)]
      [(app ,[e0 #f -> e0 ig0] ,[e1 #f -> e1 ig1] ...)
       (values `(app ,e0 ,e1 ...) #f)]
      [(quoted-const ,d) (values `(quoted-const ,d) #f)]
      [(let ([,x ,[e #t -> e lambda?]] ...) ,[body #f -> body ig])
       (let-values ([(let-x* let-e* letrec-x* letrec-e*)
                     (let f ([x x] [e e] [lambda? lambda?])
                       (if (null? x)
                           (values '() '() '() '())
                           (let-values ([(let-x let-e letrec-x letrec-e)
                                         (f (cdr x) (cdr e) (cdr lambda?))])
                             (let ([lhs (car x)]
                                   [rhs (car e)]
                                   [rhs-lambda? (car lambda?)])
                               (if rhs-lambda?
                                   (values let-x let-e (cons lhs letrec-x)
                                           (cons rhs letrec-e))
                                   (values (cons lhs let-x) (cons rhs let-e)
                                           letrec-x letrec-e))))))])
         (if (null? letrec-x*)
             (values `(let ([,let-x* ,let-e*] ...) ,body) #f)
             (if (null? let-x*)
                 (values `(letrec ([,letrec-x* ,letrec-e*] ...) ,body) #f)
                 (values `(letrec ([,letrec-x* ,letrec-e*] ...)
                            (let ([,let-x* ,let-e*] ...) ,body)) #f))))]
      [(letrec ([,x1 (lambda (,x2 ...) ,[body1 #f -> body1 ig1])] ...)
         ,[body2 #f -> body2 ig2])
       (values `(letrec ([,x1 (lambda (,x2 ...) ,body1)] ...) ,body2) #f)])
    (LambdaExpr : LambdaExpr (ir [rhs? #f]) -> LambdaExpr (dummy)
      [(lambda (,x ...) ,[body #f -> body ig])
       (values `(lambda (,x ...) ,body) #t)]))

  (define-language L7 (extends L6) (Expr (e body) (- lexpr)))

  (define-parser parse-L7 L7)

  (define-pass remove-anonymous-lambda : L6 (ir) -> L7 ()
    (Expr : Expr (ir) -> Expr ()
      [(lambda (,x ...) ,[body])
       (let ([anon (gen-symbol 'anon)])
         `(letrec ([,anon (lambda (,x ...) ,body)]) (var ,anon)))]))

#;
  (define-pass remove-anonymous-lambda : L6 (ir) -> L7 ()
    (Expr : Expr (ir) -> Expr ()
      [(lambda (,x ...) ,[body])
       (let ([anon (gen-symbol 'anon)])
         `(letrec ([,anon (lambda (,x ...) ,body)]) (var ,anon)))]
      [(var ,x) `(var ,x)]
      [(quoted-const ,d) `(quoted-const ,d)]
      [(if ,[e1] ,[e2] ,[e3]) `(if ,e1 ,e2 ,e3)]
      [(begin ,[e1] ... ,[e2]) `(begin ,e1 ... ,e2)]
      [(let ([,x ,[e]] ...) ,[body]) `(let ([,x ,e] ...) ,body)]
      [(letrec ([,x ,[lexpr]] ...) ,[body])
       `(letrec ([,x ,lexpr] ...) ,body)]
      [(primapp ,pr ,[e] ...) `(primapp ,pr ,e ...)]
      [(app ,[e0] ,[e1] ...) `(app ,e0 ,e1 ...)])
    (LambdaExpr : LambdaExpr (ir) -> LambdaExpr ()
      [(lambda (,x ...) ,[body]) `(lambda (,x ...) ,body)]))

  (define-language L8 (extends L7)
    (entry Expr)
    (LambdaExpr (lexpr) (- (lambda (x ...) body)))
    (FreeExp (free-body) (+ (free (x ...) body) => body))
    (LambdaExpr (lexpr) (+ (lambda (x ...) free-body))))

  (define-parser parse-L8 L8)

  (define-pass uncover-free : L7 (ir) -> L8 ()
    (definitions
      (define LambdaExpr*
        (lambda (lexpr* free*)
          (if (null? lexpr*)
              (values '() free*)
              (let-values ([(lexpr free*) (LambdaExpr (car lexpr*) free*)])
                (let-values ([(lexpr* free*) (LambdaExpr* (cdr lexpr*) free*)])
                  (values (cons lexpr lexpr*) free*))))))
      (define Expr*
        (lambda (e* free*)
          (if (null? e*)
              (values '() free*)
              (let-values ([(e free*) (Expr (car e*) free*)])
                (let-values ([(e* free*) (Expr* (cdr e*) free*)])
                  (values (cons e e*) free*)))))))
    (Expr : Expr (ir free*) -> Expr (free*)
      [(letrec ([,x* ,lexpr*] ...) ,[body free*])
       (let-values ([(e* free*) (LambdaExpr* lexpr* free*)])
         (values `(letrec ([,x* ,e*] ...) ,body) (difference free* x*)))]
      [(let ([,x* ,e*] ...) ,[body free*])
       (let-values ([(e* free*) (Expr* e* (difference free* x*))])
         (values `(let ([,x* ,e*] ...) ,body) free*))]
      [(var ,x) (values `(var ,x) (cons x free*))]
     ; TODO: get threaded variables working so we don't need to do this by hand
      [(app ,[e free*] ,e* ...)
       (let-values ([(e* free*) (Expr* e* free*)])
         (values `(app ,e ,e* ...) free*))]
      [(primapp ,pr ,e* ...)
       (let-values ([(e* free*) (Expr* e* free*)])
         (values `(primapp ,pr ,e* ...) free*))]
      [(if ,[e1 free*] ,e2 ,e3)
       (let-values ([(e2 free*) (Expr e2 free*)])
         (let-values ([(e3 free*) (Expr e3 free*)])
           (values `(if ,e1 ,e2 ,e3) free*)))]
      [(begin ,e* ... ,[e free*])
       (let-values ([(e* free*) (Expr* e* free*)])
         (values `(begin ,e* ... ,e) free*))])
    (LambdaExpr : LambdaExpr (ir free*) -> LambdaExpr (free*)
      [(lambda (,x* ...) ,[body free*])
       (let ([free* (difference free* x*)])
         (values `(lambda (,x* ...) (free (,free* ...) ,body)) free*))])
    (let-values ([(e free*) (Expr ir '())]) e))

  (define-language L9
    (terminals
      (variable (x))
      (datum (d))
      (user-primitive (pr)))
    (Expr (e body)
      (var x)
      (quoted-const d)
      (if e1 e2 e3)
      (begin e1 ... e2)
      (let ((x e) ...) body)
      (letrec ((x lexpr) ...) c-letrec)
      (primapp pr e ...)
      (app e0 e1 ...)
      (anonymous-call e0 e1 ...))
    (LambdaExpr (lexpr)
      (lambda (x ...) bf-body))
    (BindFree (bf-body)
      (bind-free (x1 x2 ...) body))
    (Closure (c-exp)
      (closure x1 x2 ...))
    (ClosureLetrec (c-letrec)
      (closure-letrec ((x c-exp) ...) body)))

  (define-parser parse-L9 L9)

  (define-pass convert-closure : L8 (ir) -> L9 ()
    (Expr : Expr (ir [direct '()]) -> Expr ()
      [(app (var ,x) ,[e1 direct -> e1] ...)
       (guard (assq x direct))
       `(app (var ,(cdr (assq x direct))) (var ,x) ,e1 ...)]
      [(app ,[e0 direct -> e0] ,[e1 direct -> e1] ...)
       `(anonymous-call ,e0 ,e1 ...)]
      [(letrec ([,x1 (lambda (,x2 ...) (free (,x3 ...) ,body1))] ...) ,body2)
       (let ([code-name* (map gen-label x1)]
             [cp* (map (lambda (x) (gen-symbol 'cp)) x1)])
         (let* ([direct (append (map cons x1 code-name*) direct)]
                [body1 (map (lambda (exp)(Expr exp direct)) body1)]
                [bind-free* (map (lambda (cp formal* free* lbody)
                                   (in-context LambdaExpr
                                              `(lambda (,cp ,formal* ...)
                                                 (bind-free (,cp ,free* ...)
                                                            ,lbody))))
                                 cp* x2 x3 body1)]
                [closure* (map (lambda (code-name free*)
                                 (in-context Closure
                                            `(closure ,code-name ,free* ...)))
                               code-name* x3)])
           `(letrec ([,code-name* ,bind-free*] ...)
              (closure-letrec ([,x1 ,closure*] ...)
                ,(Expr body2 direct)))))]))

  (define-language L10 (extends L9)
    (entry LetrecExpr)
    (LetrecExpr (lrexpr) (+ (letrec ((x lexpr) ...) e)))
    (Expr (e body)
      (- (letrec ((x lexpr) ...) c-letrec))
      (+ (closure-letrec ((x c-exp) ...) body)))
    (ClosureLetrec (c-letrec) (- (closure-letrec ((x c-exp) ...) body))))

  (define-parser parse-L10 L10)

  (define-pass lift-letrec : L9 (ir) -> L10 ()
    (definitions
      (define Expr*
        (lambda (e* binding*)
          (if (null? e*)
              (values '() binding*)
              (let-values ([(e binding*) (Expr (car e*) binding*)])
                (let-values ([(e* binding*) (Expr* (cdr e*) binding*)])
                  (values (cons e e*) binding*))))))
      (define LambdaExpr*
        (lambda (lexpr* binding*)
          (if (null? lexpr*)
              (values '() binding*)
              (let-values ([(lexpr binding*) (LambdaExpr (car lexpr*) binding*)])
                (let-values ([(lexpr* binding*) (LambdaExpr* (cdr lexpr*) binding*)])
                  (values (cons lexpr lexpr*) binding*)))))))
    (Expr : Expr (ir binding*) -> Expr (binding*)
     ; TODO: we'd like to do this using variable threading!
      [(var ,x) (values `(var ,x) binding*)]
      [(quoted-const ,d) (values `(quoted-const ,d) binding*)]
      [(if ,e1 ,e2 ,[e3 binding*])
       (let-values ([(e1 binding*) (Expr e1 binding*)])
         (let-values ([(e2 binding*) (Expr e2 binding*)])
           (values `(if ,e1 ,e2 ,e3) binding*)))]
      [(begin ,e1 ... ,[e2 binding*])
       (let-values ([(e1 binding*) (Expr* e1 binding*)])
         (values `(begin ,e1 ... ,e2) binding*))]
      [(let ([,x*  ,e*] ...) ,[body binding*])
       (let-values ([(e* binding*) (Expr* e* binding*)])
         (values `(let ([,x* ,e*] ...) ,body) binding*))]
      [(primapp ,pr ,e* ...)
       (let-values ([(e* binding*) (Expr* e* binding*)])
         (values `(primapp ,pr ,e* ...) binding*))]
      [(app ,[e binding*] ,e* ...)
       (let-values ([(e* binding*) (Expr* e* binding*)])
         (values `(app ,e ,e* ...) binding*))]
      [(anonymous-call ,[e binding*] ,e* ...)
       (let-values ([(e* binding*) (Expr* e* binding*)])
         (values `(anonymous-call ,e ,e* ...) binding*))]
      [(letrec ((,x* ,lexpr*) ...) ,[e binding*])
       (let-values ([(lexpr* binding*) (LambdaExpr* lexpr* binding*)])
         (values e (append (map cons x* lexpr*) binding*)))])
    (LambdaExpr : LambdaExpr (ir binding*) -> LambdaExpr (binding*)
      [(lambda (,x* ...) ,[bf-body binding*])
       (values `(lambda (,x* ...) ,bf-body) binding*)])
    (BindFree : BindFree (ir binding*) -> BindFree (binding*)
      [(bind-free (,x ,x* ...) ,[body binding*])
       (values `(bind-free (,x ,x* ...) ,body) binding*)])
    (ClosureLetrec : ClosureLetrec (ir binding*) -> Expr (binding*)
      [(closure-letrec ([,x* ,[c-exp*]] ...) ,[body binding*])
       (values `(closure-letrec ([,x* ,c-exp*] ...) ,body) binding*)])
    (let-values ([(e binding*) (Expr ir '())])
      (let ([x* (map car binding*)] [e* (map cdr binding*)])
        `(letrec ([,x* ,e*] ...) ,e))))

  (define-language L11 (extends L10)
    (entry LetrecExpr)
    (terminals
      (+ (system-primitive (spr))))
    (Expr (e body)
      (- (closure-letrec ((x c-exp) ...) body))
      (+ (sys-primapp spr e ...)))
    (BindFree (bf-body) (- (bind-free (x1 x2 ...) body)))
    (Closure (c-exp) (- (closure x1 x2 ...)))
    (LambdaExpr (lexpr)
      (- (lambda (x ...) bf-body))
      (+ (lambda (x ...) body))))

  (define-parser parse-L11 L11)

  (define-pass explicit-closure : L10 (ir) -> L11 ()
    (LetrecExpr : LetrecExpr (ir) -> LetrecExpr ()
      [(letrec ((,x ,[lexpr]) ...) ,e)
       (let ([e (Expr e '() '())]) `(letrec ((,x ,lexpr) ...) ,e))])

    (Expr : Expr (ir [cp '()] [env '()]) -> Expr ()
      [(var ,x)
       (let ([i (list-index x env)])
         (if (>= i 0)
             `(sys-primapp closure-ref (var ,cp) (quoted-const ,i))
             `(var ,x)))]
      [(closure-letrec ((,x ,[c-exp -> e free**]) ...)
         ,[body cp env -> body])
       (let* ([e* (append (apply append
                                 (map
                                   (lambda (lhs free*)
                                     (map
                                       (lambda (i free)
                                         `(sys-primapp
                                            closure-set!
                                            (var ,lhs)
                                            (quoted-const ,i)
                                            ,(let ([ind (list-index free env)])
                                               (if (>= ind 0)
                                                   `(sys-primapp
                                                      closure-ref
                                                      (var ,cp)
                                                      (quoted-const ,ind))
                                                   `(var ,free)))))
                                       (iota (length free*)) free*))
                                   x free**))
                          (list body))])
         (let* ([re* (reverse e*)] [e1 (cdr re*)] [e2 (car re*)])
           `(let ([,x ,e] ...) (begin ,e1 ... ,e2))))])
    (BindFree : BindFree (ir) -> Expr ()
      [(bind-free (,x1 ,x2 ...) ,[body x1 x2 -> body]) `,body])
    (Closure : Closure (ir) -> Expr (dummy)
      [(closure ,x1 ,x2 ...)
       (values `(sys-primapp make-closure (var ,x1)
                             (quoted-const ,(length x2))) x2)])
    (LambdaExpr : LambdaExpr (ir) -> LambdaExpr ()
      [(lambda (,x ...) ,[bf-body -> body]) `(lambda (,x ...) ,body)]))

  (define-language L12
    (terminals
      (variable (x))
      (datum (d))
      (value-primitive (vp))
      (predicate-primitive (pp))
      (effect-primitive (ep))
      (system-primitive (spr)))
    (LetrecExpr (lrexpr)
      (letrec ((x lexpr) ...) v))
    (LambdaExpr (lexpr)
      (lambda (x ...) v))
    (Value (v)
      (var x)
      (quoted-const d)
      (if p1 v2 v3)
      (begin f0 ... v1)
      (let ((x v1) ...) v2)
      (primapp vp v ...)
      (sys-primapp spr v ...)
      (anonymous-call v0 v1 ...)
      (app v0 v1 ...))
    (Predicate (p)
      (true)
      (false)
      (if p1 p2 p3)
      (begin f0 ... p1)
      (let ((x v) ...) p)
      (primapp pp v ...)
      (sys-primapp spr v ...)
      (anonymous-call v0 v1 ...)
      (app v0 v1 ...))
    (Effect (f)
      (nop)
      (if p1 f2 f3)
      (begin f0 ... f1)
      (let ((x v) ...) f)
      (primapp ep v ...)
      (sys-primapp spr v ...)
      (anonymous-call v0 v1 ...)
      (app v0 v1 ...)))

  (define-parser parse-L12 L12)

  (define-pass normalize-context : L11 (ir) -> L12 ()
    (LetrecExpr : LetrecExpr (ir) -> LetrecExpr ()
      [(letrec ((,x ,[lexpr]) ...) ,[v]) `(letrec ((,x ,lexpr) ...) ,v)])
    (LambdaExpr : LambdaExpr (ir) -> LambdaExpr ()
      [(lambda (,x ...) ,[v]) `(lambda (,x ...) ,v)])
    (Value : Expr (ir) -> Value ()
      [(var ,x) `(var ,x)]
      [(quoted-const ,d) `(quoted-const ,d)]
      [(if ,[p0] ,[v1] ,[v2]) `(if ,p0 ,v1 ,v2)]
      [(begin ,[f0] ... ,[v1]) `(begin ,f0 ... ,v1)]
      [(let ((,x ,[v1]) ...) ,[v2]) `(let ((,x ,v1) ...) ,v2)]
      [(primapp ,pr ,[p])
       (guard (equal? pr 'not))
       `(if ,p (quoted-const #f) (quoted-const #t))]
      [(primapp ,pr ,[v0] ...)
       (guard (predicate-primitive? pr))
       `(if (primapp ,pr ,v0 ...) (quoted-const #t) (quoted-const #f))]
      [(primapp ,pr ,[v0] ...)
       (guard (value-primitive? pr))
       `(primapp ,pr ,v0 ...)]
      [(primapp ,pr ,[v0] ...)
       (guard (effect-primitive? pr))
       `(begin (primapp ,pr ,v0 ...) (primapp void))]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (predicate-primitive? spr))
       `(if (sys-primapp ,spr ,v0 ...) (quoted-const #t) (quoted-const #f))]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (value-primitive? spr))
       `(sys-primapp ,spr ,v0 ...)]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (effect-primitive? spr))
       `(begin (primapp ,spr ,v0 ...) (primapp void))]
      [(anonymous-call ,[v0] ,[v1] ...) `(anonymous-call ,v0 ,v1 ...)]
      [(app ,[v0] ,[v1] ...) `(app ,v0 ,v1 ...)])
    (Predicate : Expr (ir) -> Predicate ()
      [(var ,x)
       `(if (primapp eq? (var ,x) (quoted-const #f)) (false) (true))]
      [(quoted-const ,d) (if d `(true) `(false))]
      [(if ,[p0] ,[p1] ,[p2]) `(if ,p0 ,p1 ,p2)]
      [(begin ,[f0] ... ,[p1]) `(begin ,f0 ... ,p1)]
      [(let ((,x ,[v]) ...) ,[p]) `(let ((,x ,v) ...) ,p)]
      [(primapp ,pr ,[p]) (guard (equal? pr 'not)) `(if ,p (false) (true))]
      [(primapp ,pr ,[v0] ...)
       (guard (predicate-primitive? pr))
       `(primapp ,pr ,v0 ...)]
      [(primapp ,pr ,[v0] ...)
       (guard (value-primitive? pr))
       `(if (primapp eq? (primapp ,pr ,v0 ...) (quoted-const #f))
            (false) (true))]
      [(primapp ,pr ,[v0] ...)
       (guard (effect-primitive? pr))
       `(begin (primapp ,pr ,v0 ...)(true))]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (predicate-primitive? spr))
       `(sys-primapp ,spr ,v0 ...)]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (value-primitive? spr))
       `(if (primapp eq? (sys-primapp ,spr ,v0 ...) (quoted-const #f))
            (false) (true))]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (effect-primitive? spr))
       `(begin (sys-primapp ,spr ,v0 ...)(true))]
      [(anonymous-call ,[v0] ,[v1] ...)
       `(if (primapp eq? (anonymous-call ,v0 ,v1 ...) (quoted-const #f))
            (false) (true))]
      [(app ,[v0] ,[v1] ...)
       `(if (primapp eq? (app ,v0 ,v1 ...) (quoted-const #f))
            (false) (true))])
    (Effect : Expr (ir) -> Effect ()
      [(var ,x) `(nop)]
      [(quoted-const ,d) `(nop)]
      [(if ,[p0] ,[f1] ,[f2]) `(if ,p0 ,f1 ,f2)]
      [(begin ,[f0] ... ,[f1]) `(begin ,f0 ... ,f1)]
      [(let ((,x ,[v]) ...) ,[f]) `(let ((,x ,v) ...) ,f)]
      [(primapp ,pr ,[f]) (guard (equal? pr 'not)) f]
      [(primapp ,pr ,[f0] ...)
       (guard (or (predicate-primitive? pr) (value-primitive? pr)))
       (if (null? f0) `(nop) `(begin ,f0 ... (nop)))]
      [(primapp ,pr ,[v0] ...)
       (guard (effect-primitive? pr))
       `(primapp ,pr ,v0 ...)]
      [(sys-primapp ,spr ,[f0] ...)
       (guard (or (predicate-primitive? spr) (value-primitive? spr)))
       (if (null? f0) `(nop) `(begin ,f0 ... (nop)))]
      [(sys-primapp ,spr ,[v0] ...)
       (guard (effect-primitive? spr))
       `(sys-primapp ,spr ,v0 ...)]
      [(anonymous-call ,[v0] ,[v1] ...) `(anonymous-call ,v0 ,v1 ...)]
      [(app ,[v0] ,[v1] ...) `(app ,v0 ,v1 ...)]))

  (define-language L13
    (terminals
      (variable (x))
      (datum (d))
      (value-primitive (vp))
      (predicate-primitive (pp))
      (effect-primitive (ep))
      (system-primitive (spr)))
    (LetrecExpr (lrexpr)
      (letrec ((x lexpr) ...) v))
    (LambdaExpr (lexpr)
      (lambda (x ...) v))
    (Triv (t)
      (var x)
      (quoted-const d))
    (Value (v)
      t
      (if p1 v2 v3)
      (begin f0 ... v1)
      (let ((x v1) ...) v2)
      (primapp vp t ...)
      (sys-primapp spr t ...)
      (anonymous-call t0 t1 ...)
      (app t0 t1 ...))
    (Predicate (p)
      (true)
      (false)
      (if p1 p2 p3)
      (begin f0 ... p1)
      (let ((x v) ...) p)
      (primapp pp t ...)
      (sys-primapp spr t ...)
      (anonymous-call t0 t1 ...)
      (app t0 t1 ...))
    (Effect (f)
      (nop)
      (if p1 f2 f3)
      (begin f0 ... f1)
      (let ((x v) ...) f)
      (primapp ep t ...)
      (sys-primapp spr t ...)
      (anonymous-call t0 t1 ...)
      (app t0 t1 ...)))

  (define-parser parse-L13 L13)

  (define-pass remove-complex-opera* : L12 (ir) -> L13 ()
    (definitions
      (define remove-nulls
        (lambda (ls)
          (if (null? ls)
              '()
              (if (null? (car ls))
                  (remove-nulls (cdr ls))
                  (cons (car ls) (remove-nulls (cdr ls))))))))
    (LetrecExpr : LetrecExpr (ir) -> LetrecExpr ()
      [(letrec ((,x ,[lexpr]) ...) ,[v]) `(letrec ((,x ,lexpr) ...) ,v)])
    (LambdaExpr : LambdaExpr (ir) -> LambdaExpr ()
      [(lambda (,x ...) ,[v]) `(lambda (,x ...) ,v)])
    (Opera : Value (ir) -> Triv (dummy)
      [(var ,x) (values `(var ,x)  '())]
      [(quoted-const ,d) (values `(quoted-const ,d) '())]
      ;  [,[v]  (let ([tmp (gen-symbol 'tmp)])
      ; 	     (values `(var ,tmp)
      ; 	       (list tmp (in-context Value `,v))))])
      [(if ,[p1] ,[v2] ,[v3])
       (let ([tmp (gen-symbol 'tmp)])
         (values `(var ,tmp)
                 (list tmp (in-context Value `(if ,p1 ,v2 ,v3)))))]
      [(begin ,[f0] ... ,[v1])
       (let ([tmp (gen-symbol 'tmp)])
         (values `(var ,tmp)
                 (list tmp (in-context Value `(begin ,f0 ... ,v1)))))]
      [(let ((,x ,[v1]) ...) ,[v2])
       (let ([tmp (gen-symbol 'tmp)])
         (values `(var ,tmp)
                 (list tmp (in-context Value `(let ((,x ,v1) ...) ,v2)))))]
      [(primapp ,vp ,[t* binding*] ...)
        (let ([binding* (remove-nulls binding*)])
          (let ([tmp (gen-symbol 'tmp)])
            (if (null? binding*)
                (values `(var ,tmp)
                  (list tmp (in-context Value `(primapp ,vp ,t* ...))))
                (let ([x (map car binding*)] [v (map cadr binding*)])
                  (values `(var ,tmp)
                    (list tmp
                      (in-context
                        Value `(let ((,x ,v) ...)
                                 (primapp ,vp ,t* ...)))))))))]
      [(sys-primapp ,spr ,[t* binding*]...)
       (let ([binding* (remove-nulls binding*)])
         (let ([tmp (gen-symbol 'tmp)])
           (if (null? binding*)
               (values `(var ,tmp)
                       (list tmp (in-context
                                   Value `(sys-primapp ,spr ,t* ...))))
               (let ([x (map car binding*)][v (map cadr binding*)])
                 (values
                   `(var ,tmp)
                   (list
                     tmp (in-context
                           Value `(let ((,x ,v) ...)
                                    (sys-primapp ,spr ,t* ...)))))))))]
      [(anonymous-call ,[v0 binding] ,[v1 binding*] ...)
         (let ([binding* (remove-nulls (cons binding binding*))]
               [tmp (gen-symbol 'tmp)])
           (if (null? binding*)
               (values `(var ,tmp)
                       (list tmp (in-context Value
                                             `(anonymous-call ,v0 ,v1 ...))))
               (let ([x (map car binding*)] [v (map cadr binding*)])
                 (values `(var ,tmp)
                         (list tmp (in-context
                                     Value
                                     `(let ((,x ,v) ...)
                                        (anonymous-call ,v0 ,v1 ...))))))))]
      [(app ,[v0] ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (let ([tmp (gen-symbol 'tmp)])
           (if (null? binding*)
               (values `(var ,tmp)
                       (list tmp (in-context Value `(app ,v0 ,t* ...))))
               (let ([x (map car binding*)] [v (map cadr binding*)])
                 (values `(var ,tmp)
                         (list tmp
                               (in-context Value
                                           `(let ((,x ,v) ...)
                                              (app ,v0 ,t* ...)))))))))])
    (Value  : Value (ir) -> Value ()
      [(var ,x) (in-context Triv `(var ,x))]
      [(quoted-const ,d) (in-context Triv `(quoted-const ,d))]
      [(if ,[p1] ,[v2] ,[v3]) `(if ,p1 ,v2 ,v3)]
      [(begin ,[f0] ... ,[v1]) `(begin ,f0 ... ,v1)]
      [(let ((,x ,[v1]) ...) ,[v2]) `(let ((,x ,v1) ...) ,v2)]
      [(primapp ,vp ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(primapp ,vp ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (primapp ,vp ,t* ...)))))]
      [(sys-primapp ,spr ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(sys-primapp ,spr ,t* ...)
             (let ([x (map car binding*)][v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (sys-primapp ,spr ,t* ...)))))]
      [(anonymous-call ,[t0 binding] ,[t1 binding*] ...)
       (let ([binding* (remove-nulls (cons binding binding*))])
         (if (null? binding*)
             `(anonymous-call ,t0 ,t1 ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (anonymous-call ,t0 ,t1 ...)))))]
      [(app ,[v0] ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(app ,v0 ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))])
    (Predicate : Predicate (ir) -> Predicate ()
      [(let ((,x ,[v]) ...) ,[p]) `(let ((,x ,v) ...) ,p)]
      [(primapp ,pp ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(primapp ,pp ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (primapp ,pp ,t* ...)))))]
      [(sys-primapp ,spr ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(sys-primapp ,spr ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (sys-primapp ,spr ,t* ...)))))]
      [(anonymous-call ,[t0 binding] ,[t1 binding*]...)
       (let ([binding* (remove-nulls (cons binding binding*))])
         (if (null? binding*)
             `(anonymous-call ,t0 ,t1 ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (anonymous-call ,t0 ,t1 ...)))))]
      [(app ,[v0] ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(app ,v0 ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))])
    (Effect : Effect (ir) -> Effect ()
      [(let ((,x ,[v]) ...) ,[f]) `(let ((,x ,v) ...) ,f)]
      [(primapp ,ep ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(primapp ,ep ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (primapp ,ep ,t* ...)))))]
      [(sys-primapp ,spr ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(sys-primapp ,spr ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...)
                  (sys-primapp ,spr ,t* ...)))))]
      [(anonymous-call ,[t0 binding] ,[t1 binding*] ...)
       (let ([binding* (remove-nulls (cons binding binding*))])
         (if (null? binding*)
             `(anonymous-call ,t0 ,t1 ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...) (anonymous-call ,t0 ,t1 ...)))))]
      [(app ,[v0] ,[t* binding*] ...)
       (let ([binding* (remove-nulls binding*)])
         (if (null? binding*)
             `(app ,v0 ,t* ...)
             (let ([x (map car binding*)] [v (map cadr binding*)])
               `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))]))

  (define-language L14 (extends L13)
    (entry LetrecExpr)
    (Value (v) (- (anonymous-call t0 t1 ...)))
    (Predicate (p) (- (anonymous-call t0 t1 ...)))
    (Effect (f) (- (anonymous-call t0 t1 ...))))

  (define-pass remove-anonymous-call : L13 (ir) -> L14 ()
    (Value : Value (ir) -> Value ()
      [(anonymous-call ,[t0] ,[t1] ...)
       (let ([tmp (gen-symbol 'tmp)])
         `(let ([,tmp (sys-primapp procedure-code ,t0)])
            (app (var ,tmp) ,t0 ,t1 ...)))])
    (Predicate : Predicate (ir) -> Predicate ()
      [(anonymous-call ,[t0] ,[t1] ...)
       (let ([tmp (gen-symbol 'tmp)])
         `(let ([,tmp (sys-primapp procedure-code ,t0)])
            (app (var ,tmp) ,t0 ,t1 ...)))])
    (Effect : Effect (ir) -> Effect ()
      [(anonymous-call ,[t0] ,[t1] ...)
       (let ([tmp (gen-symbol 'tmp)])
         `(let ([,tmp (sys-primapp procedure-code ,t0)])
            (app (var ,tmp) ,t0 ,t1 ...)))]))

  (define-parser parse-L14 L14)

  (define-language L15
    (terminals
      (variable (x))
      (datum (d))
      (value-primitive (vp))
      (predicate-primitive (pp))
      (effect-primitive (ep))
      (system-primitive (spr)))
    (LetrecExpr (lrexpr)
      (letrec ((x1 lexpr) ...) rnexpr))
    (RunExpr (rnexpr)
      (run (x) tl))
    (LambdaExpr (lexpr)
      (lambda (x ...) tl))
    (Triv (t)
      (var x)
      (quoted-const d))
    (Application (a)
      (app t0 t1 ...))
    (Tail (tl)
      (return t1 t2)
      (if p1 tl2 tl3)
      (begin f0 ... tl1)
      (let ((x ntl1) ...) tl2)
      (app t0 t1 ...))
    (Nontail (ntl)
      t
      (if p1 ntl2 ntl3)
      (begin f0 ... ntl1)
      (let ((x ntl1) ...) ntl2)
      (primapp vp t ...)
      (sys-primapp spr t ...)
      (return-point x a))
    (Predicate (p)
      (true)
      (false)
      (if p1 p2 p3)
      (begin f0 ... p1)
      (let ((x ntl) ...) p)
      (primapp pp t ...)
      (sys-primapp spr t ...))
    (Effect (f)
      (nop)
      (if p1 f2 f3)
      (begin f0 ... f1)
      (let ((x ntl) ...) f)
      (primapp ep t ...)
      (sys-primapp spr t ...)
      (return-point x a)))

  (define-parser parse-L15 L15)

  ; (define process-tail
  ;       (lambda (expr rp)
  ;         (match expr
  ;           [(quote ,datum) `(return ,rp (quote ,datum))]
  ;           [,var (guard (symbol? var)) `(return ,rp ,var)]
  ;           [(if ,test ,[conseq] ,[altern])
  ;            `(if ,(process-nontail test) ,conseq ,altern)]
  ;           [(begin ,expr* ...)
  ;            `(begin
  ;               ,@((foldl '())
  ;                  (lambda (expr)
  ;                    (lambda (expr*)
  ;                      (if (null? expr*)
  ;                          (cons (process-tail expr rp) expr*)
  ;                          (cons (process-nontail expr) expr*))))
  ;                  expr*))]
  ;           [(let ([,lhs* ,rhs*] ...) ,[body])
  ;            (let ([rhs* (map process-nontail rhs*)])
  ;              `(let ([,lhs* ,rhs*] ...)
  ;                 ,body))]
  ;           [(,prim ,rand* ...)
  ;            (guard (primitive? prim))
  ;            (let ([rand* (map process-nontail rand*)])
  ;              (let ([tmp (gen-symbol 'tmp)])
  ;                `(let ([,tmp (,prim ,rand* ...)])
  ;                   (return ,rp ,tmp))))]
  ;           [(,rator ,rand* ...)
  ;            (let ([rator (process-nontail rator)]
  ;                  [rand* (map process-nontail rand*)])
  ;              `(,rator ,rp ,rand* ...))]
  ;           [,expr (error 'insert-dummy-rp "Invalid expression: ~s" expr)])))
  ;     (define process-nontail
  ;       (lambda (expr)
  ;         (match expr
  ;           [(quote ,datum) `(quote ,datum)]
  ;           [,var (guard (symbol? var)) `,var]
  ;           [(if ,[test] ,[conseq] ,[altern])
  ;            `(if ,test ,conseq ,altern)]
  ;           [(begin ,[expr*] ...) `(begin ,expr* ...)]
  ;           [(let ([,lhs* ,[rhs*]] ...) ,[body])
  ;            `(let ([,lhs* ,rhs*] ...) ,body)]
  ;           [(,prim ,[rand*] ...)
  ;            (guard (primitive? prim))
  ;            `(,prim ,rand* ...)]
  ;           [(,[rator] ,[rand*] ...)
  ;            (let ([label (gen-label (gen-symbol 'lab))])
  ;              `(return-point ,label
  ;                 (,rator ,label ,rand* ...)))]
  ;           [,expr (error 'insert-dummy-rp "Invalid expression: ~s" expr)])))
  ;     (define process-lambda
  ;       (lambda (expr)
  ;         (match expr
  ;           [(lambda (,formal* ...)  ,body)
  ;            (let ([rp (gen-symbol 'rp)])
  ;              `(lambda (,rp ,formal* ...)
  ;                 ,(process-tail body rp)))])))
  ;     (define process-letrec
  ;       (lambda (expr)
  ;         (match expr
  ;           [(letrec ([,lhs* ,rhs*] ...) ,body)
  ;            (let ([rhs* (map process-lambda rhs*)])
  ;              (let ([rp (gen-symbol 'rp)])
  ;                `(letrec ([,lhs* ,rhs*] ...)
  ;                   (run (,rp)
  ;                     ,(process-tail body rp)))))])))

  (define-pass introduce-dummy-rp : L14 (ir) -> L15 ()
    (LetrecExpr : LetrecExpr (ir) -> LetrecExpr ()
      [(letrec ((,x ,[lexpr]) ...) ,[rnexpr])
       `(letrec ((,x ,lexpr) ...) ,rnexpr)])
    (LambdaExpr : LambdaExpr (ir) -> LambdaExpr ()
      [(lambda (,x ...) ,v)
       (let ([rp (gen-symbol 'rp)])
         (let ([tl (ValueTail v rp)])
           `(lambda (,rp ,x ...) ,tl)))])
    (ValueRun : Value (ir) -> RunExpr ()
      [(var ,x) (let ([rp (gen-symbol 'rp)])
                  `(run (,rp) (return (var ,rp) (var ,x))))]
      [(quoted-const ,d)
       (let ([rp (gen-symbol 'rp)])
         `(run (,rp) (return (var ,rp) (quoted-const ,d))))]
      [(if ,[p1] ,v2 ,v3)
       (let ([rp (gen-symbol 'rp)])
         (let ([tl2 (ValueTail v2 rp)]
               [tl3 (ValueTail v3 rp)])
           `(run (,rp) (if ,p1 ,tl2 ,tl3))))]
      [(begin ,[f0] ... ,v1)
       (let ([rp (gen-symbol 'rp)])
         (let ([tl1 (ValueTail v1 rp)])
           `(run (,rp) (begin ,f0 ... ,tl1))))]
      [(let ((,x ,[ntl1]) ...) ,v2)
       (let ([rp (gen-symbol 'rp)])
         (let ([tl2 (ValueTail v2 rp)])
           `(run (,rp) (let ((,x ,ntl1) ...) ,tl2))))]
      [(primapp ,vp ,[t] ...)
       (let ([rp (gen-symbol 'rp)])
         (let ([tmp (gen-symbol 'tmp)])
           `(run (,rp) (let ([,tmp (primapp ,vp ,t ...)])
                         (return (var ,rp) (var ,tmp))))))]
      [(sys-primapp ,spr ,[t] ...)
       (let ([rp (gen-symbol 'rp)])
         (let ([tmp (gen-symbol 'tmp)])
           `(run (,rp) (let ([,tmp (primapp ,spr ,t ...)])
                         (return (var ,rp) (var ,tmp))))))]
      [(app ,[t0] ,[t1] ...)
       (let ([rp (gen-symbol 'rp)])
         `(run (,rp)(app ,t0 (var ,rp) ,t1 ...)))])
    (ValueTail : Value (ir rp) -> Tail ()
      [(var ,x) `(return (var ,rp) (var ,x))]
      [(quoted-const ,d) `(return (var ,rp) (quoted-const ,d))]
      [(if ,[p1] ,[ValueTail : v2 rp -> tl2] ,[ValueTail : v3 rp -> tl3])
       `(if ,p1 ,tl2 ,tl3)]
      [(begin ,[f0] ... ,[ValueTail : v1 rp -> tl1]) `(begin ,f0 ... ,tl1)]
      [(let ((,x ,[ntl1]) ...) ,[ValueTail : v2 rp -> tl2])
       `(let ((,x ,ntl1) ...) ,tl2)]
      [(primapp ,vp ,[t] ...)
       (let ([tmp (gen-symbol 'tmp)])
         `(let ([,tmp (primapp ,vp ,t ...)])
            (return (var ,rp) (var ,tmp))))]
      [(sys-primapp ,spr ,[t] ...)
       (let ([tmp (gen-symbol 'tmp)])
         `(let ([,tmp (primapp ,spr ,t ...)])
            (return (var ,rp) (var ,tmp))))]
      [(app ,[t0] ,[t1] ...) `(app ,t0 (var ,rp) ,t1 ...)])
    (ValueNTail : Value (ir) -> Nontail ()
      [(if ,[p1] ,[ntl2] ,[ntl3]) `(if ,p1 ,ntl2 ,ntl3)]
      [(begin ,[f0] ... ,[ntl1]) `(begin ,f0 ... ,ntl1)]
      [(let ((,x ,[ntl1]) ...) ,[ntl2]) `(let ((,x ,ntl1) ...) ,ntl2)]
      [(app ,[t0] ,[t1] ...)
       (let ([label (gen-label (gen-symbol 'lab))])
         `(return-point ,label (app ,t0 (var ,label) ,t1 ...)))])
    (Predicate : Predicate (ir) -> Predicate ()
      [(let ((,x ,[ntl1]) ...) ,[p]) `(let ((,x ,ntl1) ...) ,p)])
    (Effect : Effect (ir) -> Effect ()
      [(let ((,x ,[ntl1]) ...) ,[f]) `(let ((,x ,ntl1) ...) ,f)]
      [(app ,[t0] ,[t1] ...)
       (let ([label (gen-label (gen-symbol 'lab))])
         `(return-point ,label (app ,t0 (var ,label) ,t1 ...)))]))

  (define-language L16 (extends L15)
    (entry LetrecExpr)
    (Tail (tl)
      (- (let ((x ntl1) ...) tl2))
      (+ (let ((x ntl1)) tl2)))
    (Nontail (ntl)
      (- (let ((x ntl1) ...) ntl2))
      (+ (let ((x ntl1)) ntl2)))
    (Predicate (p)
      (- (let ((x ntl) ...) p))
      (+ (let ((x ntl)) p)))
    (Effect (f)
      (- (let ((x ntl) ...) f))
      (+ (let ((x ntl)) f))))

  (define-parser parse-L16 L16)

  (define-pass remove-nonunary-let : L15 (ir) -> L16 ()
    (Tail : Tail (ir) -> Tail ()
      [(let ((,x ,[ntl]) ...) ,[tl])
       (let loop ([lhs* x] [rhs* ntl])
         (if (null? lhs*)
             tl
             (let ([x (car lhs*)]
                   [ntl (car rhs*)]
                   [tl (loop (cdr lhs*) (cdr rhs*))])
               `(let ((,x ,ntl)) ,tl))))])
    (Nontail : Nontail (ir) -> Nontail ()
      [(let ((,x ,[ntl1]) ...) ,[ntl2])
       (let loop ([lhs* x] [rhs* ntl1])
         (if (null? lhs*)
             ntl2
             (let ([x (car lhs*)]
                   [ntl1 (car rhs*)]
                   [ntl2 (loop (cdr lhs*) (cdr rhs*))])
               `(let ((,x ,ntl1)) ,ntl2))))])
    (Predicate : Predicate (ir) -> Predicate ()
      [(let ((,x ,[ntl]) ...) ,[p])
       (let loop ([lhs* x] [rhs* ntl])
         (if (null? lhs*)
             p
             (let ([x (car lhs*)]
                   [ntl (car rhs*)]
                   [p (loop (cdr lhs*) (cdr rhs*))])
               `(let ((,x ,ntl)) ,p))))])
    (Effect : Effect (ir) -> Effect ()
      [(let ((,x ,[ntl]) ...) ,[f])
       (let loop ([lhs* x] [rhs* ntl])
         (if (null? lhs*)
             f
             (let ([x (car lhs*)]
                   [ntl (car rhs*)]
                   [f (loop (cdr lhs*) (cdr rhs*))])
               `(let ((,x ,ntl)) ,f))))]))

  (define-language L17 (extends L16)
    (entry LetrecExpr)
    (RunExpr (rnexpr)
      (- (run (x) tl))
      (+ (run (x) dec)))
    (LambdaExpr (lexpr)
      (- (lambda (x ...) tl))
      (+ (lambda (x ...) dec)))
    (DeclareExpr (dec) (+ (declare (x ...) tl)))
    (Tail (tl) (- (let ((x ntl1)) tl2)))
    (Nontail (ntl)
      (- t
         (if p1 ntl2 ntl3)
         (begin f0 ... ntl1)
         (let ((x ntl1)) ntl2)
         (primapp vp t ...)
         (sys-primapp spr t ...)
         (return-point x a)))
    (RhsExpr (rhs)
      (+ t
         (if p1 rhs2 rhs3)
         (begin f0 ... rhs1)
         (primapp vp t ...)
         (sys-primapp spr t ...)
         (return-point x a)))
    (Predicate (p) (- (let ((x ntl)) p)))
    (Effect (f)
      (- (let ((x ntl)) f))
      (+ (set! x rhs))))

  (define-parser parse-L17 L17)

  (define-pass return-of-set! : L16 (ir) -> L17 ()
    (definitions
      (define Effect*
        (lambda (f* var*)
          (if (null? f*)
              (values '() var*)
              (let-values ([(f var*) (Effect (car f*) var*)])
                (let-values ([(f* var*) (Effect* (cdr f*) var*)])
                  (values (cons f f*) var*)))))))
    (RunExpr : RunExpr (ir) -> RunExpr ()
      [(run (,x) ,[tl '() -> tl var*]) `(run (,x) (declare (,var* ...) ,tl))])
    (LambdaExpr : LambdaExpr (ir) -> LambdaExpr ()
      [(lambda (,x* ...) ,[tl '() -> tl var*]) `(lambda (,x* ...) (declare (,var* ...) ,tl))])
    (Tail : Tail (ir var*) -> Tail (var*)
      [(let ([,x ,ntl]) ,[tl var*])
       (let-values ([(rhs var*) (Nontail ntl var*)])
         (values `(begin (set! ,x ,rhs) ,tl) (cons x var*)))]
      [(if ,[p1 var*] ,tl2 ,tl3)
       (let-values ([(tl2 var*) (Tail tl2 var*)])
         (let-values ([(tl3 var*) (Tail tl3 var*)])
           (values `(if ,p1 ,tl2 ,tl3) var*)))]
      [(begin ,f* ... ,[tl var*])
       (let-values ([(f* var*) (Effect* f* var*)])
         (values `(begin ,f* ... ,tl) var*))])
    (Nontail : Nontail (ir var*) -> RhsExpr (var*)
      [(let ((,x ,ntl1)) ,[rhs2 var*])
       (let-values ([(rhs1 var*) (Nontail ntl1 var*)])
         (values `(begin (set! ,x ,rhs1) ,rhs2) (cons x var*)))]
      [(if ,[p1 var*] ,ntl2 ,ntl3)
       (let-values ([(rhs2 var*) (Nontail ntl2 var*)])
         (let-values ([(rhs3 var*) (Nontail ntl3 var*)])
           (values `(if ,p1 ,rhs2 ,rhs3) var*)))]
      [(begin ,f* ... ,[rhs var*])
       (let-values ([(f* var*) (Effect* f* var*)])
         (values `(begin ,f* ... ,rhs) var*))]
     ; TODO: something we could do better here? Triv->Rhs is effectively just this code
      [(quoted-const ,d) (values `(quoted-const ,d) var*)]
      [(var ,x) (values `(var ,x) var*)])
    (Effect : Effect (ir var*) -> Effect (var*)
      [(let ([,x ,ntl]) ,[f var*])
       (let-values ([(rhs var*) (Nontail ntl var*)])
         (values `(begin (set! ,x ,rhs) ,f) var*))]
      [(if ,[p1 var*] ,f2 ,f3)
       (let-values ([(f2 var*) (Effect f2 var*)])
         (let-values ([(f3 var*) (Effect f3 var*)])
           (values `(if ,p1 ,f2 ,f3) var*)))]
      [(begin ,f* ... ,[f var*])
       (let-values ([(f* var*) (Effect* f* var*)])
         (values `(begin ,f* ... ,f) var*))])
    (Predicate : Predicate (ir var*) -> Predicate (var*)
      [(let ([,x ,ntl]) ,[p var*])
       (let-values ([(rhs var*) (Nontail ntl var*)])
         (values `(begin (set! ,x ,rhs) ,p) (cons x var*)))]
      [(if ,[p1 var*] ,p2 ,p3)
       (let-values ([(p2 var*) (Predicate p2 var*)])
         (let-values ([(p3 var*) (Predicate p3 var*)])
           (values `(if ,p1 ,p2 ,p3) var*)))]
      [(begin ,f* ... ,[p var*])
       (let-values ([(f* var*) (Effect* f* var*)])
         (values `(begin ,f* ... ,p) var*))]))

  (define-language L18 (extends L17)
    (entry LetrecExpr)
    (Triv (t) (+ (label x))))

  (define-parser parse-L18 L18)

  (define-pass explicit-labels : L17 (ir) -> L18 ()
    (LetrecExpr : LetrecExpr (ir [labs '()]) -> LetrecExpr ()
      [(letrec ((,x ,[lexpr x -> lexpr]) ...) ,[rnexpr x -> rnexpr])
       `(letrec ((,x ,lexpr) ...) ,rnexpr)])
    (LambdaExpr : LambdaExpr (ir labs) -> LambdaExpr ())
    (Triv : Triv (ir labs) -> Triv ()
      [(var ,x) (if (memq x labs) `(label ,x) `(var ,x))])
    (Application : Application (ir labs) -> Application ())
    (DeclareExpr : DeclareExpr (ir labs) -> DeclareExpr ())
    (RunExpr : RunExpr (ir labs) -> RunExpr ())
    (Tail : Tail (ir labs) -> Tail ())
    (RhsExpr : RhsExpr (ir labs) -> RhsExpr ()
      [(return-point ,x ,a) (let ([a (Application a (cons x labs))])
                              `(return-point ,x ,a))])
    (Predicate : Predicate (ir labs) -> Predicate ())
    (Effect : Effect (ir labs) -> Effect ()
      [(return-point ,x ,a) (let ([a (Application a (cons x labs))])
                              `(return-point ,x ,a))])))