module/language/cps/slot-allocation.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
   4
   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.
   9 ;;;;
  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.
  14 ;;;;
  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
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; A module to assign stack slots to variables in a CPS term.
  22 ;;;
  23 ;;; Code:
  24
  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
  33             lookup-slot
  34             lookup-maybe-slot
  35             lookup-constant-value
  36             lookup-maybe-constant-value
  37             lookup-nlocals
  38             lookup-call-proc-slot
  39             lookup-parallel-moves
  40             lookup-dead-slot-map))
  41
  42 (define-record-type $allocation
  43   (make-allocation dfa slots
  44                    has-constv constant-values
  45                    call-allocations
  46                    nlocals)
  47   allocation?
  48
  49   ;; A DFA records all variables bound in a function, and assigns them
  50   ;; indices.  The slot in which a variable is stored at runtime can be
  51   ;; had by indexing into the SLOTS vector with the variable's index.
  52   ;;
  53   (dfa allocation-dfa)
  54   (slots allocation-slots)
  55
  56   ;; Not all variables have slots allocated.  Variables that are
  57   ;; constant and that are only used by primcalls that can accept
  58   ;; constants directly are not allocated to slots, and their SLOT value
  59   ;; is false.  Likewise constants that are only used by calls are not
  60   ;; allocated into slots, to avoid needless copying.  If a variable is
  61   ;; constant, its constant value is set in the CONSTANT-VALUES vector
  62   ;; and the corresponding bit in the HAS-CONSTV bitvector is set.
  63   ;;
  64   (has-constv allocation-has-constv)
  65   (constant-values allocation-constant-values)
  66
  67   ;; Some continuations have additional associated information.  This
  68   ;; addition information is a /call allocation/.  Call allocations
  69   ;; record the way that functions are passed values, and how their
  70   ;; return values are rebound to local variables.
  71   ;;
  72   ;; A call allocation contains three pieces of information: the call's
  73   ;; /proc slot/, a set of /parallel moves/, and a /dead slot map/.  The
  74   ;; proc slot indicates the slot of a procedure in a procedure call, or
  75   ;; where the procedure would be in a multiple-value return.  The
  76   ;; parallel moves shuffle locals into position for a call, or shuffle
  77   ;; returned values back into place.  Though they use the same slot,
  78   ;; moves for a call are called "call moves", and moves to handle a
  79   ;; return are "return moves".  The dead slot map indicates, for a
  80   ;; call, what slots should be ignored by GC when marking the frame.
  81   ;;
  82   ;; $kreceive continuations record a proc slot and a set of return moves
  83   ;; to adapt multiple values from the stack to local variables.
  84   ;;
  85   ;; Tail calls record arg moves, but no proc slot.
  86   ;;
  87   ;; Non-tail calls record arg moves, a call slot, and a dead slot map.
  88   ;; Multiple-valued returns will have an associated $kreceive
  89   ;; continuation, which records the same proc slot, but has return
  90   ;; moves and no dead slot map.
  91   ;;
  92   ;; $prompt handlers are $kreceive continuations like any other.
  93   ;;
  94   ;; $values expressions with more than 1 value record moves but have no
  95   ;; proc slot or dead slot map.
  96   ;;
  97   ;; A set of moves is expressed as an ordered list of (SRC . DST)
  98   ;; moves, where SRC and DST are slots.  This may involve a temporary
  99   ;; variable.  A dead slot map is a bitfield, as an integer.
 100   ;;
 101   (call-allocations allocation-call-allocations)
 102
 103   ;; The number of locals for a $kclause.
 104   ;;
 105   (nlocals allocation-nlocals))
 106
 107 (define-record-type $call-allocation
 108   (make-call-allocation proc-slot moves dead-slot-map)
 109   call-allocation?
 110   (proc-slot call-allocation-proc-slot)
 111   (moves call-allocation-moves)
 112   (dead-slot-map call-allocation-dead-slot-map))
 113
 114 (define (find-first-zero n)
 115   ;; Naive implementation.
 116   (let lp ((slot 0))
 117     (if (logbit? slot n)
 118         (lp (1+ slot))
 119         slot)))
 120
 121 (define (find-first-trailing-zero n)
 122   (let lp ((slot (let lp ((count 2))
 123                    (if (< n (ash 1 (1- count)))
 124                        count
 125                        ;; Grow upper bound slower than factor 2 to avoid
 126                        ;; needless bignum allocation on 32-bit systems
 127                        ;; when there are more than 16 locals.
 128                        (lp (+ count (ash count -1)))))))
 129     (if (or (zero? slot) (logbit? (1- slot) n))
 130         slot
 131         (lp (1- slot)))))
 132
 133 (define (lookup-maybe-slot sym allocation)
 134   (match allocation
 135     (($ $allocation dfa slots)
 136      (vector-ref slots (dfa-var-idx dfa sym)))))
 137
 138 (define (lookup-slot sym allocation)
 139   (or (lookup-maybe-slot sym allocation)
 140       (error "Variable not allocated to a slot" sym)))
 141
 142 (define (lookup-constant-value sym allocation)
 143   (match allocation
 144     (($ $allocation dfa slots has-constv constant-values)
 145      (let ((idx (dfa-var-idx dfa sym)))
 146        (if (bitvector-ref has-constv idx)
 147            (vector-ref constant-values idx)
 148            (error "Variable does not have constant value" sym))))))
 149
 150 (define (lookup-maybe-constant-value sym allocation)
 151   (match allocation
 152     (($ $allocation dfa slots has-constv constant-values)
 153      (let ((idx (dfa-var-idx dfa sym)))
 154        (values (bitvector-ref has-constv idx)
 155                (vector-ref constant-values idx))))))
 156
 157 (define (lookup-call-allocation k allocation)
 158   (or (hashq-ref (allocation-call-allocations allocation) k)
 159       (error "Continuation not a call" k)))
 160
 161 (define (lookup-call-proc-slot k allocation)
 162   (or (call-allocation-proc-slot (lookup-call-allocation k allocation))
 163       (error "Call has no proc slot" k)))
 164
 165 (define (lookup-parallel-moves k allocation)
 166   (or (call-allocation-moves (lookup-call-allocation k allocation))
 167       (error "Call has no use parallel moves slot" k)))
 168
 169 (define (lookup-dead-slot-map k allocation)
 170   (or (call-allocation-dead-slot-map (lookup-call-allocation k allocation))
 171       (error "Call has no dead slot map" k)))
 172
 173 (define (lookup-nlocals k allocation)
 174   (or (hashq-ref (allocation-nlocals allocation) k)
 175       (error "Not a clause continuation" k)))
 176
 177 (define (solve-parallel-move src dst tmp)
 178   "Solve the parallel move problem between src and dst slot lists, which
 179 are comparable with eqv?.  A tmp slot may be used."
 180
 181   ;; This algorithm is taken from: "Tilting at windmills with Coq:
 182   ;; formal verification of a compilation algorithm for parallel moves"
 183   ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
 184   ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
 185
 186   (define (split-move moves reg)
 187     (let loop ((revhead '()) (tail moves))
 188       (match tail
 189         (((and s+d (s . d)) . rest)
 190          (if (eqv? s reg)
 191              (cons d (append-reverse revhead rest))
 192              (loop (cons s+d revhead) rest)))
 193         (_ #f))))
 194
 195   (define (replace-last-source reg moves)
 196     (match moves
 197       ((moves ... (s . d))
 198        (append moves (list (cons reg d))))))
 199
 200   (let loop ((to-move (map cons src dst))
 201              (being-moved '())
 202              (moved '())
 203              (last-source #f))
 204     ;; 'last-source' should always be equivalent to:
 205     ;; (and (pair? being-moved) (car (last being-moved)))
 206     (match being-moved
 207       (() (match to-move
 208             (() (reverse moved))
 209             (((and s+d (s . d)) . t1)
 210              (if (or (eqv? s d) ; idempotent
 211                      (not s))   ; src is a constant and can be loaded directly
 212                  (loop t1 '() moved #f)
 213                  (loop t1 (list s+d) moved s)))))
 214       (((and s+d (s . d)) . b)
 215        (match (split-move to-move d)
 216          ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
 217          (#f (match b
 218                (() (loop to-move '() (cons s+d moved) #f))
 219                (_ (if (eqv? d last-source)
 220                       (loop to-move
 221                             (replace-last-source tmp b)
 222                             (cons s+d (acons d tmp moved))
 223                             tmp)
 224                       (loop to-move b (cons s+d moved) last-source))))))))))
 225
 226 (define (dead-after-def? k-idx v-idx dfa)
 227   (not (bitvector-ref (dfa-k-in dfa k-idx) v-idx)))
 228
 229 (define (dead-after-use? k-idx v-idx dfa)
 230   (not (bitvector-ref (dfa-k-out dfa k-idx) v-idx)))
 231
 232 (define (allocate-slots fun dfg)
 233   (let* ((dfa (compute-live-variables fun dfg))
 234          (min-label (dfg-min-label dfg))
 235          (label-count (dfg-label-count dfg))
 236          (usev (make-vector label-count '()))
 237          (defv (make-vector label-count '()))
 238          (slots (make-vector (dfa-var-count dfa) #f))
 239          (constant-values (make-vector (dfa-var-count dfa) #f))
 240          (has-constv (make-bitvector (dfa-var-count dfa) #f))
 241          (has-slotv (make-bitvector (dfa-var-count dfa) #t))
 242          (needs-slotv (make-bitvector (dfa-var-count dfa) #t))
 243          (needs-hintv (make-bitvector (dfa-var-count dfa) #f))
 244          (call-allocations (make-hash-table))
 245          (nlocals 0)                    ; Mutable.  It pains me.
 246          (nlocals-table (make-hash-table)))
 247
 248     (define (label->idx label) (- label min-label))
 249     (define (idx->label idx) (+ idx min-label))
 250
 251     (define (bump-nlocals! nlocals*)
 252       (when (< nlocals nlocals*)
 253         (set! nlocals nlocals*)))
 254
 255     (define (empty-live-slots)
 256       #b0)
 257
 258     (define (add-live-slot slot live-slots)
 259       (logior live-slots (ash 1 slot)))
 260
 261     (define (kill-dead-slot slot live-slots)
 262       (logand live-slots (lognot (ash 1 slot))))
 263
 264     (define (compute-slot live-slots hint)
 265       ;; Slots 253-255 are reserved for shuffling; see comments in
 266       ;; assembler.scm.
 267       (if (and hint (not (logbit? hint live-slots))
 268                (or (< hint 253) (> hint 255)))
 269           hint
 270           (let ((slot (find-first-zero live-slots)))
 271             (if (or (< slot 253) (> slot 255))
 272                 slot
 273                 (+ 256 (find-first-zero (ash live-slots -256)))))))
 274
 275     (define (compute-call-proc-slot live-slots)
 276       (+ 2 (find-first-trailing-zero live-slots)))
 277
 278     (define (compute-prompt-handler-proc-slot live-slots)
 279       (if (zero? live-slots)
 280           0
 281           (1- (find-first-trailing-zero live-slots))))
 282
 283     (define (recompute-live-slots k nargs)
 284       (let ((in (dfa-k-in dfa (label->idx k))))
 285         (let lp ((v 0) (live-slots 0))
 286           (let ((v (bit-position #t in v)))
 287             (if v
 288                 (let ((slot (vector-ref slots v)))
 289                   (lp (1+ v)
 290                       (if slot
 291                           (add-live-slot slot live-slots)
 292                           live-slots)))
 293                 live-slots)))))
 294
 295     (define* (allocate! var-idx hint live)
 296       (cond
 297        ((not (bitvector-ref needs-slotv var-idx)) live)
 298        ((vector-ref slots var-idx) => (cut add-live-slot <> live))
 299        ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
 300        (else
 301         (let ((slot (compute-slot live hint)))
 302           (bump-nlocals! (1+ slot))
 303           (vector-set! slots var-idx slot)
 304           (add-live-slot slot live)))))
 305
 306     ;; Although some parallel moves may proceed without a temporary
 307     ;; slot, in general one is needed.  That temporary slot must not be
 308     ;; part of the source or destination sets, and that slot should not
 309     ;; correspond to a live variable.  Usually the source and
 310     ;; destination sets are a subset of the union of the live sets
 311     ;; before and after the move.  However for stack slots that don't
 312     ;; have names -- those slots that correspond to function arguments
 313     ;; or to function return values -- it could be that they are out of
 314     ;; the computed live set.  In that case they need to be adjoined to
 315     ;; the live set, used when choosing a temporary slot.
 316     ;;
 317     ;; Note that although we reserve slots 253-255 for shuffling
 318     ;; operands that address less than the full 24-bit range of locals,
 319     ;; that reservation doesn't apply here, because this temporary
 320     ;; itself is used while doing parallel assignment via "mov", and
 321     ;; "mov" does not need shuffling.
 322     (define (compute-tmp-slot live stack-slots)
 323       (find-first-zero (fold add-live-slot live stack-slots)))
 324
 325     (define (parallel-move src-slots dst-slots tmp-slot)
 326       (let ((moves (solve-parallel-move src-slots dst-slots tmp-slot)))
 327         (when (assv tmp-slot moves)
 328           (bump-nlocals! (1+ tmp-slot)))
 329         moves))
 330
 331     ;; Find variables that are actually constant, and determine which
 332     ;; of those can avoid slot allocation.
 333     (define (compute-constants!)
 334       (let lp ((n 0))
 335         (when (< n (vector-length constant-values))
 336           (let ((sym (dfa-var-sym dfa n)))
 337             (call-with-values (lambda () (find-constant-value sym dfg))
 338               (lambda (has-const? const)
 339                 (when has-const?
 340                   (bitvector-set! has-constv n has-const?)
 341                   (vector-set! constant-values n const)
 342                   (when (not (constant-needs-allocation? sym const dfg))
 343                     (bitvector-set! needs-slotv n #f)))
 344                 (lp (1+ n))))))))
 345
 346     ;; Record uses and defs, as lists of variable indexes, indexed by
 347     ;; label index.
 348     (define (compute-uses-and-defs!)
 349       (let lp ((n 0))
 350         (when (< n (vector-length usev))
 351           (match (lookup-cont (idx->label n) dfg)
 352             (($ $kfun src meta self)
 353              (vector-set! defv n (list (dfa-var-idx dfa self))))
 354             (($ $kargs names syms body)
 355              (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
 356              (vector-set! usev n
 357                           (map (cut dfa-var-idx dfa <>)
 358                                (match (find-expression body)
 359                                  (($ $call proc args)
 360                                   (cons proc args))
 361                                  (($ $callk k proc args)
 362                                   (cons proc args))
 363                                  (($ $primcall name args)
 364                                   args)
 365                                  (($ $values args)
 366                                   args)
 367                                  (($ $prompt escape? tag handler)
 368                                   (list tag))
 369                                  (_ '())))))
 370             (_ #f))
 371           (lp (1+ n)))))
 372
 373     ;; Results of function calls that are not used don't need to be
 374     ;; allocated to slots.
 375     (define (compute-unused-results!)
 376       (define (kreceive-get-kargs kreceive)
 377         (match (lookup-cont kreceive dfg)
 378           (($ $kreceive arity kargs) kargs)
 379           (_ #f)))
 380       (let ((candidates (make-bitvector label-count #f)))
 381         ;; Find all $kargs that are the successors of $kreceive nodes.
 382         (let lp ((n 0))
 383           (when (< n label-count)
 384             (and=> (kreceive-get-kargs (idx->label n))
 385                    (lambda (kargs)
 386                      (bitvector-set! candidates (label->idx kargs) #t)))
 387             (lp (1+ n))))
 388         ;; For $kargs that only have $kreceive predecessors, remove unused
 389         ;; variables from the needs-slotv set.
 390         (let lp ((n 0))
 391           (let ((n (bit-position #t candidates n)))
 392             (when n
 393               (match (lookup-predecessors (idx->label n) dfg)
 394                 ;; At least one kreceive is in the predecessor set, so we
 395                 ;; only need to do the check for nodes with >1
 396                 ;; predecessor.
 397                 ((or (_) ((? kreceive-get-kargs) ...))
 398                  (for-each (lambda (var)
 399                              (when (dead-after-def? n var dfa)
 400                                (bitvector-set! needs-slotv var #f)))
 401                            (vector-ref defv n)))
 402                 (_ #f))
 403               (lp (1+ n)))))))
 404
 405     ;; Compute the set of variables whose allocation should be delayed
 406     ;; until a "hint" is known about where to allocate them.  This is
 407     ;; the case for some procedure arguments.
 408     ;;
 409     ;; This algorithm used is a conservative approximation of what
 410     ;; really should happen, which would be eager allocation of call
 411     ;; frames as soon as it's known that a call will happen.  It would
 412     ;; be nice to recast this as a proper data-flow problem.
 413     (define (compute-needs-hint!)
 414       (define (live-before n)
 415         (dfa-k-in dfa n))
 416       (define (live-after n)
 417         (dfa-k-out dfa n))
 418
 419       ;; Walk backwards.  At a call, compute the set of variables that
 420       ;; have allocated slots and are live before but not after.  This
 421       ;; set contains candidates for needs-hintv.
 422       (define (scan-for-call n)
 423         (when (<= 0 n)
 424           (match (lookup-cont (idx->label n) dfg)
 425             (($ $kargs names syms body)
 426              (match (find-expression body)
 427                ((or ($ $call) ($ $callk))
 428                 (let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
 429                   (bit-set*! args (live-before n) #t)
 430                   (bit-set*! args (live-after n) #f)
 431                   (bit-set*! args no-slot-needed #f)
 432                   (if (bit-position #t args 0)
 433                       (scan-for-hints (1- n) args)
 434                       (scan-for-call (1- n)))))
 435                (_ (scan-for-call (1- n)))))
 436             (_ (scan-for-call (1- n))))))
 437
 438       ;; Walk backwards in the current basic block.  Stop when the block
 439       ;; ends, we reach a call, or when an expression kills a value.
 440       (define (scan-for-hints n args)
 441         (when (< 0 n)
 442           (match (lookup-cont (idx->label n) dfg)
 443             (($ $kargs names syms body)
 444              (match (lookup-predecessors (idx->label (1+ n)) dfg)
 445                (((? (cut eqv? <> (idx->label n))))
 446                 ;; If we are indeed in the same basic block, then if we
 447                 ;; are finished with the scan, we kill uses of the
 448                 ;; terminator, but leave its definitions.
 449                 (match (find-expression body)
 450                   ((or ($ $void) ($ $const) ($ $prim) ($ $closure)
 451                        ($ $primcall) ($ $prompt)
 452                        ;; If $values has more than one argument, it may
 453                        ;; use a temporary, which would invalidate our
 454                        ;; assumptions that slots not allocated are not
 455                        ;; used.
 456                        ($ $values (or () (_))))
 457                    (let ((dead (make-bitvector (bitvector-length args) #f)))
 458                      (bit-set*! dead (live-before n) #t)
 459                      (bit-set*! dead (live-after n) #f)
 460                      (bit-set*! dead no-slot-needed #f)
 461                      (if (bit-position #t dead 0)
 462                          (finish-hints n (live-before n) args)
 463                          (scan-for-hints (1- n) args))))
 464                   ((or ($ $call) ($ $callk) ($ $values))
 465                    (finish-hints n (live-before n) args))))
 466                ;; Otherwise we kill uses of the block entry.
 467                (_ (finish-hints n (live-before (1+ n)) args))))
 468             (_ (finish-hints n (live-before (1+ n)) args)))))
 469
 470       ;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
 471       ;; looking for calls.
 472       (define (finish-hints n kill args)
 473         (bit-invert! args)
 474         (bit-set*! args kill #t)
 475         (bit-invert! args)
 476         (bit-set*! needs-hintv args #t)
 477         (scan-for-call n))
 478
 479       (define no-slot-needed
 480         (make-bitvector (bitvector-length needs-slotv) #f))
 481
 482       (bit-set*! no-slot-needed needs-slotv #t)
 483       (bit-invert! no-slot-needed)
 484       (scan-for-call (1- label-count)))
 485
 486     (define (allocate-call label k uses pre-live post-live)
 487       (match (lookup-cont k dfg)
 488         (($ $ktail)
 489          (let* ((tail-nlocals (length uses))
 490                 (tail-slots (iota tail-nlocals))
 491                 (pre-live (fold allocate! pre-live uses tail-slots))
 492                 (moves (parallel-move (map (cut vector-ref slots <>) uses)
 493                                       tail-slots
 494                                       (compute-tmp-slot pre-live tail-slots))))
 495            (bump-nlocals! tail-nlocals)
 496            (hashq-set! call-allocations label
 497                        (make-call-allocation #f moves #f))))
 498         (($ $kreceive arity kargs)
 499          (let* ((proc-slot (compute-call-proc-slot post-live))
 500                 (call-slots (map (cut + proc-slot <>) (iota (length uses))))
 501                 (pre-live (fold allocate! pre-live uses call-slots))
 502                 (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
 503                                           call-slots
 504                                           (compute-tmp-slot pre-live
 505                                                             call-slots)))
 506                 (result-vars (vector-ref defv (label->idx kargs)))
 507                 (value-slots (map (cut + proc-slot 1 <>)
 508                                   (iota (length result-vars))))
 509                 ;; Shuffle the first result down to the lowest slot, and
 510                 ;; leave any remaining results where they are.  This
 511                 ;; strikes a balance between avoiding shuffling,
 512                 ;; especially for unused extra values, and avoiding
 513                 ;; frame size growth due to sparse locals.
 514                 (result-live (match (cons result-vars value-slots)
 515                                ((() . ()) post-live)
 516                                (((var . vars) . (slot . slots))
 517                                 (fold allocate!
 518                                       (allocate! var #f post-live)
 519                                       vars slots))))
 520                 (result-slots (map (cut vector-ref slots <>) result-vars))
 521                 ;; Filter out unused results.
 522                 (value-slots (filter-map (lambda (val result) (and result val))
 523                                          value-slots result-slots))
 524                 (result-slots (filter (lambda (x) x) result-slots))
 525                 (result-moves (parallel-move value-slots
 526                                              result-slots
 527                                              (compute-tmp-slot result-live
 528                                                                value-slots)))
 529                 (dead-slot-map (logand (1- (ash 1 (- proc-slot 2)))
 530                                        (lognot post-live))))
 531            (bump-nlocals! (+ proc-slot (length uses)))
 532            (hashq-set! call-allocations label
 533                        (make-call-allocation proc-slot arg-moves dead-slot-map))
 534            (hashq-set! call-allocations k
 535                        (make-call-allocation proc-slot result-moves #f))))
 536
 537         (_
 538          (let* ((proc-slot (compute-call-proc-slot post-live))
 539                 (call-slots (map (cut + proc-slot <>) (iota (length uses))))
 540                 (pre-live (fold allocate! pre-live uses call-slots))
 541                 (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
 542                                           call-slots
 543                                           (compute-tmp-slot pre-live
 544                                                             call-slots))))
 545            (bump-nlocals! (+ proc-slot (length uses)))
 546            (hashq-set! call-allocations label
 547                        (make-call-allocation proc-slot arg-moves #f))))))
 548
 549     (define (allocate-values label k uses pre-live post-live)
 550       (match (lookup-cont k dfg)
 551         (($ $ktail)
 552          (let* ((src-slots (map (cut vector-ref slots <>) uses))
 553                 (tail-nlocals (1+ (length uses)))
 554                 (dst-slots (cdr (iota tail-nlocals)))
 555                 (moves (parallel-move src-slots dst-slots
 556                                       (compute-tmp-slot pre-live dst-slots))))
 557            (bump-nlocals! tail-nlocals)
 558            (hashq-set! call-allocations label
 559                        (make-call-allocation #f moves #f))))
 560         (($ $kargs (_) (_))
 561          ;; When there is only one value in play, we allow the dst to be
 562          ;; hinted (see scan-for-hints).  If the src doesn't have a
 563          ;; slot, then the actual slot for the dst would end up being
 564          ;; decided by the call that uses it.  Because we don't know the
 565          ;; slot, we can't really compute the parallel moves in that
 566          ;; case, so just bail and rely on the bytecode emitter to
 567          ;; handle the one-value case specially.
 568          (match (cons uses (vector-ref defv (label->idx k)))
 569            (((src) . (dst))
 570             (allocate! dst (vector-ref slots src) post-live))))
 571         (($ $kargs)
 572          (let* ((src-slots (map (cut vector-ref slots <>) uses))
 573                 (dst-vars (vector-ref defv (label->idx k)))
 574                 (result-live (fold allocate! post-live dst-vars src-slots))
 575                 (dst-slots (map (cut vector-ref slots <>) dst-vars))
 576                 (moves (parallel-move src-slots dst-slots
 577                                       (compute-tmp-slot (logior pre-live result-live)
 578                                                         '()))))
 579            (hashq-set! call-allocations label
 580                        (make-call-allocation #f moves #f))))
 581         (($ $kif) #f)))
 582
 583     (define (allocate-prompt label k handler nargs)
 584       (match (lookup-cont handler dfg)
 585         (($ $kreceive arity kargs)
 586          (let* ((handler-live (recompute-live-slots handler nargs))
 587                 (proc-slot (compute-prompt-handler-proc-slot handler-live))
 588                 (result-vars (vector-ref defv (label->idx kargs)))
 589                 (value-slots (map (cut + proc-slot 1 <>)
 590                                   (iota (length result-vars))))
 591                 (result-live (fold allocate!
 592                                    handler-live result-vars value-slots))
 593                 (result-slots (map (cut vector-ref slots <>) result-vars))
 594                 ;; Filter out unused results.
 595                 (value-slots (filter-map (lambda (val result) (and result val))
 596                                          value-slots result-slots))
 597                 (result-slots (filter (lambda (x) x) result-slots))
 598                 (moves (parallel-move value-slots
 599                                       result-slots
 600                                       (compute-tmp-slot result-live
 601                                                         value-slots))))
 602            (bump-nlocals! (+ proc-slot 1 (length result-vars)))
 603            (hashq-set! call-allocations handler
 604                        (make-call-allocation proc-slot moves #f))))))
 605
 606     (define (allocate-defs! n live)
 607       (fold (cut allocate! <> #f <>) live (vector-ref defv n)))
 608
 609     ;; This traversal will visit definitions before uses, as
 610     ;; definitions dominate uses and a block's dominator will appear
 611     ;; before it, in reverse post-order.
 612     (define (visit-clause n nargs live)
 613       (let lp ((n n) (live (recompute-live-slots (idx->label n) nargs)))
 614         (define (kill-dead live vars-by-label-idx pred)
 615           (fold (lambda (v live)
 616                   (let ((slot (vector-ref slots v)))
 617                     (if (and slot (pred n v dfa))
 618                         (kill-dead-slot slot live)
 619                         live)))
 620                 live
 621                 (vector-ref vars-by-label-idx n)))
 622         (define (kill-dead-defs live)
 623           (kill-dead live defv dead-after-def?))
 624         (define (kill-dead-uses live)
 625           (kill-dead live usev dead-after-use?))
 626         (if (= n label-count)
 627             n
 628             (let* ((label (idx->label n))
 629                    (live (if (control-point? label dfg)
 630                              (recompute-live-slots label nargs)
 631                              live))
 632                    (live (kill-dead-defs (allocate-defs! n live)))
 633                    (post-live (kill-dead-uses live)))
 634               ;; LIVE are the live slots coming into the term.
 635               ;; POST-LIVE is the subset that is still live after the
 636               ;; term uses its inputs.
 637               (match (lookup-cont (idx->label n) dfg)
 638                 (($ $kclause) n)
 639                 (($ $kargs names syms body)
 640                  (let ((uses (vector-ref usev n)))
 641                    (match (find-call body)
 642                      (($ $continue k src (or ($ $call) ($ $callk)))
 643                       (allocate-call label k uses live post-live))
 644                      (($ $continue k src ($ $primcall)) #t)
 645                      (($ $continue k src ($ $values))
 646                       (allocate-values label k uses live post-live))
 647                      (($ $continue k src ($ $prompt escape? tag handler))
 648                       (allocate-prompt label k handler nargs))
 649                      (_ #f)))
 650                  (lp (1+ n) post-live))
 651                 ((or ($ $kreceive) ($ $kif) ($ $ktail))
 652                  (lp (1+ n) post-live)))))))
 653
 654     (define (visit-entry)
 655       (define (visit-clauses n live)
 656         (unless (eqv? live (add-live-slot 0 (empty-live-slots)))
 657           (error "Unexpected clause live set"))
 658         (set! nlocals 1)
 659         (match (lookup-cont (idx->label n) dfg)
 660           (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
 661            (unless (eq? (idx->label (1+ n)) kbody)
 662              (error "Unexpected label order"))
 663            (let* ((nargs (length names))
 664                   (next (visit-clause (1+ n)
 665                                       nargs
 666                                       (fold allocate! live
 667                                             (vector-ref defv (1+ n))
 668                                             (cdr (iota (1+ nargs)))))))
 669              (hashq-set! nlocals-table (idx->label n) nlocals)
 670              (when (< next label-count)
 671                (match alternate
 672                  (($ $cont kalt)
 673                   (unless (eq? kalt (idx->label next))
 674                     (error "Unexpected clause order"))))
 675                (visit-clauses next live))))))
 676       (match (lookup-cont (idx->label 0) dfg)
 677         (($ $kfun src meta self)
 678          (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
 679
 680     (compute-constants!)
 681     (compute-uses-and-defs!)
 682     (compute-unused-results!)
 683     (compute-needs-hint!)
 684     (visit-entry)
 685
 686     (make-allocation dfa slots
 687                      has-constv constant-values
 688                      call-allocations
 689                      nlocals-table)))