From b899f0c3b0ee6ab4082f319caf1a731f3e410513 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Fri, 16 Apr 2010 14:05:14 -0500 Subject: [PATCH] Implement support for (call/cc), and shorthand form (let/cc). Adds support for non-local returns, among other control-flow structures. --- compiler.ss | 105 ++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 81 insertions(+), 24 deletions(-) diff --git a/compiler.ss b/compiler.ss index 80bf150..16a7982 100755 --- a/compiler.ss +++ b/compiler.ss @@ -16,12 +16,15 @@ [(lambda) (simplify-lambda form)] [(begin) (simplify-form `(let () ,@(cdr form)))] [(set!) (simplify-set! form)] - [(car cdr cons) (simplify-primitive (case (first form) - [(car) '%car] - [(cdr) '%cdr] - [(cons) '%cons]) - (cdr form))] - [(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr quote) form] + [(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))] + [(car cdr cons call/cc) + (simplify-primitive (case (first form) + [(car) '%car] + [(cdr) '%cdr] + [(cons) '%cons] + [(call/cc) '%call/cc]) + (cdr form))] + [(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc quote) form] [else (simplify-funcall form)]) (if (eq? form '()) '%nil form))) @@ -34,11 +37,13 @@ (cond [(pair? after) (cons subform after)] [(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))] [(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)])) + [else + `(,subform + (%set! ,(second form) %void))])) '() (cddr value-form)))) `(%set! ,(second form) ,value-form)))) @@ -180,7 +185,8 @@ (values '() '() #f))) (define (add-tail-call k rval form) - `(%bind ,(second form) + (define k-argv (gensym)) + `(%bind (,@(second form) ,k-argv) ,@(foldr (lambda (subform after) (cond [(pair? after) @@ -193,6 +199,14 @@ (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)] @@ -201,6 +215,11 @@ `((%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)) @@ -267,11 +286,22 @@ ; @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)) @@ -280,12 +310,13 @@ [x (gensym)]) `((%bind (,k ,x) (%set! ,k ,(simplify-form - `(lambda (,x) + `(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)]) @@ -296,6 +327,36 @@ (%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))))) @@ -332,7 +393,7 @@ form `(%bind ,(second form) ,@(map recurse (cddr 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)))] [else (error "Unsimplified form:" form)]) (if (eq? form old-var) @@ -353,7 +414,7 @@ frm (map cons (second form) new-vars))) (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)]) form)) @@ -371,13 +432,10 @@ (list new-form))) (map flatten-binds (cddr form)))]) `(%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)]) form)) -(define (compile form) - (simplify-form `(lambda () ,form))) - (define (free-variables form [input? #t] [output? #t]) (define (recurse form) (free-variables form input? output?)) (if (pair? form) @@ -389,7 +447,7 @@ (cons (second form) (recurse (third form))) (recurse (third form)))] [(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)))] [else (error "Unsimplified form:" form)]) @@ -414,7 +472,7 @@ `(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form)) ,@(map reduce-variables (cddr 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)))] [else (error "Unsimplified form:" form)]) form)) @@ -436,9 +494,8 @@ (cons subform after))) '() (map reduce-set! (cddr form)))))] - [(quote) form] - [(%if %tail-call %apply %set! %lambda %cons %car %cdr) - `(,(first form) ,@(map reduce-set! (cdr form)))] + [(%if %tail-call %apply %cons %car %cdr %call/cc quote) form] + [(%set! %lambda) `(,(first form) ,@(map reduce-set! (cdr form)))] [else (error "Unsimplified form:" form)]) form)) @@ -447,8 +504,8 @@ (reduce-set! form))) -(pretty-print (optimize (compile (read)))) -;(pretty-print (compile (read))) -;(pretty-print (optimize (trace compile (read)))) +(pretty-print (optimize (simplify-form `(lambda () ,(read))))) +;(pretty-print (simplify-form (read))) +;(pretty-print (optimize (trace simplify-form (read)))) ; vim:set sw=2 expandtab: