Really restore clisp cross-compilation.

[sbcl.git] / src / compiler / pack.lisp

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index 4fa1d16..7e61cf0 100644 (file)
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -47,17 +47,17 @@
         (kind (tn-kind tn))
         (sb-conflicts (finite-sb-conflicts sb))
         (sb-always-live (finite-sb-always-live sb)))
-    (macrolet ((do-offsets (&body body)
-                 `(loop repeat size
-                        for offset upfrom offset
+    (macrolet ((do-offsets ((var) &body body)
+                 `(loop for ,var upfrom offset
+                        repeat size
                         thereis (progn ,@body))))
       (cond
         ((eq kind :component)
-         (do-offsets
-             (let ((loc-live (svref sb-always-live offset)))
+         (do-offsets (offset-iter)
+             (let ((loc-live (svref sb-always-live offset-iter)))
                (dotimes (i (ir2-block-count *component-being-compiled*))
                  (when (/= (sbit loc-live i) 0)
-                   (return offset))))))
+                   (return offset-iter))))))
         (confs
          ;; TN is global, iterate over the blocks TN is live in.
          (do ((conf confs (global-conflicts-next-tnwise conf)))
@@ -66,23 +66,23 @@
            (let* ((block (global-conflicts-block conf))
                   (num (ir2-block-number block)))
              (if (eq (global-conflicts-kind conf) :live)
-                 (do-offsets
-                     (let ((loc-live (svref sb-always-live offset)))
+                 (do-offsets (offset-iter)
+                     (let ((loc-live (svref sb-always-live offset-iter)))
                        (when (/= (sbit loc-live num) 0)
-                         (return-from offset-conflicts-in-sb offset))))
-                 (do-offsets
-                     (let ((loc-confs (svref sb-conflicts offset)))
+                         (return-from offset-conflicts-in-sb offset-iter))))
+                 (do-offsets (offset-iter)
+                     (let ((loc-confs (svref sb-conflicts offset-iter)))
                        (when (/= (sbit (svref loc-confs num)
                                        (global-conflicts-number conf))
                                  0)
-                         (return-from offset-conflicts-in-sb offset))))))))
+                         (return-from offset-conflicts-in-sb offset-iter))))))))
         (t
-         (do-offsets
-             (and (/= (sbit (svref (svref sb-conflicts offset)
+         (do-offsets (offset-iter)
+             (and (/= (sbit (svref (svref sb-conflicts offset-iter)
                                    (ir2-block-number (tn-local tn)))
                             (tn-local-number tn))
                       0)
-                  offset)))))))
+                  offset-iter)))))))
 
 ;;; Return true if TN has a conflict in SC at the specified offset.
 (declaim (ftype (function (tn sc index) (values (or null index) &optional))
@@ -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