X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e140d85d5346f6cc3bd8b9f3954b063e159a2708..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps.scm

diff --git a/module/language/cps.scm b/module/language/cps.scm
index e0d708ae8..ee201979f 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -27,8 +27,8 @@
 ;;; $letk binds a set of mutually recursive continuations, each one an
 ;;; instance of $cont.  A $cont declares the name of a continuation, and
 ;;; then contains as a subterm the particular continuation instance:
-;;; $kif for test continuations, $kargs for continuations that bind
-;;; values, etc.
+;;; $kargs for continuations that bind values, $ktail for the tail
+;;; continuation, etc.
 ;;;
 ;;; $continue nodes call continuations.  The expression contained in the
 ;;; $continue node determines the value or values that are passed to the
@@ -57,29 +57,29 @@
 ;;;     but which truncates them to some number of required values,
 ;;;     possibly with a rest list.
 ;;;
-;;;   - $kentry labels an entry point for a $fun (a function), and
+;;;   - $kfun labels an entry point for a $fun (a function), and
 ;;;     contains a $ktail representing the formal argument which is the
 ;;;     function's continuation.
 ;;;
-;;;   - $kentry also contains $kclause continuations, corresponding to
-;;;     the case-lambda clauses of the function.  $kclause actually
-;;;     contains the clause body.  This is because the $kclause
-;;;     logically matches or doesn't match a given set of actual
-;;;     arguments against a formal arity, then proceeds to a "body"
-;;;     continuation (which is a $kargs).
+;;;   - $kfun also contain a $kclause continuation, corresponding to
+;;;     the first case-lambda clause of the function.  $kclause actually
+;;;     contains the clause body, and the subsequent clause (if any).
+;;;     This is because the $kclause logically matches or doesn't match
+;;;     a given set of actual arguments against a formal arity, then
+;;;     proceeds to a "body" continuation (which is a $kargs).
 ;;;
 ;;;     That's to say that a $fun can be matched like this:
 ;;;
 ;;;     (match f
-;;;       (($ $fun src meta free
-;;;           ($ $cont kentry
-;;;              ($ $kentry self ($ $cont ktail _ ($ $ktail))
-;;;                 (($ $kclause arity
-;;;                     ($ $cont kbody _ ($ $kargs names syms body)))
-;;;                  ...))))
+;;;       (($ $fun free
+;;;           ($ $cont kfun
+;;;              ($ $kfun src meta self ($ $cont ktail ($ $ktail))
+;;;                 ($ $kclause arity
+;;;                    ($ $cont kbody ($ $kargs names syms body))
+;;;                    alternate))))
 ;;;         #t))
 ;;;
-;;;     A $continue to ktail is in tail position.  $kentry, $kclause,
+;;;     A $continue to ktail is in tail position.  $kfun, $kclause,
 ;;;     and $ktail will never be seen elsewhere in a CPS term.
 ;;;
 ;;;   - $prompt continues to the body of the prompt, having pushed on a
@@ -92,7 +92,7 @@
 ;;;   - $letk, $letrec, and $continue are terms.
 ;;;
 ;;;   - $cont is a continuation, containing a continuation body ($kargs,
-;;;     $kif, etc).
+;;;     $ktail, etc).
 ;;;
 ;;;   - $continue terms contain an expression ($call, $const, $fun,
 ;;;     etc).
@@ -107,6 +107,7 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:export (;; Helper.
             $arity
             make-$arity
@@ -118,19 +119,30 @@
             $cont
 
             ;; Continuation bodies.
-            $kif $kreceive $kargs $kentry $ktail $kclause
+            $kreceive $kargs $kfun $ktail $kclause
 
             ;; Expressions.
-            $void $const $prim $fun $call $callk $primcall $values $prompt
+            $const $prim $fun $closure $branch
+            $call $callk $primcall $values $prompt
+
+            ;; First-order CPS root.
+            $program
+
+            ;; Fresh names.
+            label-counter var-counter
+            fresh-label fresh-var
+            with-fresh-name-state compute-max-label-and-var
+            let-fresh
 
             ;; Building macros.
-            let-gensyms
             build-cps-term build-cps-cont build-cps-exp
             rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
 
             ;; Misc.
             parse-cps unparse-cps
-            fold-conts fold-local-conts))
+            make-global-cont-folder make-local-cont-folder
+            fold-conts fold-local-conts
+            visit-cont-successors))
 
 ;; FIXME: Use SRFI-99, when Guile adds it.
 (define-syntax define-record-type*
@@ -165,33 +177,58 @@
 ;; Terms.
 (define-cps-type $letk conts body)
 (define-cps-type $continue k src exp)
-(define-cps-type $letrec names syms funs body)
+(define-cps-type $letrec names syms funs body) ; Higher-order.
 
 ;; Continuations
 (define-cps-type $cont k cont)
-(define-cps-type $kif kt kf)
 (define-cps-type $kreceive arity k)
 (define-cps-type $kargs names syms body)
-(define-cps-type $kentry self tail clauses)
+(define-cps-type $kfun src meta self tail clause)
 (define-cps-type $ktail)
-(define-cps-type $kclause arity cont)
+(define-cps-type $kclause arity cont alternate)
 
 ;; Expressions.
-(define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
-(define-cps-type $fun src meta free body)
+(define-cps-type $fun free body) ; Higher-order.
+(define-cps-type $closure label nfree) ; First-order.
+(define-cps-type $branch k exp)
 (define-cps-type $call proc args)
-(define-cps-type $callk k proc args)
+(define-cps-type $callk k proc args) ; First-order.
 (define-cps-type $primcall name args)
 (define-cps-type $values args)
 (define-cps-type $prompt escape? tag handler)
 
-(define-syntax let-gensyms
-  (syntax-rules ()
-    ((_ (sym ...) body body* ...)
-     (let ((sym (gensym (symbol->string 'sym))) ...)
-       body body* ...))))
+;; The root of a higher-order CPS term is $cont containing a $kfun.  The
+;; root of a first-order CPS term is a $program.
+(define-cps-type $program funs)
+
+(define label-counter (make-parameter #f))
+(define var-counter (make-parameter #f))
+
+(define (fresh-label)
+  (let ((count (or (label-counter)
+                   (error "fresh-label outside with-fresh-name-state"))))
+    (label-counter (1+ count))
+    count))
+
+(define (fresh-var)
+  (let ((count (or (var-counter)
+                   (error "fresh-var outside with-fresh-name-state"))))
+    (var-counter (1+ count))
+    count))
+
+(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
+  (let ((label (fresh-label)) ...
+        (var (fresh-var)) ...)
+    body ...))
+
+(define-syntax-rule (with-fresh-name-state fun body ...)
+  (call-with-values (lambda () (compute-max-label-and-var fun))
+    (lambda (max-label max-var)
+      (parameterize ((label-counter (1+ max-label))
+                     (var-counter (1+ max-var)))
+        body ...))))
 
 (define-syntax build-arity
   (syntax-rules (unquote)
@@ -200,25 +237,24 @@
      (make-$arity req opt rest kw allow-other-keys?))))
 
 (define-syntax build-cont-body
-  (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
+  (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
     ((_ (unquote exp))
      exp)
-    ((_ ($kif kt kf))
-     (make-$kif kt kf))
     ((_ ($kreceive req rest kargs))
      (make-$kreceive (make-$arity req '() rest '() #f) kargs))
+    ((_ ($kargs (name ...) (unquote syms) body))
+     (make-$kargs (list name ...) syms (build-cps-term body)))
     ((_ ($kargs (name ...) (sym ...) body))
      (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
     ((_ ($kargs names syms body))
      (make-$kargs names syms (build-cps-term body)))
-    ((_ ($kentry self tail (unquote clauses)))
-     (make-$kentry self (build-cps-cont tail) clauses))
-    ((_ ($kentry self tail (clause ...)))
-     (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause) ...)))
+    ((_ ($kfun src meta self tail clause))
+     (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
     ((_ ($ktail))
      (make-$ktail))
-    ((_ ($kclause arity cont))
-     (make-$kclause (build-arity arity) (build-cps-cont cont)))))
+    ((_ ($kclause arity cont alternate))
+     (make-$kclause (build-arity arity) (build-cps-cont cont)
+                    (build-cps-cont alternate)))))
 
 (define-syntax build-cps-cont
   (syntax-rules (unquote)
@@ -227,26 +263,31 @@
 
 (define-syntax build-cps-exp
   (syntax-rules (unquote
-                 $void $const $prim $fun $call $callk $primcall $values $prompt)
+                 $const $prim $fun $closure $branch
+                 $call $callk $primcall $values $prompt)
     ((_ (unquote exp)) exp)
-    ((_ ($void)) (make-$void))
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
-    ((_ ($fun src meta free body))
-     (make-$fun src meta free (build-cps-cont body)))
+    ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
+    ((_ ($closure k nfree)) (make-$closure k nfree))
+    ((_ ($call proc (unquote args))) (make-$call proc args))
     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
     ((_ ($call proc args)) (make-$call proc args))
+    ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
     ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
     ((_ ($callk k proc args)) (make-$callk k proc args))
+    ((_ ($primcall name (unquote args))) (make-$primcall name args))
     ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
     ((_ ($primcall name args)) (make-$primcall name args))
+    ((_ ($values (unquote args))) (make-$values args))
     ((_ ($values (arg ...))) (make-$values (list arg ...)))
     ((_ ($values args)) (make-$values args))
+    ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
     ((_ ($prompt escape? tag handler))
      (make-$prompt escape? tag handler))))
 
 (define-syntax build-cps-term
-  (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+  (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
     ((_ (unquote exp))
      exp)
     ((_ ($letk (unquote conts) body))
@@ -261,7 +302,7 @@
     ((_ ($letconst () body))
      (build-cps-term body))
     ((_ ($letconst ((name sym val) tail ...) body))
-     (let-gensyms (kconst)
+     (let-fresh (kconst) ()
        (build-cps-term
          ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
            ($continue kconst (let ((props (source-properties val)))
@@ -269,6 +310,12 @@
              ($const val))))))
     ((_ ($letrec names gensyms funs body))
      (make-$letrec names gensyms funs (build-cps-term body)))
+    ((_ ($program (unquote conts)))
+     (make-$program conts))
+    ((_ ($program (cont ...)))
+     (make-$program (list (build-cps-cont cont) ...)))
+    ((_ ($program conts))
+     (make-$program conts))
     ((_ ($continue k src exp))
      (make-$continue k src (build-cps-exp exp)))))
 
@@ -304,45 +351,54 @@
     (('k sym body)
      (build-cps-cont
        (sym ,(parse-cps body))))
-    (('kif kt kf)
-     (build-cont-body ($kif kt kf)))
     (('kreceive req rest k)
      (build-cont-body ($kreceive req rest k)))
     (('kargs names syms body)
      (build-cont-body ($kargs names syms ,(parse-cps body))))
-    (('kentry self tail clauses)
+    (('kfun src meta self tail clause)
      (build-cont-body
-      ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
+      ($kfun (src exp) meta self ,(parse-cps tail)
+        ,(and=> clause parse-cps))))
     (('ktail)
      (build-cont-body
       ($ktail)))
     (('kclause (req opt rest kw allow-other-keys?) body)
      (build-cont-body
       ($kclause (req opt rest kw allow-other-keys?)
-        ,(parse-cps body))))
+        ,(parse-cps body)
+        ,#f)))
+    (('kclause (req opt rest kw allow-other-keys?) body alternate)
+     (build-cont-body
+      ($kclause (req opt rest kw allow-other-keys?)
+        ,(parse-cps body)
+        ,(parse-cps alternate))))
     (('kseq body)
      (build-cont-body ($kargs () () ,(parse-cps body))))
 
     ;; Calls.
     (('continue k exp)
      (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
-    (('void)
-     (build-cps-exp ($void)))
     (('const exp)
      (build-cps-exp ($const exp)))
     (('prim name)
      (build-cps-exp ($prim name)))
-    (('fun meta free body)
-     (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
+    (('fun free body)
+     (build-cps-exp ($fun free ,(parse-cps body))))
+    (('closure k nfree)
+     (build-cps-exp ($closure k nfree)))
     (('letrec ((name sym fun) ...) body)
      (build-cps-term
        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+    (('program (cont ...))
+     (build-cps-term ($program ,(map parse-cps cont))))
     (('call proc arg ...)
      (build-cps-exp ($call proc arg)))
     (('callk k proc arg ...)
      (build-cps-exp ($callk k proc arg)))
     (('primcall name arg ...)
      (build-cps-exp ($primcall name arg)))
+    (('branch k exp)
+     (build-cps-exp ($branch k ,(parse-cps exp))))
     (('values arg ...)
      (build-cps-exp ($values arg)))
     (('prompt escape? tag handler)
@@ -364,43 +420,46 @@
      `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
     (($ $cont sym body)
      `(k ,sym ,(unparse-cps body)))
-    (($ $kif kt kf)
-     `(kif ,kt ,kf))
     (($ $kreceive ($ $arity req () rest '() #f) k)
      `(kreceive ,req ,rest ,k))
     (($ $kargs () () body)
      `(kseq ,(unparse-cps body)))
     (($ $kargs names syms body)
      `(kargs ,names ,syms ,(unparse-cps body)))
-    (($ $kentry self tail clauses)
-     `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
+    (($ $kfun src meta self tail clause)
+     `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
     (($ $ktail)
      `(ktail))
-    (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
-     `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
+    (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
+     `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
+               . ,(if alternate (list (unparse-cps alternate)) '())))
 
     ;; Calls.
     (($ $continue k src exp)
      `(continue ,k ,(unparse-cps exp)))
-    (($ $void)
-     `(void))
     (($ $const val)
      `(const ,val))
     (($ $prim name)
      `(prim ,name))
-    (($ $fun src meta free body)
-     `(fun ,meta ,free ,(unparse-cps body)))
+    (($ $fun free body)
+     `(fun ,free ,(unparse-cps body)))
+    (($ $closure k nfree)
+     `(closure ,k ,nfree))
     (($ $letrec names syms funs body)
      `(letrec ,(map (lambda (name sym fun)
                       (list name sym (unparse-cps fun)))
                     names syms funs)
         ,(unparse-cps body)))
+    (($ $program conts)
+     `(program ,(map unparse-cps conts)))
     (($ $call proc args)
      `(call ,proc ,@args))
     (($ $callk k proc args)
      `(callk ,k ,proc ,@args))
     (($ $primcall name args)
      `(primcall ,name ,@args))
+    (($ $branch k exp)
+     `(branch ,k ,(unparse-cps exp)))
     (($ $values args)
      `(values ,@args))
     (($ $prompt escape? tag handler)
@@ -408,67 +467,166 @@
     (_
      (error "unexpected cps" exp))))
 
-(define (fold-conts proc seed fun)
-  (define (cont-folder cont seed)
+(define-syntax-rule (make-global-cont-folder seed ...)
+  (lambda (proc cont seed ...)
+    (define (cont-folder cont seed ...)
+      (match cont
+        (($ $cont k cont)
+         (let-values (((seed ...) (proc k cont seed ...)))
+           (match cont
+             (($ $kargs names syms body)
+              (term-folder body seed ...))
+
+             (($ $kfun src meta self tail clause)
+              (let-values (((seed ...) (cont-folder tail seed ...)))
+                (if clause
+                    (cont-folder clause seed ...)
+                    (values seed ...))))
+
+             (($ $kclause arity body alternate)
+              (let-values (((seed ...) (cont-folder body seed ...)))
+                (if alternate
+                    (cont-folder alternate seed ...)
+                    (values seed ...))))
+
+             (_ (values seed ...)))))))
+
+    (define (fun-folder fun seed ...)
+      (match fun
+        (($ $fun free body)
+         (cont-folder body seed ...))))
+
+    (define (term-folder term seed ...)
+      (match term
+        (($ $letk conts body)
+         (let-values (((seed ...) (term-folder body seed ...)))
+           (let lp ((conts conts) (seed seed) ...)
+             (if (null? conts)
+                 (values seed ...)
+                 (let-values (((seed ...) (cont-folder (car conts) seed ...)))
+                   (lp (cdr conts) seed ...))))))
+
+        (($ $continue k src exp)
+         (match exp
+           (($ $fun) (fun-folder exp seed ...))
+           (_ (values seed ...))))
+
+        (($ $letrec names syms funs body)
+         (let-values (((seed ...) (term-folder body seed ...)))
+           (let lp ((funs funs) (seed seed) ...)
+             (if (null? funs)
+                 (values seed ...)
+                 (let-values (((seed ...) (fun-folder (car funs) seed ...)))
+                   (lp (cdr funs) seed ...))))))))
+
+    (cont-folder cont seed ...)))
+
+(define-syntax-rule (make-local-cont-folder seed ...)
+  (lambda (proc cont seed ...)
+    (define (cont-folder cont seed ...)
+      (match cont
+        (($ $cont k (and cont ($ $kargs names syms body)))
+         (let-values (((seed ...) (proc k cont seed ...)))
+           (term-folder body seed ...)))
+        (($ $cont k cont)
+         (proc k cont seed ...))))
+    (define (term-folder term seed ...)
+      (match term
+        (($ $letk conts body)
+         (let-values (((seed ...) (term-folder body seed ...)))
+           (let lp ((conts conts) (seed seed) ...)
+             (match conts
+               (() (values seed ...))
+               ((cont) (cont-folder cont seed ...))
+               ((cont . conts)
+                (let-values (((seed ...) (cont-folder cont seed ...)))
+                  (lp conts seed ...)))))))
+        (($ $letrec names syms funs body) (term-folder body seed ...))
+        (_ (values seed ...))))
+    (define (clause-folder clause seed ...)
+      (match clause
+        (($ $cont k (and cont ($ $kclause arity body alternate)))
+         (let-values (((seed ...) (proc k cont seed ...)))
+           (if alternate
+               (let-values (((seed ...) (cont-folder body seed ...)))
+                 (clause-folder alternate seed ...))
+               (cont-folder body seed ...))))))
     (match cont
-      (($ $cont k cont)
-       (let ((seed (proc k cont seed)))
-         (match cont
-           (($ $kargs names syms body)
-            (term-folder body seed))
-
-           (($ $kentry self tail clauses)
-            (fold cont-folder (cont-folder tail seed) clauses))
-
-           (($ $kclause arity body)
-            (cont-folder body seed))
-
-           (_ seed))))))
+      (($ $cont k (and cont ($ $kfun src meta self tail clause)))
+       (let*-values (((seed ...) (proc k cont seed ...))
+                     ((seed ...) (if clause
+                                     (clause-folder clause seed ...)
+                                     (values seed ...))))
+         (cont-folder tail seed ...))))))
+
+(define (compute-max-label-and-var fun)
+  (match fun
+    (($ $cont)
+     ((make-global-cont-folder max-label max-var)
+      (lambda (label cont max-label max-var)
+        (values (max label max-label)
+                (match cont
+                  (($ $kargs names vars body)
+                   (let lp ((body body) (max-var (fold max max-var vars)))
+                     (match body
+                       (($ $letk conts body) (lp body max-var))
+                       (($ $letrec names vars funs body)
+                        (lp body (fold max max-var vars)))
+                       (_ max-var))))
+                  (($ $kfun src meta self)
+                   (max self max-var))
+                  (_ max-var))))
+      fun -1 -1))
+    (($ $program conts)
+     (define (fold/2 proc in s0 s1)
+      (if (null? in)
+          (values s0 s1)
+          (let-values (((s0 s1) (proc (car in) s0 s1)))
+            (fold/2 proc (cdr in) s0 s1))))
+     (let lp ((conts conts) (max-label -1) (max-var -1))
+       (if (null? conts)
+           (values max-label max-var)
+           (call-with-values (lambda ()
+                               ((make-local-cont-folder max-label max-var)
+                                (lambda (label cont max-label max-var)
+                                  (values (max label max-label)
+                                          (match cont
+                                            (($ $kargs names vars body)
+                                             (fold max max-var vars))
+                                            (($ $kfun src meta self)
+                                             (max self max-var))
+                                            (_ max-var))))
+                                (car conts) max-label max-var))
+             (lambda (max-label max-var)
+               (lp (cdr conts) max-label max-var))))))))
 
-  (define (fun-folder fun seed)
-    (match fun
-      (($ $fun src meta free body)
-       (cont-folder body seed))))
-
-  (define (term-folder term seed)
-    (match term
-      (($ $letk conts body)
-       (fold cont-folder (term-folder body seed) conts))
-
-      (($ $continue k src exp)
-       (match exp
-         (($ $fun) (fun-folder exp seed))
-         (_ seed)))
-
-      (($ $letrec names syms funs body)
-       (fold fun-folder (term-folder body seed) funs))))
-
-  (fun-folder fun seed))
+(define (fold-conts proc seed fun)
+  ((make-global-cont-folder seed) proc fun seed))
 
-(define (fold-local-conts proc seed cont)
-  (define (cont-folder cont seed)
-    (match cont
-      (($ $cont k cont)
-       (let ((seed (proc k cont seed)))
-         (match cont
-           (($ $kargs names syms body)
-            (term-folder body seed))
+(define (fold-local-conts proc seed fun)
+  ((make-local-cont-folder seed) proc fun seed))
 
-           (($ $kentry self tail clauses)
-            (fold cont-folder (cont-folder tail seed) clauses))
+(define (visit-cont-successors proc cont)
+  (match cont
+    (($ $kargs names syms body)
+     (let lp ((body body))
+       (match body
+         (($ $letk conts body) (lp body))
+         (($ $letrec names vars funs body) (lp body))
+         (($ $continue k src exp)
+          (match exp
+            (($ $prompt escape? tag handler) (proc k handler))
+            (($ $branch kt) (proc k kt))
+            (_ (proc k)))))))
 
-           (($ $kclause arity body)
-            (cont-folder body seed))
+    (($ $kreceive arity k) (proc k))
 
-           (_ seed))))))
+    (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
 
-  (define (term-folder term seed)
-    (match term
-      (($ $letk conts body)
-       (fold cont-folder (term-folder body seed) conts))
+    (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
 
-      (($ $continue) seed)
+    (($ $kfun src meta self tail ($ $cont clause)) (proc clause))
 
-      (($ $letrec names syms funs body) (term-folder body seed))))
+    (($ $kfun src meta self tail #f) (proc))
 
-  (cont-folder cont seed))
+    (($ $ktail) (proc))))