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:
parent
6b51229c48
commit
0b0b352dd6
202
compiler.ss
202
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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue