Use Tree-IL-like case-lambda clause chaining in CPS

[bpt/guile.git] / module / language / cps / closure-conversion.scm

diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index c03b409..89c491f 100644 (file)
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -60,7 +60,7 @@ called with @var{sym}.
 values in the term."
   (if (memq sym bound)
       (k sym)
-      (let-gensyms (k* sym*)
+      (let-fresh (k*) (sym*)
         (receive (exp free) (k sym*)
           (values (build-cps-term
                     ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
@@ -86,7 +86,7 @@ values: the term and a list of additional free variables in the term."
 label of the outer procedure, where the initialization will be
 performed, and @var{outer-bound} is the list of bound variables there."
   (fold (lambda (free idx body)
-          (let-gensyms (k idxsym)
+          (let-fresh (k) (idxsym)
             (build-cps-term
               ($letk ((k ($kargs () () ,body)))
                 ,(convert-free-var
@@ -128,15 +128,20 @@ convert functions to flat closures."
        (values (build-cps-cont (sym ($kargs names syms ,body)))
                free)))
 
-    (($ $cont sym ($ $kentry self tail clauses))
-     (receive (clauses free) (cc* clauses self (list self))
-       (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
+    (($ $cont sym ($ $kentry self tail clause))
+     (receive (clause free) (if clause
+                                (cc clause self (list self))
+                                (values #f '()))
+       (values (build-cps-cont (sym ($kentry self ,tail ,clause)))
                free)))
 
-    (($ $cont sym ($ $kclause arity body))
+    (($ $cont sym ($ $kclause arity body alternate))
      (receive (body free) (cc body self bound)
-       (values (build-cps-cont (sym ($kclause ,arity ,body)))
-               free)))
+       (receive (alternate free*) (if alternate
+                                      (cc alternate self bound)
+                                      (values #f '()))
+         (values (build-cps-cont (sym ($kclause ,arity ,body ,alternate)))
+                 (union free free*)))))
 
     (($ $cont)
      ;; Other kinds of continuations don't bind values and don't have
@@ -157,7 +162,7 @@ convert functions to flat closures."
               (receive (fun-body fun-free) (cc fun-body #f '())
                 (lp in
                     (lambda (body)
-                      (let-gensyms (k)
+                      (let-fresh (k) ()
                         (build-cps-term
                           ($letk ((k ($kargs (name) (sym) ,(bindings body))))
                             ($continue k src
@@ -180,7 +185,7 @@ convert functions to flat closures."
                   free))
          (_
           (values
-           (let-gensyms (kinit v)
+           (let-fresh (kinit) (v)
              (build-cps-term
                ($letk ((kinit ($kargs (v) (v)
                                 ,(init-closure
@@ -241,7 +246,7 @@ convert functions to flat closures."
       (($ $letk conts body)
        ($letk ,(map visit-cont conts) ,(visit-term body)))
       (($ $continue k src ($ $primcall 'free-ref (closure sym)))
-       ,(let-gensyms (idx)
+       ,(let-fresh () (idx)
           (build-cps-term
             ($letconst (('idx idx (free-index sym)))
               ($continue k src ($primcall 'free-ref (closure idx)))))))
@@ -254,24 +259,26 @@ convert functions to flat closures."
     (rewrite-cps-cont cont
       (($ $cont sym ($ $kargs names syms body))
        (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kclause arity body))
-       (sym ($kclause ,arity ,(visit-cont body))))
+      (($ $cont sym ($ $kclause arity body alternate))
+       (sym ($kclause ,arity ,(visit-cont body)
+                      ,(and alternate (visit-cont alternate)))))
       ;; Other kinds of continuations don't bind values and don't have
       ;; bodies.
       (($ $cont)
        ,cont)))
 
   (rewrite-cps-cont body
-    (($ $cont sym ($ $kentry self tail clauses))
-     (sym ($kentry self ,tail ,(map visit-cont clauses))))))
+    (($ $cont sym ($ $kentry self tail clause))
+     (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))))
 
 (define (convert-closures exp)
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
-  (match exp
-    (($ $fun src meta () body)
-     (receive (body free) (cc body #f '())
-       (unless (null? free)
-         (error "Expected no free vars in toplevel thunk" exp body free))
-       (build-cps-exp
-         ($fun src meta free ,(convert-to-indices body free)))))))
+  (with-fresh-name-state exp
+    (match exp
+      (($ $fun src meta () body)
+       (receive (body free) (cc body #f '())
+         (unless (null? free)
+           (error "Expected no free vars in toplevel thunk" exp body free))
+         (build-cps-exp
+           ($fun src meta free ,(convert-to-indices body free))))))))