[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 3/9] Add closure conversion
From: |
Andy Wingo |
Subject: |
[PATCH 3/9] Add closure conversion |
Date: |
Thu, 29 Aug 2013 09:49:33 +0200 |
* module/Makefile.am
* module/language/cps/closure-conversion.scm: New module, implementing a
closure conversion pass.
---
module/Makefile.am | 1 +
module/language/cps/closure-conversion.scm | 273 +++++++++++++++++++++++++++++
2 files changed, 274 insertions(+)
create mode 100644 module/language/cps/closure-conversion.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index fea910f..6fd88e6 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 0000000..9a9738b
--- /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}.
+
address@hidden 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.
address@hidden 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
address@hidden, 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)))))))
--
1.8.3.2
- CPS language and Tree-IL->CPS->RTL compiler, Andy Wingo, 2013/08/29
- [PATCH 1/9] Add CPS language, Andy Wingo, 2013/08/29
- [PATCH 2/9] (compile foo #:to 'cps), Andy Wingo, 2013/08/29
- [PATCH 4/9] RTL language, Andy Wingo, 2013/08/29
- [PATCH 5/9] Add CPS primitives info module, Andy Wingo, 2013/08/29
- [PATCH 6/9] Add arity-adapting module, Andy Wingo, 2013/08/29
- [PATCH 3/9] Add closure conversion,
Andy Wingo <=
- [PATCH 7/9] Add pass to reify primcalls without corresponding VM ops, Andy Wingo, 2013/08/29
- [PATCH 8/9] Add CPS -> RTL compiler, Andy Wingo, 2013/08/29
- [PATCH 9/9] Add contification pass, Andy Wingo, 2013/08/29
- Re: CPS language and Tree-IL->CPS->RTL compiler, Ludovic Courtès, 2013/08/29
- Re: CPS language and Tree-IL->CPS->RTL compiler, Noah Lavine, 2013/08/29