rosella/compiler.ss

#! /usr/bin/mzscheme
#lang scheme

(define (trace fn . args)
  (let ([x (apply fn args)])
    (pretty-print x)
    x))

(define (subst old new lst)
  (foldr (lambda (x rst)
           (cons (if (eq? x old)
                     new
                     x)
                 rst))
         '()
         lst))

(define (simplify-form form)
  (if (pair? form)
      (case (car form)
        [(let) (simplify-let form)]
        [(let*) (simplify-let* form)]
        [(letrec) (simplify-letrec form)]
        [(if) (simplify-if form)]
        [(lambda) (simplify-lambda form)]
        [(begin) (simplify-form `(let () ,@(cdr form)))]
        [(set!) (simplify-set! form)]
        [(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))]
        [(car cdr cons call/cc)
         (simplify-primitive (case (first form)
                               [(make-box) '%make-box]
                               [(set-box!) '%set-box!]
                               [(unbox)    '%unbox]
                               [(cons)     '%cons]
                               [(set-car!) '%set-car!]
                               [(car)      '%car]
                               [(set-cdr!) '%set-cdr!]
                               [(cdr)      '%cdr]
                               [(call/cc)  '%call/cc]
                               )
                             (cdr form))]
        [(%bind %if %set! %lambda quote
          %tail-call %apply %call/cc
          %cons %set-car! %car %set-cdr! %cdr
          %make-box %set-box! %unbox)
         form]
        [else (simplify-funcall form)])
      (if (eq? form '()) '%nil form)))

(define (form-sets? form var [call-may-set? #t])
  (define (recurse simple-form)
    (if (pair? simple-form)
        (case (car simple-form)
          [(%bind) (and (not (memq var (second simple-form)))
                        (ormap recurse (cddr simple-form)))]
          [(%set!) (eq? (second simple-form) var)]
          [(%tail-call %apply %call/cc) call-may-set?]
          [(quote %lambda %if
            %make-box %set-box! %unbox
            %cons %set-car! %car %set-cdr! %cdr)
           #f]
          [else (error "Invalid simple form:" simple-form)])
        #f))
  (recurse (simplify-form form)))

(define (form-uses? form var [call-may-use? #t] [descend? #t])
  (define (recurse simple-form)
    (if (pair? simple-form)
        (case (car simple-form)
          [(%bind) (and (not (memq var (second simple-form)))
                        (ormap recurse (cddr simple-form)))]
          [(%set!) (recurse (third simple-form))]
          [(%tail-call %apply %call/cc) (and call-may-use? #t)]
          [(%if %make-box %set-box! %unbox
            %cons %set-car! %car %set-cdr! %cdr)
           (ormap recurse (cdr simple-form))]
          [(%lambda) (and descend?
                          (memq var (free-variables simple-form))
                          #t)]
          [(quote) #f]
          [else (error "Invalid simple form:" simple-form)])
        (eq? simple-form var)))
  (recurse (simplify-form form)))

(define (form-captures? form var [input? #t] [output? #t])
  (define (recurse simple-form)
    (if (pair? simple-form)
        (case (car simple-form)
          [(%bind) (and (not (memq var (second simple-form)))
                        (ormap recurse (cddr simple-form)))]
          [(%set!) (recurse (third simple-form))]
          [(%tail-call %apply %call/cc %if quote
            %make-box %set-box! %unbox
            %cons %set-car! %car %set-cdr! %cdr)
           #f]
          [(%lambda) (and (memq var (free-variables simple-form input? output?)) #t)]
          [else (error "Invalid simple form:" simple-form)])
        #f))
  (recurse (simplify-form form)))

(define (form-captures-input? form var)
  (form-captures? form var #t #f))

(define (form-captures-output? form var)
  (form-captures? form var #f #t))

(define (simplify-set! form)
  (let ([value-form (simplify-form (third form))])
    (if (and (pair? value-form) (eq? (first value-form) '%bind))
        (simplify-form
          `(let ,(second value-form)
             ,@(foldr (lambda (subform after)
                        (cond
                          [(pair? after) (cons subform after)]
                          [(or (not (pair? subform))
                               (memq (first subform) '(%apply %call/cc %car %cdr %cons %bind %if %unbox quote)))
                           `((set! ,(second form) ,subform))]
                          [(and (pair? subform) (eq? (first subform) '%tail-call))
                           `(,subform)] ; The %set! wouldn't be executed anyway.
                          [else
                           `(,subform
                             (%set! ,(second form) %void))]))
                      '()
                      (cddr value-form))))
        `(%set! ,(second form) ,value-form))))

(define (simplify-primitive new-id value-forms)
  (define bindings (map (lambda (vf)
                          (if (pair? vf)
                              (list (gensym) vf)
                              (list vf vf)))
                        value-forms))
  (define temp-bindings (filter (lambda (x) (not (eq? (first x) (second x))))
                                bindings))
  (simplify-form
    `(let ,(map first temp-bindings)
       ,@(map (lambda (x) `(set! ,(first x) ,(second x))) temp-bindings)
       (,new-id ,@(map first bindings)))))

; (let ([var expr]...) bodyexpr...)  ; first eval exprs, then assign bindings in parallel
;    => (%bind (tmp...)
;         (%set! tmp ,(simplify-form expr))...
;         (%bind (var...)
;           (%set! var tmp)...
;           bodyexpr...))

(define (simplify-let form)
  (define bindings (second form))
  (define bodyexprs (cdr (cdr form)))
  (flatten-binds
    (cond
      [(not (pair? bindings))
       `(%bind () ,@(map simplify-form bodyexprs))]
      [(not (pair? (cdr bindings)))
       (let ([binding (first bindings)])
         (make-bindings-unique
           `(%bind (,(if (pair? binding) (first binding) binding))
              ,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding)
                                                             ,(second binding))))
                                    '())
              ,@(map simplify-form bodyexprs))))]
      [else
       (let ([vars (map (lambda (x) (if (pair? x) (first x) x)) bindings)]
             [temp-bindings (append-map (lambda (x)
                                          (if (pair? x)
                                              (let ([tmp (gensym)])
                                                `((,tmp
                                                   ,(simplify-form `(set! ,tmp ,(second x)))
                                                   (%set! ,(first x) ,tmp))))
                                              '()))
                                        bindings)])
         `(%bind ,(map first temp-bindings)
               ,@(map second temp-bindings)
               ,(make-bindings-unique
                  `(%bind ,vars
                     ,@(map third temp-bindings)
                     ,@(map simplify-form bodyexprs)))))])))

; (let* ...)   ; eval exprs & bind variables serially
;    => (let ([var-0 expr-0])
;         (let ([var-1 expr-1])
;           (...
;             bodyexprs...)))

(define (simplify-let* form)
   (define bindings (second form))
   (define bodyexprs (cdr (cdr form)))
   (define (add-binding bind bodyexpr)
      `(let (,bind) ,bodyexpr))
   (simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))

; (letrec ...) ; init bindings to undefined, then assign values in series
;    => (let (var...)
;         (set! var expr)...
;         bodyexprs)

(define (simplify-letrec form)
  (define bindings (second form))
  (define bodyexprs (cdr (cdr form)))
  (simplify-form
    `(let (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
       ,@(append-map
           (lambda (x)
             (if (pair? x)
                 `((set! ,(first x) ,(second x)))
                 '()))
           bindings)
       ,@bodyexprs)))

(define (simplify-if form)
  (define cond-val (gensym))
  (define next-fn (gensym))
  (define true-fn (gensym))
  (define false-fn (gensym))
  (define-values (cond-expr true-expr false-expr)
                 (apply values (cdr form)))
  (simplify-form
    (if (or (pair? true-expr) (pair? false-expr))
        `(let ([,cond-val ,cond-expr]
               [,true-fn  (lambda () ,true-expr)]
               [,false-fn (lambda () ,false-expr)])
           (let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
             (%apply ,next-fn %nil)))
        `(let ([,cond-val ,cond-expr])
           (%if ,cond-val ,(simplify-form true-expr) ,(simplify-form false-expr))))))

; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
;    => (lambda argv
;         (let ([argv-temp argv])
;           (let ([required-0 (car argv-temp)])
;             (set! argv-temp (cdr argv-temp)))
;             (let ([required-1 (car argv-temp)])
;               (set! argv-temp (cdr argv-temp)))
;               (...
;                 (let (optional-0)
;                   (if (eq? argv-temp %nil)
;                       (set! optional-0 default-expr-0)
;                       (set! optional-0 (car argv-temp)))
;                   (set! argv-temp (cdr argv-temp))
;                   (let (optional-1)
;                     (if (eq? argv-temp %nil)
;                         (set! optional-1 default-expr-1)
;                         (set! optional-1 (car argv-temp)))
;                     (set! argv-temp (cdr argv-temp))
;                     (...
;                       (let ([rest argv-temp])
;                         bodyexpr...)...)))...)))

(define (split-arglist arglist)
   (define (split-optional arglist)
      (if (pair? arglist)
          (let-values ([(opt rst) (split-optional (cdr arglist))])
            (values (cons (car arglist) opt) rst)) 
          (values '() arglist)))
   (if (pair? arglist)
       (if (pair? (car arglist))
         (let-values ([(opt rst) (split-optional arglist)])
            (values '() opt rst))
         (let-values ([(req opt rst) (split-arglist (cdr arglist))])
            (values (cons (car arglist) req) opt rst)))
       (values '() '() #f)))

(define (add-tail-call k rval form)
  (define k-argv (gensym))
  `(%bind (,@(second form) ,k-argv)
     ,@(foldr (lambda (subform after)
                (cond
                  [(pair? after)
                   (cons subform after)]
                  [(and (pair? subform)
                        (eq? (first subform) '%set!)
                        (eq? (second subform) rval)
                        (pair? (third subform))
                        (eq? (first (third subform)) '%apply))
                   (let ([fn (second (third subform))]
                         [argv (third (third subform))])
                     `((%tail-call ,fn ,argv ,k)))]
                  [(and (pair? subform)
                        (eq? (first subform) '%set!)
                        (eq? (second subform) rval)
                        (pair? (third subform))
                        (eq? (first (third subform)) '%call/cc))
                   (let ([fn (second (third subform))])
                     `((%set! ,k-argv (%cons %k %nil))
                       (%tail-call ,fn ,k-argv %k)))]
                  [(and (pair? subform)
                        (eq? (first subform) '%tail-call))
                   `(,subform)]
                  [(and (pair? subform)
                        (eq? (first subform) '%apply))
                   `((%tail-call ,(second subform)
                                 ,(third subform)
                                 ,k))]
                  [(and (pair? subform)
                        (eq? (first subform) '%set!)
                        (eq? (second subform) rval)
                        (eq? (third subform) '%void))
                   `((%tail-call ,k %nil #f))]
                  [(and (pair? subform)
                        (eq? (first subform) '%set!)
                        (eq? (second subform) rval))
                   `(,subform
                     (%set! ,rval (%cons ,rval %nil))
                     (%tail-call ,k ,rval #f))]
                  [else
                   `(,subform
                     (%tail-call ,k %nil #f))]))
               '()
               (cddr form))))

(define (simplify-lambda form)
   (define arglist (car (cdr form)))
   (define bodyexprs (cdr (cdr form)))

   (define-values (requireds optionals rest) (split-arglist arglist))
   (define argv-temp (gensym))
   (define k (gensym))
   (define rval (gensym))

   (define (add-req req inner) `(let ([,req (car ,argv-temp)])
                                  (set! ,argv-temp (cdr ,argv-temp))
                                  ,inner))
   (define (add-opt opt-list inner) `(let (,(car opt-list))
                                       (if (pair? ,argv-temp)
                                           (begin
                                             (set! ,(first opt-list) (car ,argv-temp))
                                             (set! ,argv-temp (cdr ,argv-temp)))
                                           (set! ,(first opt-list) ,(second opt-list)))
                                       ,inner))
   (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
                                   `(begin ,@bodyexprs)))
   `(%lambda 
      ,((compose transform-to-cps
                 (lambda (x) (add-tail-call k rval x))
                 flatten-binds)
        `(%bind (,rval ,k)
           (%set! ,k %k)
           ,(simplify-form
              `(set! ,rval (let ([,argv-temp %argv])
                             ,(foldr add-req
                                     (foldr add-opt
                                            rest+bodyexprs
                                            optionals)
                                     requireds))))))))

(define (narrow-binds simple-lambda-form)
  (define bind (second simple-lambda-form))
  (define (at-top-level? var)
    (or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind))
        (ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind))))
  (define (captured-twice? var)
    (let/cc return
      (foldl (lambda (subform once?)
               (if (form-captures? subform var)
                   (if once? (return #t) #t)
                   once?))
             (at-top-level? var)
             (cddr bind))
      #f))

  (define extra-binds
    (filter-not captured-twice?
                (filter-not at-top-level?
                            (second bind))))
   `(%lambda
     (%bind ,(remove* extra-binds (second bind))
       ,@(map (lambda (subform)
                (foldl (lambda (var subform)
                         (if (and (pair? subform)
                                  (eq? (first subform) '%set!)
                                  (pair? (third subform))
                                  (eq? (first (third subform)) '%lambda))
                             (let* ([dest (second subform)]
                                    [value (third subform)]
                                    [bind (second value)])
                               `(%set! ,dest ,(narrow-binds
                                                `(%lambda
                                                   ,(if (form-captures? value var)
                                                        `(%bind (,@(second bind) ,var)
                                                           ,@(cddr bind))
                                                        bind)))))
                             subform))
                         subform
                         extra-binds))
              (cddr bind)))))

(define (promote-to-box var form)
  (define (recurse subform) (promote-to-box var subform))
  (if (pair? form)
    (case (car form)
      [(%bind)
       (flatten-binds
        `(%bind ,(second form)
           ,@(if (memq var (second form))
                 `((%set! ,var (%make-box %undef)))
                 '())
           ,@(map recurse (cddr form))))]
      [(%lambda)
       `(%lambda ,(recurse (second form)))]
      [(%set!)
       (let ([value (recurse (third form))]
             [kind (if (eq? (second form) var) '%set-box! '%set!)])
         ; If value is (%bind), could only come from clause below.
         (if (and (pair? value) (eq? (first value) '%bind))
             (if (and (pair? (fourth value)) (not (eq? kind '%set!)))
                 (let ([tmp (gensym)])
                   `(%bind (,@(second value) ,tmp)
                      ,(third value)
                      (%set! ,tmp ,(fourth value))
                      (,kind ,(second form) ,tmp)))
                 `(%bind ,(second value)
                    ,(third value)
                    (,kind ,(second form) ,(fourth value))))
             (if (and (pair? value) (not (eq? kind '%set!)))
                 (let ([tmp (gensym)])
                   `(%bind (,tmp)
                      (%set! ,tmp ,value)
                      (,kind ,(second form) ,tmp)))
                 `(,kind ,(second form) ,value))))]
      [(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox)
       (if (memq var (cdr form))
           (let ([tmp (gensym)])
             `(%bind (,tmp)
                (%set! ,tmp (%unbox ,var))
                (,(first form) ,@(subst var tmp (cdr form)))))
           form)]
      [(quote) form]
      [else (error "Unsimplified form:" form)])
    (if (eq? form var)
        `(%unbox ,form)
        form)))

; form needs to be flattened (%bind ...)
(define (is-shared-var? var form)
  (define captured-input?  (ormap (lambda (f) (form-captures-input?  f var)) (cddr form)))
  (define captured-output? (ormap (lambda (f) (form-captures-output? f var)) (cddr form)))
  (define (set-after-first-use?)
    (let/cc return
      (foldr (lambda (subform set-after?)
               (if (or set-after? (form-sets? subform var captured-output?))
                   (if (form-uses? subform var captured-input?)
                       (return #t)
                       #t)
                   #f))
             #f
             (cddr form))
      #f))
  (and (or captured-input?
           captured-output?)
       (set-after-first-use?)))

(define (promote-shared-vars simple-lambda-form)
  (define bind (second simple-lambda-form))
  `(%lambda
     ,(foldl (lambda (var frm)
               (if (is-shared-var? var frm)
                   (promote-to-box var frm)
                   frm))
             bind
             (second bind))))

; <= (%bind (var...)
;      @before
;      (%apply x y)
;      @after))
; => (%bind (var... k)
;      @before
;      (%set k (lambda _ @after))
;      (%tail-call x y k)))

; <= (%bind (var...)
;      @before
;      (%set v (%apply x y))
;      @after))
; => (%bind (var... k)
;      @before
;      (%set k (lambda (x)
;                (%set! v x)
;                @after))
;      (%tail-call x y k)))

; <= (%bind (var...)
;      @before
;      (call/cc l)
;      @after)
; => (%bind (var... k k2)
;      @before
;      (%set! k (lambda _ @after))
;      (%set! k-argv (%cons k %nil))
;      (%tail-call l k-argv k))

(define (transform-to-cps form)
  (flatten-binds
    `(%bind ,(second form)
       ,@(foldr (lambda (subform after)
                  (cond
                    ; (%set! v (%apply x y))
                    [(and (pair? subform)
                          (eq? (first subform) '%set!)
                          (pair? (third subform))
                          (eq? (first (third subform)) '%apply))
                       (let ([k (gensym)]
                             [x (gensym)])
                         `((%bind (,k ,x)
                             (%set! ,k ,(simplify-form
                                          `(lambda (,x . ,(gensym))
                                             (%set! ,(second subform) ,x)
                                             ,@after)))
                             (%tail-call ,(second (third subform))
                                         ,(third (third subform))
                                         ,k))))]
                    ; (%apply x y)
                    [(and (pair? subform)
                          (eq? (first subform) '%apply))
                       (let ([k (gensym)])
                         `((%bind (,k)
                             (%set! ,k ,(simplify-form
                                          `(lambda ,(gensym)
                                             ,@after)))
                             (%tail-call ,(second subform)
                                         ,(third subform)
                                         ,k))))]
                    ; (%set! v (%call/cc x))
                    [(and (pair? subform)
                          (eq? (first subform) '%set!)
                          (pair? (third subform))
                          (eq? (first (third subform)) '%call/cc))
                       (let ([k (gensym)]
                             [k-argv (gensym)]
                             [x (gensym)])
                         `((%bind (,k ,k-argv)
                             (%set! ,k ,(simplify-form
                                          `(lambda (,x . ,(gensym))
                                             (%set! ,(second subform) ,x)
                                             ,@after)))
                             (%set! ,k-argv (%cons ,k %nil))
                             (%tail-call ,(second (third subform))
                                         ,k-argv
                                         ,k))))]
                    ; (%call/cc x)
                    [(and (pair? subform)
                          (eq? (first subform) '%call/cc))
                       (let ([k (gensym)]
                             [k-argv (gensym)])
                         `((%bind (,k ,k-argv)
                             (%set! ,k ,(simplify-form
                                          `(lambda ,(gensym)
                                             ,@after)))
                             (%set! ,k-argv (%cons ,k %nil))
                             (%tail-call ,(second subform)
                                         ,k-argv
                                         ,k))))]
                    [else (cons subform after)]))
                '()
                (cddr form)))))

; (fn-expr arg-expr...)
;    => (let ([fn-var fn-expr] arg-var... argv)
;         (set! fn-var fn-expr)
;         (set! arg-var arg-expr)...
;         (set! argv %nil)
;         (set! argv (cons arg-var argv))... [reversed]
;         (%apply fn-var argv))

(define (simplify-funcall form)
  (define fn-expr (car form))
  (define arg-exprs (cdr form))
  (define fn-var (gensym))
  (define arg-vars (map (lambda (x) (gensym)) arg-exprs))
  (define argv (gensym))
  (simplify-form
    `(let (,fn-var ,@arg-vars ,argv)
       (set! ,fn-var ,fn-expr)
       ,@(map (lambda (x y) `(set! ,x ,y)) arg-vars arg-exprs)
       (%set! ,argv %nil)
       ,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
       (%apply ,fn-var ,argv))))

(define (subst-var old-var new-var form)
  (define (recurse form)
    (subst-var old-var new-var form))
  (if (pair? form)
    (case (car form)
      [(%bind)
       (if (memq old-var (second form))
           form
           `(%bind ,(second form) ,@(map recurse (cddr form))))]
      [(quote) form]
      [(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc %make-box %set-box! %unbox)
       `(,(first form) ,@(map recurse (cdr form)))]
      [else (error "Unsimplified form:" form)])
    (if (eq? form old-var)
        new-var
        form)))

(define (make-bindings-unique form)
  (if (pair? form)
    (case (car form)
      [(%bind)
       (let ([new-vars (map (lambda _ (gensym)) (second form))])
         `(%bind ,new-vars
            ,@(map (lambda (frm)
                     (foldl (lambda (pair s)
                              (subst-var (car pair)
                                         (cdr pair)
                                         s))
                            frm
                            (map cons (second form) new-vars)))
                   (cddr form))))]
      [(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form]
      [else (error "Unsimplified form:" form)])
    form))

(define (flatten-binds form)
  (if (pair? form)
    (case (car form)
      [(%bind)
       (let* ([bound-vars (second form)]
              [subforms (append-map (lambda (new-form)
                                      (if (and (pair? new-form) (eq? (car new-form) '%bind))
                                        (begin
                                          (set! bound-vars (append bound-vars (second new-form)))
                                          (cddr new-form))
                                        (list new-form)))
                                    (map flatten-binds (cddr form)))])
         `(%bind ,bound-vars ,@subforms))]
      [(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form]
      [else (error "Unsimplified form:" form)])
    form))

(define (free-variables form [input? #t] [output? #t])
  (define (recurse form) (free-variables form input? output?))
  (if (pair? form)
    (case (car form)
      [(%bind)
       (remove* (second form)
                (remove-duplicates (append-map recurse (cddr form))))]
      [(%set!) (if output?
                   (cons (second form) (recurse (third form)))
                   (recurse (third form)))]
      [(quote) '()]
      [(%if %tail-call %apply %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox)
       (remove-duplicates (append-map recurse (cdr form)))]
      [else
       (error "Unsimplified form:" form)])
    (if (and input?
             (symbol? form)
             (not (memq form '(%nil %undef %self %argv %ctx %k))))
        (list form)
        '())))

(define (free-input-variables form)
  (free-variables form #t #f))

(define (free-output-variables form)
  (free-variables form #f #t))

; Don't bind variables which aren't referenced.
(define (reduce-variables form)
  (if (pair? form)
    (case (car form)
      [(%bind)
       (let ([ref-vars (remove-duplicates (append-map free-variables (cddr form)))])
         `(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form))
            ,@(map reduce-variables (cddr form))))]
      [(quote) form]
      [(%if %tail-call %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox)
         `(,(first form) ,@(map reduce-variables (cdr form)))]
      [else (error "Unsimplified form:" form)])
    form))

; Don't set variables which won't be accessed later.
(define (reduce-set! form)
  (if (pair? form)
    (case (car form)
      [(%bind)
       (let ([bound-vars (second form)])
         `(%bind ,bound-vars
            ,@(foldr (lambda (subform after)
                       (if (and (pair? subform)
                                (eq? (first subform) '%set!)
                                (memq (second subform) bound-vars)
                                (not (memq (second subform)
                                           (append-map free-input-variables after))))
                           after
                           (cons subform after)))
                     '()
                     (map reduce-set! (cddr form)))))]
      [(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form]
      [(%set! %lambda) `(,(first form) ,@(map reduce-set! (cdr form)))]
      [else (error "Unsimplified form:" form)])
    form))

(define (simplify-toplevel-lambda form)
  (promote-shared-vars
    (narrow-binds
      (simplify-lambda form))))

(define (optimize-simplified-lambda form)
  (reduce-variables
    (reduce-set!
      form)))

(pretty-print (optimize-simplified-lambda (simplify-toplevel-lambda `(lambda () ,(read)))))
;(pretty-print (simplify-toplevel-lambda `(lambda () ,(read))))

; vim:set sw=2 expandtab: