From 981802c4c228c9f662ebb22cefcbb241cf2b107b Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 15 Jul 2015 09:43:33 +0200
Subject: [PATCH] Wire up new closure conversion pass

* module/language/cps/compile-bytecode.scm (compile-bytecode): Only
  convert closures if the #:cps2-convert? option is not passed.

* module/language/cps2/compile-cps.scm (conts->fun*, compile-cps): Add
  support for CPS2 closure conversion, disabled by default.
---
 module/language/cps/compile-bytecode.scm |  4 +++-
 module/language/cps2/compile-cps.scm     | 27 ++++++++++++++++++++----
 2 files changed, 26 insertions(+), 5 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 86a3db733..b66b1a693 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -517,7 +517,9 @@
   ;;
   ;; (set! exp (optimize exp opts))
 
-  (set! exp (convert-closures exp))
+  (set! exp (if (not (kw-arg-ref opts #:cps2-convert? #f))
+                (convert-closures exp)
+                exp))
   ;; first-order optimization should go here
   (set! exp (reify-primitives exp))
   (set! exp (renumber exp))
diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm
index 4294f9463..da51d3536 100644
--- a/module/language/cps2/compile-cps.scm
+++ b/module/language/cps2/compile-cps.scm
@@ -27,6 +27,7 @@
   #:use-module (language cps2)
   #:use-module ((language cps) #:prefix cps:)
   #:use-module (language cps2 utils)
+  #:use-module (language cps2 closure-conversion)
   #:use-module (language cps2 optimize)
   #:use-module (language cps2 renumber)
   #:use-module (language cps intmap)
@@ -34,7 +35,7 @@
 
 ;; Precondition: For each function in CONTS, the continuation names are
 ;; topologically sorted.
-(define (conts->fun conts)
+(define* (conts->fun conts #:optional (kfun 0))
   (define (convert-fun kfun)
     (let ((doms (compute-dom-edges (compute-idoms conts kfun))))
       (define (visit-cont label)
@@ -97,8 +98,26 @@
         (($ $kfun src meta self tail clause)
          (kfun (cps:$kfun src meta self (tail (cps:$ktail))
                  ,(visit-clause clause)))))))
-  (convert-fun 0))
+  (convert-fun kfun))
+
+(define (conts->fun* conts)
+  (cps:build-cps-term
+   (cps:$program
+    ,(intmap-fold-right (lambda (label cont out)
+                          (match cont
+                            (($ $kfun)
+                             (cons (conts->fun conts label) out))
+                            (_ out)))
+                        conts
+                        '()))))
+
+(define (kw-arg-ref args kw default)
+  (match (memq kw args)
+    ((_ val . _) val)
+    (_ default)))
 
 (define (compile-cps exp env opts)
-  (let ((exp (renumber (optimize-higher-order-cps exp opts))))
-    (values (conts->fun exp) env env)))
+  (let ((exp (optimize-higher-order-cps exp opts)))
+    (if (kw-arg-ref opts #:cps2-convert? #f)
+        (values (conts->fun* (renumber (convert-closures exp))) env env)
+        (values (conts->fun (renumber exp)) env env))))