diff --git a/scmvm/language/scheme.scm b/scmvm/language/scheme.scm index bb8bcc7..00b91cc 100644 --- a/scmvm/language/scheme.scm +++ b/scmvm/language/scheme.scm @@ -80,86 +80,89 @@ [(e* ...) `(begin ,@(map desugar-exp e*))])) -;; A-Normalization +;; CPS conversion +;; Re-structure the program into "Continuation Passing Style", where non-atomic +;; expressions must pass their continuations explicitly, changing to a very +;; "lambda-like" format +;; - begin expressions are decomposed +;; - let expressions are transformed into closed function applications ;; ::= ... ;; ::= | ;; ::= (define ) ;; ::= ;; | -;; | (let (( )) ) ;; ::= ( ...) -;; | (if ) -;; | (set! ) +;; | (if ) +;; | (set-then! ) ;; ::= (lambda ( ...) exp) -;; | | | #t | #f -;; Atomic expressions are guaranteed to terminate without side effects or errors -;; - All arguments to lambdas are atomic -;; - All complex (non-atomic) expressions are let-bound or in a tail position -;; - All let expressions bind a single var -;; - begin expressions are decomposed +;; | | | | #t | #f +;; +;; We choose a hybrid transformation based on https://matt.might.net/articles/cps-conversion/ -;; This is a classical construction, Flanegan et al. 1993 -;; see https://matt.might.net/articles/a-normalization/ +(define undefined-value (make-symbol "undefined")) -(define (normalize-prgm prgm) - (map (lambda (top) - (if (eq? (car top) 'define) - (normalize-define top) - (normalize-term top))) - prgm)) +(define (hybrid-conversion expr) + ;; M : expr -> aexp + ;; T-k : expr, (aexp -> cexp) -> cexp + ;; T-c : expr, aexp -> cexp + (define (M expr) + ;; M dispatches to the appropriate transformer + (match expr + [`(lambda (,var) ,expr) + (let ([$k (gensym "$k")]) + `(lambda (,var ,$k) ,(T-c expr $k)))] + [_ expr])) -(define (normalize-define def) - (match def - [`(define ,var ,exp) - `(define ,var ,(normalize-term exp))])) + (define (T-k expr k) + ;; T-k takes an explicit continuation and calls it when done + ;; As an invariant, T-k cannot nest a T-c call directly + (match expr + [`(lambda . ,_) (k (M expr))] + [ (? atomic?) (k (M expr))] + [ ('begin e) (T-k e k)] + [ ('begin e e* ...) + (T-k e (lambda _ (T-k `(begin ,@e*) k)))] + [ ('let ([v* e*] ...) body) + (T-k `((lambda (,@v*) ,body) ,@e*) k)] + [ ('if exp1 exp2 exp3) + (T-k exp1 (lambda ($exp1) + (if $exp1 + (T-k exp2 k) + (T-k exp3 k))))] + [ ('set! var expr) + (T-k expr (lambda ($expr) + `(set-then! ,var ,$expr ,(k undefined-value))))] + [(f e* ...) + (let* ([$rv (gensym "$rv")] + [cont `(lambda (,$rv) ,(k $rv))]) + (T-k f (lambda ($f) + (T*-k e* (lambda ($e*) + `(,$f ,@$e* ,cont))))))])) -(define (normalize-term term) - (normalize-exp term identity)) - -(define (normalize-exp exp k) - (match exp - [`(lambda ,params ,exp) - (k `(lambda ,params ,(normalize-term exp)))] - - [`(if ,exp1 ,exp2 ,exp3) - (normalize-name - exp1 - (lambda (e1) - (k `(if ,e1 - ,(normalize-term exp2) - ,(normalize-term exp3)))))] - - [(f a* ...) - (normalize-name - f - (lambda (t) - (normalize-name* - a* - (lambda (t*) - (k (cons t t*))))))] - - [`(let () ,exp) - (normalize-exp exp k)] - - [`(let ((,var ,exp1) . ,more) ,exp2) - (normalize-exp - exp1 - (lambda (e) - `(let ((,var ,e)) - ,(normalize-exp `(let (,@more) ,exp2) k))))] - - [('begin e* ... e) - (normalize-exp `(let (,@(map (lambda (t) (cons (gensym "t") t)) e*)) e) k)] - - [(? atomic?) (k exp)])) - -(define (normalize-name name k) - (normalize-exp - name - (lambda (t) - (if (atomic? t) - (k t) - (let ([$t (gensym "t")]) - `(let ([,$t ,t]) ,(k $t))))))) - -(define-cps-loop normalize-name* normalize-name) + (define (T-c expr c) + ;; T-c takes a symbolic continuation, and uses it to construct CPS + (match expr + [`(lambda . ,_) `(,c ,(M expr))] + [ (? atomic?) `(,c ,(M expr))] + [ ('begin e) (T-c e c)] + [ ('begin e e* ...) + (T-k e (lambda _ (T-c `(begin ,@e*) c)))] + [ ('let ([v* e*] ...) body) + (T-c `((lambda (,@v*) ,body) ,@e*) c)] + [ ('if exp1 exp2 exp3) + (let ([$k (gensym "$k")]) ;; Bind cont to avoid blow up + `((lambda (,$k)) + ,(T-k exp1 (lambda (aexp) + `(if ,aexp + ,(T-c exp2 $k) + ,(T-c exp3 $k)))) + ,c))] + [ ('set! var expr) + (T-k expr (lambda ($expr) + `(set-then ,var ,$expr (,c ,undefined-value))))] + [ (f e* ...) + (T-k f (lambda ($f) + (T*-k e* (lambda ($e*) + `(,$f ,@$e* ,c)))))])) + (define-cps-loop T*-k T-k) + (T-c expr 'ktail))