mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 00:30:21 +02:00
Code Activity
guile/module/language/cps/closure-conversion.scm
Andy Wingo c54c151eb6 $primcall has a "param" member 
* module/language/cps.scm ($primcall): Add "param" member, which will be
  a constant parameter to the primcall.  The idea is that constants used
  by primcalls as immediates don't need to participate in optimizations
  in any way -- they should not participate in CSE, have the same
  lifetime as the primcall so not part of DCE either, and don't need
  slot allocation.  Indirecting them through a named $const binding is
  complication for no benefit.  This change should eventually improve
  compilation time and memory usage, once we fully take advantage of it,
  as the number of labels and variables will go down.
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/handle-interrupts.scm:
* module/language/cps/licm.scm:
* module/language/cps/peel-loops.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/rotate-loops.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/specialize-numbers.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/split-rec.scm:
* module/language/cps/type-checks.scm:
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm:
* module/language/cps/utils.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt all users.
2017-11-05 15:00:16 +01:00

834 lines
35 KiB
Scheme
Raw Blame History

;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 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 cps closure-conversion)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold
filter-map
))
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps 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 ($ $primcall name param args))
(add-uses args uses))
(($ $primcall name param 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
@var{conts}. 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.
(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)))
(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 param args)
($primcall name param ,(map subst args)))
(($ $branch k ($ $primcall name param args))
($branch k ($primcall name param ,(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 rec-labels env)
(define (add-bound-var bound label 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 rec-labels)
;; Otherwise be sure to use "self" references in any
;; closure.
(add-bound-var bound label 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 labels
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 ($ $primcall name param args))
(add-uses args uses))
(($ $primcall name param 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-label label shared bound->label)
(cond
((intmap-ref shared label (lambda (_) #f))
=> (lambda (closure)
(intmap-ref bound->label closure)))
(else label)))
(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 shared)
"Given the label->bound-var map @var{free-vars}, remove free variables
that are 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 (closure-label label shared bound->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 (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? (closure-label label shared bound->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
@code{free-ref} 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 #f (self)))))))
(_
(let ((idx (intset-find free var)))
(cond
(self-known?
(with-cps cps
(letv var* u64)
(let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body))
(letk kunbox ($kargs ('idx) (u64)
($continue k* #f
($primcall 'vector-ref #f (self u64)))))
($ (with-cps-constants ((idx idx))
(build-term
($continue kunbox #f
($primcall 'scm->u64 #f (idx))))))))
(else
(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 'free-ref #f (self idx)))))))))))))
(else
(with-cps cps
($ (k var))))))
(define (convert-args cps vars k)
"Convert a number of possibly free references to bound references.
@var{k} 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 #f (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"))
(with-cps cps
($ (with-cps-constants ((nfree nfree)
(false #f))
(letv u64)
(letk kunbox ($kargs ('nfree) (u64)
($continue k src
($primcall 'make-vector #f (u64 false)))))
(build-term
($continue kunbox src ($primcall 'scm->u64 #f (nfree))))))))))
(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! #f (var v1))))))))
(letk kcdr ($kargs () () ,body))
(build-term
($continue kcdr src ($primcall 'set-car! #f (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)
(cond
(known?
(with-cps cps
(letv u64)
(letk kunbox
($kargs ('idx) (u64)
($continue k src
($primcall 'vector-set! #f (var u64 v)))))
($ (with-cps-constants ((idx idx))
(build-term
($continue kunbox src
($primcall 'scm->u64 #f (idx))))))))
(else
(with-cps cps
($ (with-cps-constants ((idx idx))
(build-term
($continue k src
($primcall 'free-set! #f
(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? (closure-label label shared bound->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 param args))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src ($primcall name param args)))))))
(($ $continue k src ($ $branch kt ($ $primcall name param args)))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src
($branch kt ($primcall name param args))))))))
(($ $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)))))))))
(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 shared)))
(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:
View git blame Copy permalink