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 ;;; A module to assign stack slots to variables in a CPS term.
25 (define-module (language cps slot-allocation)
26 #:use-module (ice-9 match)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-9)
29 #:use-module (srfi srfi-26)
30 #:use-module (language cps)
31 #:use-module (language cps dfg)
32 #:export (allocate-slots
36 lookup-maybe-constant-value
39 lookup-parallel-moves))
41 (define-record-type $allocation
42 (make-allocation dfa slots
43 has-constv constant-values
48 ;; A DFA records all variables bound in a function, and assigns them
49 ;; indices. The slot in which a variable is stored at runtime can be
50 ;; had by indexing into the SLOTS vector with the variable's index.
53 (slots allocation-slots)
55 ;; Not all variables have slots allocated. Variables that are
56 ;; constant and that are only used by primcalls that can accept
57 ;; constants directly are not allocated to slots, and their SLOT value
58 ;; is false. Likewise constants that are only used by calls are not
59 ;; allocated into slots, to avoid needless copying. If a variable is
60 ;; constant, its constant value is set in the CONSTANT-VALUES vector
61 ;; and the corresponding bit in the HAS-CONSTV bitvector is set.
63 (has-constv allocation-has-constv)
64 (constant-values allocation-constant-values)
66 ;; Some continuations have additional associated information. This
67 ;; addition information is a /call allocation/. Call allocations
68 ;; record the way that functions are passed values, and how their
69 ;; return values are rebound to local variables.
71 ;; A call allocation contains two pieces of information: the call's
72 ;; /proc slot/, and a set of /parallel moves/. The proc slot
73 ;; indicates the slot of a procedure in a procedure call, or where the
74 ;; procedure would be in a multiple-value return. The parallel moves
75 ;; shuffle locals into position for a call, or shuffle returned values
76 ;; back into place. Though they use the same slot, moves for a call
77 ;; are called "call moves", and moves to handle a return are "return
80 ;; $ktrunc continuations record a proc slot and a set of return moves
81 ;; to adapt multiple values from the stack to local variables.
83 ;; Tail calls record arg moves, but no proc slot.
85 ;; Non-tail calls record arg moves and a call slot. Multiple-valued
86 ;; returns will have an associated $ktrunc continuation, which records
87 ;; the same proc slot, but has return moves.
89 ;; $prompt handlers are $ktrunc continuations like any other.
91 ;; $values expressions with more than 1 value record moves but have no
94 ;; A set of moves is expressed as an ordered list of (SRC . DST)
95 ;; moves, where SRC and DST are slots. This may involve a temporary
98 (call-allocations allocation-call-allocations)
100 ;; The number of locals for a $kclause.
102 (nlocals allocation-nlocals))
104 (define-record-type $call-allocation
105 (make-call-allocation proc-slot moves)
107 (proc-slot call-allocation-proc-slot)
108 (moves call-allocation-moves))
110 (define (find-first-zero n)
111 ;; Naive implementation.
117 (define (find-first-trailing-zero n)
118 (let lp ((slot (let lp ((count 2))
119 (if (< n (ash 1 (1- count)))
121 ;; Grow upper bound slower than factor 2 to avoid
122 ;; needless bignum allocation on 32-bit systems
123 ;; when there are more than 16 locals.
124 (lp (+ count (ash count -1)))))))
125 (if (or (zero? slot) (logbit? (1- slot) n))
129 (define (lookup-maybe-slot sym allocation)
131 (($ $allocation dfa slots)
132 (vector-ref slots (dfa-var-idx dfa sym)))))
134 (define (lookup-slot sym allocation)
135 (or (lookup-maybe-slot sym allocation)
136 (error "Variable not allocated to a slot" sym)))
138 (define (lookup-constant-value sym allocation)
140 (($ $allocation dfa slots has-constv constant-values)
141 (let ((idx (dfa-var-idx dfa sym)))
142 (if (bitvector-ref has-constv idx)
143 (vector-ref constant-values idx)
144 (error "Variable does not have constant value" sym))))))
146 (define (lookup-maybe-constant-value sym allocation)
148 (($ $allocation dfa slots has-constv constant-values)
149 (let ((idx (dfa-var-idx dfa sym)))
150 (values (bitvector-ref has-constv idx)
151 (vector-ref constant-values idx))))))
153 (define (lookup-call-allocation k allocation)
154 (or (hashq-ref (allocation-call-allocations allocation) k)
155 (error "Continuation not a call" k)))
157 (define (lookup-call-proc-slot k allocation)
158 (or (call-allocation-proc-slot (lookup-call-allocation k allocation))
159 (error "Call has no proc slot" k)))
161 (define (lookup-parallel-moves k allocation)
162 (or (call-allocation-moves (lookup-call-allocation k allocation))
163 (error "Call has no use parallel moves slot" k)))
165 (define (lookup-nlocals k allocation)
166 (or (hashq-ref (allocation-nlocals allocation) k)
167 (error "Not a clause continuation" k)))
169 (define (solve-parallel-move src dst tmp)
170 "Solve the parallel move problem between src and dst slot lists, which
171 are comparable with eqv?. A tmp slot may be used."
173 ;; This algorithm is taken from: "Tilting at windmills with Coq:
174 ;; formal verification of a compilation algorithm for parallel moves"
175 ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
176 ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
178 (define (split-move moves reg)
179 (let loop ((revhead '()) (tail moves))
181 (((and s+d (s . d)) . rest)
183 (cons d (append-reverse revhead rest))
184 (loop (cons s+d revhead) rest)))
187 (define (replace-last-source reg moves)
190 (append moves (list (cons reg d))))))
192 (let loop ((to-move (map cons src dst))
196 ;; 'last-source' should always be equivalent to:
197 ;; (and (pair? being-moved) (car (last being-moved)))
201 (((and s+d (s . d)) . t1)
202 (if (or (eqv? s d) ; idempotent
203 (not s)) ; src is a constant and can be loaded directly
204 (loop t1 '() moved #f)
205 (loop t1 (list s+d) moved s)))))
206 (((and s+d (s . d)) . b)
207 (match (split-move to-move d)
208 ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
210 (() (loop to-move '() (cons s+d moved) #f))
211 (_ (if (eqv? d last-source)
213 (replace-last-source tmp b)
214 (cons s+d (acons d tmp moved))
216 (loop to-move b (cons s+d moved) last-source))))))))))
218 (define (dead-after-def? def-k v-idx dfa)
219 (let ((l (dfa-k-idx dfa def-k)))
220 (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
222 (define (dead-after-use? use-k v-idx dfa)
223 (let ((l (dfa-k-idx dfa use-k)))
224 (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
226 (define (allocate-slots fun dfg)
227 (let* ((dfa (compute-live-variables fun dfg))
228 (cfa (analyze-control-flow fun dfg))
229 (usev (make-vector (cfa-k-count cfa) '()))
230 (defv (make-vector (cfa-k-count cfa) '()))
231 (contv (make-vector (cfa-k-count cfa) #f))
232 (slots (make-vector (dfa-var-count dfa) #f))
233 (constant-values (make-vector (dfa-var-count dfa) #f))
234 (has-constv (make-bitvector (dfa-var-count dfa) #f))
235 (has-slotv (make-bitvector (dfa-var-count dfa) #t))
236 (needs-slotv (make-bitvector (dfa-var-count dfa) #t))
237 (needs-hintv (make-bitvector (dfa-var-count dfa) #f))
238 (call-allocations (make-hash-table))
239 (nlocals 0) ; Mutable. It pains me.
240 (nlocals-table (make-hash-table)))
242 (define (bump-nlocals! nlocals*)
243 (when (< nlocals nlocals*)
244 (set! nlocals nlocals*)))
246 (define (empty-live-slots)
249 (define (add-live-slot slot live-slots)
250 (logior live-slots (ash 1 slot)))
252 (define (kill-dead-slot slot live-slots)
253 (logand live-slots (lognot (ash 1 slot))))
255 (define (compute-slot live-slots hint)
256 (if (and hint (not (logbit? hint live-slots)))
258 (find-first-zero live-slots)))
260 (define (compute-call-proc-slot live-slots)
261 (+ 2 (find-first-trailing-zero live-slots)))
263 (define (compute-prompt-handler-proc-slot live-slots)
264 (1- (find-first-trailing-zero live-slots)))
266 (define (recompute-live-slots k nargs)
267 (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
268 (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
269 (let ((v (bit-position #t in v)))
271 (let ((slot (vector-ref slots v)))
274 (add-live-slot slot live-slots)
278 (define* (allocate! var-idx hint live)
280 ((not (bitvector-ref needs-slotv var-idx)) live)
281 ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
282 ((vector-ref slots var-idx) => (cut add-live-slot <> live))
284 (let ((slot (compute-slot live hint)))
285 (bump-nlocals! (1+ slot))
286 (vector-set! slots var-idx slot)
287 (add-live-slot slot live)))))
289 ;; Although some parallel moves may proceed without a temporary
290 ;; slot, in general one is needed. That temporary slot must not be
291 ;; part of the source or destination sets, and that slot should not
292 ;; correspond to a live variable. Usually the source and
293 ;; destination sets are a subset of the union of the live sets
294 ;; before and after the move. However for stack slots that don't
295 ;; have names -- those slots that correspond to function arguments
296 ;; or to function return values -- it could be that they are out of
297 ;; the computed live set. In that case they need to be adjoined to
298 ;; the live set, used when choosing a temporary slot.
299 (define (compute-tmp-slot live stack-slots)
300 (find-first-zero (fold add-live-slot live stack-slots)))
302 (define (parallel-move src-slots dst-slots tmp-slot)
303 (let ((moves (solve-parallel-move src-slots dst-slots tmp-slot)))
304 (when (assv tmp-slot moves)
305 (bump-nlocals! (1+ tmp-slot)))
308 ;; Find variables that are actually constant, and determine which
309 ;; of those can avoid slot allocation.
310 (define (compute-constants!)
312 (when (< n (vector-length constant-values))
313 (let ((sym (dfa-var-sym dfa n)))
314 (call-with-values (lambda () (find-constant-value sym dfg))
315 (lambda (has-const? const)
317 (bitvector-set! has-constv n has-const?)
318 (vector-set! constant-values n const)
319 (when (not (constant-needs-allocation? sym const dfg))
320 (bitvector-set! needs-slotv n #f)))
323 ;; Transform the DFG's continuation table to a vector, for easy
325 (define (compute-conts!)
326 (let ((cont-table (dfg-cont-table dfg)))
328 (when (< n (vector-length contv))
329 (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) cont-table))
332 ;; Record uses and defs, as lists of variable indexes, indexed by
333 ;; CFA continuation index.
334 (define (compute-uses-and-defs!)
336 (when (< n (vector-length usev))
337 (match (vector-ref contv n)
339 (vector-set! defv n (list (dfa-var-idx dfa self))))
340 (($ $kargs names syms body)
341 (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
343 (map (cut dfa-var-idx dfa <>)
344 (match (find-expression body)
347 (($ $primcall name args)
351 (($ $prompt escape? tag handler)
357 ;; Results of function calls that are not used don't need to be
358 ;; allocated to slots.
359 (define (compute-unused-results!)
360 (define (ktrunc-get-kargs n)
361 (match (vector-ref contv n)
362 (($ $ktrunc arity kargs) (cfa-k-idx cfa kargs))
364 (let ((candidates (make-bitvector (vector-length contv) #f)))
365 ;; Find all $kargs that are the successors of $ktrunc nodes.
367 (when (< n (vector-length contv))
368 (and=> (ktrunc-get-kargs n)
370 (bitvector-set! candidates kargs #t)))
372 ;; For $kargs that only have $ktrunc predecessors, remove unused
373 ;; variables from the needs-slotv set.
375 (let ((n (bit-position #t candidates n)))
377 (match (cfa-predecessors cfa n)
378 ;; At least one ktrunc is in the predecessor set, so we
379 ;; only need to do the check for nodes with >1
381 ((or (_) ((? ktrunc-get-kargs) ...))
382 (for-each (lambda (var)
383 (when (dead-after-def? (cfa-k-sym cfa n) var dfa)
384 (bitvector-set! needs-slotv var #f)))
385 (vector-ref defv n)))
389 ;; Compute the set of variables whose allocation should be delayed
390 ;; until a "hint" is known about where to allocate them. This is
391 ;; the case for some procedure arguments.
393 ;; This algorithm used is a conservative approximation of what
394 ;; really should happen, which would be eager allocation of call
395 ;; frames as soon as it's known that a call will happen. It would
396 ;; be nice to recast this as a proper data-flow problem.
397 (define (compute-needs-hint!)
398 ;; We traverse the graph using reverse-post-order on a forward
399 ;; control-flow graph, but we did the live variable analysis in
400 ;; the opposite direction -- so the continuation numbers don't
401 ;; correspond. This helper adapts them.
402 (define (cfa-k-idx->dfa-k-idx n)
403 (dfa-k-idx dfa (cfa-k-sym cfa n)))
405 (define (live-before n)
406 (dfa-k-in dfa (cfa-k-idx->dfa-k-idx n)))
407 (define (live-after n)
408 (dfa-k-out dfa (cfa-k-idx->dfa-k-idx n)))
410 ;; Walk backwards. At a call, compute the set of variables that
411 ;; have allocated slots and are live before but not after. This
412 ;; set contains candidates for needs-hintv.
413 (define (scan-for-call n)
415 (match (vector-ref contv n)
416 (($ $kargs names syms body)
417 (match (find-expression body)
419 (let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
420 (bit-set*! args (live-before n) #t)
421 (bit-set*! args (live-after n) #f)
422 (bit-set*! args no-slot-needed #f)
423 (if (bit-position #t args 0)
424 (scan-for-hints (1- n) args)
425 (scan-for-call (1- n)))))
426 (_ (scan-for-call (1- n)))))
427 (_ (scan-for-call (1- n))))))
429 ;; Walk backwards in the current basic block. Stop when the block
430 ;; ends, we reach a call, or when an expression kills a value.
431 (define (scan-for-hints n args)
433 (match (vector-ref contv n)
434 (($ $kargs names syms body)
435 (match (cfa-predecessors cfa (1+ n))
436 (((? (cut eqv? <> n)))
437 ;; If we are indeed in the same basic block, then if we
438 ;; are finished with the scan, we kill uses of the
439 ;; terminator, but leave its definitions.
440 (match (find-expression body)
441 ((or ($ $void) ($ $const) ($ $prim) ($ $fun)
442 ($ $primcall) ($ $prompt))
443 (let ((dead (make-bitvector (bitvector-length args) #f)))
444 (bit-set*! dead (live-before n) #t)
445 (bit-set*! dead (live-after n) #f)
446 (bit-set*! dead no-slot-needed #f)
447 (if (bit-position #t dead 0)
448 (finish-hints n (live-before n) args)
449 (scan-for-hints (1- n) args))))
450 ((or ($ $call) ($ $values))
451 (finish-hints n (live-before n) args))))
452 ;; Otherwise we kill uses of the block entry.
453 (_ (finish-hints n (live-before (1+ n)) args))))
454 (_ (finish-hints n (live-before (1+ n)) args)))))
456 ;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
457 ;; looking for calls.
458 (define (finish-hints n kill args)
460 (bit-set*! args kill #t)
462 (bit-set*! needs-hintv args #t)
465 (define no-slot-needed
466 (make-bitvector (bitvector-length needs-slotv) #f))
468 (bit-set*! no-slot-needed needs-slotv #t)
469 (bit-invert! no-slot-needed)
470 (scan-for-call (1- (vector-length contv))))
472 (define (allocate-call label k uses pre-live post-live)
473 (match (vector-ref contv (cfa-k-idx cfa k))
475 (let* ((tail-nlocals (length uses))
476 (tail-slots (iota tail-nlocals))
477 (pre-live (fold allocate! pre-live uses tail-slots))
478 (moves (parallel-move (map (cut vector-ref slots <>) uses)
480 (compute-tmp-slot pre-live tail-slots))))
481 (bump-nlocals! tail-nlocals)
482 (hashq-set! call-allocations label
483 (make-call-allocation #f moves))))
484 (($ $ktrunc arity kargs)
485 (let* ((proc-slot (compute-call-proc-slot post-live))
486 (call-slots (map (cut + proc-slot <>) (iota (length uses))))
487 (pre-live (fold allocate! pre-live uses call-slots))
488 (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
490 (compute-tmp-slot pre-live
492 (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
493 (value-slots (map (cut + proc-slot 1 <>)
494 (iota (length result-vars))))
495 (result-live (fold allocate!
496 post-live result-vars value-slots))
497 (result-slots (map (cut vector-ref slots <>) result-vars))
498 ;; Filter out unused results.
499 (value-slots (filter-map (lambda (val result) (and result val))
500 value-slots result-slots))
501 (result-slots (filter (lambda (x) x) result-slots))
502 (result-moves (parallel-move value-slots
504 (compute-tmp-slot result-live
506 (bump-nlocals! (+ proc-slot (length uses)))
507 (hashq-set! call-allocations label
508 (make-call-allocation proc-slot arg-moves))
509 (hashq-set! call-allocations k
510 (make-call-allocation proc-slot result-moves))))
513 (let* ((proc-slot (compute-call-proc-slot post-live))
514 (call-slots (map (cut + proc-slot <>) (iota (length uses))))
515 (pre-live (fold allocate! pre-live uses call-slots))
516 (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
518 (compute-tmp-slot pre-live
520 (bump-nlocals! (+ proc-slot (length uses)))
521 (hashq-set! call-allocations label
522 (make-call-allocation proc-slot arg-moves))))))
524 (define (allocate-values label k uses pre-live post-live)
525 (let* ((src-slots (map (cut vector-ref slots <>) uses))
526 (dst-slots (match (vector-ref contv (cfa-k-idx cfa k))
528 (let ((tail-nlocals (1+ (length uses))))
529 (bump-nlocals! tail-nlocals)
530 (cdr (iota tail-nlocals))))
532 (let ((dst-vars (vector-ref defv (cfa-k-idx cfa k))))
533 (fold allocate! post-live dst-vars src-slots)
534 (map (cut vector-ref slots <>) dst-vars)))))
535 (moves (parallel-move src-slots
537 (compute-tmp-slot pre-live dst-slots))))
538 (hashq-set! call-allocations label
539 (make-call-allocation #f moves))))
541 (define (allocate-prompt label k handler nargs)
542 (match (vector-ref contv (cfa-k-idx cfa handler))
543 (($ $ktrunc arity kargs)
544 (let* ((handler-live (recompute-live-slots handler nargs))
545 (proc-slot (compute-prompt-handler-proc-slot handler-live))
546 (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
547 (value-slots (map (cut + proc-slot 1 <>)
548 (iota (length result-vars))))
549 (result-live (fold allocate!
550 handler-live result-vars value-slots))
551 (result-slots (map (cut vector-ref slots <>) result-vars))
552 ;; Filter out unused results.
553 (value-slots (filter-map (lambda (val result) (and result val))
554 value-slots result-slots))
555 (result-slots (filter (lambda (x) x) result-slots))
556 (moves (parallel-move value-slots
558 (compute-tmp-slot result-live
560 (bump-nlocals! (+ proc-slot 1 (length result-vars)))
561 (hashq-set! call-allocations handler
562 (make-call-allocation proc-slot moves))))))
564 (define (allocate-defs! n live)
565 (fold (cut allocate! <> #f <>) live (vector-ref defv n)))
567 ;; This traversal will visit definitions before uses, as
568 ;; definitions dominate uses and a block's dominator will appear
569 ;; before it, in reverse post-order.
570 (define (visit-clause n nargs live)
571 (let lp ((n n) (live live))
572 (define (kill-dead live vars-by-cfa-idx pred)
573 (fold (lambda (v live)
574 (let ((slot (vector-ref slots v)))
577 (pred (cfa-k-sym cfa n) v dfa))
578 (kill-dead-slot slot live)
581 (vector-ref vars-by-cfa-idx n)))
582 (define (kill-dead-defs live)
583 (kill-dead live defv dead-after-def?))
584 (define (kill-dead-uses live)
585 (kill-dead live usev dead-after-use?))
586 (if (= n (cfa-k-count cfa))
588 (let* ((label (cfa-k-sym cfa n))
589 (live (if (control-point? label dfg)
590 (recompute-live-slots label nargs)
592 (live (kill-dead-defs (allocate-defs! n live)))
593 (post-live (kill-dead-uses live)))
594 ;; LIVE are the live slots coming into the term.
595 ;; POST-LIVE is the subset that is still live after the
596 ;; term uses its inputs.
597 (match (vector-ref contv n)
599 (($ $kargs names syms body)
600 (let ((uses (vector-ref usev n)))
601 (match (find-call body)
602 (($ $continue k src ($ $call))
603 (allocate-call label k uses live post-live))
604 (($ $continue k src ($ $primcall)) #t)
605 ;; We only need to make a call allocation if there
606 ;; are two or more values.
607 (($ $continue k src ($ $values (_ _ . _)))
608 (allocate-values label k uses live post-live))
609 (($ $continue k src ($ $values)) #t)
610 (($ $continue k src ($ $prompt escape? tag handler))
611 (allocate-prompt label k handler nargs))
613 (lp (1+ n) post-live))
614 ((or ($ $ktrunc) ($ $kif) ($ $ktail))
615 (lp (1+ n) post-live)))))))
617 (define (visit-entry)
618 (define (visit-clauses n live)
619 (unless (eqv? live (add-live-slot 0 (empty-live-slots)))
620 (error "Unexpected clause live set"))
622 (match (vector-ref contv n)
623 (($ $kclause arity ($ $cont kbody ($ $kargs names)))
624 (unless (eq? (cfa-k-sym cfa (1+ n)) kbody)
625 (error "Unexpected CFA order"))
626 (let* ((nargs (length names))
627 (next (visit-clause (1+ n)
630 (vector-ref defv (1+ n))
631 (cdr (iota (1+ nargs)))))))
632 (hashq-set! nlocals-table (cfa-k-sym cfa n) nlocals)
633 (when (< next (cfa-k-count cfa))
634 (visit-clauses next live))))))
635 (match (vector-ref contv 0)
637 (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
641 (compute-uses-and-defs!)
642 (compute-unused-results!)
643 (compute-needs-hint!)
646 (make-allocation dfa slots
647 has-constv constant-values