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