module/language/cps/slot-allocation.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 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-constant-value
  35             lookup-maybe-constant-value
  36             lookup-nlocals
  37             lookup-call-proc-slot
  38             lookup-parallel-moves))
  39
  40 ;; Continuations can bind variables.  The $allocation structure
  41 ;; represents the slot in which a variable is stored.
  42 ;;
  43 ;; Not all variables have slots allocated.  Variables that are constant
  44 ;; and that are only used by primcalls that can accept constants
  45 ;; directly are not allocated to slots, and their SLOT value is false.
  46 ;; Likewise constants that are only used by calls are not allocated into
  47 ;; slots, to avoid needless copying.  If a variable is constant, its
  48 ;; constant value is set to the CONST slot and HAS-CONST? is set to a
  49 ;; true value.
  50 ;;
  51 (define-record-type $allocation
  52   (make-allocation slot has-const? const)
  53   allocation?
  54   (slot allocation-slot)
  55   (has-const? allocation-has-const?)
  56   (const allocation-const))
  57
  58 ;; Continuations can also have associated allocation data.  For example,
  59 ;; when a call happens in a labelled continuation, we need to know what
  60 ;; slot the procedure goes in.  Likewise before branching to the target
  61 ;; continuation, we might need to shuffle values into the right place: a
  62 ;; parallel move.  $cont-allocation stores allocation data keyed on the
  63 ;; continuation label.
  64 (define-record-type $cont-allocation
  65   (make-cont-allocation call-proc-slot parallel-moves)
  66   cont-allocation?
  67
  68   ;; Currently calls are allocated in the caller frame, above all locals
  69   ;; that are live at the time of the call.  Therefore there is no
  70   ;; parallel move problem.  We could be more clever here.
  71   ;;
  72   ;; $prompt expressions also use this call slot to indicate where the
  73   ;; handler's arguments are expected, but without reserving space for a
  74   ;; frame or for the procedure slot.
  75   (call-proc-slot cont-call-proc-slot)
  76
  77   ;; Tail calls, multiple-value returns, and jumps to continuations with
  78   ;; multiple arguments are forms of parallel assignment.  A
  79   ;; $parallel-move represents a specific solution to the parallel
  80   ;; assignment problem, with an ordered list of (SRC . DST) moves.  This
  81   ;; may involve a temporary variable.
  82   ;;
  83   ;; ((src . dst) ...)
  84   (parallel-moves cont-parallel-moves))
  85
  86 (define (find-first-zero n)
  87   ;; Naive implementation.
  88   (let lp ((slot 0))
  89     (if (logbit? slot n)
  90         (lp (1+ slot))
  91         slot)))
  92
  93 (define (find-first-trailing-zero n count)
  94   (let lp ((slot count))
  95     (if (or (zero? slot) (logbit? (1- slot) n))
  96         slot
  97         (lp (1- slot)))))
  98
  99 (define (lookup-allocation sym allocation)
 100   (let ((res (hashq-ref allocation sym)))
 101     (unless res
 102       (error "Variable or continuation not defined" sym))
 103     res))
 104
 105 (define (lookup-slot sym allocation)
 106   (match (lookup-allocation sym allocation)
 107     (($ $allocation slot has-const? const) slot)))
 108
 109 (define (lookup-constant-value sym allocation)
 110   (match (lookup-allocation sym allocation)
 111     (($ $allocation slot #t const) const)
 112     (_
 113      (error "Variable does not have constant value" sym))))
 114
 115 (define (lookup-maybe-constant-value sym allocation)
 116   (match (lookup-allocation sym allocation)
 117     (($ $allocation slot has-const? const)
 118      (values has-const? const))))
 119
 120 (define (lookup-call-proc-slot k allocation)
 121   (match (lookup-allocation k allocation)
 122     (($ $cont-allocation proc-slot parallel-moves)
 123      (unless proc-slot
 124        (error "Continuation not a call" k))
 125      proc-slot)
 126     (_
 127      (error "Continuation not a call" k))))
 128
 129 (define (lookup-nlocals k allocation)
 130   (match (lookup-allocation k allocation)
 131     ((? number? nlocals) nlocals)
 132     (_
 133      (error "Not a clause continuation" k))))
 134
 135 (define (lookup-parallel-moves k allocation)
 136   (match (lookup-allocation k allocation)
 137     (($ $cont-allocation proc-slot parallel-moves)
 138      (unless parallel-moves
 139        (error "Continuation does not have parallel moves" k))
 140      parallel-moves)
 141     (_
 142      (error "Continuation not a call" k))))
 143
 144 (define (solve-parallel-move src dst tmp)
 145   "Solve the parallel move problem between src and dst slot lists, which
 146 are comparable with eqv?.  A tmp slot may be used."
 147
 148   ;; This algorithm is taken from: "Tilting at windmills with Coq:
 149   ;; formal verification of a compilation algorithm for parallel moves"
 150   ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
 151   ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
 152
 153   (define (split-move moves reg)
 154     (let loop ((revhead '()) (tail moves))
 155       (match tail
 156         (((and s+d (s . d)) . rest)
 157          (if (eqv? s reg)
 158              (cons d (append-reverse revhead rest))
 159              (loop (cons s+d revhead) rest)))
 160         (_ #f))))
 161
 162   (define (replace-last-source reg moves)
 163     (match moves
 164       ((moves ... (s . d))
 165        (append moves (list (cons reg d))))))
 166
 167   (let loop ((to-move (map cons src dst))
 168              (being-moved '())
 169              (moved '())
 170              (last-source #f))
 171     ;; 'last-source' should always be equivalent to:
 172     ;; (and (pair? being-moved) (car (last being-moved)))
 173     (match being-moved
 174       (() (match to-move
 175             (() (reverse moved))
 176             (((and s+d (s . d)) . t1)
 177              (if (or (eqv? s d) ; idempotent
 178                      (not s))   ; src is a constant and can be loaded directly
 179                  (loop t1 '() moved #f)
 180                  (loop t1 (list s+d) moved s)))))
 181       (((and s+d (s . d)) . b)
 182        (match (split-move to-move d)
 183          ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
 184          (#f (match b
 185                (() (loop to-move '() (cons s+d moved) #f))
 186                (_ (if (eqv? d last-source)
 187                       (loop to-move
 188                             (replace-last-source tmp b)
 189                             (cons s+d (acons d tmp moved))
 190                             tmp)
 191                       (loop to-move b (cons s+d moved) last-source))))))))))
 192
 193 (define (dead-after-def? def-k v-idx dfa)
 194   (let ((l (dfa-k-idx dfa def-k)))
 195     (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
 196
 197 (define (dead-after-use? use-k v-idx dfa)
 198   (let ((l (dfa-k-idx dfa use-k)))
 199     (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
 200
 201 (define (allocate-slots fun)
 202   (define (empty-live-slots)
 203     #b0)
 204
 205   (define (add-live-slot slot live-slots)
 206     (logior live-slots (ash 1 slot)))
 207
 208   (define (kill-dead-slot slot live-slots)
 209     (logand live-slots (lognot (ash 1 slot))))
 210
 211   (define (compute-slot live-slots hint)
 212     (if (and hint (not (logbit? hint live-slots)))
 213         hint
 214         (find-first-zero live-slots)))
 215
 216   (define (compute-call-proc-slot live-slots nlocals)
 217     (+ 3 (find-first-trailing-zero live-slots nlocals)))
 218
 219   (define (compute-prompt-handler-proc-slot live-slots nlocals)
 220     (1- (find-first-trailing-zero live-slots nlocals)))
 221
 222   (define (recompute-live-slots k slots nargs dfa)
 223     (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
 224       (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
 225         (let ((v (bit-position #t in v)))
 226           (if v
 227               (let ((slot (vector-ref slots v)))
 228                 (lp (1+ v)
 229                     (if slot
 230                         (add-live-slot slot live-slots)
 231                         live-slots)))
 232               live-slots)))))
 233
 234   (define (visit-clause clause dfg dfa allocation slots live-slots)
 235     (define nlocals (compute-slot live-slots #f))
 236     (define nargs
 237       (match clause
 238         (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
 239          (length syms))))
 240
 241     (define (allocate! sym k hint live-slots)
 242       (match (hashq-ref allocation sym)
 243         (($ $allocation slot)
 244          ;; Parallel move already allocated this one.
 245          (if slot
 246              (add-live-slot slot live-slots)
 247              live-slots))
 248         (_
 249          (call-with-values (lambda () (find-constant-value sym dfg))
 250            (lambda (has-const? const)
 251              (cond
 252               ((and has-const? (not (constant-needs-allocation? sym const dfg)))
 253                (hashq-set! allocation sym
 254                            (make-allocation #f has-const? const))
 255                live-slots)
 256               (else
 257                (let ((slot (compute-slot live-slots hint)))
 258                  (when (>= slot nlocals)
 259                    (set! nlocals (+ slot 1)))
 260                  (vector-set! slots (dfa-var-idx dfa sym) slot)
 261                  (hashq-set! allocation sym
 262                              (make-allocation slot has-const? const))
 263                  (add-live-slot slot live-slots)))))))))
 264
 265     (define (allocate-prompt-handler! k live-slots)
 266       (let ((proc-slot (compute-prompt-handler-proc-slot live-slots nlocals)))
 267         (hashq-set! allocation k
 268                     (make-cont-allocation
 269                      proc-slot
 270                      (match (hashq-ref allocation k)
 271                        (($ $cont-allocation #f moves) moves)
 272                        (#f #f))))
 273         live-slots))
 274
 275     (define (allocate-frame! k nargs live-slots)
 276       (let ((proc-slot (compute-call-proc-slot live-slots nlocals)))
 277         (set! nlocals (max nlocals (+ proc-slot 1 nargs)))
 278         (hashq-set! allocation k
 279                     (make-cont-allocation
 280                      proc-slot
 281                      (match (hashq-ref allocation k)
 282                        (($ $cont-allocation #f moves) moves)
 283                        (#f #f))))
 284         live-slots))
 285
 286     (define (parallel-move! src-k src-slots pre-live-slots post-live-slots dst-slots)
 287       (let* ((tmp-slot (find-first-zero (logior pre-live-slots post-live-slots)))
 288              (moves (solve-parallel-move src-slots dst-slots tmp-slot)))
 289         (when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
 290           (set! nlocals (+ tmp-slot 1)))
 291         (hashq-set! allocation src-k
 292                     (make-cont-allocation
 293                      (match (hashq-ref allocation src-k)
 294                        (($ $cont-allocation proc-slot #f) proc-slot)
 295                        (#f #f))
 296                      moves))
 297         post-live-slots))
 298
 299     (define (visit-cont cont label live-slots)
 300       (define (maybe-kill-definition sym live-slots)
 301         (let* ((v (dfa-var-idx dfa sym))
 302                (slot (vector-ref slots v)))
 303           (if (and slot (> slot nargs) (dead-after-def? label v dfa))
 304               (kill-dead-slot slot live-slots)
 305               live-slots)))
 306
 307       (define (maybe-recompute-live-slots live-slots)
 308         (if (control-point? label dfg)
 309             (recompute-live-slots label slots nargs dfa)
 310             live-slots))
 311
 312       (match cont
 313         (($ $kclause arity ($ $cont k src body))
 314          (visit-cont body k live-slots))
 315
 316         (($ $kargs names syms body)
 317          (visit-term body label
 318                      (maybe-recompute-live-slots
 319                       (fold maybe-kill-definition
 320                             (fold (cut allocate! <> label #f <>) live-slots syms)
 321                             syms))))
 322
 323         (($ $ktrunc) live-slots)
 324         (($ $kif) live-slots)))
 325
 326     (define (visit-term term label live-slots)
 327       (match term
 328         (($ $letk conts body)
 329          (let ((live-slots (visit-term body label live-slots)))
 330            (for-each (match-lambda
 331                       (($ $cont k src cont)
 332                        (visit-cont cont k live-slots)))
 333                      conts))
 334          live-slots)
 335
 336         (($ $continue k exp)
 337          (visit-exp exp label k live-slots))))
 338
 339     (define (visit-exp exp label k live-slots)
 340       (define (use sym live-slots)
 341         (let* ((v (dfa-var-idx dfa sym))
 342                (l (dfa-k-idx dfa label))
 343                (slot (vector-ref slots v)))
 344           (if (and slot (> slot nargs) (dead-after-use? label v dfa))
 345               (kill-dead-slot slot live-slots)
 346               live-slots)))
 347
 348       (match exp
 349         (($ $var sym)
 350          (use sym live-slots))
 351
 352         (($ $call proc args)
 353          (match (lookup-cont k (dfg-cont-table dfg))
 354            (($ $ktail)
 355             (let ((tail-nlocals (1+ (length args))))
 356               (set! nlocals (max nlocals tail-nlocals))
 357               (parallel-move! label
 358                               (map (cut lookup-slot <> allocation)
 359                                    (cons proc args))
 360                               live-slots (fold use live-slots (cons proc args))
 361                               (iota tail-nlocals))))
 362            (($ $ktrunc arity kargs)
 363             (let* ((live-slots
 364                     (fold use
 365                           (use proc
 366                                (allocate-frame! label (length args) live-slots))
 367                           args))
 368                    (proc-slot (lookup-call-proc-slot label allocation))
 369                    (dst-syms (lookup-bound-syms kargs dfg))
 370                    (nvals (length dst-syms))
 371                    (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
 372                    (live-slots* (fold (cut allocate! <> kargs <> <>)
 373                                       live-slots dst-syms src-slots))
 374                    (dst-slots (map (cut lookup-slot <> allocation)
 375                                    dst-syms)))
 376               (parallel-move! label src-slots live-slots live-slots* dst-slots)))
 377            (else
 378             (fold use
 379                   (use proc (allocate-frame! label (length args) live-slots))
 380                   args))))
 381
 382         (($ $primcall name args)
 383          (fold use live-slots args))
 384
 385         (($ $values args)
 386          (let ((live-slots* (fold use live-slots args)))
 387            (define (compute-dst-slots)
 388              (match (lookup-cont k (dfg-cont-table dfg))
 389                (($ $ktail)
 390                 (let ((tail-nlocals (1+ (length args))))
 391                   (set! nlocals (max nlocals tail-nlocals))
 392                   (cdr (iota tail-nlocals))))
 393                (_
 394                 (let* ((src-slots (map (cut lookup-slot <> allocation) args))
 395                        (dst-syms (lookup-bound-syms k dfg))
 396                        (dst-live-slots (fold (cut allocate! <> k <> <>)
 397                                              live-slots* dst-syms src-slots)))
 398                   (map (cut lookup-slot <> allocation) dst-syms)))))
 399
 400            (parallel-move! label
 401                            (map (cut lookup-slot <> allocation) args)
 402                            live-slots live-slots*
 403                            (compute-dst-slots))))
 404
 405         (($ $prompt escape? tag handler pop)
 406          (match (lookup-cont handler (dfg-cont-table dfg))
 407            (($ $ktrunc arity kargs)
 408             (let* ((live-slots (allocate-prompt-handler! label live-slots))
 409                    (proc-slot (lookup-call-proc-slot label allocation))
 410                    (dst-syms (lookup-bound-syms kargs dfg))
 411                    (nvals (length dst-syms))
 412                    (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
 413                    (live-slots* (fold (cut allocate! <> kargs <> <>)
 414                                       live-slots dst-syms src-slots))
 415                    (dst-slots (map (cut lookup-slot <> allocation)
 416                                    dst-syms)))
 417               (parallel-move! handler src-slots live-slots live-slots* dst-slots))))
 418          (use tag live-slots))
 419
 420         (_ live-slots)))
 421
 422     (match clause
 423       (($ $cont k _ body)
 424        (visit-cont body k live-slots)
 425        (hashq-set! allocation k nlocals))))
 426
 427   (match fun
 428     (($ $fun meta free ($ $cont k _ ($ $kentry self
 429                                        ($ $cont ktail _ ($ $ktail))
 430                                        clauses)))
 431      (let* ((dfg (compute-dfg fun #:global? #f))
 432             (dfa (compute-live-variables ktail dfg))
 433             (allocation (make-hash-table))
 434             (slots (make-vector (dfa-var-count dfa) #f))
 435             (live-slots (add-live-slot 0 (empty-live-slots))))
 436        (vector-set! slots (dfa-var-idx dfa self) 0)
 437        (hashq-set! allocation self (make-allocation 0 #f #f))
 438        (for-each (cut visit-clause <> dfg dfa allocation slots live-slots)
 439                  clauses)
 440        allocation))))