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

Implement support for (call/cc), and shorthand form (let/cc). 

Adds support for non-local returns, among other control-flow structures.
This commit is contained in:
Jesse D. McDonald 2010-04-16 14:05:14 -05:00
parent 14b2a1570a
commit b899f0c3b0
1 changed files with 81 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
compiler.ss
View File

@ -16,12 +16,15 @@
[(lambda) (simplify-lambda form)] [(lambda) (simplify-lambda form)]
[(begin) (simplify-form `(let () ,@(cdr form)))] [(begin) (simplify-form `(let () ,@(cdr form)))]
[(set!) (simplify-set! form)] [(set!) (simplify-set! form)]
[(car cdr cons) (simplify-primitive (case (first form) [(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(car cdr cons call/cc)
(simplify-primitive (case (first form)
[(car) '%car] [(car) '%car]
[(cdr) '%cdr] [(cdr) '%cdr]
[(cons) '%cons]) [(cons) '%cons]
[(call/cc) '%call/cc])
(cdr form))] (cdr form))]
[(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr quote) form] [(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc quote) form]
[else (simplify-funcall form)]) [else (simplify-funcall form)])
(if (eq? form '()) '%nil form))) (if (eq? form '()) '%nil form)))
@ -34,11 +37,13 @@
(cond (cond
[(pair? after) (cons subform after)] [(pair? after) (cons subform after)]
[(or (not (pair? subform)) [(or (not (pair? subform))
(memq (first subform) '(%apply %car %cdr %cons %bind %if quote))) (memq (first subform) '(%apply %call/cc %car %cdr %cons %bind %if quote)))
`((set! ,(second form) ,subform))] `((set! ,(second form) ,subform))]
[(and (pair? subform) (eq? (first subform) '%tail-call)) [(and (pair? subform) (eq? (first subform) '%tail-call))
`(,subform)] ; The %set! wouldn't be executed anyway. `(,subform)] ; The %set! wouldn't be executed anyway.
[else (error "set! used with non-value form:" subform)])) [else
`(,subform
(%set! ,(second form) %void))]))
'() '()
(cddr value-form)))) (cddr value-form))))
`(%set! ,(second form) ,value-form)))) `(%set! ,(second form) ,value-form))))
@ -180,7 +185,8 @@
(values '() '() #f))) (values '() '() #f)))
(define (add-tail-call k rval form) (define (add-tail-call k rval form)
`(%bind ,(second form) (define k-argv (gensym))
`(%bind (,@(second form) ,k-argv)
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(cond (cond
[(pair? after) [(pair? after)
@ -193,6 +199,14 @@
(let ([fn (second (third subform))] (let ([fn (second (third subform))]
[argv (third (third subform))]) [argv (third (third subform))])
`((%tail-call ,fn ,argv ,k)))] `((%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) [(and (pair? subform)
(eq? (first subform) '%tail-call)) (eq? (first subform) '%tail-call))
`(,subform)] `(,subform)]
@ -201,6 +215,11 @@
`((%tail-call ,(second subform) `((%tail-call ,(second subform)
,(third subform) ,(third subform)
,k))] ,k))]
[(and (pair? subform)
(eq? (first subform) '%set!)
(eq? (second subform) rval)
(eq? (third subform) '%void))
`((%tail-call ,k %nil #f))]
[(and (pair? subform) [(and (pair? subform)
(eq? (first subform) '%set!) (eq? (first subform) '%set!)
(eq? (second subform) rval)) (eq? (second subform) rval))
@ -267,11 +286,22 @@
; @after)) ; @after))
; (%tail-call x y k))) ; (%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) (define (transform-to-cps form)
(flatten-binds (flatten-binds
`(%bind ,(second form) `(%bind ,(second form)
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(cond (cond
; (%set! v (%apply x y))
[(and (pair? subform) [(and (pair? subform)
(eq? (first subform) '%set!) (eq? (first subform) '%set!)
(pair? (third subform)) (pair? (third subform))
@ -280,12 +310,13 @@
[x (gensym)]) [x (gensym)])
`((%bind (,k ,x) `((%bind (,k ,x)
(%set! ,k ,(simplify-form (%set! ,k ,(simplify-form
`(lambda (,x) `(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x) (%set! ,(second subform) ,x)
,@after))) ,@after)))
(%tail-call ,(second (third subform)) (%tail-call ,(second (third subform))
,(third (third subform)) ,(third (third subform))
,k))))] ,k))))]
; (%apply x y)
[(and (pair? subform) [(and (pair? subform)
(eq? (first subform) '%apply)) (eq? (first subform) '%apply))
(let ([k (gensym)]) (let ([k (gensym)])
@ -296,6 +327,36 @@
(%tail-call ,(second subform) (%tail-call ,(second subform)
,(third subform) ,(third subform)
,k))))] ,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)])) [else (cons subform after)]))
'() '()
(cddr form))))) (cddr form)))))
@ -332,7 +393,7 @@
form form
`(%bind ,(second form) ,@(map recurse (cddr form))))] `(%bind ,(second form) ,@(map recurse (cddr form))))]
[(quote) form] [(quote) form]
[(%if %tail-call %apply %lambda %set! %cons %car %cdr) [(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc)
`(,(first form) ,@(map recurse (cdr form)))] `(,(first form) ,@(map recurse (cdr form)))]
[else (error "Unsimplified form:" form)]) [else (error "Unsimplified form:" form)])
(if (eq? form old-var) (if (eq? form old-var)
@ -353,7 +414,7 @@
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 quote) form] [(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc quote) form]
[else (error "Unsimplified form:" form)]) [else (error "Unsimplified form:" form)])
form)) form))
@ -371,13 +432,10 @@
(list new-form))) (list new-form)))
(map flatten-binds (cddr form)))]) (map flatten-binds (cddr form)))])
`(%bind ,bound-vars ,@subforms))] `(%bind ,bound-vars ,@subforms))]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr quote) form] [(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc quote) form]
[else (error "Unsimplified form:" form)]) [else (error "Unsimplified form:" form)])
form)) form))
(define (compile 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?))
(if (pair? form) (if (pair? form)
@ -389,7 +447,7 @@
(cons (second form) (recurse (third form))) (cons (second form) (recurse (third form)))
(recurse (third form)))] (recurse (third form)))]
[(quote) '()] [(quote) '()]
[(%if %tail-call %apply %lambda %cons %car %cdr) [(%if %tail-call %apply %lambda %cons %car %cdr %call/cc)
(remove-duplicates (append-map recurse (cdr form)))] (remove-duplicates (append-map recurse (cdr form)))]
[else [else
(error "Unsimplified form:" form)]) (error "Unsimplified form:" form)])
@ -414,7 +472,7 @@
`(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form)) `(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form))
,@(map reduce-variables (cddr form))))] ,@(map reduce-variables (cddr form))))]
[(quote) form] [(quote) form]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr) [(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc)
`(,(first form) ,@(map reduce-variables (cdr form)))] `(,(first form) ,@(map reduce-variables (cdr form)))]
[else (error "Unsimplified form:" form)]) [else (error "Unsimplified form:" form)])
form)) form))
@ -436,9 +494,8 @@
(cons subform after))) (cons subform after)))
'() '()
(map reduce-set! (cddr form)))))] (map reduce-set! (cddr form)))))]
[(quote) form] [(%if %tail-call %apply %cons %car %cdr %call/cc quote) form]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr) [(%set! %lambda) `(,(first form) ,@(map reduce-set! (cdr form)))]
`(,(first form) ,@(map reduce-set! (cdr form)))]
[else (error "Unsimplified form:" form)]) [else (error "Unsimplified form:" form)])
form)) form))
@ -447,8 +504,8 @@
(reduce-set! (reduce-set!
form))) form)))
(pretty-print (optimize (compile (read)))) (pretty-print (optimize (simplify-form `(lambda () ,(read)))))
;(pretty-print (compile (read))) ;(pretty-print (simplify-form (read)))
;(pretty-print (optimize (trace compile (read)))) ;(pretty-print (optimize (trace simplify-form (read))))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab: