Put a lid on the T-k issues

scmvm/language/scheme.scm

@@ -2,6 +2,7 @@
   #:use-module (scmvm assembler)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -110,7 +111,7 @@
    [(define? (car prgm))
     (let-values ([(bindings cont) (collect-bindings prgm)])
       `(letrec ,bindings ,(desugar-body cont)))]
-   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr exp)))]))
+   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr prgm)))]))
 
 (define (desugar-exp exp)
   (match exp
@@ -169,6 +170,66 @@
   (let ([v0 (uniq-var v)])
     (values (environment-extend r (list (cons v v0))) v0)))
 
+(define (cps-aexp expr r)
+  (match expr
+    [('lambda (v* ...) e)
+     (let-values
+         ([($k) (gensym "$k-")]
+          [(r0 v*0) (uniq-names r v*)])
+       `(lambda (,@v*0 ,$k) ,(cps-cexp-fo e $k r0)))]
+    [(? primitive?) `(cps-prim ,expr)]
+    ((? symbol?)
+     (let ([kons (environment-assq r expr)])
+       (if kons (cdr kons) (signal-exception "Undefined variable:" expr))))
+    [(? atomic?) expr]))
+
+(define (cps-cexp-fo expr c r)
+  (match expr
+    [ ('quote _) `(,c ,expr)]
+    [`(lambda . ,_) `(,c ,(cps-aexp expr r))]
+    [ (? atomic?) `(,c ,(cps-aexp expr r))]
+    [ (f e* ...)
+      (cps-cexp-ho
+       f
+       (lambda ($f)
+         (cps-cexp-map
+          e*
+          (lambda ($e*)
+            `(,$f ,@$e* ,c))
+          r))
+       r)]))
+
+(define (cps-cexp-ho expr k r)
+  (match expr
+    [ ('quote _) (k expr)]
+    [`(lambda . ,_) (k (cps-aexp expr r))]
+    [ (? atomic?) (k (cps-aexp expr r))]
+    [ (f e* ...)
+      (let ([$rv (gensym "$rv-")])
+        (cps-cexp-ho
+         f
+         (lambda ($f)
+           (cps-cexp-map
+            e*
+            (lambda ($e*)
+              `(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
+            r))
+         r))]))
+
+(define (cps-cexp-map exprs k r)
+  ;; exp* * (aexp -> cexp) -> cexp
+  (if (pair? exprs)
+      (cps-cexp-ho
+       (car exprs)
+       (lambda ($e)
+         (cps-cexp-map
+          (cdr exprs)
+          (lambda ($e*)
+            (k (cons $e $e*)))
+          r))
+       r)
+      (k '())))
+
 (define (M expr r)
   ;; M dispatches to the appropriate transformer
   ;; expr -> aexp
@@ -194,7 +255,8 @@
     [ ('letrec ([v* e*] ...) body)
       (let-values ([(r0 v*0) (uniq-names r v*)])
         (T*-k e* (lambda ($e*)
-                   (T-k body (lambda ($body) `(letrec ,(zip v*0 $e*) (,c ,$body))) r0))
+                   `(letrec ,(zip v*0 $e*)
+                      ,(T-c body c r0)))
              r0))]
     [ ('begin e) (T-c e c r)]
     [ ('begin e e* ...)
@@ -226,7 +288,7 @@
   ;; (expr * (aexp -> cexp) -> cexp)
   (match expr
     [('quote e) (k expr)]
-    [`(lambda . ,_) (k (M expr r))]
+    [('lambda . _) (k (M expr r))]
     [(? atomic?)   (k (M expr r))]
     [('letrec ([v* e*] ...) body)
      (let-values ([(r0 v*0) (uniq-names r v*)])
@@ -256,13 +318,12 @@
        (T-k e (lambda ($e)
                 `(set-then! ,v0 ,$e ,(k undefined-value))) r))]
     [(f e* ...)
-     (let* ([$rv (gensym "$rv-")]
-            [$k  (gensym "$k-")])
+     (let ([$rv (gensym "$rv-")])
        (T-k f
             (lambda ($f)
               (T*-k e*
                     (lambda ($e*)
-                      (k `((lambda (,$k) (,$f ,@$e* ,$k)) (lambda (,$rv) ,$rv))))
+                      `(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
                     r))
             r))]))
 
@@ -294,6 +355,63 @@
     (primitive-eval `(display (call/cc (lambda (ktail) ,(ir-convert prgm)))))
     (newline))
   (ir-interpreter))
+ ;; Optimization
+(define-syntax-rule (define-cps-type name field ...)
+  (begin
+    (define-cps-record-type name field ...)
+    (set-record-type-printer! name cps-printer)))
+
+(define-syntax define-cps-record-type
+  (lambda (ctx)
+    (define (syntax-append id . syns)
+      (datum->syntax id (apply symbol-append (map syntax->datum syns))))
+    (syntax-case ctx ()
+      [(_ name field ...)
+       (with-syntax ([ctor (syntax-append #'name #'make- #'name)]
+                     [pred (syntax-append #'name #'name #'?)]
+                     [(getter ...) (map (lambda (f) (syntax-append f #'name #'- f))
+                                        #'(field ...))])
+         #'(define-record-type name
+             (ctor field ...)
+             pred
+             (field getter) ...))])))
+
+(define (cps-printer cps port)
+  (format port "<cps ~s>" (unparse-cps cps)))
+
+(define-cps-type $constant val)
+(define-cps-type $primitive name)
+(define-cps-type $var name)
+(define-cps-type $abstraction vars body ktail)
+(define-cps-type $alternative pred kt kf)
+(define-cps-type $fix vars exps body)
+(define-cps-type $assignment var exp cont)
+(define-cps-type $application f args ktail)
+
+(define (parse-cps exp)
+  (match exp
+    [(? constant?) (make-$constant exp)]
+    [('cps-prim name) (make-$primitive name)]
+    [(? symbol?) (make-$var exp)]
+    [('lambda (vars ... ktail) body) (make-$abstraction (map parse-cps vars) (parse-cps body) ktail)]
+    [('if pred k1 k2) (make-$alternative (parse-cps pred) k1 k2)]
+    [('letrec ([vars exps] ...) body) (make-$fix (map parse-cps vars) (map parse-cps exps) (parse-cps body))]
+    [('set!-then var exp cont) (make-$assignment var (parse-cps exp) (parse-cps cont))]
+    [(f args ... ktail) (make-$application (parse-cps f) (map parse-cps args) ktail)]
+    [_ (error "unexpected cps while parsing" exp)]))
+
+(define (unparse-cps exp)
+  (match exp
+    [($ $constant val) val]
+    [($ $primitive name) `(cps-prim ,name)]
+    [($ $var name) name]
+    [($ $abstraction vars body ktail) `(lambda (,@vars ,ktail) ,body)]
+    [($ $alternative pred kt kf) `(if ,pred ,kt ,kf)]
+    [($ $fix vars exps body) `(letrec ,(zip vars exps) ,body)]
+    [($ $assignment var expr cont) `(set!-then ,var ,expr ,cont)]
+    [($ $application fun args ktail) `(,fun ,@args ,ktail)]
+    [_ (error "Unexpected cps while unparsing" exp)]))
+
  ;; Compilation
 
 (define (meaning e r)