Test Closure Conversion

* test-suite/tests/cps-closure-conversion.test: test closure conversion.
* module/language/cps/closure-conversion.scm: some bug fixes.

2 files changed, 207 insertions, 28 deletions

diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 9cba8d23c..f3053a4c1 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -93,35 +93,70 @@
             env)))))
 
       ((<letrec> names funcs body)
-       ;; with a letrec, we need to run the primitive make-closure (and
-       ;; maybe later fix-closure too) to generate the procedures, and
-       ;; then run the body of the letrec in an environment with the
-       ;; procedures available. so we actually don't use the letrec
-       ;; machinery - we replace the letrec names with dummies and turn
-       ;; the letrec names into arguments of make-closure's
-       ;; continuation. this is really ugly.
-       (let* ((func (car funcs))
-              (closure-env (alloc-closure-vals
-                            (free-vals func)))
-              (new-names (map (lambda (n) (gensym "dummy-")) names)))
+       (let* ((closure-envs
+               ;; we make the names the prefix of all of the closure
+               ;; name lists so that the closed-over functions will be
+               ;; able to refer to each other.
+               (map (lambda (func) (alloc-closure-vals
+                                    (append
+                                     names
+                                     (free-vals func))))
+                    funcs))
+              (dummies (map (lambda (n) (gensym "dummy-")) names))
+              (unspec-name (gensym "unspec-")))
          (make-letrec
-          new-names
-          (list (visit func closure-env))
-          (let ((con (gensym "con-")))
-            ;; first make the closure, then run the body of the letrec.
-            ;; Note: we only allow a single closure in the letrec right
-            ;; now.
-            (make-letcont
-             (list con)
-             (list (make-lambda
-                    names #f (visit body env)))
-             (make-call
-              (make-primitive 'make-closure)
-              con
-              ;; the first argument of a make-closure call is special.
-              (cons (car new-names)
-                    (free-vals func))))))))
-
+          ;; after closure conversion, lambda objects don't have lexical
+          ;; environments. the "dummies" refer to the new lambda
+          ;; objects, and the names from the original letrec will refer
+          ;; to the new closure objects.
+          dummies
+          (map (lambda (func env)
+                 (visit func env))
+               funcs closure-envs)
+          ;; we need a dummy value to put in closures before we call
+          ;; fix-closure. we use *unspecified*.
+          (make-letval
+           (list unspec-name)
+           (list (make-const *unspecified*))
+           ;; iterate over the list of functions, generating a
+           ;; make-closure call for each one
+           (let iter ((funcs-tail funcs)
+                      (dummies-tail dummies)
+                      (names-tail names))
+             (if (not (null? funcs-tail))
+                 (let ((con (gensym "con-")))
+                   (make-letcont
+                    (list con)
+                    (list (make-lambda
+                           (list (car names-tail)) #f
+                           (iter (cdr funcs-tail)
+                                 (cdr dummies-tail)
+                                 (cdr names-tail))))
+                    (make-call
+                     (make-primitive 'make-closure)
+                     con
+                     (cons (car dummies-tail)
+                           (append (map (lambda (n) unspec-name) names)
+                                   (free-vals (car funcs-tail)))))))
+                 ;; we always fix up the closure even if there's only
+                 ;; one function, because it might refer to itself.
+                 (let iter ((funcs-tail funcs)
+                            (names-tail names))
+                   (let ((con (gensym "con-")))
+                     (make-letcont
+                      (list con)
+                      (list (make-lambda
+                             '() #f
+                             (if (not (null? (cdr funcs-tail)))
+                                 (iter (cdr funcs-tail)
+                                       (cdr names-tail))
+                                 (visit body env))))
+                      (make-call
+                       (make-primitive 'fix-closure)
+                       con
+                       (cons (car names-tail)
+                             names)))))))))))
+                                
       ((<letcont> names conts body)
        (make-letcont
         names
diff --git a/test-suite/tests/cps-closure-conversion.test b/test-suite/tests/cps-closure-conversion.test
new file mode 100644
index 000000000..b5cb86c19
--- /dev/null
+++ b/test-suite/tests/cps-closure-conversion.test
@@ -0,0 +1,144 @@
+(use-modules
+ (test-suite lib)
+ (language cps)
+ (language cps compile-rtl)
+ (language cps closure-conversion)
+ (language cps cps-isomorphic))
+
+(define (cc cps)
+  (closure-convert cps (calculate-free-values cps)))
+
+(pass-if "call"
+  (cps-isomorphic?
+   (cc (parse-cps '(lambda (x) #f
+                     (letrec
+                       (func)
+                       ((lambda () #f (call return #f (x))))
+                       (call return #f (func))))))
+   (parse-cps
+    `(lambda (x) #f
+       (letrec
+         (func)
+         ((lambda () #f
+            (letval (n) ((const 1))
+              (letcont (ref-k)
+                       ((lambda (x-val) #f
+                          (call return #f (x-val))))
+                (call (primitive closure-ref) ref-k (n))))))
+         (letval (unspec) ((const ,*unspecified*))
+           (letcont
+            (closure-k)
+            ((lambda (cl) #f
+              (letcont
+               (fixed-k)
+               ((lambda () #f (call return #f (cl))))
+               (call (primitive fix-closure) fixed-k (cl cl)))))
+            (call (primitive make-closure) closure-k (func unspec x)))))))))
+
+(pass-if "letval"
+  (cps-isomorphic?
+   (cc (parse-cps '(lambda (x) #f
+                     (letrec
+                       (func)
+                       ((lambda () #f
+                          (letval (x-var) ((var x))
+                            (call return #f (x-var)))))
+                     (call return #f (func))))))
+   (parse-cps
+    `(lambda (x) #f
+       (letrec
+         (func)
+         ((lambda () #f
+            (letval (n) ((const 1))
+              (letcont
+                (ref-k)
+                ((lambda (val) #f
+                   (letval (x-var) ((var val))
+                     (call return #f (x-var)))))
+               (call (primitive closure-ref) ref-k (n))))))
+         (letval
+          (unspec)
+          ((const ,*unspecified*))
+          (letcont
+           (closure-k)
+           ((lambda (cl) #f
+             (letcont
+              (fixed-k)
+              ((lambda () #f
+                (call return #f (cl))))
+              (call (primitive fix-closure) fixed-k (cl cl)))))
+           (call (primitive make-closure) closure-k (func unspec x)))))))))
+
+(pass-if "letrec"
+  (cps-isomorphic?
+   (cc (parse-cps '(lambda (x) #f
+                           (letval (x-var) ((var x))
+                                   (letrec
+                                       (get set)
+                                     ((lambda () #f
+                                              (call (primitive ref) return (x-var)))
+                                      (lambda (val) #f
+                                              (call (primitive set) return (x-var val))))
+                                     (letval (values-var)
+                                             ((module-var toplevel values #t))
+                                             (letcont
+                                              (values-k)
+                                              ((lambda (values) #f
+                                                       (call values return (get set))))
+                                              (call (primitive ref) values-k (values-var)))))))))
+   (parse-cps
+    `(lambda (x) #f
+             (letval (x-var) ((var x))
+                     (letrec
+                         (get-code set-code)
+                       ((lambda () #f
+                                (letval (idx-0) ((const 2))
+                                        (letcont
+                                         (do-get)
+                                         ((lambda (closure-var) #f
+                                                  (call (primitive ref) return (closure-var))))
+                                         (call (primitive closure-ref) do-get (idx-0)))))
+                        (lambda (new-val) #f
+                                (letval (idx-0) ((const 2))
+                                        (letcont
+                                         (do-set)
+                                         ((lambda (closure-var) #f
+                                                  (call (primitive set) return (closure-var new-val))))
+                                         (call (primitive closure-ref) do-set (idx-0))))))
+
+                       (letval
+                        (unspec-name)
+                        ((const ,*unspecified*))
+                        (letcont
+                         (get-closure)
+                         ((lambda (get-c) #f
+                                  (letcont
+                                   (set-closure)
+                                   ((lambda (set-c) #f
+                                            (letcont
+                                             (fixed-get)
+                                             ((lambda () #f
+                                                      (letcont
+                                                       (fixed-set)
+                                                       ((lambda () #f
+                                                                (letval (values-var)
+                                                                        ((module-var toplevel values #t))
+                                                                        (letcont
+                                                                         (values-k)
+                                                                         ((lambda (values) #f
+                                                                                  (call values return (get-c set-c))))
+                                                                         (call (primitive ref) values-k (values-var))))))
+                                                       (call (primitive fix-closure)
+                                                             fixed-set
+                                                             (set-c get-c set-c)))))
+                                             (call (primitive fix-closure)
+                                                   fixed-get
+                                                   (get-c get-c set-c)))))
+                                   (call (primitive make-closure)
+                                         set-closure
+                                         (set-code unspec-name unspec-name
+                                                   x-var)))))
+                         (call (primitive make-closure)
+                               get-closure
+                               (get-code unspec-name unspec-name
+                                         x-var))))))))))