nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up handling of (let) and (%bind), plus misc. cleanup. 

With this change, any (%bind) returned from (simplify-let) or (simplify-form)
can be assumed to be flat, with unique bound symbols. Before, this was only
true of (%lambda) forms and the output of (compile).
This commit is contained in:
Jesse D. McDonald 2010-04-15 12:23:09 -05:00
parent 6b51229c48
commit 0b0b352dd6
1 changed files with 103 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

202
compiler.ss
View File

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