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