1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014, 2015 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 ($ $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 (visit-exp exp bound))
132 (for-each clear-well-known! args)
133 (fold adjoin '() args))
134 (($ $prompt escape? tag handler)
135 (clear-well-known! tag)
138 (let ((free (visit-cont exp '())))
140 (error "Expected no free vars in toplevel thunk" free exp))
141 (values bound-vars free-vars named-funs (compute-well-known-labels)))))
143 (define (prune-free-vars free-vars named-funs well-known var-aliases)
144 (define (well-known? label)
145 (bitvector-ref well-known label))
146 (let ((eliminated (make-bitvector (label-counter) #f))
147 (label-aliases (make-vector (label-counter) #f)))
149 (let ((label (bit-position #t well-known label)))
151 (match (hashq-ref free-vars label)
152 ;; Mark all well-known closures that have no free variables
154 (() (bitvector-set! eliminated label #t))
155 ;; Replace well-known closures that have just one free
156 ;; variable by references to that free variable.
158 (vector-set! label-aliases label var))
161 ;; Iterative free variable elimination.
164 (define (adjoin elt list)
165 ;; Normally you wouldn't see duplicates in a free variable
166 ;; list, but with aliases that is possible.
167 (if (memq elt list) list (cons elt list)))
168 (define (prune-free closure-label free)
172 (let lp ((var var) (alias-stack '()))
173 (match (hashq-ref named-funs var)
176 ((bitvector-ref eliminated label)
177 (prune-free closure-label free))
178 ((vector-ref label-aliases label)
181 ((memq label alias-stack)
182 ;; We have found a set of mutually recursive
183 ;; well-known procedures, each of which only
184 ;; closes over one of the others. Mark them
185 ;; all for elimination.
186 (for-each (lambda (label)
187 (bitvector-set! eliminated label #t)
190 (prune-free closure-label free))
192 (lp var (cons label alias-stack))))))
193 ((eq? closure-label label)
194 ;; Eliminate self-reference.
195 (prune-free closure-label free))
197 (adjoin var (prune-free closure-label free)))))
198 (_ (adjoin var (prune-free closure-label free))))))))
199 (hash-for-each-handle
204 (let ((orig-nfree (length free))
205 (free (prune-free label free)))
207 ;; If we managed to eliminate one or more free variables
208 ;; from a well-known function, it could be that we can
209 ;; eliminate or alias this function as well.
210 (when (and (well-known? label)
211 (< (length free) orig-nfree))
214 (bitvector-set! eliminated label #t)
217 (vector-set! label-aliases label var)
221 ;; Iterate to fixed point.
222 (when recurse? (lp))))
223 ;; Populate var-aliases from label-aliases.
224 (hash-for-each (lambda (var cont)
227 (let ((alias (vector-ref label-aliases label)))
229 (vector-set! var-aliases var alias))))))
232 (define (convert-one bound label fun free-vars named-funs well-known aliases)
233 (define (well-known? label)
234 (bitvector-ref well-known label))
236 (let ((free (hashq-ref free-vars label))
237 (self-known? (well-known? label))
238 (self (match fun (($ $kfun _ _ self) self))))
239 (define (convert-free-var var k)
240 "Convert one possibly free variable reference to a bound reference.
242 If @var{var} is free, it is replaced by a closure reference via a
243 @code{free-ref} primcall, and @var{k} is called with the new var.
244 Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
246 ((list-index (cut eq? <> var) free)
247 => (lambda (free-idx)
248 (match (cons self-known? free)
249 ;; A reference to the one free var of a well-known function.
251 ;; A reference to one of the two free vars in a well-known
254 (let-fresh (k*) (var*)
256 ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
258 ($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
260 (let-fresh (k* kidx) (idx var*)
262 ($letk ((kidx ($kargs ('idx) (idx)
263 ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
267 ((not self-known?) 'free-ref)
268 ((<= free-idx #xff) 'vector-ref/immediate)
271 ($continue kidx #f ($const free-idx)))))))))
272 ((eq? var bound) (k self))
275 (define (convert-free-vars vars k)
276 "Convert a number of possibly free references to bound references.
277 @var{k} is called with the bound references, and should return the
282 (convert-free-var var
284 (convert-free-vars vars
286 (k (cons var vars)))))))))
288 (define (allocate-closure src name var label known? free body)
289 "Allocate a new closure."
290 (match (cons known? free)
294 ($letk ((k* ($kargs (name) (var) ,body)))
296 ($closure label (length free)))))))
298 ;; Well-known closure with no free variables; elide the
302 ;; Well-known closure with one free variable; the free var is the
303 ;; closure, and no new binding need be made.
306 ;; Well-known closure with two free variables; the closure is a
308 (let-fresh (kinit kfalse) (false)
310 ($letk ((kinit ($kargs (name) (var)
312 (kfalse ($kargs ('false) (false)
314 ($primcall 'cons (false false))))))
315 ($continue kfalse src ($const #f))))))
316 ;; Well-known callee with more than two free variables; the closure
319 (let ((nfree (length free)))
320 (let-fresh (kinit klen kfalse) (false len-var)
322 ($letk ((kinit ($kargs (name) (var) ,body))
324 ($kargs ('false) (false)
326 ($kargs ('len) (len-var)
328 ($primcall (if (<= nfree #xff)
329 'make-vector/immediate
332 ($continue klen src ($const nfree))))))
333 ($continue kfalse src ($const #f)))))))))
335 (define (init-closure src var known? closure-free body)
336 "Initialize the free variables @var{closure-free} in a closure
337 bound to @var{var}, and continue with @var{body}."
338 (match (cons known? closure-free)
339 ;; Well-known callee with no free variables; no initialization
342 ;; Well-known callee with one free variable; no initialization
345 ;; Well-known callee with two free variables; do a set-car! and
348 (let-fresh (kcar kcdr) ()
353 ($letk ((kcar ($kargs () ()
358 ($letk ((kcdr ($kargs () () ,body)))
360 ($primcall 'set-cdr! (var v1))))))))))
362 ($primcall 'set-car! (var v0)))))))))
363 ;; Otherwise residualize a sequence of vector-set! or free-set!,
364 ;; depending on whether the callee is well-known or not.
366 (fold (lambda (free idx body)
367 (let-fresh (k) (idxvar)
369 ($letk ((k ($kargs () () ,body)))
374 ($letconst (('idx idxvar idx))
377 ((not known?) 'free-set!)
378 ((<= idx #xff) 'vector-set!/immediate)
380 (var idxvar free)))))))))))
383 (iota (length closure-free))))))
385 ;; Load the closure for a known call. The callee may or may not be
386 ;; known at all call sites.
387 (define (convert-known-proc-call var label self self-known? free k)
388 ;; Well-known closures with one free variable are replaced at their
389 ;; use sites by uses of the one free variable. The use sites of a
390 ;; well-known closures are only in well-known proc calls, and in
391 ;; free lists of other closures. Here we handle the call case; the
392 ;; free list case is handled by prune-free-vars.
394 (let ((var* (vector-ref aliases var)))
398 (match (cons (well-known? label)
399 (hashq-ref free-vars label))
401 ;; Calling a well-known procedure with no free variables; pass #f
405 ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
406 ($continue k* #f ($const #f))))))
408 ;; Calling a well-known procedure with one free variable; pass
409 ;; the free variable as the closure.
410 (convert-free-var (rename var) k))
412 (convert-free-var var k))))
414 (define (visit-cont cont)
415 (rewrite-cps-cont cont
416 (($ $cont label ($ $kargs names vars body))
417 (label ($kargs names vars ,(visit-term body))))
418 (($ $cont label ($ $kfun src meta self tail clause))
419 (label ($kfun src meta self ,tail
420 ,(and clause (visit-cont clause)))))
421 (($ $cont label ($ $kclause arity body alternate))
422 (label ($kclause ,arity ,(visit-cont body)
423 ,(and alternate (visit-cont alternate)))))
425 (define (visit-term term)
427 (($ $letk conts body)
429 ($letk ,(map visit-cont conts) ,(visit-term body))))
432 (($ $letrec names vars funs body)
433 (let lp ((in (map list names vars funs))
434 (bindings (lambda (body) body))
435 (body (visit-term body)))
438 (((name var ($ $fun ()
440 ($ $cont kfun ($ $kfun src))))) . in)
441 (let ((fun-free (hashq-ref free-vars kfun)))
445 src name var kfun (well-known? kfun) fun-free
448 src var (well-known? kfun) fun-free
451 (($ $continue k src (or ($ $const) ($ $prim)))
454 (($ $continue k src ($ $fun () ($ $cont kfun)))
455 (let ((fun-free (hashq-ref free-vars kfun)))
456 (match (cons (well-known? kfun) fun-free)
459 ($continue k src ,(if known?
460 (build-cps-exp ($const #f))
461 (build-cps-exp ($closure kfun 0))))))
463 ;; A well-known closure of one free variable is replaced
464 ;; at each use with the free variable itself, so we don't
465 ;; need a binding at all; and yet, the continuation
466 ;; expects one value, so give it something. DCE should
469 ($continue k src ,(build-cps-exp ($const #f)))))
473 src #f var kfun (well-known? kfun) fun-free
475 src var (well-known? kfun) fun-free
476 (build-cps-term ($continue k src ($values (var)))))))))))
478 (($ $continue k src ($ $call proc args))
479 (match (hashq-ref named-funs proc)
481 (convert-known-proc-call
482 proc kfun self self-known? free
484 (convert-free-vars args
488 ($callk kfun proc args))))))))
490 (convert-free-vars (cons proc args)
495 ($call proc args)))))))))
497 (($ $continue k src ($ $primcall name args))
498 (convert-free-vars args
501 ($continue k src ($primcall name args))))))
503 (($ $continue k src ($ $branch kt ($ $primcall name args)))
504 (convert-free-vars args
508 ($branch kt ($primcall name args)))))))
510 (($ $continue k src ($ $branch kt ($ $values (arg))))
511 (convert-free-var arg
515 ($branch kt ($values (arg))))))))
517 (($ $continue k src ($ $values args))
518 (convert-free-vars args
521 ($continue k src ($values args))))))
523 (($ $continue k src ($ $prompt escape? tag handler))
524 (convert-free-var tag
528 ($prompt escape? tag handler))))))))
529 (visit-cont (build-cps-cont (label ,fun)))))
531 (define (convert-closures fun)
532 "Convert free reference in @var{exp} to primcalls to @code{free-ref},
533 and allocate and initialize flat closures."
534 (let ((dfg (compute-dfg fun)))
535 (with-fresh-name-state-from-dfg dfg
536 (call-with-values (lambda () (analyze-closures fun dfg))
537 (lambda (bound-vars free-vars named-funs well-known)
538 (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
539 (aliases (make-vector (var-counter) #f)))
540 (prune-free-vars free-vars named-funs well-known aliases)
543 ,(map (lambda (label)
544 (convert-one (hashq-ref bound-vars label) label
545 (lookup-cont label dfg)
546 free-vars named-funs well-known aliases))