projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Iterative Chaitin-Briggs style spilling/coloring register allocation
[sbcl.git]
/
src
/
compiler
/
pack.lisp
diff --git
a/src/compiler/pack.lisp
b/src/compiler/pack.lisp
index
4fa1d16
..
d95c5eb
100644
(file)
--- a/
src/compiler/pack.lisp
+++ b/
src/compiler/pack.lisp
@@
-1588,9
+1588,16
@@
most-positive-fixnum
(length path)))))
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)
(defun pack (component)
(unwind-protect
(let ((optimize nil)
+ (speed-3 nil)
(2comp (component-info component)))
(init-sb-vectors component)
(2comp (component-info component)))
(init-sb-vectors component)
@@
-1598,6
+1605,10
@@
;; checking whether any blocks in the component have (> SPEED
;; COMPILE-SPEED).
;;
;; 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
;; 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)
;; 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)
;; 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).
;; 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
;; Pack any leftover normal/restricted TN that is not already
;; allocated to a finite SC, or TNs that do not appear in any