--- /dev/null
+;;;; This file contains code for the iterative spilling/coloring
+;;;; register allocator
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!REGALLOC")
+;;;; Useful references to understand the algorithms and decisions made
+;;;; in this allocator.
+;;;;
+;;;; For more background:
+;;;;
+;;;; Chaitin, Gregory J. "Register allocation & spilling via graph
+;;;; coloring." ACM Sigplan Notices. Vol. 17. No. 6. ACM, 1982.
+;;;; (http://web.eecs.umich.edu/~mahlke/courses/583f12/reading/chaitin82.pdf)
+;;;;
+;;;; Briggs, Preston. "Register allocation via graph coloring."
+;;;; Diss. Rice University, 1992.
+;;;; (http://www.cs.utexas.edu/~mckinley/380C/lecs/briggs-thesis-1992.pdf)
+;;;;
+;;;; Shorter or more directly applied articles:
+;;;;
+;;;; Briggs, Preston, Keith D. Cooper, and Linda Torczon.
+;;;; "Improvements to graph coloring register allocation." ACM
+;;;; Transactions on Programming Languages and Systems (TOPLAS) 16.3
+;;;; (1994): 428-455.
+;;;; (http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.30.2616)
+;;;;
+;;;; Smith, Michael D., Norman Ramsey, and Glenn Holloway. "A
+;;;; generalized algorithm for graph-coloring register allocation."
+;;;; ACM SIGPLAN Notices. Vol. 39. No. 6. ACM, 2004.
+;;;; (http://www.cs.tufts.edu/~nr/pubs/gcra-abstract.html)
+;;;;
+;;;; Cooper, Keith D., Anshuman Dasgupta, and Jason Eckhardt.
+;;;; "Revisiting graph coloring register allocation: A study of the
+;;;; Chaitin-Briggs and Callahan-Koblenz algorithms." Languages and
+;;;; Compilers for Parallel Computing. Springer Berlin Heidelberg,
+;;;; 2006. 1-16.
+;;;; (http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.107.9598)
+\f
+;;; Interference graph data structure
+(defstruct (ordered-set
+ (:include sset)
+ (:conc-name #:oset-))
+ (members nil :type list))
+
+(defun oset-adjoin (oset element)
+ (when (sset-adjoin element oset)
+ (push element (oset-members oset))
+ t))
+
+(defun oset-delete (oset element)
+ (when (sset-delete element oset)
+ (setf (oset-members oset)
+ (delete element (oset-members oset)))
+ t))
+
+(defun oset-member (oset element)
+ (sset-member element oset))
+
+(defmacro do-oset-elements ((variable oset &optional return) &body body)
+ `(dolist (,variable (oset-members ,oset) ,return)
+ ,@body))
+
+;; vertex in an interference graph
+(def!struct (vertex
+ (:include sset-element)
+ (:constructor make-vertex (tn pack-type)))
+ ;; incidence set, as an ordered list (for reproducibility)
+ (incidence (make-ordered-set) :type ordered-set)
+ ;; list of potential locations in the TN's preferred SB for the
+ ;; vertex, taking into account reserve locations and preallocated
+ ;; TNs.
+ (initial-domain nil :type list)
+ (initial-domain-size 0 :type index)
+ ;; TN this is a vertex for.
+ (tn nil :type tn)
+ ;; type of packing necessary. We should only have to determine
+ ;; colors for :normal TNs/vertices
+ (pack-type nil :type (member :normal :wired :restricted))
+ ;; color = (cons offset sc)
+ (color nil :type (or cons null))
+ ;; current status, removed from the interference graph or not (on
+ ;; stack or not)
+ (invisible nil :type t)
+ ;; (tn-spill-cost (vertex-tn vertex))
+ (spill-cost 0 :type fixnum))
+
+(declaim (inline vertex-sc))
+(defun vertex-sc (vertex)
+ (tn-sc (vertex-tn vertex)))
+
+;; interference graph
+(def!struct (interference-graph
+ (:constructor %make-interference-graph)
+ (:conc-name #:ig-))
+ ;; sorted set of yet-uncolored (and not necessarily spilled)
+ ;; vertices: vertices with lower spill cost come first.
+ (vertices nil :type list)
+ ;; unsorted set of precolored vertices.
+ (precolored-vertices nil :type list)
+ (tn-vertex (bug "missing arg") :type hash-table)
+ ;; A function that maps TNs to vertices, and then to the vertex's
+ ;; assigned offset, if any. The offset (or NIL) is returned first,
+ ;; then the vertex as a second value.
+ (tn-vertex-mapping (bug "missing arg") :type function))
+\f
+;;; Interference graph construction
+;;;
+;;; First, compute conflict edges between vertices that aren't
+;;; precolored: precolored vertices have already been handled via
+;;; domain initialisation.
+;;;
+;;; This area is ripe for hard-to-explain bugs. If PACK-COLORED starts
+;;; AVERing out, it may be useful to comment out most of
+;;; INSERT-CONFLICT-EDGES and test for TNS-CONFLICT in a double loop
+;;; over the concatenation of all three vertex lists.
+
+;; Adjoin symmetric edge (A,B) to both A and B. Unless
+;; PERHAPS-REDUNDANT, aver that these edges are new.
+(defun insert-one-edge (a b &optional perhaps-redundant)
+ (declare (type vertex a b))
+ (aver (neq a b))
+ ;; not even in the same storage base => no conflict;
+ ;; or one is pre-allocated => handled via domain.
+ (unless (or (neq (sc-sb (vertex-sc a)) (sc-sb (vertex-sc b)))
+ (tn-offset (vertex-tn a))
+ (tn-offset (vertex-tn b)))
+ (aver (or (oset-adjoin (vertex-incidence a) b)
+ perhaps-redundant))
+ (aver (or (oset-adjoin (vertex-incidence b) a)
+ perhaps-redundant))))
+
+;; Partition the global TNs that appear in that IR2 block, between
+;; those that are LIVE throughout the block and the rest.
+(defun block-gtns (block tn-vertex)
+ (declare (type ir2-block block)
+ (type hash-table tn-vertex))
+ (collect ((live-gtns)
+ (gtns))
+ (do ((conflict (ir2-block-global-tns block)
+ (global-conflicts-next-blockwise
+ conflict)))
+ ((null conflict)
+ (values (live-gtns) (gtns)))
+ (let ((tn (global-conflicts-tn conflict)))
+ (awhen (and (not (tn-offset tn))
+ (not (eql :component (tn-kind tn)))
+ (gethash tn tn-vertex))
+ (if (eql (global-conflicts-kind conflict) :live)
+ (live-gtns it)
+ (gtns (cons it conflict))))))))
+
+;; Scan CONFLICTS for conflicts with TNs that come after VERTEX in the
+;; local TN order. Also, add edges with all LIVE-GTNs: they conflict
+;; with everything but are absent from conflict bitvectors.
+(defun insert-block-local-conflicts-for (vertex number conflicts
+ local-tns ltn-count
+ gtn-p live-gtns tn-vertex)
+ (declare (type vertex vertex) (type local-tn-number number)
+ (type local-tn-bit-vector conflicts)
+ (type local-tn-vector local-tns) (type local-tn-count ltn-count)
+ (type list live-gtns) (type hash-table tn-vertex))
+ ;; conflict with all live gtns
+ (dolist (b live-gtns)
+ (insert-one-edge vertex b gtn-p))
+ ;; and add conflicts if LTN number > number
+ (loop
+ with local = (tn-local (vertex-tn vertex))
+ for j from (1+ number) below ltn-count
+ when (plusp (sbit conflicts j))
+ do (let ((b (aref local-tns j)))
+ (when (tn-p b)
+ (aver (or gtn-p
+ (tn-global-conflicts b)
+ (eq local (tn-local b))))
+ (awhen (gethash b tn-vertex)
+ (insert-one-edge vertex it (and gtn-p
+ (tn-global-conflicts b))))))))
+
+;; Compute all conflicts in a single IR2 block
+(defun insert-block-local-conflicts (block tn-vertex)
+ (declare (type ir2-block block)
+ (type hash-table tn-vertex))
+ (let* ((local-tns (ir2-block-local-tns block))
+ (n (ir2-block-local-tn-count block)))
+ (multiple-value-bind (live-gtns gtns)
+ (block-gtns block tn-vertex)
+ ;; all live gtns conflict with one another
+ (loop for (a . rest) on live-gtns do
+ (dolist (b rest)
+ (insert-one-edge a b t)))
+ ;; normal gtn-* edges
+ (loop for (a . conflict) in gtns do
+ (let ((number (global-conflicts-number conflict))
+ (conflicts (global-conflicts-conflicts conflict)))
+ (insert-block-local-conflicts-for a number conflicts
+ local-tns n
+ t live-gtns tn-vertex)))
+ ;; local-* interference
+ (dotimes (i n)
+ (binding* ((a (aref local-tns i))
+ (vertex (gethash a tn-vertex) :exit-if-null)
+ (conflicts (tn-local-conflicts a)))
+ (unless (or (tn-offset a)
+ (tn-global-conflicts a))
+ (insert-block-local-conflicts-for vertex i conflicts
+ local-tns n
+ nil live-gtns tn-vertex)))))))
+
+;; Compute all conflict edges for component
+;; COMPONENT-VERTICES is a list of vertices for :component TNs,
+;; GLOBAL-VERTICES a list of vertices for TNs with global conflicts,
+;; and LOCAL-VERTICES a list of vertices for local TNs.
+;;
+;; TN-VERTEX is a hash table from TN -> VERTEX, for all vertices that
+;; must be colored.
+(defun insert-conflict-edges (component
+ component-vertices global-vertices
+ local-vertices tn-vertex)
+ (declare (type list component-vertices global-vertices local-vertices)
+ (type hash-table tn-vertex))
+ ;; COMPONENT vertices conflict with everything
+ (loop for (a . rest) on component-vertices
+ do (dolist (b rest)
+ (insert-one-edge a b))
+ (dolist (b global-vertices)
+ (insert-one-edge a b))
+ (dolist (b local-vertices)
+ (insert-one-edge a b)))
+ ;; Find the other edges by enumerating IR2 blocks
+ (do-ir2-blocks (block component)
+ (insert-block-local-conflicts block tn-vertex)))
+\f
+;;; Interference graph construction, the rest: annotating vertex
+;;; structures, and bundling up the conflict graph.
+;;;
+;;; Also, permanently removing a vertex from a graph, without
+;;; reconstructing it from scratch.
+
+;; Supposing that TN is restricted to its preferred SC, what locations
+;; are available?
+(defun restricted-tn-locations (tn)
+ (declare (type tn tn))
+ (let* ((sc (tn-sc tn))
+ (reserve (sc-reserve-locations sc)))
+ (loop
+ for loc in (sc-locations sc)
+ unless (or (and reserve (memq loc reserve)) ; common case: no reserve
+ (conflicts-in-sc tn sc loc))
+ collect loc)))
+
+;; walk over vertices, precomputing as much information as possible,
+;; and partitioning according to their kind.
+;; Return the partition, and a hash table to map tns to vertices.
+(defun prepare-vertices (vertices)
+ (let (component-vertices
+ global-vertices
+ local-vertices
+ (tn-vertex (make-hash-table)))
+ (loop for i upfrom 0
+ for vertex in vertices
+ do (let* ((tn (vertex-tn vertex))
+ (offset (tn-offset tn))
+ (sc (tn-sc tn))
+ (locs (if offset
+ (list offset)
+ (restricted-tn-locations tn))))
+ (aver (not (unbounded-tn-p tn)))
+ (setf (vertex-number vertex) i
+ (vertex-incidence vertex) (make-ordered-set)
+ (vertex-initial-domain vertex) locs
+ (vertex-initial-domain-size vertex) (length locs)
+ (vertex-color vertex) (and offset
+ (cons offset sc))
+ (vertex-invisible vertex) nil
+ (vertex-spill-cost vertex) (tn-cost tn)
+ (gethash tn tn-vertex) vertex)
+ (cond (offset) ; precolored -> no need to track conflict
+ ((eql :component (tn-kind tn))
+ (push vertex component-vertices))
+ ((tn-global-conflicts tn)
+ (push vertex global-vertices))
+ (t
+ (aver (tn-local tn))
+ (push vertex local-vertices)))))
+ (values component-vertices global-vertices local-vertices
+ tn-vertex)))
+
+;; Construct the interference graph for these vertices in the component.
+;; All TNs types are included in the graph, both with offset and without,
+;; but only those requiring coloring appear in the VERTICES slot.
+(defun make-interference-graph (vertices component)
+ (multiple-value-bind (component-vertices global-vertices local-vertices
+ tn-vertex)
+ (prepare-vertices vertices)
+ (insert-conflict-edges component
+ component-vertices global-vertices local-vertices
+ tn-vertex)
+ ;; Normalize adjacency list ordering, and collect all uncolored
+ ;; vertices in the graph.
+ (collect ((colored)
+ (uncolored))
+ (dolist (v vertices)
+ (let ((incidence (vertex-incidence v)))
+ (setf (oset-members incidence)
+ ;; this really doesn't matter, but minimises variability
+ (sort (oset-members incidence) #'< :key #'vertex-number)))
+ (cond ((vertex-color v)
+ (aver (tn-offset (vertex-tn v)))
+ (colored v))
+ (t
+ (aver (not (tn-offset (vertex-tn v))))
+ (uncolored v))))
+ ;; Later passes like having this list sorted; do it in advance.
+ (%make-interference-graph
+ :vertices (stable-sort (uncolored) #'< :key #'vertex-spill-cost)
+ :precolored-vertices (colored)
+ :tn-vertex tn-vertex
+ :tn-vertex-mapping (lambda (tn)
+ (awhen (gethash tn tn-vertex)
+ (values (car (vertex-color it))
+ it)))))))
+
+;; &key reset: whether coloring/invisibility information should be
+;; removed from all the remaining vertices
+(defun remove-vertex-from-interference-graph (vertex graph &key reset)
+ (declare (type vertex vertex) (type interference-graph graph))
+ (let ((vertices (if reset
+ (loop for v in (ig-vertices graph)
+ unless (eql v vertex)
+ do (aver (not (tn-offset (vertex-tn v))))
+ (setf (vertex-invisible v) nil
+ (vertex-color v) nil)
+ and collect v)
+ (remove vertex (ig-vertices graph)))))
+ (setf (ig-vertices graph) vertices)
+ (do-oset-elements (neighbor (vertex-incidence vertex) graph)
+ (oset-delete (vertex-incidence neighbor) vertex))))
+\f
+;;; Support code
+
+;; Return non-nil if COLOR conflicts with any of NEIGHBOR-COLORS.
+;; Take into account element sizes of the respective SCs.
+(defun color-conflict-p (color neighbor-colors)
+ (declare (type (cons integer sc) color))
+ (flet ((intervals-intersect-p (x x-width y y-width)
+ (when (< y x)
+ (rotatef x y)
+ (rotatef x-width y-width))
+ ;; x <= y. [x, x+x-width] and [y, y+y-width) intersect iff
+ ;; y \in [x, x+x-width).
+ (< y (+ x x-width))))
+ (destructuring-bind (offset . sc) color
+ (let ((element-size (sc-element-size sc)))
+ (loop for (neighbor-offset . neighbor-sc) in neighbor-colors
+ thereis (intervals-intersect-p
+ offset element-size
+ neighbor-offset (sc-element-size neighbor-sc)))))))
+
+;; Assumes that VERTEX pack-type is :WIRED.
+(defun vertex-color-possible-p (vertex color)
+ (declare (type integer color) (type vertex vertex))
+ (and (or (and (neq (vertex-pack-type vertex) :wired)
+ (not (tn-offset (vertex-tn vertex))))
+ (= color (car (vertex-color vertex))))
+ (memq color (vertex-initial-domain vertex))
+ (not (color-conflict-p
+ (cons color (vertex-sc vertex))
+ (collect ((colors))
+ (do-oset-elements (neighbor (vertex-incidence vertex)
+ (colors))
+ (unless (vertex-invisible neighbor)
+ (colors (vertex-color neighbor)))))))))
+
+;; Sorted list of all possible locations for vertex in its preferred
+;; SC: more heavily loaded (i.e that should be tried first) locations
+;; first. vertex-initial-domain is already sorted, only have to
+;; remove offsets that aren't currently available.
+(defun vertex-domain (vertex)
+ (declare (type vertex vertex))
+ (remove-if-not (lambda (color)
+ (vertex-color-possible-p vertex color))
+ (vertex-initial-domain vertex)))
+
+;; Return a list of vertices that we might want VERTEX to share its
+;; location with.
+(defun vertex-target-vertices (vertex tn-offset)
+ (declare (type vertex vertex) (type function tn-offset))
+ (let ((sb (sc-sb (vertex-sc vertex)))
+ (neighbors (vertex-incidence vertex))
+ vertices)
+ (do-target-tns (current (vertex-tn vertex) :limit 20)
+ (multiple-value-bind (offset target)
+ (funcall tn-offset current)
+ (when (and offset
+ (eq sb (sc-sb (tn-sc current)))
+ (not (oset-member neighbors target)))
+ (pushnew target vertices))))
+ (nreverse vertices)))
+
+;; Choose the "best" color for these vertices: a color is good if as
+;; many of these vertices simultaneously take that color, and those
+;; that can't have a low spill cost.
+(defun vertices-best-color (vertices colors)
+ (let ((best-color nil)
+ (best-compatible '())
+ (best-cost nil))
+ ;; TODO: sort vertices by spill cost, so that high-spill cost ones
+ ;; are more likely to be compatible? We're trying to find a
+ ;; maximal 1-colorable subgraph here, ie. a maximum independent
+ ;; set :\ Still, a heuristic like first attempting to pack in
+ ;; max-cost vertices may be useful
+ (dolist (color colors)
+ (let ((compatible '())
+ (cost 0))
+ (dolist (vertex vertices)
+ (when (and (notany (lambda (existing)
+ (oset-member (vertex-incidence existing)
+ vertex))
+ compatible)
+ (vertex-color-possible-p vertex color))
+ (incf cost (max 1 (vertex-spill-cost vertex)))
+ (push vertex compatible)))
+ (when (or (null best-cost)
+ (> cost best-cost))
+ (setf best-color color
+ best-compatible compatible
+ best-cost cost))))
+ (values best-color best-compatible)))
+\f
+;;; Coloring inner loop
+
+;; Greedily choose the color for this vertex, also moving around any
+;; :target vertex to the same color if possible.
+(defun find-vertex-color (vertex tn-vertex-mapping)
+ (awhen (vertex-domain vertex)
+ (let* ((targets (vertex-target-vertices vertex tn-vertex-mapping))
+ (sc (vertex-sc vertex))
+ (sb (sc-sb sc)))
+ (multiple-value-bind (color recolor-vertices)
+ (if targets
+ (vertices-best-color targets it)
+ (values (first it) nil))
+ (aver color)
+ (dolist (target recolor-vertices)
+ (aver (car (vertex-color target)))
+ (unless (eql color (car (vertex-color target)))
+ (aver (eq sb (sc-sb (vertex-sc target))))
+ (aver (not (tn-offset (vertex-tn target))))
+ #+nil ; this check is slow
+ (aver (vertex-color-possible-p target color))
+ (setf (car (vertex-color target)) color)))
+ (cons color sc)))))
+
+;; Partition vertices into those that are likely to be colored and
+;; those that are likely to be spilled. Assumes that the interference
+;; graph's vertices are sorted with the least spill cost first, so
+;; that the stacks end up with the greatest spill cost vertices first.
+(defun partition-and-order-vertices (interference-graph)
+ (flet ((domain-size (vertex)
+ (vertex-initial-domain-size vertex))
+ (degree (vertex)
+ (count-if-not #'vertex-invisible
+ (oset-members (vertex-incidence vertex))))
+ (eliminate-vertex (vertex)
+ (setf (vertex-invisible vertex) t)))
+ (let* ((precoloring-stack '())
+ (prespilling-stack '())
+ (vertices (ig-vertices interference-graph)))
+ ;; walk the vertices from least important to most important TN wrt
+ ;; spill cost. That way the TNs we really don't want to spill are
+ ;; at the head of the colouring lists.
+ (loop for vertex in vertices do
+ (aver (not (vertex-color vertex))) ; we already took those out above
+ (eliminate-vertex vertex)
+ ;; FIXME: some interference will be with vertices that don't
+ ;; take the same number of slots. Find a smarter heuristic.
+ (cond ((< (degree vertex) (domain-size vertex))
+ (push vertex precoloring-stack))
+ (t
+ (push vertex prespilling-stack))))
+ (values precoloring-stack prespilling-stack))))
+
+;; Try and color the interference graph once.
+(defun color-interference-graph (interference-graph)
+ (let ((tn-vertex (ig-tn-vertex-mapping interference-graph)))
+ (flet ((color-vertices (vertices)
+ (dolist (vertex vertices)
+ (awhen (find-vertex-color vertex tn-vertex)
+ (setf (vertex-color vertex) it
+ (vertex-invisible vertex) nil)))))
+ (multiple-value-bind (probably-colored probably-spilled)
+ (partition-and-order-vertices interference-graph)
+ (color-vertices probably-colored)
+ ;; These might benefit from further ordering... LexBFS?
+ (color-vertices probably-spilled))))
+ interference-graph)
+\f
+;;; Iterative spilling logic.
+
+;; maximum number of spill iterations
+(defvar *pack-iterations* 500)
+
+;; Find the least-spill-cost neighbor in each color.
+;; FIXME: this is too slow and isn't the right interface anymore.
+;; The code might be fast enough if there were a simple way to detect
+;; whether a given vertex is a min-candidate for another uncolored
+;; vertex.
+;; I'm leaving this around as an idea of what a smart spill choice
+;; might be like. -- PK
+#+nil
+(defun collect-min-spill-candidates (vertex)
+ (let ((colors '()))
+ (do-oset-elements (neighbor (vertex-incidence vertex))
+ (when (eql :normal (vertex-pack-type neighbor))
+ (let* ((color (car (vertex-color neighbor)))
+ (cell (assoc color colors))
+ (cost-neighbor (tn-spill-cost (vertex-tn neighbor))))
+ (cond (cell
+ (when (< cost-neighbor (tn-spill-cost
+ (vertex-tn (cdr cell))))
+ (setf (cdr cell) neighbor)))
+ (t (push (cons color neighbor) colors))))))
+ (remove nil (mapcar #'cdr colors))))
+
+;; Try to color the graph. If some TNs are left uncolored, find a
+;; spill candidate, force it on the stack, and try again.
+(defun iterate-color (vertices component
+ &optional (iterations *pack-iterations*))
+ (let* ((spill-list '())
+ ;; presorting edges helps; later sorts are stable, so this
+ ;; ends up sorting by (sum of) loop depth for TNs with equal
+ ;; costs.
+ (vertices (stable-sort (copy-list vertices) #'>
+ :key (lambda (vertex)
+ (tn-loop-depth
+ (vertex-tn vertex)))))
+ (nvertices (length vertices))
+ (graph (make-interference-graph vertices component))
+ to-spill)
+ (labels ((spill-candidates-p (vertex)
+ (unless (vertex-color vertex)
+ (aver (eql :normal (vertex-pack-type vertex)))
+ t))
+ (iter (to-spill)
+ (when to-spill
+ (setf (vertex-invisible to-spill) t
+ (vertex-color to-spill) nil)
+ (push to-spill spill-list)
+ (setf graph (remove-vertex-from-interference-graph
+ to-spill graph :reset t)))
+ (color-interference-graph graph)
+ (find-if #'spill-candidates-p (ig-vertices graph))))
+ (loop repeat iterations
+ while (setf to-spill (iter to-spill))))
+ (let ((colored (ig-vertices graph)))
+ (aver (= nvertices (+ (length spill-list) (length colored)
+ (length (ig-precolored-vertices graph)))))
+ colored)))
+\f
+;;; Nice interface
+
+;; Just pack vertices that have been assigned a color.
+(defun pack-colored (colored-vertices optimize)
+ (dolist (vertex colored-vertices)
+ (let* ((color (vertex-color vertex))
+ (offset (car color))
+ (tn (vertex-tn vertex)))
+ (cond ((tn-offset tn))
+ (offset
+ (aver (not (conflicts-in-sc tn (tn-sc tn) offset)))
+ (setf (tn-offset tn) offset)
+ (pack-wired-tn (vertex-tn vertex) optimize))
+ (t
+ ;; we better not have a :restricted TN not packed in its
+ ;; finite SC
+ (aver (neq (vertex-pack-type vertex) :restricted)))))))
+
+;; Pack pre-allocated TNs, collect vertices, and color.
+(defun pack-iterative (component 2comp optimize)
+ (declare (type component component) (type ir2-component 2comp))
+ (collect ((vertices))
+ ;; Pack TNs that *must* be in a certain location, but still
+ ;; register them in the interference graph: it's useful to have
+ ;; them in the graph for targeting purposes.
+ (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (pack-wired-tn tn optimize)
+ (unless (unbounded-tn-p tn)
+ (vertices (make-vertex tn :wired))))
+
+ ;; Preallocate vertices that *must* be in this finite SC. If
+ ;; targeting is improved, giving them a high priority in regular
+ ;; regalloc may be a better idea.
+ (collect ((component)
+ (normal))
+ (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (unless (or (tn-offset tn) (unbounded-tn-p tn))
+ (vertices (make-vertex tn :restricted))
+ (if (eq :component (tn-kind tn))
+ (component tn)
+ (normal tn))))
+ ;; First, pack TNs that span the whole component to minimise
+ ;; fragmentation. Also, pack high cost TNs first, so they get
+ ;; nice targeting.
+ (flet ((pack-tns (tns)
+ (dolist (tn (stable-sort tns #'> :key #'tn-cost))
+ (pack-tn tn t optimize))))
+ (pack-tns (component))
+ (pack-tns (normal))))
+
+ ;; Now that all pre-packed TNs are registered as vertices, work on
+ ;; the rest. Walk through all normal TNs, and determine whether
+ ;; we should try to put them in registers or stick them straight
+ ;; to the stack.
+ (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
+ ((null tn))
+ ;; Only consider TNs that aren't forced on the stack and for
+ ;; which the spill cost is non-negative (i.e. not live across so
+ ;; many calls that it's simpler to just leave them on the stack)
+ (when (and (not (tn-offset tn))
+ (neq (tn-kind tn) :more)
+ (not (unbounded-tn-p tn))
+ (not (and (sc-save-p (tn-sc tn)) ; SC is caller-save, and
+ (minusp (tn-cost tn))))) ; TN lives in many calls
+ ;; otherwise, we'll let the final pass handle them.
+ (vertices (make-vertex tn :normal))))
+ ;; Sum loop depths to guide the spilling logic
+ (assign-tn-depths component :reducer #'+)
+ ;; Iteratively find a coloring/spill partition, and allocate those
+ ;; for which we have a location
+ (pack-colored (iterate-color (vertices) component)
+ optimize))
+ nil)
projects / sbcl.git / commitdiff