Add closure conversion

* module/Makefile.am
* module/language/cps/closure-conversion.scm: New module, implementing a
  closure conversion pass.

2 files changed, 274 insertions, 0 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index fea910f5e..6fd88e68c 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -119,6 +119,7 @@ TREE_IL_LANG_SOURCES =						\
 
 CPS_LANG_SOURCES =						\
   language/cps.scm						\
+  language/cps/closure-conversion.scm				\
   language/cps/spec.scm						\
   language/cps/verify.scm
 
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
new file mode 100644
index 000000000..9a9738b4a
--- /dev/null
+++ b/module/language/cps/closure-conversion.scm
@@ -0,0 +1,273 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; This pass converts a CPS term in such a way that no function has any
+;;; free variables.  Instead, closures are built explicitly with
+;;; make-closure primcalls, and free variables are referenced through
+;;; the closure.
+;;;
+;;; Closure conversion also removes any $letrec forms that contification
+;;; did not handle.  See (language cps) for a further discussion of
+;;; $letrec.
+;;;
+;;; Code:
+
+(define-module (language cps closure-conversion)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (fold
+                                        lset-union lset-difference
+                                        list-index))
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-26)
+  #:use-module (language cps)
+  #:export (convert-closures))
+
+(define (union s1 s2)
+  (lset-union eq? s1 s2))
+
+(define (difference s1 s2)
+  (lset-difference eq? s1 s2))
+
+;; bound := sym ...
+;; free := sym ...
+
+(define (convert-free-var sym self bound k)
+  "Convert one possibly free variable reference to a bound reference.
+
+If @var{sym} is free (i.e., not present in @var{bound},), it is replaced
+by a closure reference via a @code{free-ref} primcall, and @var{k} is
+called with the new var.  Otherwise @var{sym} is bound, so @var{k} is
+called with @var{sym}.
+
+@var{k} should return two values: a term and a list of additional free
+values in the term."
+  (if (memq sym bound)
+      (k sym)
+      (let-gensyms (k* sym*)
+        (receive (exp free) (k sym*)
+          (values (build-cps-term
+                    ($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
+                      ($continue k* ($primcall 'free-ref (self sym)))))
+                  (cons sym free))))))
+  
+(define (convert-free-vars syms self bound k)
+  "Convert a number of possibly free references to bound references.
+@var{k} is called with the bound references, and should return two
+values: the term and a list of additional free variables in the term."
+  (match syms
+    (() (k '()))
+    ((sym . syms)
+     (convert-free-var sym self bound
+                       (lambda (sym)
+                         (convert-free-vars syms self bound
+                                            (lambda (syms)
+                                              (k (cons sym syms)))))))))
+  
+(define (init-closure src v free outer-self outer-bound body)
+  "Initialize the free variables @var{free} in a closure bound to
+@var{v}, and continue with @var{body}.  @var{outer-self} must be the
+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)
+            (build-cps-term
+              ($letk ((k src ($kargs () () ,body)))
+                ,(convert-free-var
+                  free outer-self outer-bound
+                  (lambda (free)
+                    (values (build-cps-term
+                              ($letconst (('idx idxsym idx))
+                                ($continue k
+                                  ($primcall 'free-set! (v idxsym free)))))
+                            '())))))))
+        body
+        free
+        (iota (length free))))
+
+(define (cc* exps self bound)
+  "Convert all free references in the list of expressions @var{exps} to
+bound references, and convert functions to flat closures.  Returns two
+values: the transformed list, and a cumulative set of free variables."
+  (let lp ((exps exps) (exps* '()) (free '()))
+    (match exps
+      (() (values (reverse exps*) free))
+      ((exp . exps)
+       (receive (exp* free*) (cc exp self bound)
+         (lp exps (cons exp* exps*) (union free free*)))))))
+
+;; Closure conversion.
+(define (cc exp self bound)
+  "Convert all free references in @var{exp} to bound references, and
+convert functions to flat closures."
+  (match exp
+    (($ $letk conts body)
+     (receive (conts free) (cc* conts self bound)
+       (receive (body free*) (cc body self bound)
+         (values (build-cps-term ($letk ,conts ,body))
+                 (union free free*)))))
+
+    (($ $cont sym src ($ $kargs names syms body))
+     (receive (body free) (cc body self (append syms bound))
+       (values (build-cps-cont (sym src ($kargs names syms ,body)))
+               free)))
+
+    (($ $cont sym src ($ $kentry self tail clauses))
+     (receive (clauses free) (cc* clauses self (list self))
+       (values (build-cps-cont (sym src ($kentry self ,tail ,clauses)))
+               free)))
+
+    (($ $cont sym src ($ $kclause arity body))
+     (receive (body free) (cc body self bound)
+       (values (build-cps-cont (sym src ($kclause ,arity ,body)))
+               free)))
+
+    (($ $cont)
+     ;; Other kinds of continuations don't bind values and don't have
+     ;; bodies.
+     (values exp '()))
+
+    ;; Remove letrec.
+    (($ $letrec names syms funs body)
+     (let ((bound (append bound syms)))
+       (receive (body free) (cc body self bound)
+         (let lp ((in (map list names syms funs))
+                  (bindings (lambda (body) body))
+                  (body body)
+                  (free free))
+           (match in
+             (() (values (bindings body) free))
+             (((name sym ($ $fun meta () fun-body)) . in)
+              (receive (fun-body fun-free) (cc fun-body #f '())
+                (lp in
+                    (lambda (body)
+                      (let-gensyms (k)
+                        (build-cps-term
+                          ($letk ((k #f ($kargs (name) (sym) ,(bindings body))))
+                            ($continue k
+                              ($fun meta fun-free ,fun-body))))))
+                    (init-closure #f sym fun-free self bound body)
+                    (union free (difference fun-free bound))))))))))
+
+    (($ $continue k ($ $var sym))
+     (convert-free-var sym self bound
+                       (lambda (sym)
+                         (values (build-cps-term ($continue k ($var sym)))
+                                 '()))))
+
+    (($ $continue k
+        (or ($ $void)
+            ($ $const)
+            ($ $prim)))
+     (values exp '()))
+
+    (($ $continue k ($ $fun meta () body))
+     (receive (body free) (cc body #f '())
+       (match free
+         (()
+          (values (build-cps-term
+                    ($continue k ($fun meta free ,body)))
+                  free))
+         (_
+          (values
+           (let-gensyms (kinit v)
+             (build-cps-term
+               ($letk ((kinit #f ($kargs (v) (v)
+                                   ,(init-closure #f v free self bound
+                                                  (build-cps-term
+                                                    ($continue k ($var v)))))))
+                 ($continue kinit ($fun meta free ,body)))))
+           (difference free bound))))))
+
+    (($ $continue k ($ $call proc args))
+     (convert-free-vars (cons proc args) self bound
+                        (match-lambda
+                         ((proc . args)
+                          (values (build-cps-term
+                                    ($continue k ($call proc args)))
+                                  '())))))
+
+    (($ $continue k ($ $primcall name args))
+     (convert-free-vars args self bound
+                        (lambda (args)
+                          (values (build-cps-term
+                                    ($continue k ($primcall name args)))
+                                  '()))))
+
+    (($ $continue k ($ $values args))
+     (convert-free-vars args self bound
+                        (lambda (args)
+                          (values (build-cps-term
+                                    ($continue k ($values args)))
+                                  '()))))
+
+    (($ $continue k ($ $prompt escape? tag handler))
+     (convert-free-var
+      tag self bound
+      (lambda (tag)
+        (values (build-cps-term
+                  ($continue k ($prompt escape? tag handler)))
+                '()))))
+
+    (_ (error "what" exp))))
+
+;; Convert the slot arguments of 'free-ref' primcalls from symbols to
+;; indices.
+(define (convert-to-indices body free)
+  (define (free-index sym)
+    (or (list-index (cut eq? <> sym) free)
+        (error "free variable not found!" sym free)))
+  (define (visit-term term)
+    (rewrite-cps-term term
+      (($ $letk conts body)
+       ($letk ,(map visit-cont conts) ,(visit-term body)))
+      (($ $continue k ($ $primcall 'free-ref (closure sym)))
+       ,(let-gensyms (idx)
+          (build-cps-term
+            ($letconst (('idx idx (free-index sym)))
+              ($continue k ($primcall 'free-ref (closure idx)))))))
+      (($ $continue k ($ $fun meta free body))
+       ($continue k ($fun meta free ,(convert-to-indices body free))))
+      (($ $continue)
+       ,term)))
+  (define (visit-cont cont)
+    (rewrite-cps-cont cont
+      (($ $cont sym src ($ $kargs names syms body))
+       (sym src ($kargs names syms ,(visit-term body))))
+      (($ $cont sym src ($ $kclause arity body))
+       (sym src ($kclause ,arity ,(visit-cont body))))
+      ;; Other kinds of continuations don't bind values and don't have
+      ;; bodies.
+      (($ $cont)
+       ,cont)))
+
+  (rewrite-cps-cont body
+    (($ $cont sym src ($ $kentry self tail clauses))
+     (sym src ($kentry self ,tail ,(map visit-cont clauses))))))
+
+(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 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 meta free ,(convert-to-indices body free)))))))