-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014 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* ($kargs (sym*) (sym*) ,exp)))
- ($continue k* #f ($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 ($kargs () () ,body)))
- ,(convert-free-var
- free outer-self outer-bound
- (lambda (free)
- (values (build-cps-term
- ($letconst (('idx idxsym idx))
- ($continue k src
- ($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 ($ $kargs names syms body))
- (receive (body free) (cc body self (append syms bound))
- (values (build-cps-cont (sym ($kargs names syms ,body)))
- free)))
-
- (($ $cont sym ($ $kentry self tail clauses))
- (receive (clauses free) (cc* clauses self (list self))
- (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
- free)))
-
- (($ $cont sym ($ $kclause arity body))
- (receive (body free) (cc body self bound)
- (values (build-cps-cont (sym ($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 src 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 ($kargs (name) (sym) ,(bindings body))))
- ($continue k src
- ($fun src meta fun-free ,fun-body))))))
- (init-closure src sym fun-free self bound body)
- (union free (difference fun-free bound))))))))))
-
- (($ $continue k src
- (or ($ $void)
- ($ $const)
- ($ $prim)))
- (values exp '()))
-
- (($ $continue k src ($ $fun src* meta () body))
- (receive (body free) (cc body #f '())
- (match free
- (()
- (values (build-cps-term
- ($continue k src ($fun src* meta free ,body)))
- free))
- (_
- (values
- (let-gensyms (kinit v)
- (build-cps-term
- ($letk ((kinit ($kargs (v) (v)
- ,(init-closure
- src v free self bound
- (build-cps-term
- ($continue k src ($values (v))))))))
- ($continue kinit src ($fun src* meta free ,body)))))
- (difference free bound))))))
-
- (($ $continue k src ($ $call proc args))
- (convert-free-vars (cons proc args) self bound
- (match-lambda
- ((proc . args)
- (values (build-cps-term
- ($continue k src ($call proc args)))
- '())))))
-
- (($ $continue k src ($ $primcall name args))
- (convert-free-vars args self bound
- (lambda (args)
- (values (build-cps-term
- ($continue k src ($primcall name args)))
- '()))))
-
- (($ $continue k src ($ $values args))
- (convert-free-vars args self bound
- (lambda (args)
- (values (build-cps-term
- ($continue k src ($values args)))
- '()))))
-
- (($ $continue k src ($ $prompt escape? tag handler))
- (convert-free-var
- tag self bound
- (lambda (tag)
- (values (build-cps-term
- ($continue k src ($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 src ($ $primcall 'free-ref (closure sym)))
- ,(let-gensyms (idx)
- (build-cps-term
- ($letconst (('idx idx (free-index sym)))
- ($continue k src ($primcall 'free-ref (closure idx)))))))
- (($ $continue k src ($ $fun src* meta free body))
- ($continue k src
- ($fun src* meta free ,(convert-to-indices body free))))
- (($ $continue)
- ,term)))
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($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 ($ $kentry self tail clauses))
- (sym ($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 src 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 src meta free ,(convert-to-indices body free)))))))
+;;; 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 $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 (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (convert-closures))
+
+;; free := var ...
+
+(define (analyze-closures exp dfg)
+ "Compute the set of free variables for all $fun instances in
+@var{exp}."
+ (let ((bound-vars (make-hash-table))
+ (free-vars (make-hash-table))
+ (named-funs (make-hash-table))
+ (well-known-vars (make-bitvector (var-counter) #t)))
+ (define (add-named-fun! var cont)
+ (hashq-set! named-funs var cont)
+ (match cont
+ (($ $cont label ($ $kfun src meta self))
+ (unless (eq? var self)
+ (hashq-set! bound-vars label var)))))
+ (define (clear-well-known! var)
+ (bitvector-set! well-known-vars var #f))
+ (define (compute-well-known-labels)
+ (let ((bv (make-bitvector (label-counter) #f)))
+ (hash-for-each
+ (lambda (var cont)
+ (match cont
+ (($ $cont label ($ $kfun src meta self))
+ (unless (equal? var self)
+ (bitvector-set! bv label
+ (and (bitvector-ref well-known-vars var)
+ (bitvector-ref well-known-vars self)))))))
+ named-funs)
+ bv))
+ (define (union a b)
+ (lset-union eq? a b))
+ (define (difference a b)
+ (lset-difference eq? a b))
+ (define (visit-cont cont bound)
+ (match cont
+ (($ $cont label ($ $kargs names vars body))
+ (visit-term body (append vars bound)))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (add-named-fun! self cont)
+ (let ((free (if clause
+ (visit-cont clause (list self))
+ '())))
+ (hashq-set! free-vars label free)
+ (difference free bound)))
+ (($ $cont label ($ $kclause arity body alternate))
+ (let ((free (visit-cont body bound)))
+ (if alternate
+ (union (visit-cont alternate bound) free)
+ free)))
+ (($ $cont) '())))
+ (define (visit-term term bound)
+ (match term
+ (($ $letk conts body)
+ (fold (lambda (cont free)
+ (union (visit-cont cont bound) free))
+ (visit-term body bound)
+ conts))
+ (($ $letrec names vars (($ $fun () cont) ...) body)
+ (let ((bound (append vars bound)))
+ (for-each add-named-fun! vars cont)
+ (fold (lambda (cont free)
+ (union (visit-cont cont bound) free))
+ (visit-term body bound)
+ cont)))
+ (($ $continue k src ($ $fun () body))
+ (match (lookup-predecessors k dfg)
+ ((_) (match (lookup-cont k dfg)
+ (($ $kargs (name) (var))
+ (add-named-fun! var body))))
+ (_ #f))
+ (visit-cont body bound))
+ (($ $continue k src exp)
+ (visit-exp exp bound))))
+ (define (visit-exp exp bound)
+ (define (adjoin var free)
+ (if (or (memq var bound) (memq var free))
+ free
+ (cons var free)))
+ (match exp
+ ((or ($ $const) ($ $prim)) '())
+ (($ $call proc args)
+ (for-each clear-well-known! args)
+ (fold adjoin (adjoin proc '()) args))
+ (($ $primcall name args)
+ (for-each clear-well-known! args)
+ (fold adjoin '() args))
+ (($ $branch kt exp)
+ (visit-exp exp bound))
+ (($ $values args)
+ (for-each clear-well-known! args)
+ (fold adjoin '() args))
+ (($ $prompt escape? tag handler)
+ (clear-well-known! tag)
+ (adjoin tag '()))))
+
+ (let ((free (visit-cont exp '())))
+ (unless (null? free)
+ (error "Expected no free vars in toplevel thunk" free exp))
+ (values bound-vars free-vars named-funs (compute-well-known-labels)))))
+
+(define (prune-free-vars free-vars named-funs well-known var-aliases)
+ (define (well-known? label)
+ (bitvector-ref well-known label))
+ (let ((eliminated (make-bitvector (label-counter) #f))
+ (label-aliases (make-vector (label-counter) #f)))
+ (let lp ((label 0))
+ (let ((label (bit-position #t well-known label)))
+ (when label
+ (match (hashq-ref free-vars label)
+ ;; Mark all well-known closures that have no free variables
+ ;; for elimination.
+ (() (bitvector-set! eliminated label #t))
+ ;; Replace well-known closures that have just one free
+ ;; variable by references to that free variable.
+ ((var)
+ (vector-set! label-aliases label var))
+ (_ #f))
+ (lp (1+ label)))))
+ ;; Iterative free variable elimination.
+ (let lp ()
+ (let ((recurse? #f))
+ (define (adjoin elt list)
+ ;; Normally you wouldn't see duplicates in a free variable
+ ;; list, but with aliases that is possible.
+ (if (memq elt list) list (cons elt list)))
+ (define (prune-free closure-label free)
+ (match free
+ (() '())
+ ((var . free)
+ (let lp ((var var) (alias-stack '()))
+ (match (hashq-ref named-funs var)
+ (($ $cont label)
+ (cond
+ ((bitvector-ref eliminated label)
+ (prune-free closure-label free))
+ ((vector-ref label-aliases label)
+ => (lambda (var)
+ (cond
+ ((memq label alias-stack)
+ ;; We have found a set of mutually recursive
+ ;; well-known procedures, each of which only
+ ;; closes over one of the others. Mark them
+ ;; all for elimination.
+ (for-each (lambda (label)
+ (bitvector-set! eliminated label #t)
+ (set! recurse? #t))
+ alias-stack)
+ (prune-free closure-label free))
+ (else
+ (lp var (cons label alias-stack))))))
+ ((eq? closure-label label)
+ ;; Eliminate self-reference.
+ (prune-free closure-label free))
+ (else
+ (adjoin var (prune-free closure-label free)))))
+ (_ (adjoin var (prune-free closure-label free))))))))
+ (hash-for-each-handle
+ (lambda (pair)
+ (match pair
+ ((label . ()) #t)
+ ((label . free)
+ (let ((orig-nfree (length free))
+ (free (prune-free label free)))
+ (set-cdr! pair free)
+ ;; If we managed to eliminate one or more free variables
+ ;; from a well-known function, it could be that we can
+ ;; eliminate or alias this function as well.
+ (when (and (well-known? label)
+ (< (length free) orig-nfree))
+ (match free
+ (()
+ (bitvector-set! eliminated label #t)
+ (set! recurse? #t))
+ ((var)
+ (vector-set! label-aliases label var)
+ (set! recurse? #t))
+ (_ #t)))))))
+ free-vars)
+ ;; Iterate to fixed point.
+ (when recurse? (lp))))
+ ;; Populate var-aliases from label-aliases.
+ (hash-for-each (lambda (var cont)
+ (match cont
+ (($ $cont label)
+ (let ((alias (vector-ref label-aliases label)))
+ (when alias
+ (vector-set! var-aliases var alias))))))
+ named-funs)))
+
+(define (convert-one bound label fun free-vars named-funs well-known aliases)
+ (define (well-known? label)
+ (bitvector-ref well-known label))
+
+ (let ((free (hashq-ref free-vars label))
+ (self-known? (well-known? label))
+ (self (match fun (($ $kfun _ _ self) self))))
+ (define (convert-free-var 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}."
+ (cond
+ ((list-index (cut eq? <> var) free)
+ => (lambda (free-idx)
+ (match (cons self-known? free)
+ ;; A reference to the one free var of a well-known function.
+ ((#t _) (k self))
+ ;; A reference to one of the two free vars in a well-known
+ ;; function.
+ ((#t _ _)
+ (let-fresh (k*) (var*)
+ (build-cps-term
+ ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
+ ($continue k* #f
+ ($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
+ (_
+ (let-fresh (k* kidx) (idx var*)
+ (build-cps-term
+ ($letk ((kidx ($kargs ('idx) (idx)
+ ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
+ ($continue k* #f
+ ($primcall
+ (cond
+ ((not self-known?) 'free-ref)
+ ((<= free-idx #xff) 'vector-ref/immediate)
+ (else 'vector-ref))
+ (self idx)))))))
+ ($continue kidx #f ($const free-idx)))))))))
+ ((eq? var bound) (k self))
+ (else (k var))))
+
+ (define (convert-free-vars 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
+ (() (k '()))
+ ((var . vars)
+ (convert-free-var var
+ (lambda (var)
+ (convert-free-vars vars
+ (lambda (vars)
+ (k (cons var vars)))))))))
+
+ (define (allocate-closure src name var label known? free body)
+ "Allocate a new closure."
+ (match (cons known? free)
+ ((#f . _)
+ (let-fresh (k*) ()
+ (build-cps-term
+ ($letk ((k* ($kargs (name) (var) ,body)))
+ ($continue k* src
+ ($closure label (length free)))))))
+ ((#t)
+ ;; Well-known closure with no free variables; elide the
+ ;; binding entirely.
+ body)
+ ((#t _)
+ ;; Well-known closure with one free variable; the free var is the
+ ;; closure, and no new binding need be made.
+ body)
+ ((#t _ _)
+ ;; Well-known closure with two free variables; the closure is a
+ ;; pair.
+ (let-fresh (kinit kfalse) (false)
+ (build-cps-term
+ ($letk ((kinit ($kargs (name) (var)
+ ,body))
+ (kfalse ($kargs ('false) (false)
+ ($continue kinit src
+ ($primcall 'cons (false false))))))
+ ($continue kfalse src ($const #f))))))
+ ;; Well-known callee with more than two free variables; the closure
+ ;; is a vector.
+ ((#t . _)
+ (let ((nfree (length free)))
+ (let-fresh (kinit klen kfalse) (false len-var)
+ (build-cps-term
+ ($letk ((kinit ($kargs (name) (var) ,body))
+ (kfalse
+ ($kargs ('false) (false)
+ ($letk ((klen
+ ($kargs ('len) (len-var)
+ ($continue kinit src
+ ($primcall (if (<= nfree #xff)
+ 'make-vector/immediate
+ 'make-vector)
+ (len-var false))))))
+ ($continue klen src ($const nfree))))))
+ ($continue kfalse src ($const #f)))))))))
+
+ (define (init-closure src var known? closure-free body)
+ "Initialize the free variables @var{closure-free} in a closure
+bound to @var{var}, and continue with @var{body}."
+ (match (cons known? closure-free)
+ ;; Well-known callee with no free variables; no initialization
+ ;; necessary.
+ ((#t) body)
+ ;; Well-known callee with one free variable; no initialization
+ ;; necessary.
+ ((#t _) body)
+ ;; Well-known callee with two free variables; do a set-car! and
+ ;; set-cdr!.
+ ((#t v0 v1)
+ (let-fresh (kcar kcdr) ()
+ (convert-free-var
+ v0
+ (lambda (v0)
+ (build-cps-term
+ ($letk ((kcar ($kargs () ()
+ ,(convert-free-var
+ v1
+ (lambda (v1)
+ (build-cps-term
+ ($letk ((kcdr ($kargs () () ,body)))
+ ($continue kcdr src
+ ($primcall 'set-cdr! (var v1))))))))))
+ ($continue kcar 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.
+ (_
+ (fold (lambda (free idx body)
+ (let-fresh (k) (idxvar)
+ (build-cps-term
+ ($letk ((k ($kargs () () ,body)))
+ ,(convert-free-var
+ free
+ (lambda (free)
+ (build-cps-term
+ ($letconst (('idx idxvar idx))
+ ($continue k src
+ ($primcall (cond
+ ((not known?) 'free-set!)
+ ((<= idx #xff) 'vector-set!/immediate)
+ (else 'vector-set!))
+ (var idxvar free)))))))))))
+ body
+ closure-free
+ (iota (length closure-free))))))
+
+ ;; Load the closure for a known call. The callee may or may not be
+ ;; known at all call sites.
+ (define (convert-known-proc-call var label self self-known? free k)
+ ;; Well-known closures with one free variable are replaced at their
+ ;; use sites by uses of the one free variable. The use sites of a
+ ;; well-known closures are only in well-known proc calls, and in
+ ;; free lists of other closures. Here we handle the call case; the
+ ;; free list case is handled by prune-free-vars.
+ (define (rename var)
+ (let ((var* (vector-ref aliases var)))
+ (if var*
+ (rename var*)
+ var)))
+ (match (cons (well-known? label)
+ (hashq-ref free-vars label))
+ ((#t)
+ ;; Calling a well-known procedure with no free variables; pass #f
+ ;; as the closure.
+ (let-fresh (k*) (v*)
+ (build-cps-term
+ ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
+ ($continue k* #f ($const #f))))))
+ ((#t _)
+ ;; Calling a well-known procedure with one free variable; pass
+ ;; the free variable as the closure.
+ (convert-free-var (rename var) k))
+ (_
+ (convert-free-var var k))))
+
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont) ,cont)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (build-cps-term
+ ($letk ,(map visit-cont conts) ,(visit-term body))))
+
+ ;; Remove letrec.
+ (($ $letrec names vars funs body)
+ (let lp ((in (map list names vars funs))
+ (bindings (lambda (body) body))
+ (body (visit-term body)))
+ (match in
+ (() (bindings body))
+ (((name var ($ $fun ()
+ (and fun-body
+ ($ $cont kfun ($ $kfun src))))) . in)
+ (let ((fun-free (hashq-ref free-vars kfun)))
+ (lp in
+ (lambda (body)
+ (allocate-closure
+ src name var kfun (well-known? kfun) fun-free
+ (bindings body)))
+ (init-closure
+ src var (well-known? kfun) fun-free
+ body)))))))
+
+ (($ $continue k src (or ($ $const) ($ $prim)))
+ term)
+
+ (($ $continue k src ($ $fun () ($ $cont kfun)))
+ (let ((fun-free (hashq-ref free-vars kfun)))
+ (match (cons (well-known? kfun) fun-free)
+ ((known?)
+ (build-cps-term
+ ($continue k src ,(if known?
+ (build-cps-exp ($const #f))
+ (build-cps-exp ($closure kfun 0))))))
+ ((#t _)
+ ;; 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.
+ (build-cps-term
+ ($continue k src ,(build-cps-exp ($const #f)))))
+ (_
+ (let-fresh () (var)
+ (allocate-closure
+ src #f var kfun (well-known? kfun) fun-free
+ (init-closure
+ src var (well-known? kfun) fun-free
+ (build-cps-term ($continue k src ($values (var)))))))))))
+
+ (($ $continue k src ($ $call proc args))
+ (match (hashq-ref named-funs proc)
+ (($ $cont kfun)
+ (convert-known-proc-call
+ proc kfun self self-known? free
+ (lambda (proc)
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src
+ ($callk kfun proc args))))))))
+ (#f
+ (convert-free-vars (cons proc args)
+ (match-lambda
+ ((proc . args)
+ (build-cps-term
+ ($continue k src
+ ($call proc args)))))))))
+
+ (($ $continue k src ($ $primcall name args))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($primcall name args))))))
+
+ (($ $continue k src ($ $branch kt ($ $primcall name args)))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ($primcall name args)))))))
+
+ (($ $continue k src ($ $branch kt ($ $values (arg))))
+ (convert-free-var arg
+ (lambda (arg)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ($values (arg))))))))
+
+ (($ $continue k src ($ $values args))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($values args))))))
+
+ (($ $continue k src ($ $prompt escape? tag handler))
+ (convert-free-var tag
+ (lambda (tag)
+ (build-cps-term
+ ($continue k src
+ ($prompt escape? tag handler))))))))
+ (visit-cont (build-cps-cont (label ,fun)))))
+
+(define (convert-closures fun)
+ "Convert free reference in @var{exp} to primcalls to @code{free-ref},
+and allocate and initialize flat closures."
+ (let ((dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (call-with-values (lambda () (analyze-closures fun dfg))
+ (lambda (bound-vars free-vars named-funs well-known)
+ (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
+ (aliases (make-vector (var-counter) #f)))
+ (prune-free-vars free-vars named-funs well-known aliases)
+ (build-cps-term
+ ($program
+ ,(map (lambda (label)
+ (convert-one (hashq-ref bound-vars label) label
+ (lookup-cont label dfg)
+ free-vars named-funs well-known aliases))
+ labels)))))))))
HCoop / bpt / guile.git / blobdiff