[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 08/09: Add CPS2 closure conversion module
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 08/09: Add CPS2 closure conversion module |
|
Date: |
Wed, 15 Jul 2015 07:51:42 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 285f62a07798293b328c1989dba846a4bd1b2609
Author: Andy Wingo <address@hidden>
Date: Mon Jul 13 11:03:53 2015 +0200
Add CPS2 closure conversion module
* module/language/cps2/closure-conversion.scm: New module.
* module/Makefile.am: Add new file.
---
module/Makefile.am | 3 +-
module/language/cps2/closure-conversion.scm | 828 +++++++++++++++++++++++++++
2 files changed, 830 insertions(+), 1 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index 88b84a1..270699b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -148,10 +148,11 @@ CPS_LANG_SOURCES =
\
CPS2_LANG_SOURCES = \
language/cps2.scm \
- language/cps2/cse.scm \
+ language/cps2/closure-conversion.scm \
language/cps2/compile-cps.scm \
language/cps2/constructors.scm \
language/cps2/contification.scm \
+ language/cps2/cse.scm \
language/cps2/dce.scm \
language/cps2/effects-analysis.scm \
language/cps2/elide-values.scm \
diff --git a/module/language/cps2/closure-conversion.scm
b/module/language/cps2/closure-conversion.scm
new file mode 100644
index 0000000..2d20919
--- /dev/null
+++ b/module/language/cps2/closure-conversion.scm
@@ -0,0 +1,828 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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 $rec expressions that
+;;; contification did not handle. See (language cps) for a further
+;;; discussion of $rec.
+;;;
+;;; Code:
+
+(define-module (language cps2 closure-conversion)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold
+ filter-map
+ ))
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps2)
+ #:use-module (language cps2 utils)
+ #:use-module (language cps2 with-cps)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:export (convert-closures))
+
+(define (compute-function-bodies conts kfun)
+ "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in
+conts."
+ (let visit-fun ((kfun kfun) (out empty-intmap))
+ (let ((body (compute-function-body conts kfun)))
+ (intset-fold
+ (lambda (label out)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
+ (visit-fun kfun out))
+ (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
+ (fold visit-fun out kfun))
+ (_ out)))
+ body
+ (intmap-add out kfun body)))))
+
+(define (compute-program-body functions)
+ (intmap-fold (lambda (label body out) (intset-union body out))
+ functions
+ empty-intset))
+
+(define (filter-reachable conts functions)
+ (let ((reachable (compute-program-body functions)))
+ (intmap-fold
+ (lambda (label cont out)
+ (if (intset-ref reachable label)
+ out
+ (intmap-remove out label)))
+ conts conts)))
+
+(define (compute-non-operator-uses conts)
+ (persistent-intset
+ (intmap-fold
+ (lambda (label cont uses)
+ (define (add-use var uses) (intset-add! uses var))
+ (define (add-uses vars uses)
+ (match vars
+ (() uses)
+ ((var . vars) (add-uses vars (add-use var uses)))))
+ (match cont
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses)
+ (($ $values args)
+ (add-uses args uses))
+ (($ $call proc args)
+ (add-uses args uses))
+ (($ $branch kt ($ $values (arg)))
+ (add-use arg uses))
+ (($ $branch kt ($ $primcall name args))
+ (add-uses args uses))
+ (($ $primcall name args)
+ (add-uses args uses))
+ (($ $prompt escape? tag handler)
+ (add-use tag uses))))
+ (_ uses)))
+ conts
+ empty-intset)))
+
+(define (compute-singly-referenced-labels conts body)
+ (define (add-ref label single multiple)
+ (define (ref k single multiple)
+ (if (intset-ref single k)
+ (values single (intset-add! multiple k))
+ (values (intset-add! single k) multiple)))
+ (define (ref0) (values single multiple))
+ (define (ref1 k) (ref k single multiple))
+ (define (ref2 k k*)
+ (if k*
+ (let-values (((single multiple) (ref k single multiple)))
+ (ref k* single multiple))
+ (ref1 k)))
+ (match (intmap-ref conts label)
+ (($ $kreceive arity k) (ref1 k))
+ (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
+ (($ $ktail) (ref0))
+ (($ $kclause arity kbody kalt) (ref2 kbody kalt))
+ (($ $kargs names syms ($ $continue k src exp))
+ (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
+ (let*-values (((single multiple) (values empty-intset empty-intset))
+ ((single multiple) (intset-fold add-ref body single multiple)))
+ (intset-subtract (persistent-intset single)
+ (persistent-intset multiple))))
+
+(define (compute-function-names conts functions)
+ "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
+whose bound vars we know."
+ (define (add-named-fun var kfun out)
+ (let ((self (match (intmap-ref conts kfun)
+ (($ $kfun src meta self) self))))
+ (intmap-add out kfun (intset var self))))
+ (intmap-fold
+ (lambda (label body out)
+ (let ((single (compute-singly-referenced-labels conts body)))
+ (intset-fold
+ (lambda (label out)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
+ (if (intset-ref single k)
+ (match (intmap-ref conts k)
+ (($ $kargs (_) (var)) (add-named-fun var kfun out))
+ (_ out))
+ out))
+ (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun)
...))))
+ (unless (intset-ref single k)
+ (error "$rec continuation has multiple predecessors??"))
+ (fold add-named-fun out vars kfun))
+ (_ out)))
+ body
+ out)))
+ functions
+ empty-intmap))
+
+(define (compute-well-known-functions conts bound->label)
+ "Compute a set of labels indicating the well-known functions in
address@hidden A well-known function is a function whose bound names we
+know and which is never used in a non-operator position."
+ (intset-subtract
+ (persistent-intset
+ (intmap-fold (lambda (bound label candidates)
+ (intset-add! candidates label))
+ bound->label
+ empty-intset))
+ (persistent-intset
+ (intset-fold (lambda (var not-well-known)
+ (match (intmap-ref bound->label var (lambda (_) #f))
+ (#f not-well-known)
+ (label (intset-add! not-well-known label))))
+ (compute-non-operator-uses conts)
+ empty-intset))))
+
+(define (intset-cons i set)
+ (intset-add set i))
+
+(define (compute-shared-closures conts well-known)
+ "Compute a map LABEL->VAR indicating the sets of functions that will
+share a closure. If a functions's label is in the map, it is shared.
+The entries indicate the var of the shared closure, which will be one of
+the bound vars of the closure."
+ (intmap-fold
+ (lambda (label cont out)
+ (match cont
+ (($ $kargs _ _
+ ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...))))
+ ;; The split-rec pass should have ensured that this $rec forms a
+ ;; strongly-connected component, so the free variables from all of
+ ;; the functions will be alive as long as one of the closures is
+ ;; alive. For that reason we can consider storing all free
+ ;; variables in one closure and sharing it.
+ (let* ((kfuns-set (fold intset-cons empty-intset kfuns))
+ (unknown-kfuns (intset-subtract kfuns-set well-known)))
+ (cond
+ ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set))
+ ;; There is only zero or one function bound here. Trivially
+ ;; shared already.
+ out)
+ ((eq? empty-intset unknown-kfuns)
+ ;; All functions are well-known; we can share a closure. Use
+ ;; the first bound variable.
+ (pk 'all-well-known kfuns)
+ (let ((closure (car vars)))
+ (intset-fold (lambda (kfun out)
+ (intmap-add out kfun closure))
+ kfuns-set out)))
+ ((trivial-intset unknown-kfuns)
+ => (lambda (unknown-kfun)
+ ;; Only one function is not-well-known. Use that
+ ;; function's closure as the shared closure.
+ (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun)))
+ (pk 'one-not-well-known kfuns closure)
+ (intset-fold (lambda (kfun out)
+ (intmap-add out kfun closure))
+ kfuns-set out))))
+ (else
+ ;; More than one not-well-known function means we need more
+ ;; than one proper closure, so we can't share.
+ out))))
+ (_ out)))
+ conts
+ empty-intmap))
+
+(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun)
+ "Rewrite CPS such that every call to a function with a shared closure
+instead is a $callk to that label, but passing the shared closure as the
+proc argument. For recursive calls, use the appropriate 'self'
+variable, if possible. Also rewrite uses of the non-well-known but
+shared closures to use the appropriate 'self' variable, if possible."
+ ;; env := var -> (var . label)
+ (define (rewrite-fun kfun cps env)
+ (define (subst var)
+ (match (intmap-ref env var (lambda (_) #f))
+ (#f var)
+ ((var . label) var)))
+
+ (define (rename-exp label cps names vars k src exp)
+ (intmap-replace!
+ cps label
+ (build-cont
+ ($kargs names vars
+ ($continue k src
+ ,(rewrite-exp exp
+ ((or ($ $const) ($ $prim)) ,exp)
+ (($ $call proc args)
+ ,(let ((args (map subst args)))
+ (rewrite-exp (intmap-ref env proc (lambda (_) #f))
+ (#f ($call proc ,args))
+ ((closure . label) ($callk label closure ,args)))))
+ (($ $primcall name args)
+ ($primcall name ,(map subst args)))
+ (($ $branch k ($ $values (arg)))
+ ($branch k ($values ((subst arg)))))
+ (($ $branch k ($ $primcall name args))
+ ($branch k ($primcall name ,(map subst args))))
+ (($ $values args)
+ ($values ,(map subst args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst tag) handler))))))))
+
+ (define (visit-exp label cps names vars k src exp)
+ (define (compute-env label bound self rec-bound env)
+ (define (add-bound-var bound env)
+ (intmap-add env bound (cons self label) (lambda (old new) new)))
+ (if (intmap-ref shared label (lambda (_) #f))
+ ;; Within a function with a shared closure, rewrite
+ ;; references to bound vars to use the "self" var.
+ (fold add-bound-var env rec-bound)
+ ;; Otherwise be sure to use "self" references in any
+ ;; closure.
+ (add-bound-var bound env)))
+ (match exp
+ (($ $fun label)
+ (rewrite-fun label cps env))
+ (($ $rec names vars (($ $fun labels) ...))
+ (fold (lambda (label var cps)
+ (match (intmap-ref cps label)
+ (($ $kfun src meta self)
+ (rewrite-fun label cps
+ (compute-env label var self vars env)))))
+ cps labels vars))
+ (_ (rename-exp label cps names vars k src exp))))
+
+ (define (rewrite-cont label cps)
+ (match (intmap-ref cps label)
+ (($ $kargs names vars ($ $continue k src exp))
+ (visit-exp label cps names vars k src exp))
+ (_ cps)))
+
+ (intset-fold rewrite-cont (intmap-ref functions kfun) cps))
+
+ ;; Initial environment is bound-var -> (shared-var . label) map for
+ ;; functions with shared closures.
+ (let ((env (intmap-fold (lambda (label shared env)
+ (intset-fold (lambda (bound env)
+ (intmap-add env bound
+ (cons shared label)))
+ (intset-remove
+ (intmap-ref label->bound label)
+ (match (intmap-ref cps label)
+ (($ $kfun src meta self) self)))
+ env))
+ shared
+ empty-intmap)))
+ (persistent-intmap (rewrite-fun kfun cps env))))
+
+(define (compute-free-vars conts kfun shared)
+ "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
+references."
+ (define (add-def var defs) (intset-add! defs var))
+ (define (add-defs vars defs)
+ (match vars
+ (() defs)
+ ((var . vars) (add-defs vars (add-def var defs)))))
+ (define (add-use var uses)
+ (intset-add! uses var))
+ (define (add-uses vars uses)
+ (match vars
+ (() uses)
+ ((var . vars) (add-uses vars (add-use var uses)))))
+ (define (visit-nested-funs body)
+ (intset-fold
+ (lambda (label out)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue _ _
+ ($ $fun kfun)))
+ (intmap-union out (visit-fun kfun)))
+ (($ $kargs _ _ ($ $continue _ _
+ ($ $rec _ _ (($ $fun labels) ...))))
+ (let* ((out (fold (lambda (kfun out)
+ (intmap-union out (visit-fun kfun)))
+ out labels))
+ (free (fold (lambda (kfun free)
+ (intset-union free (intmap-ref out kfun)))
+ empty-intset labels)))
+ (fold (lambda (kfun out)
+ ;; For functions that share a closure, the free
+ ;; variables for one will be the union of the free
+ ;; variables for all.
+ (if (intmap-ref shared kfun (lambda (_) #f))
+ (intmap-replace out kfun free)
+ out))
+ out
+ labels)))
+ (_ out)))
+ body
+ empty-intmap))
+ (define (visit-fun kfun)
+ (let* ((body (compute-function-body conts kfun))
+ (free (visit-nested-funs body)))
+ (call-with-values
+ (lambda ()
+ (intset-fold
+ (lambda (label defs uses)
+ (match (intmap-ref conts label)
+ (($ $kargs names vars ($ $continue k src exp))
+ (values
+ (add-defs vars defs)
+ (match exp
+ ((or ($ $const) ($ $prim)) uses)
+ (($ $fun kfun)
+ (intset-union (persistent-intset uses)
+ (intmap-ref free kfun)))
+ (($ $rec names vars (($ $fun kfun) ...))
+ (fold (lambda (kfun uses)
+ (intset-union (persistent-intset uses)
+ (intmap-ref free kfun)))
+ uses kfun))
+ (($ $values args)
+ (add-uses args uses))
+ (($ $call proc args)
+ (add-use proc (add-uses args uses)))
+ (($ $callk label proc args)
+ (add-use proc (add-uses args uses)))
+ (($ $branch kt ($ $values (arg)))
+ (add-use arg uses))
+ (($ $branch kt ($ $primcall name args))
+ (add-uses args uses))
+ (($ $primcall name args)
+ (add-uses args uses))
+ (($ $prompt escape? tag handler)
+ (add-use tag uses)))))
+ (($ $kfun src meta self)
+ (values (add-def self defs) uses))
+ (_ (values defs uses))))
+ body empty-intset empty-intset))
+ (lambda (defs uses)
+ (intmap-add free kfun (intset-subtract
+ (persistent-intset uses)
+ (persistent-intset defs)))))))
+ (visit-fun kfun))
+
+(define (eliminate-closure? label free-vars)
+ (eq? (intmap-ref free-vars label) empty-intset))
+
+(define (closure-alias label well-known free-vars)
+ (and (intset-ref well-known label)
+ (trivial-intset (intmap-ref free-vars label))))
+
+(define (prune-free-vars free-vars bound->label well-known)
+ "Given the label->bound-var map @var{free-vars}, remove free variables
+that are well-known functions with zero free variables, and replace
+references to well-known functions with one free variable with that free
+variable, until we reach a fixed point on the free-vars map."
+ (define (prune-free in-label free free-vars)
+ (intset-fold (lambda (var free)
+ (match (intmap-ref bound->label var (lambda (_) #f))
+ (#f free)
+ (label
+ (cond
+ ((eliminate-closure? label free-vars)
+ (intset-remove free var))
+ ((closure-alias label well-known free-vars)
+ => (lambda (alias)
+ ;; If VAR is free in LABEL, then ALIAS must
+ ;; also be free because its definition must
+ ;; precede VAR's definition.
+ (intset-add (intset-remove free var) alias)))
+ (else free)))))
+ free free))
+ (fixpoint (lambda (free-vars)
+ (intmap-fold (lambda (label free free-vars)
+ (intmap-replace free-vars label
+ (prune-free label free
free-vars)))
+ free-vars
+ free-vars))
+ free-vars))
+
+(define (intset-find set i)
+ (let lp ((idx 0) (start #f))
+ (let ((start (intset-next set start)))
+ (cond
+ ((not start) (error "not found" set i))
+ ((= start i) idx)
+ (else (lp (1+ idx) (1+ start)))))))
+
+(define (intmap-select map set)
+ (persistent-intmap
+ (intmap-fold
+ (lambda (k v out)
+ (if (intset-ref set k)
+ (intmap-add! out k v)
+ out))
+ map
+ empty-intmap)))
+
+(define (intset-count set)
+ (intset-fold (lambda (_ count) (1+ count)) set 0))
+
+(define (convert-one cps label body free-vars bound->label well-known shared)
+ (define (well-known? label)
+ (intset-ref well-known label))
+
+ (let* ((free (intmap-ref free-vars label))
+ (nfree (intset-count free))
+ (self-known? (well-known? label))
+ (self (match (intmap-ref cps label) (($ $kfun _ _ self) self))))
+ (define (convert-arg cps var k)
+ "Convert one possibly free variable reference to a bound reference.
+
+If @var{var} is free, it is replaced by a closure reference via a
address@hidden primcall, and @var{k} is called with the new var.
+Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
+ ;; We know that var is not the name of a well-known function.
+ (cond
+ ((and=> (intmap-ref bound->label var (lambda (_) #f))
+ (lambda (kfun)
+ (and (eq? empty-intset (intmap-ref free-vars kfun))
+ kfun)))
+ ;; A not-well-known function with zero free vars. Copy as a
+ ;; constant, relying on the linker to reify just one copy.
+ => (lambda (kfun)
+ (with-cps cps
+ (letv var*)
+ (let$ body (k var*))
+ (letk k* ($kargs (#f) (var*) ,body))
+ (build-term ($continue k* #f ($closure kfun 0))))))
+ ((intset-ref free var)
+ (match (vector self-known? nfree)
+ (#(#t 1)
+ ;; A reference to the one free var of a well-known function.
+ (with-cps cps
+ ($ (k self))))
+ (#(#t 2)
+ ;; A reference to one of the two free vars in a well-known
+ ;; function.
+ (let ((op (if (= var (intset-next free)) 'car 'cdr)))
+ (with-cps cps
+ (letv var*)
+ (let$ body (k var*))
+ (letk k* ($kargs (#f) (var*) ,body))
+ (build-term ($continue k* #f ($primcall op (self)))))))
+ (_
+ (let* ((idx (intset-find free var))
+ (op (cond
+ ((not self-known?) 'free-ref)
+ ((<= idx #xff) 'vector-ref/immediate)
+ (else 'vector-ref))))
+ (with-cps cps
+ (letv var*)
+ (let$ body (k var*))
+ (letk k* ($kargs (#f) (var*) ,body))
+ ($ (with-cps-constants ((idx idx))
+ (build-term
+ ($continue k* #f ($primcall op (self idx)))))))))))
+ (else
+ (with-cps cps
+ ($ (k var))))))
+
+ (define (convert-args cps vars k)
+ "Convert a number of possibly free references to bound references.
address@hidden is called with the bound references, and should return the
+term."
+ (match vars
+ (()
+ (with-cps cps
+ ($ (k '()))))
+ ((var . vars)
+ (convert-arg cps var
+ (lambda (cps var)
+ (convert-args cps vars
+ (lambda (cps vars)
+ (with-cps cps
+ ($ (k (cons var vars)))))))))))
+
+ (define (allocate-closure cps k src label known? nfree)
+ "Allocate a new closure, and pass it to $var{k}."
+ (match (vector known? nfree)
+ (#(#f nfree)
+ ;; The call sites cannot be enumerated; allocate a closure.
+ (with-cps cps
+ (build-term ($continue k src ($closure label nfree)))))
+ (#(#t 2)
+ ;; Well-known closure with two free variables; the closure is a
+ ;; pair.
+ (with-cps cps
+ ($ (with-cps-constants ((false #f))
+ (build-term
+ ($continue k src ($primcall 'cons (false false))))))))
+ ;; Well-known callee with more than two free variables; the closure
+ ;; is a vector.
+ (#(#t nfree)
+ (unless (> nfree 2)
+ (error "unexpected well-known nullary, unary, or binary closure"))
+ (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector)))
+ (with-cps cps
+ ($ (with-cps-constants ((nfree nfree)
+ (false #f))
+ (build-term
+ ($continue k src ($primcall op (nfree false)))))))))))
+
+ (define (init-closure cps k src var known? free)
+ "Initialize the free variables @var{closure-free} in a closure
+bound to @var{var}, and continue to @var{k}."
+ (match (vector known? (intset-count free))
+ ;; Well-known callee with zero or one free variables; no
+ ;; initialization necessary.
+ (#(#t (or 0 1))
+ (with-cps cps
+ (build-term ($continue k src ($values ())))))
+ ;; Well-known callee with two free variables; do a set-car! and
+ ;; set-cdr!.
+ (#(#t 2)
+ (let* ((free0 (intset-next free))
+ (free1 (intset-next free (1+ free0))))
+ (convert-arg cps free0
+ (lambda (cps v0)
+ (with-cps cps
+ (let$ body
+ (convert-arg free1
+ (lambda (cps v1)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'set-cdr! (var v1))))))))
+ (letk kcdr ($kargs () () ,body))
+ (build-term
+ ($continue kcdr src ($primcall 'set-car! (var v0)))))))))
+ ;; Otherwise residualize a sequence of vector-set! or free-set!,
+ ;; depending on whether the callee is well-known or not.
+ (_
+ (let lp ((cps cps) (prev #f) (idx 0))
+ (match (intset-next free prev)
+ (#f (with-cps cps
+ (build-term ($continue k src ($values ())))))
+ (v (with-cps cps
+ (let$ body (lp (1+ v) (1+ idx)))
+ (letk k ($kargs () () ,body))
+ ($ (convert-arg v
+ (lambda (cps v)
+ (with-cps cps
+ ($ (with-cps-constants ((idx idx))
+ (let ((op (cond
+ ((not known?) 'free-set!)
+ ((<= idx #xff)
'vector-set!/immediate)
+ (else 'vector-set!))))
+ (build-term
+ ($continue k src
+ ($primcall op (var idx
v))))))))))))))))))
+
+ (define (make-single-closure cps k src kfun)
+ (let ((free (intmap-ref free-vars kfun)))
+ (match (vector (well-known? kfun) (intset-count free))
+ (#(#f 0)
+ (with-cps cps
+ (build-term ($continue k src ($closure kfun 0)))))
+ (#(#t 0)
+ (with-cps cps
+ (build-term ($continue k src ($const #f)))))
+ (#(#t 1)
+ ;; A well-known closure of one free variable is replaced
+ ;; at each use with the free variable itself, so we don't
+ ;; need a binding at all; and yet, the continuation
+ ;; expects one value, so give it something. DCE should
+ ;; clean up later.
+ (with-cps cps
+ (build-term ($continue k src ($const #f)))))
+ (#(well-known? nfree)
+ ;; A bit of a mess, but beta conversion should remove the
+ ;; final $values if possible.
+ (with-cps cps
+ (letv closure)
+ (letk k* ($kargs () () ($continue k src ($values (closure)))))
+ (let$ init (init-closure k* src closure well-known? free))
+ (letk knew ($kargs (#f) (closure) ,init))
+ ($ (allocate-closure knew src kfun well-known? nfree)))))))
+
+ ;; The callee is known, but not necessarily well-known.
+ (define (convert-known-proc-call cps k src label closure args)
+ (define (have-closure cps closure)
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src ($callk label closure args)))))))
+ (cond
+ ((eq? (intmap-ref free-vars label) empty-intset)
+ ;; Known call, no free variables; no closure needed.
+ ;; Pass #f as closure argument.
+ (with-cps cps
+ ($ (with-cps-constants ((false #f))
+ ($ (have-closure false))))))
+ ((and (well-known? label)
+ (trivial-intset (intmap-ref free-vars label)))
+ ;; Well-known closures with one free variable are
+ ;; replaced at their use sites by uses of the one free
+ ;; variable.
+ => (lambda (var)
+ (convert-arg cps var have-closure)))
+ (else
+ ;; Otherwise just load the proc.
+ (convert-arg cps closure have-closure))))
+
+ (define (visit-term cps term)
+ (match term
+ (($ $continue k src (or ($ $const) ($ $prim)))
+ (with-cps cps
+ term))
+
+ (($ $continue k src ($ $fun kfun))
+ (with-cps cps
+ ($ (make-single-closure k src kfun))))
+
+ ;; Remove letrec.
+ (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))
+ (match (vector names vars kfuns)
+ (#(() () ())
+ ;; Trivial empty case.
+ (with-cps cps
+ (build-term ($continue k src ($values ())))))
+ (#((name) (var) (kfun))
+ ;; Trivial single case. We have already proven that K has
+ ;; only LABEL as its predecessor, so we have been able
+ ;; already to rewrite free references to the bound name with
+ ;; the self name.
+ (with-cps cps
+ ($ (make-single-closure k src kfun))))
+ (#(_ _ (kfun0 . _))
+ ;; A non-trivial strongly-connected component. Does it have
+ ;; a shared closure?
+ (match (intmap-ref shared kfun0 (lambda (_) #f))
+ (#f
+ ;; Nope. Allocate closures for each function.
+ (let lp ((cps (match (intmap-ref cps k)
+ ;; Steal declarations from the continuation.
+ (($ $kargs names vals body)
+ (intmap-replace cps k
+ (build-cont
+ ($kargs () () ,body))))))
+ (in (map vector names vars kfuns))
+ (init (lambda (cps)
+ (with-cps cps
+ (build-term
+ ($continue k src ($values ())))))))
+ (match in
+ (() (init cps))
+ ((#(name var kfun) . in)
+ (let* ((known? (well-known? kfun))
+ (free (intmap-ref free-vars kfun))
+ (nfree (intset-count free)))
+ (define (next-init cps)
+ (with-cps cps
+ (let$ body (init))
+ (letk k ($kargs () () ,body))
+ ($ (init-closure k src var known? free))))
+ (with-cps cps
+ (let$ body (lp in next-init))
+ (letk k ($kargs (name) (var) ,body))
+ ($ (allocate-closure k src kfun known? nfree))))))))
+ (shared
+ ;; If shared is in the bound->var map, that means one of
+ ;; the functions is not well-known. Otherwise use kfun0
+ ;; as the function label, but just so make-single-closure
+ ;; can find the free vars, not for embedding in the
+ ;; closure.
+ (let* ((kfun (intmap-ref bound->label shared (lambda (_)
kfun0)))
+ (cps (match (intmap-ref cps k)
+ ;; Make continuation declare only the shared
+ ;; closure.
+ (($ $kargs names vals body)
+ (intmap-replace cps k
+ (build-cont
+ ($kargs (#f) (shared)
,body)))))))
+ (with-cps cps
+ ($ (make-single-closure k src kfun)))))))))
+
+ (($ $continue k src ($ $call proc args))
+ (match (intmap-ref bound->label proc (lambda (_) #f))
+ (#f
+ (convert-arg cps proc
+ (lambda (cps proc)
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src ($call proc args)))))))))
+ (label
+ (convert-known-proc-call cps k src label proc args))))
+
+ (($ $continue k src ($ $callk label proc args))
+ (convert-known-proc-call cps k src label proc args))
+
+ (($ $continue k src ($ $primcall name args))
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src ($primcall name args)))))))
+
+ (($ $continue k src ($ $branch kt ($ $primcall name args)))
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($branch kt ($primcall name args))))))))
+
+ (($ $continue k src ($ $branch kt ($ $values (arg))))
+ (convert-arg cps arg
+ (lambda (cps arg)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($branch kt ($values (arg)))))))))
+
+ (($ $continue k src ($ $values args))
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src ($values args)))))))
+
+ (($ $continue k src ($ $prompt escape? tag handler))
+ (convert-arg cps tag
+ (lambda (cps tag)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($prompt escape? tag handler)))))))))
+
+ (pk 'convert-one label body free self-known?)
+ (intset-fold (lambda (label cps)
+ (match (intmap-ref cps label (lambda (_) #f))
+ (($ $kargs names vars term)
+ (with-cps cps
+ (let$ term (visit-term term))
+ (setk label ($kargs names vars ,term))))
+ (_ cps)))
+ body
+ cps)))
+
+(define (convert-closures cps)
+ "Convert free reference in @var{cps} to primcalls to @code{free-ref},
+and allocate and initialize flat closures."
+ (let* ((kfun 0) ;; Ass-u-me.
+ ;; label -> body-label...
+ (functions (compute-function-bodies cps kfun))
+ (cps (filter-reachable cps functions))
+ ;; label -> bound-var...
+ (label->bound (compute-function-names cps functions))
+ ;; bound-var -> label
+ (bound->label (invert-partition label->bound))
+ ;; label...
+ (well-known (compute-well-known-functions cps bound->label))
+ ;; label -> closure-var
+ (shared (compute-shared-closures cps well-known))
+ (cps (rewrite-shared-closure-calls cps functions label->bound shared
+ kfun))
+ ;; label -> free-var...
+ (free-vars (compute-free-vars cps kfun shared))
+ (free-vars (prune-free-vars free-vars bound->label well-known)))
+ (let ((free-in-program (intmap-ref free-vars kfun)))
+ (unless (eq? empty-intset free-in-program)
+ (error "Expected no free vars in program" free-in-program)))
+ (with-fresh-name-state cps
+ (persistent-intmap
+ (intmap-fold
+ (lambda (label body cps)
+ (convert-one cps label body free-vars bound->label well-known
shared))
+ functions
+ cps)))))
+
+;;; Local Variables:
+;;; eval: (put 'convert-arg 'scheme-indent-function 2)
+;;; eval: (put 'convert-args 'scheme-indent-function 2)
+;;; End:
- [Guile-commits] branch master updated (dbe6247 -> 981802c), Andy Wingo, 2015/07/15
- [Guile-commits] 01/09: Reorganizing of intset/intmap helper functions, Andy Wingo, 2015/07/15
- [Guile-commits] 02/09: intset-union fast paths, Andy Wingo, 2015/07/15
- [Guile-commits] 03/09: Fix intset-subtract to reliably produce empty-intset, Andy Wingo, 2015/07/15
- [Guile-commits] 04/09: CPS2 renumber works with first-order CPS, Andy Wingo, 2015/07/15
- [Guile-commits] 05/09: Tweak intset printing, Andy Wingo, 2015/07/15
- [Guile-commits] 06/09: Beginnings of first-order CPS optimization, Andy Wingo, 2015/07/15
- [Guile-commits] 07/09: Verify pass works on first-order CPS, Andy Wingo, 2015/07/15
- [Guile-commits] 09/09: Wire up new closure conversion pass, Andy Wingo, 2015/07/15
- [Guile-commits] 08/09: Add CPS2 closure conversion module,
Andy Wingo <=