diff --git a/compiler.ss b/compiler.ss index be7b80f..91c032c 100755 --- a/compiler.ss +++ b/compiler.ss @@ -14,7 +14,7 @@ [(letrec) (simplify-letrec form)] [(if) (simplify-if form)] [(lambda) (simplify-lambda form)] - [(begin) `(%bind () ,@(map simplify-form (cdr form)))] + [(begin) (simplify-form `(let () ,@(cdr form)))] [(set!) (simplify-set! form)] [(car cdr cons) (simplify-primitive (case (first form) [(car) '%car] @@ -28,18 +28,19 @@ (define (simplify-set! form) (let ([value-form (simplify-form (third form))]) (if (and (pair? value-form) (eq? (first value-form) '%bind)) - `(%bind ,(second value-form) - ,@(foldr (lambda (subform after) - (if (pair? after) - (cons subform after) - (if (or (not (pair? subform)) - (memq (first subform) '(%apply %car %cdr %cons %bind %if))) - (list (simplify-set! `(set! ,(second form) ,subform))) - (if (and (pair? subform) (eq? (first subform) '%tail-call)) - (list subform) ; The %set! wouldn't be executed anyway. - (error "set! used with non-value form:" subform))))) - '() - (cddr value-form))) + (simplify-form + `(let ,(second value-form) + ,@(foldr (lambda (subform after) + (cond + [(pair? after) (cons subform after)] + [(or (not (pair? subform)) + (memq (first subform) '(%apply %car %cdr %cons %bind %if))) + `((set! ,(second form) ,subform))] + [(and (pair? subform) (eq? (first subform) '%tail-call)) + `(,subform)] ; The %set! wouldn't be executed anyway. + [else (error "set! used with non-value form:" subform)])) + '() + (cddr value-form)))) `(%set! ,(second form) ,value-form)))) (define (simplify-primitive new-id value-forms) @@ -50,10 +51,10 @@ value-forms)) (define temp-bindings (filter (lambda (x) (not (eq? (first x) (second x)))) bindings)) - - `(%bind ,(map first temp-bindings) - ,@(map (lambda (x) (simplify-set! `(set! ,(first x) ,(second x)))) temp-bindings) - (,new-id ,@(map first 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...) @@ -63,31 +64,36 @@ ; bodyexpr...)) (define (simplify-let form) - (define bindings (second form)) - (define bodyexprs (cdr (cdr form))) - (define vars (map (lambda (x) (if (pair? x) (first x) x)) bindings)) - (define temp-bindings - (append-map - (lambda (x) (if (pair? x) - (let ([tmp (gensym)]) - `((,tmp - ,(simplify-form `(set! ,tmp ,(second x))) - (%set! ,(first x) ,tmp)))) - '())) - bindings)) - (if (pair? bindings) - (if (pair? (cdr bindings)) - `(%bind ,(map first temp-bindings) - ,@(map second temp-bindings) - (%bind ,vars - ,@(map third temp-bindings) - ,@(map simplify-form bodyexprs))) - `(%bind (,(first vars)) - ,@(if (pair? (first bindings)) - `(,(simplify-form `(set! ,(first vars) ,(second (first bindings))))) - '()) - ,@(map simplify-form bodyexprs))) - `(%bind () ,@(map simplify-form bodyexprs)))) + (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]) @@ -110,14 +116,15 @@ (define (simplify-letrec form) (define bindings (second form)) (define bodyexprs (cdr (cdr form))) - `(%bind (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings)) - ,@(append-map - (lambda (x) - (if (pair? x) - `(,(simplify-form `(set! ,(first x) ,(simplify-form (second x))))) - '())) - bindings) - ,@(map simplify-form bodyexprs))) + (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)) @@ -175,32 +182,34 @@ (define (add-tail-call k rval form) `(%bind ,(second form) ,@(foldr (lambda (subform after) - (if (pair? after) - (cons subform after) - (if (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))) - (if (and (pair? subform) - (eq? (first subform) '%tail-call)) - (list subform) - (if (and (pair? subform) - (eq? (first subform) '%apply)) - `((%tail-call ,(second subform) - ,(third subform) - ,k)) - (if (and (pair? subform) - (eq? (first subform) '%set!) - (eq? (second subform) rval)) - `(,subform - (%set! ,rval (%cons ,rval %nil)) - (%tail-call ,k ,rval #f)) - `(,subform - (%tail-call ,k %nil #f)))))))) + (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) '%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)) + `(,subform + (%set! ,rval (%cons ,rval %nil)) + (%tail-call ,k ,rval #f))] + [else + `(,subform + (%tail-call ,k %nil #f))])) '() (cddr form)))) @@ -231,14 +240,13 @@ (flatten-binds `(%bind (,rval ,k) (%set! ,k %k) - ,(make-bindings-unique - (simplify-form - `(set! ,rval (let ([,argv-temp %argv]) - ,(foldr add-req - (foldr add-opt - rest+bodyexprs - optionals) - requireds))))))))))) + ,(simplify-form + `(set! ,rval (let ([,argv-temp %argv]) + ,(foldr add-req + (foldr add-opt + rest+bodyexprs + optionals) + requireds)))))))))) ; <= (%bind (var...) ; @before ; (%apply x y) @@ -306,12 +314,13 @@ (define fn-var (gensym)) (define arg-vars (map (lambda (x) (gensym)) arg-exprs)) (define argv (gensym)) - `(%bind (,fn-var ,@arg-vars ,argv) - ,(simplify-form `(set! ,fn-var ,fn-expr)) - ,@(map (lambda (x y) (simplify-form `(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))) + (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) @@ -340,7 +349,7 @@ (subst-var (car pair) (cdr pair) s)) - (make-bindings-unique frm) + frm (map cons (second form) new-vars))) (cddr form))))] [(%if %tail-call %apply %lambda %set! %cons %car %cdr) form] @@ -365,13 +374,8 @@ [else (error "Unsimplified form:" form)]) form)) -(define (compile-lambda lambda-form) - (flatten-binds - (make-bindings-unique - (simplify-form lambda-form)))) - (define (compile form) - (compile-lambda `(lambda () ,form))) + (simplify-form `(lambda () ,form))) (define (free-variables form [input? #t] [output? #t]) (define (recurse form) (free-variables form input? output?)) @@ -439,8 +443,8 @@ (reduce-set! form))) -;(void (trace optimize (trace compile-lambda (trace simplify-form `(lambda () ,(read)))))) -;(pretty-print (compile (read))) (pretty-print (optimize (compile (read)))) +;(pretty-print (compile (read))) +;(pretty-print (optimize (trace compile (read)))) ; vim:set sw=2 expandtab: