Choose CPS over ANF due to body of literature on topic

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
 ;; <prgm> ::= <top> ...
 ;; <top>  ::= <def> | <exp>
 ;; <def>  ::= (define <var> <exp>)
 ;; <exp>  ::= <aexp>
 ;;          | <cexp>
-;;          | (let ((<var> <exp>)) <exp>)
 ;; <cexp> ::= (<aexp> <aexp> ...)
-;;          | (if <aexp> <exp> <exp>)
-;;          | (set! <var> <exp>)
+;;          | (if <aexp> <cexp> <cexp>)
+;;          | (set-then! <var> <aexp> <cexp>)
 ;; <aexp> ::= (lambda (<var> ...) exp)
-;;          | <num> | <var> | #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 
+;;          | <num> | <sym> | <var> | #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))