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