From c295a1ec99a7316523e7674cec71da05da8fc072 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Tue, 12 Nov 2013 18:39:35 -0500 Subject: [PATCH] Iterative Chaitin-Briggs style spilling/coloring register allocation * sb-regalloc:*register-allocation-method* determine which packing algorithm is chosen. - :adaptive, the default value, only executes the iterative algorithm if some code block has (> speed compilation-speed) and (speed 3); otherwise, the usual greedy algorithm is chosen. - :greedy always chooses the old greedy algorithm. - :iterative always chooses the new iterative algorithm. Some references describing this family of register allocation, spilling and coalescing algorithms are listed in the header of src/compiler/pack-iterative.lisp. This code is simply an optimised and cleaned up version of the awesome work done by Alexandra Barchunova as part of Google Summer of Code '13. It's difficult to overestimate the amount of earlier time and effort that aren't visible but had to happen to fix bugs and document old code in order to finally make this possible. Hectokudos to abarch! --- NEWS | 8 + build-order.lisp-expr | 1 + package-data-list.lisp-expr | 3 +- src/compiler/pack-iterative.lisp | 642 ++++++++++++++++++++++++++++++++++++++ src/compiler/pack.lisp | 27 +- 5 files changed, 675 insertions(+), 6 deletions(-) create mode 100644 src/compiler/pack-iterative.lisp diff --git a/NEWS b/NEWS index 034b9fa..79be5ec 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,13 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.1.14: + * new feature: the iterative spilling/coloring register allocator developed + by Alexandra Barchunova during Google Summer of Code 2013 is now merged + in. By default, it only activates for functions that optimize with + (speed 3) and (> speed compilation-speed), but setting + sb-regalloc:*register-allocation-method* to :iterative forces its + execution. The previous behaviour can be obtained by instead setting that + variable to :greedy. Thanks again to Google for their support, and, more + crucially, to Alexandra Barchunova for her hard work. * enhancement: sb-ext:save-lisp-and-die on Windows now accepts :application-type argument, which can be :console or :gui. :gui allows having GUI applications without an automatically appearing console window. diff --git a/build-order.lisp-expr b/build-order.lisp-expr index c6b35e8..70648ee 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -632,6 +632,7 @@ ("src/compiler/represent") ("src/compiler/ir2opt") ("src/compiler/pack") + ("src/compiler/pack-iterative") ("src/compiler/codegen") ("src/compiler/debug") diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b528643..c9204fb 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2260,7 +2260,8 @@ ISBN 0-262-61074-4, with exceptions as noted in the User Manual." "VOP-INFO-TARGET-FUN" "VOP-NEXT" "VOP-NODE" "VOP-PARSE-OR-LOSE" "VOP-PARSE-TEMPS" "VOP-PREV" "VOP-REFS" "VOP-RESULTS" "VOP-SAVE-SET" "VOP-TEMPS")) - :export ("PACK" "TARGET-IF-DESIRABLE" + :export ("PACK" "TARGET-IF-DESIRABLE" "*REGISTER-ALLOCATION-METHOD*" + "*PACK-ITERATIONS*" "*PACK-ASSIGN-COSTS*" "*PACK-OPTIMIZE-SAVES*" "*TN-WRITE-COSTS*" "*TN-LOOP-DEPTH-MULTIPLIER*")) diff --git a/src/compiler/pack-iterative.lisp b/src/compiler/pack-iterative.lisp new file mode 100644 index 0000000..89bac87 --- /dev/null +++ b/src/compiler/pack-iterative.lisp @@ -0,0 +1,642 @@ +;;;; 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) + +;;; 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)) + +;;; 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))) + +;;; 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)))) + +;;; 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))) + +;;; 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) + +;;; 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))) + +;;; 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) diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 4fa1d16..d95c5eb 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -1588,9 +1588,16 @@ most-positive-fixnum (length path))))) +(declaim (type (member :iterative :greedy :adaptive) + *register-allocation-method*)) +(defvar *register-allocation-method* :adaptive) + +(declaim (ftype function pack-greedy pack-iterative)) + (defun pack (component) (unwind-protect (let ((optimize nil) + (speed-3 nil) (2comp (component-info component))) (init-sb-vectors component) @@ -1598,6 +1605,10 @@ ;; checking whether any blocks in the component have (> SPEED ;; COMPILE-SPEED). ;; + ;; Also, determine if any such block also declares (speed 3), + ;; in which case :adaptive register allocation will switch to + ;; the iterative Chaitin-Briggs spilling/coloring algorithm. + ;; ;; FIXME: This means that a declaration can have a minor ;; effect even outside its scope, and as the packing is done ;; component-globally it'd be tricky to use strict scoping. I @@ -1606,10 +1617,12 @@ ;; doesn't affect the semantics of the generated code in any ;; way. -- JES 2004-10-06 (do-ir2-blocks (block component) - (when (policy (block-last (ir2-block-block block)) - (> speed compilation-speed)) - (setf optimize t) - (return))) + (let ((block (block-last (ir2-block-block block)))) + (when (policy block (> speed compilation-speed)) + (setf optimize t) + (when (policy block (= speed 3)) + (setf speed-3 t) + (return))))) ;; Call the target functions. (do-ir2-blocks (block component) @@ -1627,7 +1640,11 @@ ;; Actually allocate registers for most TNs. After this, only ;; :normal tns may be left unallocated (or TNs :restricted to ;; an unbounded SC). - (pack-greedy component 2comp optimize) + (funcall (ecase *register-allocation-method* + (:greedy #'pack-greedy) + (:iterative #'pack-iterative) + (:adaptive (if speed-3 #'pack-iterative #'pack-greedy))) + component 2comp optimize) ;; Pack any leftover normal/restricted TN that is not already ;; allocated to a finite SC, or TNs that do not appear in any -- 1.7.10.4