1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; This pass converts a CPS term in such a way that no function has any
22 ;;; free variables. Instead, closures are built explicitly with
23 ;;; make-closure primcalls, and free variables are referenced through
26 ;;; Closure conversion also removes any $letrec forms that contification
27 ;;; did not handle. See (language cps) for a further discussion of
32 (define-module (language cps closure-conversion)
33 #:use-module (ice-9 match)
34 #:use-module ((srfi srfi-1) #:select (fold
35 lset-union lset-difference
37 #:use-module (srfi srfi-9)
38 #:use-module (srfi srfi-26)
39 #:use-module (language cps)
40 #:use-module (language cps dfg)
41 #:export (convert-closures))
45 (define (analyze-closures exp dfg)
46 "Compute the set of free variables for all $fun instances in
48 (let ((bound-vars (make-hash-table))
49 (free-vars (make-hash-table))
50 (named-funs (make-hash-table))
51 (well-known-vars (make-bitvector (var-counter) #t)))
52 (define (add-named-fun! var cont)
53 (hashq-set! named-funs var cont)
55 (($ $cont label ($ $kfun src meta self))
56 (unless (eq? var self)
57 (hashq-set! bound-vars label var)))))
58 (define (clear-well-known! var)
59 (bitvector-set! well-known-vars var #f))
60 (define (compute-well-known-labels)
61 (let ((bv (make-bitvector (label-counter) #f)))
65 (($ $cont label ($ $kfun src meta self))
66 (unless (equal? var self)
67 (bitvector-set! bv label
68 (and (bitvector-ref well-known-vars var)
69 (bitvector-ref well-known-vars self)))))))
74 (define (difference a b)
75 (lset-difference eq? a b))
76 (define (visit-cont cont bound)
78 (($ $cont label ($ $kargs names vars body))
79 (visit-term body (append vars bound)))
80 (($ $cont label ($ $kfun src meta self tail clause))
81 (add-named-fun! self cont)
82 (let ((free (if clause
83 (visit-cont clause (list self))
85 (hashq-set! free-vars label free)
86 (difference free bound)))
87 (($ $cont label ($ $kclause arity body alternate))
88 (let ((free (visit-cont body bound)))
90 (union (visit-cont alternate bound) free)
93 (define (visit-term term bound)
96 (fold (lambda (cont free)
97 (union (visit-cont cont bound) free))
98 (visit-term body bound)
100 (($ $letrec names vars (($ $fun () cont) ...) body)
101 (let ((bound (append vars bound)))
102 (for-each add-named-fun! vars cont)
103 (fold (lambda (cont free)
104 (union (visit-cont cont bound) free))
105 (visit-term body bound)
107 (($ $continue k src ($ $fun () body))
108 (match (lookup-predecessors k dfg)
109 ((_) (match (lookup-cont k dfg)
110 (($ $kargs (name) (var))
111 (add-named-fun! var body))))
113 (visit-cont body bound))
114 (($ $continue k src exp)
115 (visit-exp exp bound))))
116 (define (visit-exp exp bound)
117 (define (adjoin var free)
118 (if (or (memq var bound) (memq var free))
122 ((or ($ $void) ($ $const) ($ $prim)) '())
124 (for-each clear-well-known! args)
125 (fold adjoin (adjoin proc '()) args))
126 (($ $primcall name args)
127 (for-each clear-well-known! args)
128 (fold adjoin '() args))
130 (for-each clear-well-known! args)
131 (fold adjoin '() args))
132 (($ $prompt escape? tag handler)
133 (clear-well-known! tag)
136 (let ((free (visit-cont exp '())))
138 (error "Expected no free vars in toplevel thunk" free exp))
139 (values bound-vars free-vars named-funs (compute-well-known-labels)))))
141 (define (prune-free-vars free-vars named-funs well-known var-aliases)
142 (define (well-known? label)
143 (bitvector-ref well-known label))
144 (let ((eliminated (make-bitvector (label-counter) #f))
145 (label-aliases (make-vector (label-counter) #f)))
147 (let ((label (bit-position #t well-known label)))
149 (match (hashq-ref free-vars label)
150 ;; Mark all well-known closures that have no free variables
152 (() (bitvector-set! eliminated label #t))
153 ;; Replace well-known closures that have just one free
154 ;; variable by references to that free variable.
156 (vector-set! label-aliases label var))
159 ;; Iterative free variable elimination.
162 (define (adjoin elt list)
163 ;; Normally you wouldn't see duplicates in a free variable
164 ;; list, but with aliases that is possible.
165 (if (memq elt list) list (cons elt list)))
166 (define (prune-free closure-label free)
170 (let lp ((var var) (alias-stack '()))
171 (match (hashq-ref named-funs var)
174 ((bitvector-ref eliminated label)
175 (prune-free closure-label free))
176 ((vector-ref label-aliases label)
179 ((memq label alias-stack)
180 ;; We have found a set of mutually recursive
181 ;; well-known procedures, each of which only
182 ;; closes over one of the others. Mark them
183 ;; all for elimination.
184 (for-each (lambda (label)
185 (bitvector-set! eliminated label #t)
188 (prune-free closure-label free))
190 (lp var (cons label alias-stack))))))
191 ((eq? closure-label label)
192 ;; Eliminate self-reference.
194 (prune-free closure-label free))
196 (adjoin var (prune-free closure-label free)))))
197 (_ (adjoin var (prune-free closure-label free))))))))
198 (hash-for-each-handle
203 (let ((orig-nfree (length free))
204 (free (prune-free label free)))
206 ;; If we managed to eliminate one or more free variables
207 ;; from a well-known function, it could be that we can
208 ;; eliminate or alias this function as well.
209 (when (and (well-known? label)
210 (< (length free) orig-nfree))
213 (bitvector-set! eliminated label #t)
216 (vector-set! label-aliases label var)
220 ;; Iterate to fixed point.
221 (when recurse? (lp))))
222 ;; Populate var-aliases from label-aliases.
223 (hash-for-each (lambda (var cont)
226 (let ((alias (vector-ref label-aliases label)))
228 (vector-set! var-aliases var alias))))))
231 (define (convert-one bound label fun free-vars named-funs well-known aliases)
232 (define (well-known? label)
233 (bitvector-ref well-known label))
235 (let ((free (hashq-ref free-vars label))
236 (self-known? (well-known? label))
237 (self (match fun (($ $kfun _ _ self) self))))
238 (define (convert-free-var var k)
239 "Convert one possibly free variable reference to a bound reference.
241 If @var{var} is free, it is replaced by a closure reference via a
242 @code{free-ref} primcall, and @var{k} is called with the new var.
243 Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
245 ((list-index (cut eq? <> var) free)
246 => (lambda (free-idx)
247 (match (cons self-known? free)
248 ;; A reference to the one free var of a well-known function.
250 ;; A reference to one of the two free vars in a well-known
253 (let-fresh (k*) (var*)
255 ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
257 ($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
259 (let-fresh (k* kidx) (idx var*)
261 ($letk ((kidx ($kargs ('idx) (idx)
262 ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
266 ((not self-known?) 'free-ref)
267 ((<= free-idx #xff) 'vector-ref/immediate)
270 ($continue kidx #f ($const free-idx)))))))))
271 ((eq? var bound) (k self))
274 (define (convert-free-vars vars k)
275 "Convert a number of possibly free references to bound references.
276 @var{k} is called with the bound references, and should return the
281 (convert-free-var var
283 (convert-free-vars vars
285 (k (cons var vars)))))))))
287 (define (allocate-closure src name var label known? free body)
288 "Allocate a new closure."
289 (match (cons known? free)
293 ($letk ((k* ($kargs (name) (var) ,body)))
295 ($closure label (length free)))))))
297 ;; Well-known closure with no free variables; elide the
301 ;; Well-known closure with one free variable; the free var is the
302 ;; closure, and no new binding need be made.
305 ;; Well-known closure with two free variables; the closure is a
307 (let-fresh (kinit kfalse) (false)
309 ($letk ((kinit ($kargs (name) (var)
311 (kfalse ($kargs ('false) (false)
313 ($primcall 'cons (false false))))))
314 ($continue kfalse src ($const #f))))))
315 ;; Well-known callee with more than two free variables; the closure
318 (let ((nfree (length free)))
319 (let-fresh (kinit klen kfalse) (false len-var)
321 ($letk ((kinit ($kargs (name) (var) ,body))
323 ($kargs ('false) (false)
325 ($kargs ('len) (len-var)
327 ($primcall (if (<= nfree #xff)
328 'make-vector/immediate
331 ($continue klen src ($const nfree))))))
332 ($continue kfalse src ($const #f)))))))))
334 (define (init-closure src var known? closure-free body)
335 "Initialize the free variables @var{closure-free} in a closure
336 bound to @var{var}, and continue with @var{body}."
337 (match (cons known? closure-free)
338 ;; Well-known callee with no free variables; no initialization
341 ;; Well-known callee with one free variable; no initialization
344 ;; Well-known callee with two free variables; do a set-car! and
347 (let-fresh (kcar kcdr) ()
352 ($letk ((kcar ($kargs () ()
357 ($letk ((kcdr ($kargs () () ,body)))
359 ($primcall 'set-cdr! (var v1))))))))))
361 ($primcall 'set-car! (var v0)))))))))
362 ;; Otherwise residualize a sequence of vector-set! or free-set!,
363 ;; depending on whether the callee is well-known or not.
365 (fold (lambda (free idx body)
366 (let-fresh (k) (idxvar)
368 ($letk ((k ($kargs () () ,body)))
373 ($letconst (('idx idxvar idx))
376 ((not known?) 'free-set!)
377 ((<= idx #xff) 'vector-set!/immediate)
379 (var idxvar free)))))))))))
382 (iota (length closure-free))))))
384 ;; Load the closure for a known call. The callee may or may not be
385 ;; known at all call sites.
386 (define (convert-known-proc-call var label self self-known? free k)
387 ;; Well-known closures with one free variable are replaced at their
388 ;; use sites by uses of the one free variable. The use sites of a
389 ;; well-known closures are only in well-known proc calls, and in
390 ;; free lists of other closures. Here we handle the call case; the
391 ;; free list case is handled by prune-free-vars.
393 (let ((var* (vector-ref aliases var)))
397 (match (cons (well-known? label)
398 (hashq-ref free-vars label))
400 ;; Calling a well-known procedure with no free variables; pass #f
404 ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
405 ($continue k* #f ($const #f))))))
407 ;; Calling a well-known procedure with one free variable; pass
408 ;; the free variable as the closure.
409 (convert-free-var (rename var) k))
411 (convert-free-var var k))))
413 (define (visit-cont cont)
414 (rewrite-cps-cont cont
415 (($ $cont label ($ $kargs names vars body))
416 (label ($kargs names vars ,(visit-term body))))
417 (($ $cont label ($ $kfun src meta self tail clause))
418 (label ($kfun src meta self ,tail
419 ,(and clause (visit-cont clause)))))
420 (($ $cont label ($ $kclause arity body alternate))
421 (label ($kclause ,arity ,(visit-cont body)
422 ,(and alternate (visit-cont alternate)))))
424 (define (visit-term term)
426 (($ $letk conts body)
428 ($letk ,(map visit-cont conts) ,(visit-term body))))
431 (($ $letrec names vars funs body)
432 (let lp ((in (map list names vars funs))
433 (bindings (lambda (body) body))
434 (body (visit-term body)))
437 (((name var ($ $fun ()
439 ($ $cont kfun ($ $kfun src))))) . in)
440 (let ((fun-free (hashq-ref free-vars kfun)))
444 src name var kfun (well-known? kfun) fun-free
447 src var (well-known? kfun) fun-free
450 (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
453 (($ $continue k src ($ $fun () ($ $cont kfun)))
454 (let ((fun-free (hashq-ref free-vars kfun)))
455 (match (cons (well-known? kfun) fun-free)
458 ($continue k src ,(if known?
459 (build-cps-exp ($const #f))
460 (build-cps-exp ($closure kfun 0))))))
462 ;; A well-known closure of one free variable is replaced
463 ;; at each use with the free variable itself, so we don't
464 ;; need a binding at all; and yet, the continuation
465 ;; expects one value, so give it something. DCE should
468 ($continue k src ,(build-cps-exp ($const #f)))))
472 src #f var kfun (well-known? kfun) fun-free
474 src var (well-known? kfun) fun-free
475 (build-cps-term ($continue k src ($values (var)))))))))))
477 (($ $continue k src ($ $call proc args))
478 (match (hashq-ref named-funs proc)
480 (convert-known-proc-call
481 proc kfun self self-known? free
483 (convert-free-vars args
487 ($callk kfun proc args))))))))
489 (convert-free-vars (cons proc args)
494 ($call proc args)))))))))
496 (($ $continue k src ($ $primcall name args))
497 (convert-free-vars args
500 ($continue k src ($primcall name args))))))
502 (($ $continue k src ($ $values args))
503 (convert-free-vars args
506 ($continue k src ($values args))))))
508 (($ $continue k src ($ $prompt escape? tag handler))
509 (convert-free-var tag
513 ($prompt escape? tag handler))))))))
514 (visit-cont (build-cps-cont (label ,fun)))))
516 (define (convert-closures fun)
517 "Convert free reference in @var{exp} to primcalls to @code{free-ref},
518 and allocate and initialize flat closures."
519 (let ((dfg (compute-dfg fun)))
520 (with-fresh-name-state-from-dfg dfg
521 (call-with-values (lambda () (analyze-closures fun dfg))
522 (lambda (bound-vars free-vars named-funs well-known)
523 (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
524 (aliases (make-vector (var-counter) #f)))
525 (prune-free-vars free-vars named-funs well-known aliases)
528 ,(map (lambda (label)
529 (convert-one (hashq-ref bound-vars label) label
530 (lookup-cont label dfg)
531 free-vars named-funs well-known aliases))