src/compiler/pack-iterative.lisp

   1 ;;;; This file contains code for the iterative spilling/coloring
   2 ;;;; register allocator
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!REGALLOC")
  14 ;;;; Useful references to understand the algorithms and decisions made
  15 ;;;; in this allocator.
  16 ;;;;
  17 ;;;; For more background:
  18 ;;;;
  19 ;;;; Chaitin, Gregory J. "Register allocation & spilling via graph
  20 ;;;; coloring." ACM Sigplan Notices. Vol. 17. No. 6. ACM, 1982.
  21 ;;;; (http://web.eecs.umich.edu/~mahlke/courses/583f12/reading/chaitin82.pdf)
  22 ;;;;
  23 ;;;; Briggs, Preston. "Register allocation via graph coloring."
  24 ;;;; Diss. Rice University, 1992.
  25 ;;;; (http://www.cs.utexas.edu/~mckinley/380C/lecs/briggs-thesis-1992.pdf)
  26 ;;;;
  27 ;;;; Shorter or more directly applied articles:
  28 ;;;;
  29 ;;;; Briggs, Preston, Keith D. Cooper, and Linda Torczon.
  30 ;;;; "Improvements to graph coloring register allocation."  ACM
  31 ;;;; Transactions on Programming Languages and Systems (TOPLAS) 16.3
  32 ;;;; (1994): 428-455.
  33 ;;;; (http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.30.2616)
  34 ;;;;
  35 ;;;; Smith, Michael D., Norman Ramsey, and Glenn Holloway.  "A
  36 ;;;; generalized algorithm for graph-coloring register allocation."
  37 ;;;; ACM SIGPLAN Notices. Vol. 39. No. 6. ACM, 2004.
  38 ;;;; (http://www.cs.tufts.edu/~nr/pubs/gcra-abstract.html)
  39 ;;;;
  40 ;;;; Cooper, Keith D., Anshuman Dasgupta, and Jason Eckhardt.
  41 ;;;; "Revisiting graph coloring register allocation: A study of the
  42 ;;;; Chaitin-Briggs and Callahan-Koblenz algorithms." Languages and
  43 ;;;; Compilers for Parallel Computing. Springer Berlin Heidelberg,
  44 ;;;; 2006. 1-16.
  45 ;;;; (http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.107.9598)
  46 \f
  47 ;;; Interference graph data structure
  48 (defstruct (ordered-set
  49             (:include sset)
  50             (:conc-name #:oset-))
  51   (members nil :type list))
  52
  53 (defun oset-adjoin (oset element)
  54   (when (sset-adjoin element oset)
  55     (push element (oset-members oset))
  56     t))
  57
  58 (defun oset-delete (oset element)
  59   (when (sset-delete element oset)
  60     (setf (oset-members oset)
  61           (delete element (oset-members oset)))
  62     t))
  63
  64 (defun oset-member (oset element)
  65   (sset-member element oset))
  66
  67 (defmacro do-oset-elements ((variable oset &optional return) &body body)
  68   `(dolist (,variable (oset-members ,oset) ,return)
  69      ,@body))
  70
  71 ;; vertex in an interference graph
  72 (def!struct (vertex
  73              (:include sset-element)
  74              (:constructor make-vertex (tn pack-type)))
  75   ;; incidence set, as an ordered list (for reproducibility)
  76   (incidence (make-ordered-set) :type ordered-set)
  77   ;; list of potential locations in the TN's preferred SB for the
  78   ;; vertex, taking into account reserve locations and preallocated
  79   ;; TNs.
  80   (initial-domain nil :type list)
  81   (initial-domain-size 0 :type index)
  82   ;; TN this is a vertex for.
  83   (tn nil :type tn)
  84   ;; type of packing necessary. We should only have to determine
  85   ;; colors for :normal TNs/vertices
  86   (pack-type nil :type (member :normal :wired :restricted))
  87   ;; color = (cons offset sc)
  88   (color nil :type (or cons null))
  89   ;; current status, removed from the interference graph or not (on
  90   ;; stack or not)
  91   (invisible nil :type t)
  92   ;; (tn-spill-cost (vertex-tn vertex))
  93   (spill-cost 0 :type fixnum))
  94
  95 (declaim (inline vertex-sc))
  96 (defun vertex-sc (vertex)
  97   (tn-sc (vertex-tn vertex)))
  98
  99 ;; interference graph
 100 (def!struct (interference-graph
 101              (:constructor %make-interference-graph)
 102              (:conc-name #:ig-))
 103   ;; sorted set of yet-uncolored (and not necessarily spilled)
 104   ;; vertices: vertices with lower spill cost come first.
 105   (vertices nil :type list)
 106   ;; unsorted set of precolored vertices.
 107   (precolored-vertices nil :type list)
 108   (tn-vertex (bug "missing arg") :type hash-table)
 109   ;; A function that maps TNs to vertices, and then to the vertex's
 110   ;; assigned offset, if any.  The offset (or NIL) is returned first,
 111   ;; then the vertex as a second value.
 112   (tn-vertex-mapping (bug "missing arg") :type function))
 113 \f
 114 ;;; Interference graph construction
 115 ;;;
 116 ;;; First, compute conflict edges between vertices that aren't
 117 ;;; precolored: precolored vertices have already been handled via
 118 ;;; domain initialisation.
 119 ;;;
 120 ;;; This area is ripe for hard-to-explain bugs. If PACK-COLORED starts
 121 ;;; AVERing out, it may be useful to comment out most of
 122 ;;; INSERT-CONFLICT-EDGES and test for TNS-CONFLICT in a double loop
 123 ;;; over the concatenation of all three vertex lists.
 124
 125 ;; Adjoin symmetric edge (A,B) to both A and B. Unless
 126 ;; PERHAPS-REDUNDANT, aver that these edges are new.
 127 (defun insert-one-edge (a b &optional perhaps-redundant)
 128   (declare (type vertex a b))
 129   (aver (neq a b))
 130   ;; not even in the same storage base => no conflict;
 131   ;; or one is pre-allocated => handled via domain.
 132   (unless (or (neq (sc-sb (vertex-sc a)) (sc-sb (vertex-sc b)))
 133               (tn-offset (vertex-tn a))
 134               (tn-offset (vertex-tn b)))
 135     (aver (or (oset-adjoin (vertex-incidence a) b)
 136               perhaps-redundant))
 137     (aver (or (oset-adjoin (vertex-incidence b) a)
 138               perhaps-redundant))))
 139
 140 ;; Partition the global TNs that appear in that IR2 block, between
 141 ;; those that are LIVE throughout the block and the rest.
 142 (defun block-gtns (block tn-vertex)
 143   (declare (type ir2-block block)
 144            (type hash-table tn-vertex))
 145   (collect ((live-gtns)
 146             (gtns))
 147     (do ((conflict (ir2-block-global-tns block)
 148                    (global-conflicts-next-blockwise
 149                     conflict)))
 150         ((null conflict)
 151          (values (live-gtns) (gtns)))
 152       (let ((tn (global-conflicts-tn conflict)))
 153         (awhen (and (not (tn-offset tn))
 154                     (not (eql :component (tn-kind tn)))
 155                     (gethash tn tn-vertex))
 156           (if (eql (global-conflicts-kind conflict) :live)
 157               (live-gtns it)
 158               (gtns (cons it conflict))))))))
 159
 160 ;; Scan CONFLICTS for conflicts with TNs that come after VERTEX in the
 161 ;; local TN order.  Also, add edges with all LIVE-GTNs: they conflict
 162 ;; with everything but are absent from conflict bitvectors.
 163 (defun insert-block-local-conflicts-for (vertex number conflicts
 164                                          local-tns ltn-count
 165                                          gtn-p live-gtns tn-vertex)
 166   (declare (type vertex vertex) (type local-tn-number number)
 167            (type local-tn-bit-vector conflicts)
 168            (type local-tn-vector local-tns) (type local-tn-count ltn-count)
 169            (type list live-gtns) (type hash-table tn-vertex))
 170   ;; conflict with all live gtns
 171   (dolist (b live-gtns)
 172     (insert-one-edge vertex b gtn-p))
 173   ;; and add conflicts if LTN number > number
 174   (loop
 175     with local = (tn-local (vertex-tn vertex))
 176     for j from (1+ number) below ltn-count
 177     when (plusp (sbit conflicts j))
 178       do (let ((b (aref local-tns j)))
 179            (when (tn-p b)
 180              (aver (or gtn-p
 181                        (tn-global-conflicts b)
 182                        (eq local (tn-local b))))
 183              (awhen (gethash b tn-vertex)
 184                (insert-one-edge vertex it (and gtn-p
 185                                                (tn-global-conflicts b))))))))
 186
 187 ;; Compute all conflicts in a single IR2 block
 188 (defun insert-block-local-conflicts (block tn-vertex)
 189   (declare (type ir2-block block)
 190            (type hash-table tn-vertex))
 191   (let* ((local-tns (ir2-block-local-tns block))
 192          (n (ir2-block-local-tn-count block)))
 193     (multiple-value-bind (live-gtns gtns)
 194         (block-gtns block tn-vertex)
 195       ;; all live gtns conflict with one another
 196       (loop for (a . rest) on live-gtns do
 197         (dolist (b rest)
 198           (insert-one-edge a b t)))
 199       ;; normal gtn-* edges
 200       (loop for (a . conflict) in gtns do
 201         (let ((number (global-conflicts-number conflict))
 202               (conflicts (global-conflicts-conflicts conflict)))
 203           (insert-block-local-conflicts-for a number conflicts
 204                                             local-tns n
 205                                             t live-gtns tn-vertex)))
 206       ;; local-* interference
 207       (dotimes (i n)
 208         (binding* ((a (aref local-tns i))
 209                    (vertex (gethash a tn-vertex) :exit-if-null)
 210                    (conflicts (tn-local-conflicts a)))
 211           (unless (or (tn-offset a)
 212                       (tn-global-conflicts a))
 213             (insert-block-local-conflicts-for vertex i conflicts
 214                                               local-tns n
 215                                               nil live-gtns tn-vertex)))))))
 216
 217 ;; Compute all conflict edges for component
 218 ;; COMPONENT-VERTICES is a list of vertices for :component TNs,
 219 ;; GLOBAL-VERTICES a list of vertices for TNs with global conflicts,
 220 ;; and LOCAL-VERTICES a list of vertices for local TNs.
 221 ;;
 222 ;; TN-VERTEX is a hash table from TN -> VERTEX, for all vertices that
 223 ;; must be colored.
 224 (defun insert-conflict-edges (component
 225                               component-vertices global-vertices
 226                               local-vertices tn-vertex)
 227   (declare (type list component-vertices global-vertices local-vertices)
 228            (type hash-table tn-vertex))
 229   ;; COMPONENT vertices conflict with everything
 230   (loop for (a . rest) on component-vertices
 231         do (dolist (b rest)
 232              (insert-one-edge a b))
 233            (dolist (b global-vertices)
 234              (insert-one-edge a b))
 235            (dolist (b local-vertices)
 236              (insert-one-edge a b)))
 237   ;; Find the other edges by enumerating IR2 blocks
 238   (do-ir2-blocks (block component)
 239     (insert-block-local-conflicts block tn-vertex)))
 240 \f
 241 ;;; Interference graph construction, the rest: annotating vertex
 242 ;;; structures, and bundling up the conflict graph.
 243 ;;;
 244 ;;; Also, permanently removing a vertex from a graph, without
 245 ;;; reconstructing it from scratch.
 246
 247 ;; Supposing that TN is restricted to its preferred SC, what locations
 248 ;; are available?
 249 (defun restricted-tn-locations (tn)
 250   (declare (type tn tn))
 251   (let* ((sc (tn-sc tn))
 252          (reserve (sc-reserve-locations sc)))
 253     (loop
 254       for loc in (sc-locations sc)
 255       unless (or (and reserve (memq loc reserve)) ; common case: no reserve
 256                  (conflicts-in-sc tn sc loc))
 257         collect loc)))
 258
 259 ;; walk over vertices, precomputing as much information as possible,
 260 ;; and partitioning according to their kind.
 261 ;; Return the partition, and a hash table to map tns to vertices.
 262 (defun prepare-vertices (vertices)
 263   (let (component-vertices
 264         global-vertices
 265         local-vertices
 266         (tn-vertex (make-hash-table)))
 267     (loop for i upfrom 0
 268           for vertex in vertices
 269           do (let* ((tn (vertex-tn vertex))
 270                     (offset (tn-offset tn))
 271                     (sc (tn-sc tn))
 272                     (locs (if offset
 273                               (list offset)
 274                               (restricted-tn-locations tn))))
 275                (aver (not (unbounded-tn-p tn)))
 276                (setf (vertex-number vertex) i
 277                      (vertex-incidence vertex) (make-ordered-set)
 278                      (vertex-initial-domain vertex) locs
 279                      (vertex-initial-domain-size vertex) (length locs)
 280                      (vertex-color vertex) (and offset
 281                                                 (cons offset sc))
 282                      (vertex-invisible vertex) nil
 283                      (vertex-spill-cost vertex) (tn-cost tn)
 284                      (gethash tn tn-vertex) vertex)
 285                (cond (offset) ; precolored -> no need to track conflict
 286                      ((eql :component (tn-kind tn))
 287                       (push vertex component-vertices))
 288                      ((tn-global-conflicts tn)
 289                       (push vertex global-vertices))
 290                      (t
 291                       (aver (tn-local tn))
 292                       (push vertex local-vertices)))))
 293     (values component-vertices global-vertices local-vertices
 294             tn-vertex)))
 295
 296 ;; Construct the interference graph for these vertices in the component.
 297 ;; All TNs types are included in the graph, both with offset and without,
 298 ;; but only those requiring coloring appear in the VERTICES slot.
 299 (defun make-interference-graph (vertices component)
 300   (multiple-value-bind (component-vertices global-vertices local-vertices
 301                         tn-vertex)
 302       (prepare-vertices vertices)
 303     (insert-conflict-edges component
 304                            component-vertices global-vertices local-vertices
 305                            tn-vertex)
 306     ;; Normalize adjacency list ordering, and collect all uncolored
 307     ;; vertices in the graph.
 308     (collect ((colored)
 309               (uncolored))
 310       (dolist (v vertices)
 311         (let ((incidence (vertex-incidence v)))
 312           (setf (oset-members incidence)
 313                 ;; this really doesn't matter, but minimises variability
 314                 (sort (oset-members incidence) #'< :key #'vertex-number)))
 315         (cond ((vertex-color v)
 316                (aver (tn-offset (vertex-tn v)))
 317                (colored v))
 318               (t
 319                (aver (not (tn-offset (vertex-tn v))))
 320                (uncolored v))))
 321       ;; Later passes like having this list sorted; do it in advance.
 322       (%make-interference-graph
 323        :vertices (stable-sort (uncolored) #'< :key #'vertex-spill-cost)
 324        :precolored-vertices (colored)
 325        :tn-vertex tn-vertex
 326        :tn-vertex-mapping (lambda (tn)
 327                             (awhen (gethash tn tn-vertex)
 328                               (values (car (vertex-color it))
 329                                       it)))))))
 330
 331 ;; &key reset: whether coloring/invisibility information should be
 332 ;; removed from all the remaining vertices
 333 (defun remove-vertex-from-interference-graph (vertex graph &key reset)
 334   (declare (type vertex vertex) (type interference-graph graph))
 335   (let ((vertices (if reset
 336                       (loop for v in (ig-vertices graph)
 337                             unless (eql v vertex)
 338                               do (aver (not (tn-offset (vertex-tn v))))
 339                                  (setf (vertex-invisible v) nil
 340                                        (vertex-color v) nil)
 341                               and collect v)
 342                       (remove vertex (ig-vertices graph)))))
 343     (setf (ig-vertices graph) vertices)
 344     (do-oset-elements (neighbor (vertex-incidence vertex) graph)
 345       (oset-delete (vertex-incidence neighbor) vertex))))
 346 \f
 347 ;;; Support code
 348
 349 ;; Return non-nil if COLOR conflicts with any of NEIGHBOR-COLORS.
 350 ;; Take into account element sizes of the respective SCs.
 351 (defun color-conflict-p (color neighbor-colors)
 352   (declare (type (cons integer sc) color))
 353   (flet ((intervals-intersect-p (x x-width y y-width)
 354            (when (< y x)
 355              (rotatef x y)
 356              (rotatef x-width y-width))
 357            ;; x <= y. [x, x+x-width] and [y, y+y-width) intersect iff
 358            ;; y \in [x, x+x-width).
 359             (< y (+ x x-width))))
 360     (destructuring-bind (offset . sc) color
 361       (let ((element-size (sc-element-size sc)))
 362         (loop for (neighbor-offset . neighbor-sc) in neighbor-colors
 363               thereis (intervals-intersect-p
 364                        offset element-size
 365                        neighbor-offset (sc-element-size neighbor-sc)))))))
 366
 367 ;; Assumes that VERTEX pack-type is :WIRED.
 368 (defun vertex-color-possible-p (vertex color)
 369   (declare (type integer color) (type vertex vertex))
 370   (and (or (and (neq (vertex-pack-type vertex) :wired)
 371                 (not (tn-offset (vertex-tn vertex))))
 372            (= color (car (vertex-color vertex))))
 373        (memq color (vertex-initial-domain vertex))
 374        (not (color-conflict-p
 375              (cons color (vertex-sc vertex))
 376              (collect ((colors))
 377                (do-oset-elements (neighbor (vertex-incidence vertex)
 378                                            (colors))
 379                  (unless (vertex-invisible neighbor)
 380                    (colors (vertex-color neighbor)))))))))
 381
 382 ;; Sorted list of all possible locations for vertex in its preferred
 383 ;; SC: more heavily loaded (i.e that should be tried first) locations
 384 ;; first.  vertex-initial-domain is already sorted, only have to
 385 ;; remove offsets that aren't currently available.
 386 (defun vertex-domain (vertex)
 387   (declare (type vertex vertex))
 388   (remove-if-not (lambda (color)
 389                    (vertex-color-possible-p vertex color))
 390                  (vertex-initial-domain vertex)))
 391
 392 ;; Return a list of vertices that we might want VERTEX to share its
 393 ;; location with.
 394 (defun vertex-target-vertices (vertex tn-offset)
 395   (declare (type vertex vertex) (type function tn-offset))
 396   (let ((sb (sc-sb (vertex-sc vertex)))
 397         (neighbors (vertex-incidence vertex))
 398         vertices)
 399     (do-target-tns (current (vertex-tn vertex) :limit 20)
 400       (multiple-value-bind (offset target)
 401           (funcall tn-offset current)
 402         (when (and offset
 403                    (eq sb (sc-sb (tn-sc current)))
 404                    (not (oset-member neighbors target)))
 405           (pushnew target vertices))))
 406     (nreverse vertices)))
 407
 408 ;; Choose the "best" color for these vertices: a color is good if as
 409 ;; many of these vertices simultaneously take that color, and those
 410 ;; that can't have a low spill cost.
 411 (defun vertices-best-color (vertices colors)
 412   (let ((best-color      nil)
 413         (best-compatible '())
 414         (best-cost       nil))
 415     ;; TODO: sort vertices by spill cost, so that high-spill cost ones
 416     ;; are more likely to be compatible?  We're trying to find a
 417     ;; maximal 1-colorable subgraph here, ie. a maximum independent
 418     ;; set :\ Still, a heuristic like first attempting to pack in
 419     ;; max-cost vertices may be useful
 420     (dolist (color colors)
 421       (let ((compatible '())
 422             (cost 0))
 423         (dolist (vertex vertices)
 424           (when (and (notany (lambda (existing)
 425                                (oset-member (vertex-incidence existing)
 426                                             vertex))
 427                              compatible)
 428                      (vertex-color-possible-p vertex color))
 429             (incf cost (max 1 (vertex-spill-cost vertex)))
 430             (push vertex compatible)))
 431         (when (or (null best-cost)
 432                   (> cost best-cost))
 433           (setf best-color      color
 434                 best-compatible compatible
 435                 best-cost       cost))))
 436     (values best-color best-compatible)))
 437 \f
 438 ;;; Coloring inner loop
 439
 440 ;; Greedily choose the color for this vertex, also moving around any
 441 ;; :target vertex to the same color if possible.
 442 (defun find-vertex-color (vertex tn-vertex-mapping)
 443   (awhen (vertex-domain vertex)
 444     (let* ((targets (vertex-target-vertices vertex tn-vertex-mapping))
 445            (sc (vertex-sc vertex))
 446            (sb (sc-sb sc)))
 447       (multiple-value-bind (color recolor-vertices)
 448           (if targets
 449               (vertices-best-color targets it)
 450               (values (first it) nil))
 451         (aver color)
 452         (dolist (target recolor-vertices)
 453           (aver (car (vertex-color target)))
 454           (unless (eql color (car (vertex-color target)))
 455             (aver (eq sb (sc-sb (vertex-sc target))))
 456             (aver (not (tn-offset (vertex-tn target))))
 457             #+nil ; this check is slow
 458             (aver (vertex-color-possible-p target color))
 459             (setf (car (vertex-color target)) color)))
 460         (cons color sc)))))
 461
 462 ;; Partition vertices into those that are likely to be colored and
 463 ;; those that are likely to be spilled.  Assumes that the interference
 464 ;; graph's vertices are sorted with the least spill cost first, so
 465 ;; that the stacks end up with the greatest spill cost vertices first.
 466 (defun partition-and-order-vertices (interference-graph)
 467   (flet ((domain-size (vertex)
 468            (vertex-initial-domain-size vertex))
 469          (degree (vertex)
 470            (count-if-not #'vertex-invisible
 471                          (oset-members (vertex-incidence vertex))))
 472          (eliminate-vertex (vertex)
 473            (setf (vertex-invisible vertex) t)))
 474     (let* ((precoloring-stack '())
 475            (prespilling-stack '())
 476            (vertices (ig-vertices interference-graph)))
 477       ;; walk the vertices from least important to most important TN wrt
 478       ;; spill cost.  That way the TNs we really don't want to spill are
 479       ;; at the head of the colouring lists.
 480       (loop for vertex in vertices do
 481         (aver (not (vertex-color vertex))) ; we already took those out above
 482         (eliminate-vertex vertex)
 483         ;; FIXME: some interference will be with vertices that don't
 484         ;;  take the same number of slots. Find a smarter heuristic.
 485         (cond ((< (degree vertex) (domain-size vertex))
 486                (push vertex precoloring-stack))
 487               (t
 488                (push vertex prespilling-stack))))
 489       (values precoloring-stack prespilling-stack))))
 490
 491 ;; Try and color the interference graph once.
 492 (defun color-interference-graph (interference-graph)
 493   (let ((tn-vertex (ig-tn-vertex-mapping interference-graph)))
 494     (flet ((color-vertices (vertices)
 495              (dolist (vertex vertices)
 496                (awhen (find-vertex-color vertex tn-vertex)
 497                  (setf (vertex-color vertex) it
 498                        (vertex-invisible vertex) nil)))))
 499       (multiple-value-bind (probably-colored probably-spilled)
 500           (partition-and-order-vertices interference-graph)
 501         (color-vertices probably-colored)
 502         ;; These might benefit from further ordering... LexBFS?
 503         (color-vertices probably-spilled))))
 504   interference-graph)
 505 \f
 506 ;;; Iterative spilling logic.
 507
 508 ;; maximum number of spill iterations
 509 (defvar *pack-iterations* 500)
 510
 511 ;; Find the least-spill-cost neighbor in each color.
 512 ;; FIXME: this is too slow and isn't the right interface anymore.
 513 ;; The code might be fast enough if there were a simple way to detect
 514 ;; whether a given vertex is a min-candidate for another uncolored
 515 ;; vertex.
 516 ;; I'm leaving this around as an idea of what a smart spill choice
 517 ;; might be like. -- PK
 518 #+nil
 519 (defun collect-min-spill-candidates (vertex)
 520   (let ((colors '()))
 521     (do-oset-elements (neighbor (vertex-incidence vertex))
 522       (when (eql :normal (vertex-pack-type neighbor))
 523         (let* ((color (car (vertex-color neighbor)))
 524                (cell (assoc color colors))
 525                (cost-neighbor (tn-spill-cost (vertex-tn neighbor))))
 526           (cond (cell
 527                  (when (< cost-neighbor (tn-spill-cost
 528                                          (vertex-tn (cdr cell))))
 529                    (setf (cdr cell) neighbor)))
 530                 (t (push (cons color neighbor) colors))))))
 531     (remove nil (mapcar #'cdr colors))))
 532
 533 ;; Try to color the graph. If some TNs are left uncolored, find a
 534 ;; spill candidate, force it on the stack, and try again.
 535 (defun iterate-color (vertices component
 536                       &optional (iterations *pack-iterations*))
 537   (let* ((spill-list '())
 538          ;; presorting edges helps; later sorts are stable, so this
 539          ;; ends up sorting by (sum of) loop depth for TNs with equal
 540          ;; costs.
 541          (vertices (stable-sort (copy-list vertices) #'>
 542                                 :key (lambda (vertex)
 543                                        (tn-loop-depth
 544                                         (vertex-tn vertex)))))
 545          (nvertices (length vertices))
 546          (graph (make-interference-graph vertices component))
 547          to-spill)
 548     (labels ((spill-candidates-p (vertex)
 549                (unless (vertex-color vertex)
 550                  (aver (eql :normal (vertex-pack-type vertex)))
 551                  t))
 552              (iter (to-spill)
 553                (when to-spill
 554                  (setf (vertex-invisible to-spill) t
 555                        (vertex-color to-spill) nil)
 556                  (push to-spill spill-list)
 557                  (setf graph (remove-vertex-from-interference-graph
 558                               to-spill graph :reset t)))
 559                (color-interference-graph graph)
 560                (find-if #'spill-candidates-p (ig-vertices graph))))
 561       (loop repeat iterations
 562             while (setf to-spill (iter to-spill))))
 563     (let ((colored (ig-vertices graph)))
 564       (aver (= nvertices (+ (length spill-list) (length colored)
 565                             (length (ig-precolored-vertices graph)))))
 566       colored)))
 567 \f
 568 ;;; Nice interface
 569
 570 ;; Just pack vertices that have been assigned a color.
 571 (defun pack-colored (colored-vertices optimize)
 572   (dolist (vertex colored-vertices)
 573     (let* ((color (vertex-color vertex))
 574            (offset (car color))
 575            (tn (vertex-tn vertex)))
 576       (cond ((tn-offset tn))
 577             (offset
 578              (aver (not (conflicts-in-sc tn (tn-sc tn) offset)))
 579              (setf (tn-offset tn) offset)
 580              (pack-wired-tn (vertex-tn vertex) optimize))
 581             (t
 582              ;; we better not have a :restricted TN not packed in its
 583              ;; finite SC
 584              (aver (neq (vertex-pack-type vertex) :restricted)))))))
 585
 586 ;; Pack pre-allocated TNs, collect vertices, and color.
 587 (defun pack-iterative (component 2comp optimize)
 588   (declare (type component component) (type ir2-component 2comp))
 589   (collect ((vertices))
 590     ;; Pack TNs that *must* be in a certain location, but still
 591     ;; register them in the interference graph: it's useful to have
 592     ;; them in the graph for targeting purposes.
 593     (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
 594         ((null tn))
 595       (pack-wired-tn tn optimize)
 596       (unless (unbounded-tn-p tn)
 597         (vertices (make-vertex tn :wired))))
 598
 599     ;; Preallocate vertices that *must* be in this finite SC.  If
 600     ;; targeting is improved, giving them a high priority in regular
 601     ;; regalloc may be a better idea.
 602     (collect ((component)
 603               (normal))
 604       (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
 605           ((null tn))
 606         (unless (or (tn-offset tn) (unbounded-tn-p tn))
 607           (vertices (make-vertex tn :restricted))
 608           (if (eq :component (tn-kind tn))
 609               (component tn)
 610               (normal tn))))
 611       ;; First, pack TNs that span the whole component to minimise
 612       ;; fragmentation.  Also, pack high cost TNs first, so they get
 613       ;; nice targeting.
 614       (flet ((pack-tns (tns)
 615                (dolist (tn (stable-sort tns #'> :key #'tn-cost))
 616                  (pack-tn tn t optimize))))
 617         (pack-tns (component))
 618         (pack-tns (normal))))
 619
 620     ;; Now that all pre-packed TNs are registered as vertices, work on
 621     ;; the rest.  Walk through all normal TNs, and determine whether
 622     ;; we should try to put them in registers or stick them straight
 623     ;; to the stack.
 624     (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
 625         ((null tn))
 626       ;; Only consider TNs that aren't forced on the stack and for
 627       ;; which the spill cost is non-negative (i.e. not live across so
 628       ;; many calls that it's simpler to just leave them on the stack)
 629       (when (and (not (tn-offset tn))
 630                  (neq (tn-kind tn) :more)
 631                  (not (unbounded-tn-p tn))
 632                  (not (and (sc-save-p (tn-sc tn))   ; SC is caller-save, and
 633                            (minusp (tn-cost tn))))) ; TN lives in many calls
 634         ;; otherwise, we'll let the final pass handle them.
 635         (vertices (make-vertex tn :normal))))
 636     ;; Sum loop depths to guide the spilling logic
 637     (assign-tn-depths component :reducer #'+)
 638     ;; Iteratively find a coloring/spill partition, and allocate those
 639     ;; for which we have a location
 640     (pack-colored (iterate-color (vertices) component)
 641                   optimize))
 642   nil)