src/compiler/pack.lisp

   1 ;;;; This file contains the implementation-independent code for Pack
   2 ;;;; phase in the compiler. Pack is responsible for assigning TNs to
   3 ;;;; storage allocations or "register allocation".
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!C")
  15
  16 (file-comment
  17   "$Header$")
  18
  19 ;;; for debugging: Some parameters controlling which optimizations we attempt.
  20 (defvar *pack-assign-costs* t)
  21 (defvar *pack-optimize-saves* t)
  22 ;;; FIXME: Perhaps SB-FLUID should be renamed to SB-TWEAK and these should be
  23 ;;; made conditional on SB-TWEAK.
  24
  25 (declaim (ftype (function (component) index) ir2-block-count))
  26 \f
  27 ;;;; conflict determination
  28
  29 ;;; Return true if the element at the specified offset in SB has a conflict
  30 ;;; with TN:
  31 ;;; -- If an component-live TN (:component kind), then iterate over all the
  32 ;;;    blocks. If the element at Offset is used anywhere in any of the
  33 ;;;    component's blocks (always-live /= 0), then there is a conflict.
  34 ;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in
  35 ;;;    (using TN-Global-Conflicts). If the TN is live everywhere in the block
  36 ;;;    (:Live), then there is a conflict if the element at offset is used
  37 ;;;    anywhere in the block (Always-Live /= 0). Otherwise, we use the local
  38 ;;;    TN number for TN in block to find whether TN has a conflict at Offset in
  39 ;;;    that block.
  40 ;;; -- If TN is local, then we just check for a conflict in the block it is
  41 ;;;    local to.
  42 (defun offset-conflicts-in-sb (tn sb offset)
  43   (declare (type tn tn) (type finite-sb sb) (type index offset))
  44   (let ((confs (tn-global-conflicts tn))
  45         (kind (tn-kind tn)))
  46     (cond
  47      ((eq kind :component)
  48       (let ((loc-live (svref (finite-sb-always-live sb) offset)))
  49         (dotimes (i (ir2-block-count *component-being-compiled*) nil)
  50           (when (/= (sbit loc-live i) 0)
  51             (return t)))))
  52      (confs
  53       (let ((loc-confs (svref (finite-sb-conflicts sb) offset))
  54             (loc-live (svref (finite-sb-always-live sb) offset)))
  55         (do ((conf confs (global-conflicts-tn-next conf)))
  56             ((null conf)
  57              nil)
  58           (let* ((block (global-conflicts-block conf))
  59                  (num (ir2-block-number block)))
  60             (if (eq (global-conflicts-kind conf) :live)
  61                 (when (/= (sbit loc-live num) 0)
  62                   (return t))
  63                 (when (/= (sbit (svref loc-confs num)
  64                                 (global-conflicts-number conf))
  65                           0)
  66                   (return t)))))))
  67      (t
  68       (/= (sbit (svref (svref (finite-sb-conflicts sb) offset)
  69                        (ir2-block-number (tn-local tn)))
  70                 (tn-local-number tn))
  71           0)))))
  72
  73 ;;; Return true if TN has a conflict in SC at the specified offset.
  74 (defun conflicts-in-sc (tn sc offset)
  75   (declare (type tn tn) (type sc sc) (type index offset))
  76   (let ((sb (sc-sb sc)))
  77     (dotimes (i (sc-element-size sc) nil)
  78       (when (offset-conflicts-in-sb tn sb (+ offset i))
  79         (return t)))))
  80
  81 ;;; Add TN's conflicts into the conflicts for the location at Offset in SC.
  82 ;;; We iterate over each location in TN, adding to the conflicts for that
  83 ;;; location:
  84 ;;; -- If TN is a :Component TN, then iterate over all the blocks, setting
  85 ;;;    all of the local conflict bits and the always-live bit. This records a
  86 ;;;    conflict with any TN that has a LTN number in the block, as well as with
  87 ;;;    :Always-Live and :Environment TNs.
  88 ;;; -- If TN is global, then iterate over the blocks TN is live in. In
  89 ;;;    addition to setting the always-live bit to represent the conflict with
  90 ;;;    TNs live throughout the block, we also set bits in the local conflicts.
  91 ;;;    If TN is :Always-Live in the block, we set all the bits, otherwise we or
  92 ;;;    in the local conflict bits.
  93 ;;; -- If the TN is local, then we just do the block it is local to, setting
  94 ;;;    always-live and OR'ing in the local conflicts.
  95 (defun add-location-conflicts (tn sc offset)
  96   (declare (type tn tn) (type sc sc) (type index offset))
  97   (let ((confs (tn-global-conflicts tn))
  98         (sb (sc-sb sc))
  99         (kind (tn-kind tn)))
 100     (dotimes (i (sc-element-size sc))
 101       (declare (type index i))
 102       (let* ((this-offset (+ offset i))
 103              (loc-confs (svref (finite-sb-conflicts sb) this-offset))
 104              (loc-live (svref (finite-sb-always-live sb) this-offset)))
 105         (cond
 106          ((eq kind :component)
 107           (dotimes (num (ir2-block-count *component-being-compiled*) nil)
 108             (declare (type index num))
 109             (setf (sbit loc-live num) 1)
 110             (set-bit-vector (svref loc-confs num))))
 111          (confs
 112           (do ((conf confs (global-conflicts-tn-next conf)))
 113               ((null conf))
 114             (let* ((block (global-conflicts-block conf))
 115                    (num (ir2-block-number block))
 116                    (local-confs (svref loc-confs num)))
 117               (declare (type local-tn-bit-vector local-confs))
 118               (setf (sbit loc-live num) 1)
 119               (if (eq (global-conflicts-kind conf) :live)
 120                   (set-bit-vector local-confs)
 121                   (bit-ior local-confs (global-conflicts-conflicts conf) t)))))
 122          (t
 123           (let ((num (ir2-block-number (tn-local tn))))
 124             (setf (sbit loc-live num) 1)
 125             (bit-ior (the local-tn-bit-vector (svref loc-confs num))
 126                      (tn-local-conflicts tn) t))))))))
 127
 128 ;;; Return the total number of IR2 blocks in Component.
 129 (defun ir2-block-count (component)
 130   (declare (type component component))
 131   (do ((2block (block-info (block-next (component-head component)))
 132                (ir2-block-next 2block)))
 133       ((null 2block)
 134        (error "What?  No ir2 blocks have a non-nil number?"))
 135     (when (ir2-block-number 2block)
 136       (return (1+ (ir2-block-number 2block))))))
 137
 138 ;;; Ensure that the conflicts vectors for each :Finite SB are large enough
 139 ;;; for the number of blocks allocated. Also clear any old conflicts and reset
 140 ;;; the current size to the initial size.
 141 (defun init-sb-vectors (component)
 142   (let ((nblocks (ir2-block-count component)))
 143     (dolist (sb *backend-sb-list*)
 144       (unless (eq (sb-kind sb) :non-packed)
 145         (let* ((conflicts (finite-sb-conflicts sb))
 146                (always-live (finite-sb-always-live sb))
 147                (max-locs (length conflicts))
 148                (last-count (finite-sb-last-block-count sb)))
 149           (unless (zerop max-locs)
 150             (let ((current-size (length (the simple-vector
 151                                              (svref conflicts 0)))))
 152               (cond
 153                ((> nblocks current-size)
 154                 (let ((new-size (max nblocks (* current-size 2))))
 155                   (declare (type index new-size))
 156                   (dotimes (i max-locs)
 157                     (declare (type index i))
 158                     (let ((new-vec (make-array new-size)))
 159                       (let ((old (svref conflicts i)))
 160                         (declare (simple-vector old))
 161                         (dotimes (j current-size)
 162                           (declare (type index j))
 163                           (setf (svref new-vec j)
 164                                 (clear-bit-vector (svref old j)))))
 165
 166                       (do ((j current-size (1+ j)))
 167                           ((= j new-size))
 168                         (declare (type index j))
 169                         (setf (svref new-vec j)
 170                               (make-array local-tn-limit :element-type 'bit
 171                                           :initial-element 0)))
 172                       (setf (svref conflicts i) new-vec))
 173                     (setf (svref always-live i)
 174                           (make-array new-size :element-type 'bit
 175                                       :initial-element 0)))))
 176                (t
 177                 (dotimes (i (finite-sb-current-size sb))
 178                   (declare (type index i))
 179                   (let ((conf (svref conflicts i)))
 180                     (declare (simple-vector conf))
 181                     (dotimes (j last-count)
 182                       (declare (type index j))
 183                       (clear-bit-vector (svref conf j))))
 184                   (clear-bit-vector (svref always-live i)))))))
 185
 186           (setf (finite-sb-last-block-count sb) nblocks)
 187           (setf (finite-sb-current-size sb) (sb-size sb))
 188           (setf (finite-sb-last-offset sb) 0))))))
 189
 190 ;;; Expand the :Unbounded SB backing SC by either the initial size or the SC
 191 ;;; element size, whichever is larger. If Needed-Size is larger, then use that
 192 ;;; size.
 193 (defun grow-sc (sc &optional (needed-size 0))
 194   (declare (type sc sc) (type index needed-size))
 195   (let* ((sb (sc-sb sc))
 196          (size (finite-sb-current-size sb))
 197          (align-mask (1- (sc-alignment sc)))
 198          (inc (max (sb-size sb)
 199                    (+ (sc-element-size sc)
 200                       (- (logandc2 (+ size align-mask) align-mask)
 201                          size))
 202                    (- needed-size size)))
 203          (new-size (+ size inc))
 204          (conflicts (finite-sb-conflicts sb))
 205          (block-size (if (zerop (length conflicts))
 206                          (ir2-block-count *component-being-compiled*)
 207                          (length (the simple-vector (svref conflicts 0))))))
 208     (declare (type index inc new-size))
 209     (assert (eq (sb-kind sb) :unbounded))
 210
 211     (when (> new-size (length conflicts))
 212       (let ((new-conf (make-array new-size)))
 213         (replace new-conf conflicts)
 214         (do ((i size (1+ i)))
 215             ((= i new-size))
 216           (declare (type index i))
 217           (let ((loc-confs (make-array block-size)))
 218             (dotimes (j block-size)
 219               (setf (svref loc-confs j)
 220                     (make-array local-tn-limit
 221                                 :initial-element 0
 222                                 :element-type 'bit)))
 223             (setf (svref new-conf i) loc-confs)))
 224         (setf (finite-sb-conflicts sb) new-conf))
 225
 226       (let ((new-live (make-array new-size)))
 227         (replace new-live (finite-sb-always-live sb))
 228         (do ((i size (1+ i)))
 229             ((= i new-size))
 230           (setf (svref new-live i)
 231                 (make-array block-size
 232                             :initial-element 0
 233                             :element-type 'bit)))
 234         (setf (finite-sb-always-live sb) new-live))
 235
 236       (let ((new-tns (make-array new-size :initial-element nil)))
 237         (replace new-tns (finite-sb-live-tns sb))
 238         (fill (finite-sb-live-tns sb) nil)
 239         (setf (finite-sb-live-tns sb) new-tns)))
 240
 241     (setf (finite-sb-current-size sb) new-size))
 242   (values))
 243
 244 ;;; This variable is true whenever we are in pack (and thus the per-SB
 245 ;;; conflicts information is in use.)
 246 (defvar *in-pack* nil)
 247
 248 ;;; In order to prevent the conflict data structures from growing
 249 ;;; arbitrarily large, we clear them whenever a GC happens and we aren't
 250 ;;; currently in pack. We revert to the initial number of locations and 0
 251 ;;; blocks.
 252 (defun pack-before-gc-hook ()
 253   (unless *in-pack*
 254     (dolist (sb *backend-sb-list*)
 255       (unless (eq (sb-kind sb) :non-packed)
 256         (let ((size (sb-size sb)))
 257           (fill nil (finite-sb-always-live sb))
 258           (setf (finite-sb-always-live sb)
 259                 (make-array size
 260                             :initial-element
 261                             #-sb-xc #*
 262                             ;; The cross-compiler isn't very good at dumping
 263                             ;; specialized arrays, so we delay construction of
 264                             ;; this SIMPLE-BIT-VECTOR until runtime.
 265                             #+sb-xc (make-array 0 :element-type 'bit)))
 266
 267           (fill nil (finite-sb-conflicts sb))
 268           (setf (finite-sb-conflicts sb)
 269                 (make-array size :initial-element '#()))
 270
 271           (fill nil (finite-sb-live-tns sb))
 272           (setf (finite-sb-live-tns sb)
 273                 (make-array size :initial-element nil))))))
 274   (values))
 275
 276 (pushnew 'pack-before-gc-hook sb!ext:*before-gc-hooks*)
 277 \f
 278 ;;;; internal errors
 279
 280 ;;; Give someone a hard time because there isn't any load function defined
 281 ;;; to move from Src to Dest.
 282 (defun no-load-function-error (src dest)
 283   (let* ((src-sc (tn-sc src))
 284          (src-name (sc-name src-sc))
 285          (dest-sc (tn-sc dest))
 286          (dest-name (sc-name dest-sc)))
 287     (cond ((eq (sb-kind (sc-sb src-sc)) :non-packed)
 288            (unless (member src-sc (sc-constant-scs dest-sc))
 289              (error "loading from an invalid constant SC?~@
 290                      VM definition inconsistent, try recompiling."))
 291            (error "no load function defined to load SC ~S ~
 292                    from its constant SC ~S"
 293                   dest-name src-name))
 294           ((member src-sc (sc-alternate-scs dest-sc))
 295            (error "no load function defined to load SC ~S from its ~
 296                    alternate SC ~S"
 297                   dest-name src-name))
 298           ((member dest-sc (sc-alternate-scs src-sc))
 299            (error "no load function defined to save SC ~S in its ~
 300                    alternate SC ~S"
 301                   src-name dest-name))
 302           (t
 303            ;; FIXME: "VM definition is inconsistent" shouldn't be a
 304            ;; possibility in SBCL.
 305            (error "loading to/from SCs that aren't alternates?~@
 306                    VM definition is inconsistent, try recompiling.")))))
 307
 308 ;;; Called when we failed to pack TN. If Restricted is true, then we we
 309 ;;; restricted to pack TN in its SC.
 310 (defun failed-to-pack-error (tn restricted)
 311   (declare (type tn tn))
 312   (let* ((sc (tn-sc tn))
 313          (scs (cons sc (sc-alternate-scs sc))))
 314     (cond
 315      (restricted
 316       (error "Failed to pack restricted TN ~S in its SC ~S."
 317              tn (sc-name sc)))
 318      (t
 319       (assert (not (find :unbounded scs
 320                          :key #'(lambda (x) (sb-kind (sc-sb x))))))
 321       (let ((ptype (tn-primitive-type tn)))
 322         (cond
 323          (ptype
 324           (assert (member (sc-number sc) (primitive-type-scs ptype)))
 325           (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@
 326                   a SC for primitive-type ~S."
 327                  (sc-name sc) (primitive-type-name ptype)))
 328          (t
 329           (error "SC ~S doesn't have any :Unbounded alternate SCs."
 330                  (sc-name sc)))))))))
 331
 332 ;;; Return a list of format arguments describing how TN is used in Op's VOP.
 333 (defun describe-tn-use (loc tn op)
 334   (let* ((vop (tn-ref-vop op))
 335          (args (vop-args vop))
 336          (results (vop-results vop))
 337          (name (with-output-to-string (stream)
 338                  (print-tn tn stream)))
 339          (2comp (component-info *component-being-compiled*))
 340          temp)
 341     (cond
 342      ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-tn))
 343       `("~2D: ~A (~:R argument)" ,loc ,name ,(1+ temp)))
 344      ((setq temp (position-in #'tn-ref-across tn results :key #'tn-ref-tn))
 345       `("~2D: ~A (~:R result)" ,loc ,name ,(1+ temp)))
 346      ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-load-tn))
 347       `("~2D: ~A (~:R argument load TN)" ,loc ,name ,(1+ temp)))
 348      ((setq temp (position-in #'tn-ref-across tn results :key
 349                               #'tn-ref-load-tn))
 350       `("~2D: ~A (~:R result load TN)" ,loc ,name ,(1+ temp)))
 351      ((setq temp (position-in #'tn-ref-across tn (vop-temps vop)
 352                               :key #'tn-ref-tn))
 353       `("~2D: ~A (temporary ~A)" ,loc ,name
 354         ,(operand-parse-name (elt (vop-parse-temps
 355                                    (vop-parse-or-lose
 356                                     (vop-info-name  (vop-info vop))))
 357                                   temp))))
 358      ((eq (tn-kind tn) :component)
 359       `("~2D: ~A (component live)" ,loc ,name))
 360      ((position-in #'tn-next tn (ir2-component-wired-tns 2comp))
 361       `("~2D: ~A (wired)" ,loc ,name))
 362      ((position-in #'tn-next tn (ir2-component-restricted-tns 2comp))
 363       `("~2D: ~A (restricted)" ,loc ,name))
 364      (t
 365       `("~2D: not referenced?" ,loc)))))
 366
 367 ;;; If load TN packing fails, try to give a helpful error message. We find
 368 ;;; a TN in each location that conflicts, and print it.
 369 (defun failed-to-pack-load-tn-error (scs op)
 370   (declare (list scs) (type tn-ref op))
 371   (collect ((used)
 372             (unused))
 373     (dolist (sc scs)
 374       (let* ((sb (sc-sb sc))
 375              (confs (finite-sb-live-tns sb)))
 376         (assert (eq (sb-kind sb) :finite))
 377         (dolist (el (sc-locations sc))
 378           (declare (type index el))
 379           (let ((conf (load-tn-conflicts-in-sc op sc el t)))
 380             (if conf
 381                 (used (describe-tn-use el conf op))
 382                 (do ((i el (1+ i))
 383                      (end (+ el (sc-element-size sc))))
 384                     ((= i end)
 385                      (unused el))
 386                   (declare (type index i end))
 387                   (let ((victim (svref confs i)))
 388                     (when victim
 389                       (used (describe-tn-use el victim op))
 390                       (return t)))))))))
 391
 392     (multiple-value-bind (arg-p n more-p costs load-scs incon)
 393         (get-operand-info op)
 394       (declare (ignore costs load-scs))
 395         (assert (not more-p))
 396         (error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~
 397                 for the ~:R ~:[result~;argument~] to~@
 398                 the ~S VOP,~@
 399                 ~:[since all SC elements are in use:~:{~%~@?~}~%~;~
 400                 ~:*but these SC elements are not in use:~%  ~S~%Bug?~*~]~
 401                 ~:[~;~@
 402                 Current cost info inconsistent with that in effect at compile ~
 403                 time. Recompile.~%Compilation order may be incorrect.~]"
 404                (mapcar #'sc-name scs)
 405                n arg-p
 406                (vop-info-name (vop-info (tn-ref-vop op)))
 407                (unused) (used)
 408                incon))))
 409
 410 ;;; Called when none of the SCs that we can load Op into are allowed by Op's
 411 ;;; primitive-type.
 412 (defun no-load-scs-allowed-by-primitive-type-error (ref)
 413   (declare (type tn-ref ref))
 414   (let* ((tn (tn-ref-tn ref))
 415          (ptype (tn-primitive-type tn)))
 416     (multiple-value-bind (arg-p pos more-p costs load-scs incon)
 417         (get-operand-info ref)
 418       (declare (ignore costs))
 419       (assert (not more-p))
 420       (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
 421               ~%  ~S,~@
 422               since the TN's primitive type ~S doesn't allow any of the SCs~@
 423               allowed by the operand restriction:~%  ~S~
 424               ~:[~;~@
 425               Current cost info inconsistent with that in effect at compile ~
 426               time. Recompile.~%Compilation order may be incorrect.~]"
 427              tn pos arg-p
 428              (template-name (vop-info (tn-ref-vop ref)))
 429              (primitive-type-name ptype)
 430              (mapcar #'sc-name (listify-restrictions load-scs))
 431              incon))))
 432 \f
 433 ;;;; register saving
 434
 435 ;;; Do stuff to note that TN is spilled at VOP for the debugger's benefit.
 436 (defun note-spilled-tn (tn vop)
 437   (when (and (tn-leaf tn) (vop-save-set vop))
 438     (let ((2comp (component-info *component-being-compiled*)))
 439       (setf (gethash tn (ir2-component-spilled-tns 2comp)) t)
 440       (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp)))))
 441   (values))
 442
 443 ;;; Make a save TN for TN, pack it, and return it. We copy various conflict
 444 ;;; information from the TN so that pack does the right thing.
 445 (defun pack-save-tn (tn)
 446   (declare (type tn tn))
 447   (let ((res (make-tn 0 :save nil nil)))
 448     (dolist (alt (sc-alternate-scs (tn-sc tn))
 449                  (error "No unbounded alternate for SC ~S."
 450                         (sc-name (tn-sc tn))))
 451       (when (eq (sb-kind (sc-sb alt)) :unbounded)
 452         (setf (tn-save-tn tn) res)
 453         (setf (tn-save-tn res) tn)
 454         (setf (tn-sc res) alt)
 455         (pack-tn res t)
 456         (return res)))))
 457
 458 ;;; Find the load function for moving from Src to Dest and emit a
 459 ;;; MOVE-OPERAND VOP with that function as its info arg.
 460 (defun emit-operand-load (node block src dest before)
 461   (declare (type node node) (type ir2-block block)
 462            (type tn src dest) (type (or vop null) before))
 463   (emit-load-template node block
 464                       (template-or-lose 'move-operand)
 465                       src dest
 466                       (list (or (svref (sc-move-functions (tn-sc dest))
 467                                        (sc-number (tn-sc src)))
 468                                 (no-load-function-error src dest)))
 469                       before)
 470   (values))
 471
 472 ;;; Find the preceding use of the VOP NAME in the emit order, starting with
 473 ;;; VOP. We must find the VOP in the same IR1 block.
 474 (defun reverse-find-vop (name vop)
 475   (do* ((block (vop-block vop) (ir2-block-prev block))
 476         (last vop (ir2-block-last-vop block)))
 477        (nil)
 478     (assert (eq (ir2-block-block block) (ir2-block-block (vop-block vop))))
 479     (do ((current last (vop-prev current)))
 480         ((null current))
 481       (when (eq (vop-info-name (vop-info current)) name)
 482         (return-from reverse-find-vop current)))))
 483
 484 ;;; For TNs that have other than one writer, we save the TN before each
 485 ;;; call. If a local call (MOVE-ARGS is :LOCAL-CALL), then we scan back for
 486 ;;; the ALLOCATE-FRAME VOP, and emit the save there. This is necessary because
 487 ;;; in a self-recursive local call, the registers holding the current arguments
 488 ;;; may get trashed by setting up the call arguments. The ALLOCATE-FRAME VOP
 489 ;;; marks a place at which the values are known to be good.
 490 (defun save-complex-writer-tn (tn vop)
 491   (let ((save (or (tn-save-tn tn)
 492                   (pack-save-tn tn)))
 493         (node (vop-node vop))
 494         (block (vop-block vop))
 495         (next (vop-next vop)))
 496     (when (eq (tn-kind save) :specified-save)
 497       (setf (tn-kind save) :save))
 498     (assert (eq (tn-kind save) :save))
 499     (emit-operand-load node block tn save
 500                        (if (eq (vop-info-move-args (vop-info vop))
 501                                :local-call)
 502                            (reverse-find-vop 'allocate-frame vop)
 503                            vop))
 504     (emit-operand-load node block save tn next)))
 505
 506 ;;; Return a VOP after which is an o.k. place to save the value of TN. For
 507 ;;; correctness, it is only required that this location be after any possible
 508 ;;; write and before any possible restore location.
 509 ;;;
 510 ;;; In practice, we return the unique writer VOP, but give up if the TN is
 511 ;;; ever read by a VOP with MOVE-ARGS :LOCAL-CALL. This prevents us from being
 512 ;;; confused by non-tail local calls.
 513 ;;;
 514 ;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, since they
 515 ;;; will correspond to restores that we have already done.
 516 (defun find-single-writer (tn)
 517   (declare (type tn tn))
 518   (do ((write (tn-writes tn) (tn-ref-next write))
 519        (res nil))
 520       ((null write)
 521        (when (and res
 522                   (do ((read (tn-reads tn) (tn-ref-next read)))
 523                       ((not read) t)
 524                     (when (eq (vop-info-move-args
 525                                (vop-info
 526                                 (tn-ref-vop read)))
 527                               :local-call)
 528                       (return nil))))
 529          (tn-ref-vop res)))
 530
 531     (unless (eq (vop-info-name (vop-info (tn-ref-vop write)))
 532                 'move-operand)
 533       (when res (return nil))
 534       (setq res write))))
 535
 536 ;;; Try to save TN at a single location. If we succeed, return T, otherwise
 537 ;;; NIL.
 538 (defun save-single-writer-tn (tn)
 539   (declare (type tn tn))
 540   (let* ((old-save (tn-save-tn tn))
 541          (save (or old-save (pack-save-tn tn)))
 542          (writer (find-single-writer tn)))
 543     (when (and writer
 544                (or (not old-save)
 545                    (eq (tn-kind old-save) :specified-save)))
 546       (emit-operand-load (vop-node writer) (vop-block writer)
 547                          tn save (vop-next writer))
 548       (setf (tn-kind save) :save-once)
 549       t)))
 550
 551 ;;; Restore a TN with a :SAVE-ONCE save TN.
 552 (defun restore-single-writer-tn (tn vop)
 553   (declare (type tn) (type vop vop))
 554   (let ((save (tn-save-tn tn)))
 555     (assert (eq (tn-kind save) :save-once))
 556     (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop)))
 557   (values))
 558
 559 ;;; Save a single TN that needs to be saved, choosing save-once if
 560 ;;; appropriate. This is also called by SPILL-AND-PACK-LOAD-TN.
 561 (defun basic-save-tn (tn vop)
 562   (declare (type tn tn) (type vop vop))
 563   (let ((save (tn-save-tn tn)))
 564     (cond ((and save (eq (tn-kind save) :save-once))
 565            (restore-single-writer-tn tn vop))
 566           ((save-single-writer-tn tn)
 567            (restore-single-writer-tn tn vop))
 568           (t
 569            (save-complex-writer-tn tn vop))))
 570   (values))
 571
 572 ;;; Scan over the VOPs in Block, emiting saving code for TNs noted in the
 573 ;;; codegen info that are packed into saved SCs.
 574 (defun emit-saves (block)
 575   (declare (type ir2-block block))
 576   (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 577       ((null vop))
 578     (when (eq (vop-info-save-p (vop-info vop)) t)
 579       (do-live-tns (tn (vop-save-set vop) block)
 580         (when (and (sc-save-p (tn-sc tn))
 581                    (not (eq (tn-kind tn) :component)))
 582           (basic-save-tn tn vop)))))
 583
 584   (values))
 585 \f
 586 ;;;; optimized saving
 587
 588 ;;; Save TN if it isn't a single-writer TN that has already been saved. If
 589 ;;; multi-write, we insert the save Before the specified VOP. Context is a VOP
 590 ;;; used to tell which node/block to use for the new VOP.
 591 (defun save-if-necessary (tn before context)
 592   (declare (type tn tn) (type (or vop null) before) (type vop context))
 593   (let ((save (tn-save-tn tn)))
 594     (when (eq (tn-kind save) :specified-save)
 595       (setf (tn-kind save) :save))
 596     (assert (member (tn-kind save) '(:save :save-once)))
 597     (unless (eq (tn-kind save) :save-once)
 598       (or (save-single-writer-tn tn)
 599           (emit-operand-load (vop-node context) (vop-block context)
 600                              tn save before))))
 601   (values))
 602
 603 ;;; Load the TN from its save location, allocating one if necessary. The
 604 ;;; load is inserted Before the specifier VOP. Context is a VOP used to tell
 605 ;;; which node/block to use for the new VOP.
 606 (defun restore-tn (tn before context)
 607   (declare (type tn tn) (type (or vop null) before) (type vop context))
 608   (let ((save (or (tn-save-tn tn) (pack-save-tn tn))))
 609     (emit-operand-load (vop-node context) (vop-block context)
 610                        save tn before))
 611   (values))
 612
 613 (eval-when (:compile-toplevel :execute)
 614
 615 ;;; Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK.
 616 (defmacro save-note-read (tn)
 617   `(let* ((tn ,tn)
 618           (num (tn-number tn)))
 619      (when (and (sc-save-p (tn-sc tn))
 620                 (zerop (sbit restores num))
 621                 (not (eq (tn-kind tn) :component)))
 622        (setf (sbit restores num) 1)
 623        (push tn restores-list))))
 624
 625 ) ; EVAL-WHEN
 626
 627 ;;; Start scanning backward at the end of Block, looking which TNs are live
 628 ;;; and looking for places where we have to save. We manipulate two sets:
 629 ;;; SAVES and RESTORES.
 630 ;;;
 631 ;;; SAVES is a set of all the TNs that have to be saved because they are
 632 ;;; restored after some call. We normally delay saving until the beginning of
 633 ;;; the block, but we must save immediately if we see a write of the saved TN.
 634 ;;; We also immediately save all TNs and exit when we see a
 635 ;;; NOTE-ENVIRONMENT-START VOP, since saves can't be done before the
 636 ;;; environment is properly initialized.
 637 ;;;
 638 ;;; RESTORES is a set of all the TNs read (and not written) between here and
 639 ;;; the next call, i.e. the set of TNs that must be restored when we reach the
 640 ;;; next (earlier) call VOP. Unlike SAVES, this set is cleared when we do
 641 ;;; the restoring after a call. Any TNs that were in RESTORES are moved into
 642 ;;; SAVES to ensure that they are saved at some point.
 643 ;;;
 644 ;;; SAVES and RESTORES are represented using both a list and a bit-vector so
 645 ;;; that we can quickly iterate and test for membership. The incoming Saves
 646 ;;; and Restores args are used for computing these sets (the initial contents
 647 ;;; are ignored.)
 648 ;;;
 649 ;;; When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error
 650 ;;; location), we pretend that all live TNs were read, unless (= speed 3), in
 651 ;;; which case we mark all the TNs that are live but not restored as spilled.
 652 (defun optimized-emit-saves-block (block saves restores)
 653   (declare (type ir2-block block) (type simple-bit-vector saves restores))
 654   (let ((1block (ir2-block-block block))
 655         (saves-list ())
 656         (restores-list ())
 657         (skipping nil))
 658     (declare (list saves-list restores-list))
 659     (clear-bit-vector saves)
 660     (clear-bit-vector restores)
 661     (do-live-tns (tn (ir2-block-live-in block) block)
 662       (when (and (sc-save-p (tn-sc tn))
 663                  (not (eq (tn-kind tn) :component)))
 664         (let ((num (tn-number tn)))
 665           (setf (sbit restores num) 1)
 666           (push tn restores-list))))
 667
 668     (do ((block block (ir2-block-prev block))
 669          (prev nil block))
 670         ((not (eq (ir2-block-block block) 1block))
 671          (assert (not skipping))
 672          (dolist (save saves-list)
 673            (let ((start (ir2-block-start-vop prev)))
 674              (save-if-necessary save start start)))
 675          prev)
 676       (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
 677           ((null vop))
 678         (let ((info (vop-info vop)))
 679           (case (vop-info-name info)
 680             (allocate-frame
 681              (assert skipping)
 682              (setq skipping nil))
 683             (note-environment-start
 684              (assert (not skipping))
 685              (dolist (save saves-list)
 686                (save-if-necessary save (vop-next vop) vop))
 687              (return-from optimized-emit-saves-block block)))
 688
 689           (unless skipping
 690             (do ((write (vop-results vop) (tn-ref-across write)))
 691                 ((null write))
 692               (let* ((tn (tn-ref-tn write))
 693                      (num (tn-number tn)))
 694                 (unless (zerop (sbit restores num))
 695                   (setf (sbit restores num) 0)
 696                   (setq restores-list
 697                         (delete tn restores-list :test #'eq)))
 698                 (unless (zerop (sbit saves num))
 699                   (setf (sbit saves num) 0)
 700                   (save-if-necessary tn (vop-next vop) vop)
 701                   (setq saves-list
 702                         (delete tn saves-list :test #'eq))))))
 703
 704           (macrolet (;; Do stuff to note a read of TN, for
 705                      ;; OPTIMIZED-EMIT-SAVES-BLOCK.
 706                      (save-note-read (tn)
 707                        `(let* ((tn ,tn)
 708                                (num (tn-number tn)))
 709                           (when (and (sc-save-p (tn-sc tn))
 710                                      (zerop (sbit restores num))
 711                                      (not (eq (tn-kind tn) :component)))
 712                           (setf (sbit restores num) 1)
 713                           (push tn restores-list)))))
 714
 715             (case (vop-info-save-p info)
 716               ((t)
 717                (dolist (tn restores-list)
 718                  (restore-tn tn (vop-next vop) vop)
 719                  (let ((num (tn-number tn)))
 720                    (when (zerop (sbit saves num))
 721                      (push tn saves-list)
 722                      (setf (sbit saves num) 1))))
 723                (setq restores-list nil)
 724                (clear-bit-vector restores))
 725               (:compute-only
 726                (cond ((policy (vop-node vop) (= speed 3))
 727                       (do-live-tns (tn (vop-save-set vop) block)
 728                         (when (zerop (sbit restores (tn-number tn)))
 729                           (note-spilled-tn tn vop))))
 730                      (t
 731                       (do-live-tns (tn (vop-save-set vop) block)
 732                         (save-note-read tn))))))
 733
 734             (if (eq (vop-info-move-args info) :local-call)
 735                 (setq skipping t)
 736                 (do ((read (vop-args vop) (tn-ref-across read)))
 737                     ((null read))
 738                   (save-note-read (tn-ref-tn read))))))))))
 739
 740 ;;; Like EMIT-SAVES, only different. We avoid redundant saving within the
 741 ;;; block, and don't restore values that aren't used before the next call.
 742 ;;; This function is just the top-level loop over the blocks in the component,
 743 ;;; which locates blocks that need saving done.
 744 (defun optimized-emit-saves (component)
 745   (declare (type component component))
 746   (let* ((gtn-count (1+ (ir2-component-global-tn-counter
 747                          (component-info component))))
 748          (saves (make-array gtn-count :element-type 'bit))
 749          (restores (make-array gtn-count :element-type 'bit))
 750          (block (ir2-block-prev (block-info (component-tail component))))
 751          (head (block-info (component-head component))))
 752     (loop
 753       (when (eq block head) (return))
 754       (when (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 755                 ((null vop) nil)
 756               (when (eq (vop-info-save-p (vop-info vop)) t)
 757                 (return t)))
 758         (setq block (optimized-emit-saves-block block saves restores)))
 759       (setq block (ir2-block-prev block)))))
 760
 761 ;;; Iterate over the normal TNs, finding the cost of packing on the stack in
 762 ;;; units of the number of references. We count all references as +1, and
 763 ;;; subtract out REGISTER-SAVE-PENALTY for each place where we would have to
 764 ;;; save a register.
 765 (defun assign-tn-costs (component)
 766   (do-ir2-blocks (block component)
 767     (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 768         ((null vop))
 769       (when (eq (vop-info-save-p (vop-info vop)) t)
 770         (do-live-tns (tn (vop-save-set vop) block)
 771           (decf (tn-cost tn) *backend-register-save-penalty*)))))
 772
 773   (do ((tn (ir2-component-normal-tns (component-info component))
 774            (tn-next tn)))
 775       ((null tn))
 776     (let ((cost (tn-cost tn)))
 777       (declare (fixnum cost))
 778       (do ((ref (tn-reads tn) (tn-ref-next ref)))
 779           ((null ref))
 780         (incf cost))
 781       (do ((ref (tn-writes tn) (tn-ref-next ref)))
 782           ((null ref))
 783         (incf cost))
 784       (setf (tn-cost tn) cost))))
 785 \f
 786 ;;;; load TN packing
 787
 788 ;;; These variables indicate the last location at which we computed the
 789 ;;; Live-TNs. They hold the Block and VOP values that were passed to
 790 ;;; Compute-Live-TNs.
 791 (defvar *live-block*)
 792 (defvar *live-vop*)
 793
 794 ;;; If we unpack some TNs, then we mark all affected blocks by sticking them in
 795 ;;; this hash-table. This is initially null. We create the hashtable if we do
 796 ;;; any unpacking.
 797 (defvar *repack-blocks*)
 798 (declaim (type (or hash-table null) *repack-blocks*))
 799
 800 ;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs live at
 801 ;;; the end of Block.
 802 (defun init-live-tns (block)
 803   (dolist (sb *backend-sb-list*)
 804     (when (eq (sb-kind sb) :finite)
 805       (fill (finite-sb-live-tns sb) nil)))
 806
 807   (do-live-tns (tn (ir2-block-live-in block) block)
 808     (let* ((sc (tn-sc tn))
 809            (sb (sc-sb sc)))
 810       (when (eq (sb-kind sb) :finite)
 811         (do ((offset (tn-offset tn) (1+ offset))
 812              (end (+ (tn-offset tn) (sc-element-size sc))))
 813             ((= offset end))
 814           (declare (type index offset end))
 815           (setf (svref (finite-sb-live-tns sb) offset) tn)))))
 816
 817   (setq *live-block* block)
 818   (setq *live-vop* (ir2-block-last-vop block))
 819
 820   (values))
 821
 822 ;;; Set the Live-TNs in :Finite SBs to represent the TNs live immediately
 823 ;;; after the evaluation of VOP in Block, excluding results of the VOP. If VOP
 824 ;;; is null, then compute the live TNs at the beginning of the block.
 825 ;;; Sequential calls on the same block must be in reverse VOP order.
 826 (defun compute-live-tns (block vop)
 827   (declare (type ir2-block block) (type vop vop))
 828   (unless (eq block *live-block*)
 829     (init-live-tns block))
 830
 831   (do ((current *live-vop* (vop-prev current)))
 832       ((eq current vop)
 833        (do ((res (vop-results vop) (tn-ref-across res)))
 834            ((null res))
 835          (let* ((tn (tn-ref-tn res))
 836                 (sc (tn-sc tn))
 837                 (sb (sc-sb sc)))
 838            (when (eq (sb-kind sb) :finite)
 839              (do ((offset (tn-offset tn) (1+ offset))
 840                   (end (+ (tn-offset tn) (sc-element-size sc))))
 841                  ((= offset end))
 842                (declare (type index offset end))
 843                (setf (svref (finite-sb-live-tns sb) offset) nil))))))
 844     (do ((ref (vop-refs current) (tn-ref-next-ref ref)))
 845         ((null ref))
 846       (let ((ltn (tn-ref-load-tn ref)))
 847         (when ltn
 848           (let* ((sc (tn-sc ltn))
 849                  (sb (sc-sb sc)))
 850             (when (eq (sb-kind sb) :finite)
 851               (let ((tns (finite-sb-live-tns sb)))
 852                 (do ((offset (tn-offset ltn) (1+ offset))
 853                      (end (+ (tn-offset ltn) (sc-element-size sc))))
 854                     ((= offset end))
 855                   (declare (type index offset end))
 856                   (assert (null (svref tns offset)))))))))
 857
 858       (let* ((tn (tn-ref-tn ref))
 859              (sc (tn-sc tn))
 860              (sb (sc-sb sc)))
 861         (when (eq (sb-kind sb) :finite)
 862           (let ((tns (finite-sb-live-tns sb)))
 863             (do ((offset (tn-offset tn) (1+ offset))
 864                  (end (+ (tn-offset tn) (sc-element-size sc))))
 865                 ((= offset end))
 866               (declare (type index offset end))
 867               (if (tn-ref-write-p ref)
 868                   (setf (svref tns offset) nil)
 869                   (let ((old (svref tns offset)))
 870                     (assert (or (null old) (eq old tn)) (old tn))
 871                     (setf (svref tns offset) tn)))))))))
 872
 873   (setq *live-vop* vop)
 874   (values))
 875
 876 ;;; Kind of like Offset-Conflicts-In-SB, except that it uses the VOP refs to
 877 ;;; determine whether a Load-TN for OP could be packed in the specified
 878 ;;; location, disregarding conflicts with TNs not referenced by this VOP.
 879 ;;; There is a conflict if either:
 880 ;;;  1. The reference is a result, and the same location is either:
 881 ;;;     -- Used by some other result.
 882 ;;;     -- Used in any way after the reference (exclusive).
 883 ;;;  2. The reference is an argument, and the same location is either:
 884 ;;;     -- Used by some other argument.
 885 ;;;     -- Used in any way before the reference (exclusive).
 886 ;;;
 887 ;;; In 1 (and 2) above, the first bullet corresponds to result-result
 888 ;;; (and argument-argument) conflicts. We need this case because there aren't
 889 ;;; any TN-REFs to represent the implicit reading of results or writing of
 890 ;;; arguments.
 891 ;;;
 892 ;;; The second bullet corresponds conflicts with temporaries or between
 893 ;;; arguments and results.
 894 ;;;
 895 ;;; We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to be
 896 ;;; referenced simultaneously and in the same way. This causes load-TNs to
 897 ;;; appear live to the beginning (or end) of the VOP, as appropriate.
 898 ;;;
 899 ;;; We return a conflicting TN if there is a conflict.
 900 (defun load-tn-offset-conflicts-in-sb (op sb offset)
 901   (declare (type tn-ref op) (type finite-sb sb) (type index offset))
 902   (assert (eq (sb-kind sb) :finite))
 903   (let ((vop (tn-ref-vop op)))
 904     (labels ((tn-overlaps (tn)
 905                (let ((sc (tn-sc tn))
 906                      (tn-offset (tn-offset tn)))
 907                  (when (and (eq (sc-sb sc) sb)
 908                             (<= tn-offset offset)
 909                             (< offset
 910                                (the index
 911                                     (+ tn-offset (sc-element-size sc)))))
 912                    tn)))
 913              (same (ref)
 914                (let ((tn (tn-ref-tn ref))
 915                      (ltn (tn-ref-load-tn ref)))
 916                  (or (tn-overlaps tn)
 917                      (and ltn (tn-overlaps ltn)))))
 918              (is-op (ops)
 919                (do ((ops ops (tn-ref-across ops)))
 920                    ((null ops) nil)
 921                  (let ((found (same ops)))
 922                    (when (and found (not (eq ops op)))
 923                      (return found)))))
 924              (is-ref (refs end)
 925                (do ((refs refs (tn-ref-next-ref refs)))
 926                    ((eq refs end) nil)
 927                  (let ((found (same refs)))
 928                  (when found (return found))))))
 929       (declare (inline is-op is-ref tn-overlaps))
 930       (if (tn-ref-write-p op)
 931           (or (is-op (vop-results vop))
 932               (is-ref (vop-refs vop) op))
 933           (or (is-op (vop-args vop))
 934               (is-ref (tn-ref-next-ref op) nil))))))
 935
 936 ;;; Iterate over all the elements in the SB that would be allocated by
 937 ;;; allocating a TN in SC at Offset, checking for conflict with load-TNs or
 938 ;;; other TNs (live in the LIVE-TNS, which must be set up.)  We also return
 939 ;;; true if there aren't enough locations after Offset to hold a TN in SC.
 940 ;;; If Ignore-Live is true, then we ignore the live-TNs, considering only
 941 ;;; references within Op's VOP.
 942 ;;;
 943 ;;; We return a conflicting TN, or :OVERFLOW if the TN won't fit.
 944 (defun load-tn-conflicts-in-sc (op sc offset ignore-live)
 945   (let* ((sb (sc-sb sc))
 946          (size (finite-sb-current-size sb)))
 947     (do ((i offset (1+ i))
 948          (end (+ offset (sc-element-size sc))))
 949         ((= i end) nil)
 950       (declare (type index i end))
 951       (let ((res (or (when (>= i size) :overflow)
 952                      (and (not ignore-live)
 953                           (svref (finite-sb-live-tns sb) i))
 954                      (load-tn-offset-conflicts-in-sb op sb i))))
 955         (when res (return res))))))
 956
 957 ;;; If a load-TN for Op is targeted to a legal location in SC, then return
 958 ;;; the offset, otherwise return NIL. We see whether the target of the
 959 ;;; operand is packed, and try that location. There isn't any need to chain
 960 ;;; down the target path, since everything is packed now.
 961 ;;;
 962 ;;; We require the target to be in SC (and not merely to overlap with SC).
 963 ;;; This prevents SC information from being lost in load TNs (we won't pack a
 964 ;;; load TN in ANY-REG when it is targeted to a DESCRIPTOR-REG.)  This
 965 ;;; shouldn't hurt the code as long as all relevant overlapping SCs are allowed
 966 ;;; in the operand SC restriction.
 967 (defun find-load-tn-target (op sc)
 968   (declare (inline member))
 969   (let ((target (tn-ref-target op)))
 970     (when target
 971       (let* ((tn (tn-ref-tn target))
 972              (loc (tn-offset tn)))
 973         (if (and (eq (tn-sc tn) sc)
 974                  (member (the index loc) (sc-locations sc))
 975                  (not (load-tn-conflicts-in-sc op sc loc nil)))
 976             loc
 977             nil)))))
 978
 979 ;;; Select a legal location for a load TN for Op in SC. We just iterate
 980 ;;; over the SC's locations. If we can't find a legal location, return NIL.
 981 (defun select-load-tn-location (op sc)
 982   (declare (type tn-ref op) (type sc sc))
 983
 984   ;; Check any target location first.
 985   (let ((target (tn-ref-target op)))
 986     (when target
 987       (let* ((tn (tn-ref-tn target))
 988              (loc (tn-offset tn)))
 989         (when (and (eq (sc-sb sc) (sc-sb (tn-sc tn)))
 990                    (member (the index loc) (sc-locations sc))
 991                    (not (load-tn-conflicts-in-sc op sc loc nil)))
 992               (return-from select-load-tn-location loc)))))
 993
 994   (dolist (loc (sc-locations sc) nil)
 995     (unless (load-tn-conflicts-in-sc op sc loc nil)
 996       (return loc))))
 997
 998 (defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.")
 999
1000 ;;; Make TN's location the same as for its save TN (allocating a save TN if
1001 ;;; necessary.)  Delete any save/restore code that has been emitted thus far.
1002 ;;; Mark all blocks containing references as needing to be repacked.
1003 (defun unpack-tn (tn)
1004   (event unpack-tn)
1005   (let ((stn (or (tn-save-tn tn)
1006                  (pack-save-tn tn))))
1007     (setf (tn-sc tn) (tn-sc stn))
1008     (setf (tn-offset tn) (tn-offset stn))
1009     (flet ((zot (refs)
1010              (do ((ref refs (tn-ref-next ref)))
1011                  ((null ref))
1012                (let ((vop (tn-ref-vop ref)))
1013                  (if (eq (vop-info-name (vop-info vop)) 'move-operand)
1014                      (delete-vop vop)
1015                      (setf (gethash (vop-block vop) *repack-blocks*) t))))))
1016       (zot (tn-reads tn))
1017       (zot (tn-writes tn))))
1018
1019   (values))
1020
1021 (defevent unpack-fallback "Unpacked some operand TN.")
1022
1023 ;;; Called by Pack-Load-TN where there isn't any location free that we can
1024 ;;; pack into. What we do is move some live TN in one of the specified SCs to
1025 ;;; memory, then mark this block all blocks that reference the TN as needing
1026 ;;; repacking. If we succeed, we throw to UNPACKED-TN. If we fail, we return
1027 ;;; NIL.
1028 ;;;
1029 ;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired
1030 ;;; or restricted.)  We prefer to unpack TNs that are not used by the VOP. If
1031 ;;; we can't find any such TN, then we unpack some argument or result
1032 ;;; TN. The only way we can fail is if all locations in SC are used by
1033 ;;; load-TNs or temporaries in VOP.
1034 (defun unpack-for-load-tn (sc op)
1035   (declare (type sc sc) (type tn-ref op))
1036   (let ((sb (sc-sb sc))
1037         (normal-tns (ir2-component-normal-tns
1038                      (component-info *component-being-compiled*)))
1039         (node (vop-node (tn-ref-vop op)))
1040         (fallback nil))
1041     (flet ((unpack-em (victims)
1042              (unless *repack-blocks*
1043                (setq *repack-blocks* (make-hash-table :test 'eq)))
1044              (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t)
1045              (dolist (victim victims)
1046                (event unpack-tn node)
1047                (unpack-tn victim))
1048              (throw 'unpacked-tn nil)))
1049       (dolist (loc (sc-locations sc))
1050         (declare (type index loc))
1051         (block SKIP
1052           (collect ((victims nil adjoin))
1053             (do ((i loc (1+ i))
1054                  (end (+ loc (sc-element-size sc))))
1055                 ((= i end))
1056               (declare (type index i end))
1057               (let ((victim (svref (finite-sb-live-tns sb) i)))
1058                 (when victim
1059                   (unless (find-in #'tn-next victim normal-tns)
1060                     (return-from SKIP))
1061                   (victims victim))))
1062
1063             (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
1064               (cond ((not conf)
1065                      (unpack-em (victims)))
1066                     ((eq conf :overflow))
1067                     ((not fallback)
1068                      (cond ((find conf (victims))
1069                             (setq fallback (victims)))
1070                            ((find-in #'tn-next conf normal-tns)
1071                             (setq fallback (list conf))))))))))
1072
1073       (when fallback
1074         (event unpack-fallback node)
1075         (unpack-em fallback))))
1076
1077   nil)
1078
1079 ;;; Try to pack a load TN in the SCs indicated by Load-SCs. If we run out
1080 ;;; of SCs, then we unpack some TN and try again. We return the packed load
1081 ;;; TN.
1082 ;;;
1083 ;;; Note: we allow a Load-TN to be packed in the target location even if that
1084 ;;; location is in a SC not allowed by the primitive type. (The SC must still
1085 ;;; be allowed by the operand restriction.)  This makes move VOPs more
1086 ;;; efficient, since we won't do a move from the stack into a non-descriptor
1087 ;;; any-reg though a descriptor argument load-TN. This does give targeting
1088 ;;; some real semantics, making it not a pure advisory to pack. It allows pack
1089 ;;; to do some packing it wouldn't have done before.
1090 (defun pack-load-tn (load-scs op)
1091   (declare (type sc-vector load-scs) (type tn-ref op))
1092   (let ((vop (tn-ref-vop op)))
1093     (compute-live-tns (vop-block vop) vop))
1094
1095   (let* ((tn (tn-ref-tn op))
1096          (ptype (tn-primitive-type tn))
1097          (scs (svref load-scs (sc-number (tn-sc tn)))))
1098     (let ((current-scs scs)
1099           (allowed ()))
1100       (loop
1101         (cond
1102          ((null current-scs)
1103           (unless allowed
1104             (no-load-scs-allowed-by-primitive-type-error op))
1105           (dolist (sc allowed)
1106             (unpack-for-load-tn sc op))
1107           (failed-to-pack-load-tn-error allowed op))
1108         (t
1109          (let* ((sc (svref *backend-sc-numbers* (pop current-scs)))
1110                 (target (find-load-tn-target op sc)))
1111            (when (or target (sc-allowed-by-primitive-type sc ptype))
1112              (let ((loc (or target
1113                             (select-load-tn-location op sc))))
1114                (when loc
1115                  (let ((res (make-tn 0 :load nil sc)))
1116                    (setf (tn-offset res) loc)
1117                    (return res))))
1118              (push sc allowed)))))))))
1119
1120 ;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by
1121 ;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy the
1122 ;;; restriction, we pack a Load-TN and load the operand into it. If a load-tn
1123 ;;; has already been allocated, we can assume that the restriction is
1124 ;;; satisfied.
1125 #!-sb-fluid (declaim (inline check-operand-restrictions))
1126 (defun check-operand-restrictions (scs ops)
1127   (declare (list scs) (type (or tn-ref null) ops))
1128
1129   ;; Check the targeted operands first.
1130   (do ((scs scs (cdr scs))
1131        (op ops (tn-ref-across op)))
1132       ((null scs))
1133       (let ((target (tn-ref-target op)))
1134         (when target
1135            (let* ((load-tn (tn-ref-load-tn op))
1136                   (load-scs (svref (car scs)
1137                                    (sc-number
1138                                     (tn-sc (or load-tn (tn-ref-tn op)))))))
1139              (if load-tn
1140                  (assert (eq load-scs t))
1141                (unless (eq load-scs t)
1142                        (setf (tn-ref-load-tn op)
1143                              (pack-load-tn (car scs) op))))))))
1144
1145   (do ((scs scs (cdr scs))
1146        (op ops (tn-ref-across op)))
1147       ((null scs))
1148       (let ((target (tn-ref-target op)))
1149         (unless target
1150            (let* ((load-tn (tn-ref-load-tn op))
1151                   (load-scs (svref (car scs)
1152                                    (sc-number
1153                                     (tn-sc (or load-tn (tn-ref-tn op)))))))
1154              (if load-tn
1155                  (assert (eq load-scs t))
1156                (unless (eq load-scs t)
1157                        (setf (tn-ref-load-tn op)
1158                              (pack-load-tn (car scs) op))))))))
1159
1160   (values))
1161
1162 ;;; Scan the VOPs in Block, looking for operands whose SC restrictions
1163 ;;; aren't satisfied. We do the results first, since they are evaluated
1164 ;;; later, and our conflict analysis is a backward scan.
1165 (defun pack-load-tns (block)
1166   (catch 'unpacked-tn
1167     (let ((*live-block* nil)
1168           (*live-vop* nil))
1169       (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
1170           ((null vop))
1171         (let ((info (vop-info vop)))
1172           (check-operand-restrictions (vop-info-result-load-scs info)
1173                                       (vop-results vop))
1174           (check-operand-restrictions (vop-info-arg-load-scs info)
1175                                       (vop-args vop))))))
1176   (values))
1177 \f
1178 ;;;; location-selection, targeting & pack interface
1179
1180 ;;;; targeting
1181
1182 ;;; Link the TN-Refs Read and Write together using the TN-Ref-Target when
1183 ;;; this seems like a good idea. Currently we always do, as this increases the
1184 ;;; success of load-TN targeting.
1185 (defun target-if-desirable (read write)
1186   (declare (type tn-ref read write))
1187   (setf (tn-ref-target read) write)
1188   (setf (tn-ref-target write) read))
1189
1190 ;;; If TN can be packed into SC so as to honor a preference to Target, then
1191 ;;; return the offset to pack at, otherwise return NIL. Target must be already
1192 ;;; packed. We can honor a preference if:
1193 ;;; -- Target's location is in SC's locations.
1194 ;;; -- The element sizes of the two SCs are the same.
1195 ;;; -- TN doesn't conflict with target's location.
1196 (defun check-ok-target (target tn sc)
1197   (declare (type tn target tn) (type sc sc) (inline member))
1198   (let* ((loc (tn-offset target))
1199          (target-sc (tn-sc target))
1200          (target-sb (sc-sb target-sc)))
1201     (declare (type index loc))
1202     (if (and (eq target-sb (sc-sb sc))
1203              (or (eq (sb-kind target-sb) :unbounded)
1204                  (member loc (sc-locations sc)))
1205              (= (sc-element-size target-sc) (sc-element-size sc))
1206              (not (conflicts-in-sc tn sc loc))
1207              (zerop (mod loc (sc-alignment sc))))
1208         loc
1209         nil)))
1210
1211 ;;; Scan along the target path from TN, looking at readers or writers. When
1212 ;;; we find a packed TN, return Check-OK-Target of that TN. If there is no
1213 ;;; target, or if the TN has multiple readers (writers), then we return NIL.
1214 ;;; We also always return NIL after 10 iterations to get around potential
1215 ;;; circularity problems.
1216 (macrolet ((frob (slot)
1217              `(let ((count 10)
1218                     (current tn))
1219                 (declare (type index count))
1220                 (loop
1221                   (let ((refs (,slot current)))
1222                     (unless (and (plusp count) refs (not (tn-ref-next refs)))
1223                       (return nil))
1224                     (let ((target (tn-ref-target refs)))
1225                       (unless target (return nil))
1226                       (setq current (tn-ref-tn target))
1227                       (when (tn-offset current)
1228                         (return (check-ok-target current tn sc)))
1229                       (decf count)))))))
1230   (defun find-ok-target-offset (tn sc)
1231     (declare (type tn tn) (type sc sc))
1232     (or (frob tn-reads)
1233         (frob tn-writes))))
1234
1235 ;;;; location selection
1236
1237 ;;; Select some location for TN in SC, returning the offset if we succeed,
1238 ;;; and NIL if we fail. We start scanning at the Last-Offset in an attempt
1239 ;;; to distribute the TNs across all storage.
1240 ;;;
1241 ;;; We call Offset-Conflicts-In-SB directly, rather than using Conflicts-In-SC.
1242 ;;; This allows us to more efficient in packing multi-location TNs: we don't
1243 ;;; have to multiply the number of tests by the TN size. This falls out
1244 ;;; natually, since we have to be aware of TN size anyway so that we don't call
1245 ;;; Conflicts-In-SC on a bogus offset.
1246 ;;;
1247 ;;; We give up on finding a location after our current pointer has wrapped
1248 ;;; twice. This will result in testing some locations twice in the case that
1249 ;;; we fail, but is simpler than trying to figure out the soonest failure
1250 ;;; point.
1251 ;;;
1252 ;;; We also give up without bothering to wrap if the current size isn't large
1253 ;;; enough to hold a single element of element-size without bothering to wrap.
1254 ;;; If it doesn't fit this iteration, it won't fit next.
1255 ;;;
1256 ;;; ### Note that we actually try to pack as many consecutive TNs as possible
1257 ;;; in the same location, since we start scanning at the same offset that the
1258 ;;; last TN was successfully packed in. This is a weakening of the scattering
1259 ;;; hueristic that was put in to prevent restricted VOP temps from hogging all
1260 ;;; of the registers. This way, all of these temps probably end up in one
1261 ;;; register.
1262 (defun select-location (tn sc &optional use-reserved-locs)
1263   (declare (type tn tn) (type sc sc) (inline member))
1264   (let* ((sb (sc-sb sc))
1265          (element-size (sc-element-size sc))
1266          (alignment (sc-alignment sc))
1267          (align-mask (1- alignment))
1268          (size (finite-sb-current-size sb))
1269          (start-offset (finite-sb-last-offset sb)))
1270     (let ((current-start
1271            (logandc2 (the index (+ start-offset align-mask)) align-mask))
1272           (wrap-p nil))
1273       (declare (type index current-start))
1274       (loop
1275         (when (> (+ current-start element-size) size)
1276           (cond ((or wrap-p (> element-size size))
1277                  (return nil))
1278                 (t
1279                  (setq current-start 0)
1280                  (setq wrap-p t))))
1281
1282         (if (or (eq (sb-kind sb) :unbounded)
1283                 (and (member current-start (sc-locations sc))
1284                      (or use-reserved-locs
1285                          (not (member current-start
1286                                       (sc-reserve-locations sc))))))
1287             (dotimes (i element-size
1288                         (return-from select-location current-start))
1289               (declare (type index i))
1290               (let ((offset (+ current-start i)))
1291                 (when (offset-conflicts-in-sb tn sb offset)
1292                   (setq current-start
1293                         (logandc2 (the index (+ (the index (1+ offset))
1294                                                 align-mask))
1295                                   align-mask))
1296                   (return))))
1297             (incf current-start alignment))))))
1298
1299 ;;; If a save TN, return the saved TN, otherwise return TN. Useful for
1300 ;;; getting the conflicts of a TN that might be a save TN.
1301 (defun original-tn (tn)
1302   (declare (type tn tn))
1303   (if (member (tn-kind tn) '(:save :save-once :specified-save))
1304       (tn-save-tn tn)
1305       tn))
1306
1307 ;;;; pack interface
1308
1309 ;;; Attempt to pack TN in all possible SCs, first in the SC chosen by
1310 ;;; representation selection, then in the alternate SCs in the order
1311 ;;; they were specified in the SC definition. If the TN-COST is
1312 ;;; negative, then we don't attempt to pack in SCs that must be saved.
1313 ;;; If Restricted, then we can only pack in TN-SC, not in any
1314 ;;; Alternate-SCs.
1315 ;;;
1316 ;;; If we are attempting to pack in the SC of the save TN for a TN
1317 ;;; with a :SPECIFIED-SAVE TN, then we pack in that location, instead
1318 ;;; of allocating a new stack location.
1319 (defun pack-tn (tn restricted)
1320   (declare (type tn tn))
1321   (let* ((original (original-tn tn))
1322          (fsc (tn-sc tn))
1323          (alternates (unless restricted (sc-alternate-scs fsc)))
1324          (save (tn-save-tn tn))
1325          (specified-save-sc
1326           (when (and save
1327                      (eq (tn-kind save) :specified-save))
1328             (tn-sc save))))
1329
1330     (do ((sc fsc (pop alternates)))
1331         ((null sc)
1332          (failed-to-pack-error tn restricted))
1333       (when (eq sc specified-save-sc)
1334         (unless (tn-offset save)
1335           (pack-tn save nil))
1336         (setf (tn-offset tn) (tn-offset save))
1337         (setf (tn-sc tn) (tn-sc save))
1338         (return))
1339       (when (or restricted
1340                 (not (and (minusp (tn-cost tn)) (sc-save-p sc))))
1341         (let ((loc (or (find-ok-target-offset original sc)
1342                        (select-location original sc)
1343                        (and restricted
1344                             (select-location original sc t))
1345                        (when (eq (sb-kind (sc-sb sc)) :unbounded)
1346                          (grow-sc sc)
1347                          (or (select-location original sc)
1348                              (error "Failed to pack after growing SC?"))))))
1349           (when loc
1350             (add-location-conflicts original sc loc)
1351             (setf (tn-sc tn) sc)
1352             (setf (tn-offset tn) loc)
1353             (return))))))
1354
1355   (values))
1356
1357 ;;; Pack a wired TN, checking that the offset is in bounds for the SB, and
1358 ;;; that the TN doesn't conflict with some other TN already packed in that
1359 ;;; location. If the TN is wired to a location beyond the end of a :Unbounded
1360 ;;; SB, then grow the SB enough to hold the TN.
1361 ;;;
1362 ;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs. This is
1363 ;;; kind of a hack to make specifying wired stack save locations for local call
1364 ;;; arguments (such as OLD-FP) work, since the caller and callee OLD-FP save
1365 ;;; locations may conflict when the save locations don't really (due to being
1366 ;;; in different frames.)
1367 (defun pack-wired-tn (tn)
1368   (declare (type tn tn))
1369   (let* ((sc (tn-sc tn))
1370          (sb (sc-sb sc))
1371          (offset (tn-offset tn))
1372          (end (+ offset (sc-element-size sc)))
1373          (original (original-tn tn)))
1374     (when (> end (finite-sb-current-size sb))
1375       (unless (eq (sb-kind sb) :unbounded)
1376         (error "~S is wired to a location that is out of bounds." tn))
1377       (grow-sc sc end))
1378
1379     ;; For non-x86 ports the presence of a save-tn associated with a tn is used
1380     ;; to identify the old-fp and return-pc tns. It depends on the old-fp and
1381     ;; return-pc being passed in registers.
1382     #!-x86
1383     (when (and (not (eq (tn-kind tn) :specified-save))
1384                (conflicts-in-sc original sc offset))
1385       (error "~S is wired to a location that it conflicts with." tn))
1386
1387     ;; Use the above check, but only print a verbose warning. This can be
1388     ;; helpful for debugging the x86 port.
1389     #+nil
1390     (when (and (not (eq (tn-kind tn) :specified-save))
1391                (conflicts-in-sc original sc offset))
1392           (format t "~&* Pack-wired-tn possible conflict:~%  ~
1393                      tn: ~S; tn-kind: ~S~%  ~
1394                      sc: ~S~%  ~
1395                      sb: ~S; sb-name: ~S; sb-kind: ~S~%  ~
1396                      offset: ~S; end: ~S~%  ~
1397                      original ~S~%  ~
1398                      tn-save-tn: ~S; tn-kind of tn-save-tn: ~S~%"
1399                   tn (tn-kind tn) sc
1400                   sb (sb-name sb) (sb-kind sb)
1401                   offset end
1402                   original
1403                   (tn-save-tn tn) (tn-kind (tn-save-tn tn))))
1404
1405     ;; On the x86 ports the old-fp and return-pc are often passed on the stack
1406     ;; so the above hack for the other ports does not always work. Here the
1407     ;; old-fp and return-pc tns are identified by being on the stack in their
1408     ;; standard save locations.
1409     #!+x86
1410     (when (and (not (eq (tn-kind tn) :specified-save))
1411                (not (and (string= (sb-name sb) "STACK")
1412                          (or (= offset 0)
1413                              (= offset 1))))
1414                (conflicts-in-sc original sc offset))
1415       (error "~S is wired to a location that it conflicts with." tn))
1416
1417     (add-location-conflicts original sc offset)))
1418
1419 (defevent repack-block "Repacked a block due to TN unpacking.")
1420
1421 (defun pack (component)
1422   (assert (not *in-pack*))
1423   (let ((*in-pack* t)
1424         (optimize (policy nil (or (>= speed cspeed) (>= space cspeed))))
1425         (2comp (component-info component)))
1426     (init-sb-vectors component)
1427
1428     ;; Call the target functions.
1429     (do-ir2-blocks (block component)
1430       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
1431           ((null vop))
1432         (let ((target-fun (vop-info-target-function (vop-info vop))))
1433           (when target-fun
1434             (funcall target-fun vop)))))
1435
1436
1437     ;; Pack wired TNs first.
1438     (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
1439         ((null tn))
1440       (pack-wired-tn tn))
1441
1442     ;; Pack restricted component TNs.
1443     (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
1444         ((null tn))
1445       (when (eq (tn-kind tn) :component)
1446         (pack-tn tn t)))
1447
1448     ;; Pack other restricted TNs.
1449     (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
1450         ((null tn))
1451       (unless (tn-offset tn)
1452         (pack-tn tn t)))
1453
1454     ;; Assign costs to normal TNs so we know which ones should always be
1455     ;; packed on the stack.
1456     (when (and optimize *pack-assign-costs*)
1457       (assign-tn-costs component))
1458
1459     ;; Pack normal TNs in the order that they appear in the code. This
1460     ;; should have some tendency to pack important TNs first, since control
1461     ;; analysis favors the drop-through. This should also help targeting,
1462     ;; since we will pack the target TN soon after we determine the location
1463     ;; of the targeting TN.
1464     (do-ir2-blocks (block component)
1465       (let ((ltns (ir2-block-local-tns block)))
1466         (do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
1467             ((minusp i))
1468           (declare (fixnum i))
1469           (let ((tn (svref ltns i)))
1470             (unless (or (null tn) (eq tn :more) (tn-offset tn))
1471               (pack-tn tn nil))))))
1472
1473     ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, which
1474     ;; could possibly not appear in any local TN map.
1475     (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
1476         ((null tn))
1477       (unless (tn-offset tn)
1478         (pack-tn tn nil)))
1479
1480     ;; Do load TN packing and emit saves.
1481     (let ((*repack-blocks* nil))
1482       (cond ((and optimize *pack-optimize-saves*)
1483              (optimized-emit-saves component)
1484              (do-ir2-blocks (block component)
1485                (pack-load-tns block)))
1486             (t
1487              (do-ir2-blocks (block component)
1488                (emit-saves block)
1489                (pack-load-tns block))))
1490       (when *repack-blocks*
1491         (loop
1492           (when (zerop (hash-table-count *repack-blocks*)) (return))
1493           (maphash #'(lambda (block v)
1494                        (declare (ignore v))
1495                        (remhash block *repack-blocks*)
1496                        (event repack-block)
1497                        (pack-load-tns block))
1498                    *repack-blocks*)))))
1499
1500   (values))