File 0005-Improve-scaling-of-type-derivation-for-LOG... of Package sbcl

Overview Repositories Revisions Requests Users Attributes Meta

File 0005-Improve-scaling-of-type-derivation-for-LOG-AND-IOR-X.patch of Package sbcl (Revision f3aa57a9614eb24475e08b4725ad0e2b)

Currently displaying revision f3aa57a9614eb24475e08b4725ad0e2b , Show latest

From 62f92bd02e9c04a46893ff9e7b88acdaeab230fa Mon Sep 17 00:00:00 2001
From: Lutz Euler <lutz.euler@freenet.de>
Date: Mon, 29 Apr 2013 22:35:01 +0200
Subject: [PATCH 5/8] Improve scaling of type derivation for LOG{AND,IOR,XOR}.

If the types of the arguments of LOG{AND,IOR,XOR} are known to be ranges
of non-negative integers the compiler currently derives the range of the
result using straightforward implementations of algorithms from
"Hacker's Delight". These take quadratical time in the number of bits of
the inputs in the worst case, potentially leading to unacceptably long
compilation times. (The algorithms are based on loops over the bits of
the inputs, doing calculations during each iteration that are themselves
linear in the number of bits of their operands.)

Instead implement bit-parallel algorithms I have found that take linear
time in all cases. While their runtime therefore is limited to much
smaller values for large inputs, it is comparable to that of the current
algorithms for small inputs, too; the new deriver for LOGXOR is in fact
faster than the old one by a factor of two to ten already in the latter
case.

The (existing) test for these derivers compares their results with those
from a brute-force algorithm for all O(N^4) many pairs of input ranges
with endpoints from the set of N-bit unsigned integers. The brute-force
algorithm needs to consider O(N^2) input pairs for each pair of ranges,
making the total runtime O(N^6). Therefore the test normally runs with
N = 5. I have tested all three new derivers successfully with N = 7.

Replace LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND with
LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-BOUNDS to make it possible to evaluate
expressions only once that the calculations for the low and the high
bound have in common. The callers always need both bounds anyway.

Adapt the test to this change. (It runs twice as fast now due to the
brute force loop calculating both bounds in one go.)

Add a test for the scaling behaviour. This needs a function to measure
runtimes over potentially large ranges; add this to test-util.lisp.

diff --git a/CREDITS b/CREDITS
index dc40fa0..99a1b12 100644
--- a/CREDITS
+++ b/CREDITS
@@ -848,6 +848,7 @@ DTC  Douglas Crosher
 JES  Juho Snellman
 JRXR Joshua Ross
 LAV  Larry Valkama
+LEU  Lutz Euler
 MG   Gabor Melis
 MNA  Martin Atzmueller
 NJF  Nathan Froyd
diff --git a/NEWS b/NEWS
index 4b3f503..053e3a2 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@ changes relative to sbcl-1.1.7:
   * enhancement: RUN-PROGRAM supports a :DIRECTORY argument to set
     the working directory of the spawned process.
     (lp#791800) (patch by Matthias Benkard)
+  * bug fix: type derivation for LOG{AND,IOR,XOR} scales linearly instead
+    of quadratically with the size of the input in the worst case.
+    (lp#1096444)
   * bug fix: handle errors when initializing *default-pathname-defaults*,
     sb-ext:*runtime-pathname*, sb-ext:*posix-argv* on startup, like character
     decoding errors, or directories being deleted.
diff --git a/src/compiler/bitops-derive-type.lisp b/src/compiler/bitops-derive-type.lisp
index 32d7ae0..7cbfb9b 100644
--- a/src/compiler/bitops-derive-type.lisp
+++ b/src/compiler/bitops-derive-type.lisp
@@ -25,48 +25,115 @@
                 (or (null min) (minusp min))))
       (values nil t t)))
 
-;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
-;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
-;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
-;;; versions in CMUCL, from which these functions copy liberally.
+;;;; Generators for simple bit masks
 
-(defun logand-derive-unsigned-low-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
-          until (zerop m) do
-          (unless (zerop (logand m (lognot a) (lognot c)))
-            (let ((temp (logandc2 (logior a m) (1- m))))
-              (when (<= temp b)
-                (setf a temp)
-                (loop-finish))
-              (setf temp (logandc2 (logior c m) (1- m)))
-              (when (<= temp d)
-                (setf c temp)
-                (loop-finish))))
-          finally (return (logand a c)))))
+;;; Return an integer consisting of zeroes in its N least significant
+;;; bit positions and ones in all others. If N is negative, return -1.
+(declaim (inline zeroes))
+(defun zeroes (n)
+  (ash -1 n))
 
-(defun logand-derive-unsigned-high-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
-          until (zerop m) do
-          (cond
-            ((not (zerop (logand b (lognot d) m)))
-             (let ((temp (logior (logandc2 b m) (1- m))))
-               (when (>= temp a)
-                 (setf b temp)
-                 (loop-finish))))
-            ((not (zerop (logand (lognot b) d m)))
-             (let ((temp (logior (logandc2 d m) (1- m))))
-               (when (>= temp c)
-                 (setf d temp)
-                 (loop-finish)))))
-          finally (return (logand b d)))))
+;;; Return an integer consisting of ones in its N least significant
+;;; bit positions and zeroes in all others. If N is negative, return 0.
+(declaim (inline ones))
+(defun ones (n)
+  (lognot (ash -1 n)))
+
+;;; The functions LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-BOUNDS below use
+;;; algorithms derived from those in the chapter "Propagating Bounds
+;;; through Logical Operations" from _Hacker's Delight_, Henry S.
+;;; Warren, Jr., 2nd ed., pp 87-90.
+;;;
+;;; We used to implement the algorithms from that source (then its first
+;;; edition) very faithfully here which exposed a weakness of theirs,
+;;; namely worst case quadratical runtime in the number of bits of the
+;;; input values, potentially leading to excessive compilation times for
+;;; expressions involving bignums. To avoid that, I have devised and
+;;; implemented variations of these algorithms that achieve linear
+;;; runtime in all cases.
+;;;
+;;; Like Warren, let's start with the high bound on LOGIOR to explain
+;;; how this is done. To follow, please read Warren's explanations on
+;;; his "maxOR" function and compare this with how the second return
+;;; value of LOGIOR-DERIVE-UNSIGNED-BOUNDS below is calculated.
+;;;
+;;; "maxOR" loops starting from the left until it finds a position where
+;;; both B and D are 1 and where it is possible to decrease one of these
+;;; bounds by setting this bit in it to 0 and all following ones to 1
+;;; without the resulting value getting below the corresponding lower
+;;; bound (A or C). This is done by calculating the modified values
+;;; during each iteration where both B and D are 1 and comparing them
+;;; against the lower bounds.
+;;; The trick to avoid the loop is to exchange the order of the steps:
+;;; First determine from which position rightwards it would be allowed
+;;; to change B or D in this way and have the result be larger or equal
+;;; than A or C respectively and then find the leftmost position equal
+;;; to this or to the right of it where both B and D are 1.
+;;; It is quite simple to find from where rightwards B could be modified
+;;; this way: This is the leftmost position where B has a 1 and A a 0,
+;;; or, cheaper to calculate, the leftmost position where A and B
+;;; differ. Thus (INTEGER-LENGTH (LOGXOR A B)) gives us this position
+;;; where a result of 1 corresponds to the rightmost bit position. As we
+;;; don't care which of B or D we modify we can take the maximum of this
+;;; value and of (INTEGER-LENGTH (LOGXOR C D)).
+;;; The rest is equally simple: Build a mask of 1 bits from the thusly
+;;; found position rightwards, LOGAND it with B and D and feed that into
+;;; INTEGER-LENGTH. From this build another mask and LOGIOR it with B
+;;; and D to set the desired bits.
+;;; The special cases where A equals B and/or C equals D are covered by
+;;; the same code provided the mask generator treats an argument of -1
+;;; the same as 0, which both ZEROES and ONES do.
+;;;
+;;; To calculate the low bound on LOGIOR we need to treat X and Y
+;;; independently for longer but the basic idea stays the same.
+;;;
+;;; LOGAND-DERIVE-UNSIGNED-BOUNDS can be derived by sufficiently many
+;;; applications of DeMorgan's law from LOGIOR-DERIVE-UNSIGNED-BOUNDS.
+;;; The implementation additionally avoids work (that is, calculations
+;;; of one's complements) by using the identity (INTEGER-LENGTH X) =
+;;; (INTEGER-LENGTH (LOGNOT X)) and observing that ZEROES is cheaper
+;;; than ONES.
+;;;
+;;; For the low bound on LOGXOR we use Warren's formula
+;;;   minXOR(a, b, c, d) = minAND(a, b, !d, !c) | minAND(!b, !a, c, d)
+;;; where "!" is bitwise negation and "|" is bitwise or. Both minANDs
+;;; are implemented as in LOGAND-DERIVE-UNSIGNED-BOUNDS (the part for
+;;; the first result), sharing the first LOGXOR and INTEGER-LENGTH
+;;; calculations as (LOGXOR A B) = (LOGXOR (LOGNOT B) (LOGNOT A)).
+;;;
+;;; For the high bound on LOGXOR Warren's formula seems unnecessarily
+;;; complex. Instead, with (LOGNOT (LOGXOR X Y)) = (LOGXOR X (LOGNOT Y))
+;;; we have
+;;;   maxXOR(a, b, c, d) = !minXOR(a, b, !d, !c)
+;;; and rewriting minXOR as above yields
+;;;   maxXOR(a, b, c, d) = !(minAND(a, b, c, d) | minAND(!b, !a, !d, !c))
+;;; This again shares the first LOGXOR and INTEGER-LENGTH calculations
+;;; between both minANDs and with the ones for the low bound.
+;;;
+;;; LEU, 2013-04-29.
+
+(defun logand-derive-unsigned-bounds (x y)
+  (let* ((a (numeric-type-low x))
+         (b (numeric-type-high x))
+         (c (numeric-type-low y))
+         (d (numeric-type-high y))
+         (length-xor-x (integer-length (logxor a b)))
+         (length-xor-y (integer-length (logxor c d))))
+    (values
+     (let* ((mask (zeroes (max length-xor-x length-xor-y)))
+            (index (integer-length (logior mask a c))))
+       (logand a c (zeroes (1- index))))
+     (let* ((mask-x (ones length-xor-x))
+            (mask-y (ones length-xor-y))
+            (index-x (integer-length (logand mask-x b (lognot d))))
+            (index-y (integer-length (logand mask-y d (lognot b)))))
+       (cond ((= index-x index-y)
+              ;; Both indexes are 0 here.
+              (logand b d))
+             ((> index-x index-y)
+              (logand (logior b (ones (1- index-x))) d))
+             (t
+              (logand (logior d (ones (1- index-y))) b)))))))
 
 (defun logand-derive-type-aux (x y &optional same-leaf)
   (when same-leaf
@@ -86,8 +153,8 @@
                     ((null y-len)
                      (specifier-type `(unsigned-byte* ,x-len)))
                     (t
-                     (let ((low (logand-derive-unsigned-low-bound x y))
-                           (high (logand-derive-unsigned-high-bound x y)))
+                     (multiple-value-bind (low high)
+                         (logand-derive-unsigned-bounds x y)
                        (specifier-type `(integer ,low ,high)))))
               ;; X is positive, but Y might be negative.
               (cond ((null x-len)
@@ -107,43 +174,28 @@
                   ;; We can't tell squat about the result.
                   (specifier-type 'integer)))))))
 
-(defun logior-derive-unsigned-low-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
-          until (zerop m) do
-          (cond
-            ((not (zerop (logandc2 (logand c m) a)))
-             (let ((temp (logand (logior a m) (1+ (lognot m)))))
-               (when (<= temp b)
-                 (setf a temp)
-                 (loop-finish))))
-            ((not (zerop (logandc2 (logand a m) c)))
-             (let ((temp (logand (logior c m) (1+ (lognot m)))))
-               (when (<= temp d)
-                 (setf c temp)
-                 (loop-finish)))))
-          finally (return (logior a c)))))
-
-(defun logior-derive-unsigned-high-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
-          until (zerop m) do
-          (unless (zerop (logand b d m))
-            (let ((temp (logior (- b m) (1- m))))
-              (when (>= temp a)
-                (setf b temp)
-                (loop-finish))
-              (setf temp (logior (- d m) (1- m)))
-              (when (>= temp c)
-                (setf d temp)
-                (loop-finish))))
-          finally (return (logior b d)))))
+(defun logior-derive-unsigned-bounds (x y)
+  (let* ((a (numeric-type-low x))
+         (b (numeric-type-high x))
+         (c (numeric-type-low y))
+         (d (numeric-type-high y))
+         (length-xor-x (integer-length (logxor a b)))
+         (length-xor-y (integer-length (logxor c d))))
+    (values
+     (let* ((mask-x (ones length-xor-x))
+            (mask-y (ones length-xor-y))
+            (index-x (integer-length (logand mask-x (lognot a) c)))
+            (index-y (integer-length (logand mask-y (lognot c) a))))
+       (cond ((= index-x index-y)
+              ;; Both indexes are 0 here.
+              (logior a c))
+             ((> index-x index-y)
+              (logior (logand a (zeroes (1- index-x))) c))
+             (t
+              (logior (logand c (zeroes (1- index-y))) a))))
+     (let* ((mask (ones (max length-xor-x length-xor-y)))
+            (index (integer-length (logand mask b d))))
+       (logior b d (ones (1- index)))))))
 
 (defun logior-derive-type-aux (x y &optional same-leaf)
   (when same-leaf
@@ -154,8 +206,8 @@
        ((and (not x-neg) (not y-neg))
         ;; Both are positive.
         (if (and x-len y-len)
-            (let ((low (logior-derive-unsigned-low-bound x y))
-                  (high (logior-derive-unsigned-high-bound x y)))
+            (multiple-value-bind (low high)
+                (logior-derive-unsigned-bounds x y)
               (specifier-type `(integer ,low ,high)))
             (specifier-type `(unsigned-byte* *))))
        ((not x-pos)
@@ -187,41 +239,25 @@
                 ;; Unbounded.
                 (specifier-type 'integer))))))))
 
-(defun logxor-derive-unsigned-low-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
-          until (zerop m) do
-          (cond
-            ((not (zerop (logandc2 (logand c m) a)))
-             (let ((temp (logand (logior a m)
-                                 (1+ (lognot m)))))
-               (when (<= temp b)
-                 (setf a temp))))
-            ((not (zerop (logandc2 (logand a m) c)))
-             (let ((temp (logand (logior c m)
-                                 (1+ (lognot m)))))
-               (when (<= temp d)
-                 (setf c temp)))))
-          finally (return (logxor a c)))))
-
-(defun logxor-derive-unsigned-high-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
-          until (zerop m) do
-          (unless (zerop (logand b d m))
-            (let ((temp (logior (- b m) (1- m))))
-              (cond
-                ((>= temp a) (setf b temp))
-                (t (let ((temp (logior (- d m) (1- m))))
-                     (when (>= temp c)
-                       (setf d temp)))))))
-          finally (return (logxor b d)))))
+(defun logxor-derive-unsigned-bounds (x y)
+  (let* ((a (numeric-type-low x))
+         (b (numeric-type-high x))
+         (c (numeric-type-low y))
+         (d (numeric-type-high y))
+         (not-b (lognot b))
+         (not-d (lognot d))
+         (length-xor-x (integer-length (logxor a b)))
+         (length-xor-y (integer-length (logxor c d)))
+         (mask (zeroes (max length-xor-x length-xor-y))))
+    (values
+     (let ((index-ad (integer-length (logior mask a not-d)))
+           (index-bc (integer-length (logior mask not-b c))))
+       (logior (logand a not-d (zeroes (1- index-ad)))
+               (logand not-b c (zeroes (1- index-bc)))))
+     (let ((index-ac (integer-length (logior mask a c)))
+           (index-bd (integer-length (logior mask not-b not-d))))
+       (lognor (logand a c (zeroes (1- index-ac)))
+               (logand not-b not-d (zeroes (1- index-bd))))))))
 
 (defun logxor-derive-type-aux (x y &optional same-leaf)
   (when same-leaf
@@ -232,8 +268,8 @@
         ((and (not x-neg) (not y-neg))
          ;; Both are positive
          (if (and x-len y-len)
-             (let ((low (logxor-derive-unsigned-low-bound x y))
-                   (high (logxor-derive-unsigned-high-bound x y)))
+             (multiple-value-bind (low high)
+                 (logxor-derive-unsigned-bounds x y)
                (specifier-type `(integer ,low ,high)))
              (specifier-type '(unsigned-byte* *))))
         ((and (not x-pos) (not y-pos))
diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index d6246bf..c4e4804 100644
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -3,7 +3,8 @@
   (:export #:with-test #:report-test-status #:*failures*
            #:really-invoke-debugger
            #:*break-on-failure* #:*break-on-expected-failure*
-           #:make-kill-thread #:make-join-thread))
+           #:make-kill-thread #:make-join-thread
+           #:runtime))
 
 (in-package :test-util)
 
@@ -133,3 +134,36 @@
   (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
         (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))
               (posix-environ))))
+
+;;; Repeat calling THUNK until its cumulated runtime, measured using
+;;; GET-INTERNAL-RUN-TIME, is larger than PRECISION. Repeat this
+;;; REPETITIONS many times and return the time one call to THUNK took
+;;; in seconds as a float, according to the minimum of the cumulated
+;;; runtimes over the repetitions.
+;;; This allows to easily measure the runtime of expressions that take
+;;; much less time than one internal time unit. Also, the results are
+;;; unaffected, modulo quantization effects, by changes to
+;;; INTERNAL-TIME-UNITS-PER-SECOND.
+;;; Taking the minimum is intended to reduce the error introduced by
+;;; garbage collections occurring at unpredictable times. The inner
+;;; loop doubles the number of calls to THUNK each time before again
+;;; measuring the time spent, so that the time measurement overhead
+;;; doesn't distort the result if calling THUNK takes very little time.
+(defun runtime* (thunk repetitions precision)
+  (loop repeat repetitions
+        minimize
+        (loop with start = (get-internal-run-time)
+              with duration = 0
+              for n = 1 then (* n 2)
+              for total-runs = n then (+ total-runs n)
+              do (dotimes (i n)
+                   (funcall thunk))
+                 (setf duration (- (get-internal-run-time) start))
+              when (> duration precision)
+              return (/ (float duration) (float total-runs)))
+        into min-internal-time-units-per-call
+        finally (return (/ min-internal-time-units-per-call
+                           (float internal-time-units-per-second)))))
+
+(defmacro runtime (form &key (repetitions 3) (precision 10))
+  `(runtime* (lambda () ,form) ,repetitions ,precision))
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 919d705..fff2114 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -241,36 +241,58 @@
 ;;; (In fact, this is such a fearsome loop that executing it with the
 ;;; evaluator would take ages... Disable it under those circumstances.)
 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
-(let* ((bits 5)
-       (size (ash 1 bits)))
-  (flet ((brute-force (a b c d op minimize)
-           (loop with extreme = (if minimize (ash 1 bits) 0)
-                 with collector = (if minimize #'min #'max)
-                 for i from a upto b do
-                 (loop for j from c upto d do
-                       (setf extreme (funcall collector
-                                              extreme
-                                              (funcall op i j))))
-                 finally (return extreme))))
-    (dolist (op '(logand logior logxor))
-      (dolist (minimize '(t nil))
-        (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND"
-                                       op minimize)
+(with-test (:name (:type-derivation :logical-operations :correctness))
+  (let* ((n-bits 5)
+         (size (ash 1 n-bits)))
+    (labels ((brute-force (a b c d op)
+               (loop with min = (ash 1 n-bits)
+                     with max = 0
+                     for i from a upto b do
+                     (loop for j from c upto d do
+                           (let ((x (funcall op i j)))
+                             (setf min (min min x)
+                                   max (max max x))))
+                     finally (return (values min max))))
+             (test (a b c d op deriver)
+               (multiple-value-bind (brute-low brute-high)
+                   (brute-force a b c d op)
+                 (multiple-value-bind (test-low test-high)
+                     (funcall deriver
+                              (sb-c::specifier-type `(integer ,a ,b))
+                              (sb-c::specifier-type `(integer ,c ,d)))
+                   (unless (and (= brute-low test-low)
+                                (= brute-high test-high))
+                     (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
+                             op a b c d
+                             brute-low brute-high test-low test-high)
+                     (assert (and (= brute-low test-low)
+                                  (= brute-high test-high))))))))
+      (dolist (op '(logand logior logxor))
+        (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op)
                                (find-package :sb-c))))
           (format t "testing type derivation: ~A~%" deriver)
           (loop for a from 0 below size do
                 (loop for b from a below size do
                       (loop for c from 0 below size do
                             (loop for d from c below size do
-                                  (let* ((brute (brute-force a b c d op minimize))
-                                         (x-type (sb-c::specifier-type `(integer ,a ,b)))
-                                         (y-type (sb-c::specifier-type `(integer ,c ,d)))
-                                         (derived (funcall deriver x-type y-type)))
-                                    (unless (= brute derived)
-                                      (format t "FAIL: ~A [~D,~D] [~D,~D] ~A~%
-ACTUAL ~D DERIVED ~D~%"
-                                              op a b c d minimize brute derived)
-                                      (assert (= brute derived)))))))))))))
+                                  (test a b c d op deriver))))))))))
+
+(with-test (:name (:type-derivation :logical-operations :scaling))
+  (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000)
+                                                 ,(expt 2 10000))))
+        (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000)
+                                                 ,(expt 2 100000))))
+        (type-y (sb-c::specifier-type '(integer 0 1))))
+    (dolist (op '(logand logior logxor))
+      (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op)
+                              (find-package :sb-c)))
+             (scale (/ (runtime (funcall deriver type-x2 type-y))
+                       (runtime (funcall deriver type-x1 type-y)))))
+        ;; Linear scaling is good, quadratical bad. Draw the line
+        ;; near the geometric mean of the corresponding SCALEs.
+        (when (> scale 32)
+          (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
+                 deriver scale))))))
 
 ;;; subtypep on CONS types wasn't taking account of the fact that a
 ;;; CONS type could be the empty type (but no other non-CONS type) in
-- 
1.8.2.1

Places

File 0005-Improve-scaling-of-type-derivation-for-LOG-AND-IOR-X.patch of Package sbcl (Revision f3aa57a9614eb24475e08b4725ad0e2b)

Places