Move optmization to after cps-ification

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)
@@ -225,17 +226,17 @@
   ;; As an invariant, T-k cannot nest a T-c call directly
   ;; (expr * (aexp -> cexp) -> cexp)
   (match expr
-    [ ('quote e) (k expr)]
-    [`(lambda . ,_) (k (M expr r))]
+    [('quote e) (k expr)]
+    [('lambda . _) (k (M expr r))]
     [(? atomic?)   (k (M expr r))]
     [('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*) ,(k $body)))
-                   r0))
-            r0))]
+             (lambda ($e*)
+               (T-k body
+                    (lambda ($body) `(letrec ,(zip v*0 $e*) ,(k $body)))
+                    r0))
+             r0))]
     [('begin e) (T-k e k r)]
     [('begin e e* ...)
      (T-k e
@@ -294,6 +295,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)