Simplify RATIONAL/constant FLOAT and INTEGER/constant RATIO comparisons

 The spec says that rationals and floats are compared by first calling
 RATIONAL on the float. Constant fold the call to RATIONAL, and round
 to an integer if applicable.

diff --git a/NEWS b/NEWS
index ba7dcd9..e62ec62 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -14,6 +14,9 @@ changes relative to sbcl-1.1.8:
   * optimization: bitwise OR forms can now trigger modular arithmetic as well,
     when the result is known to be negative.
   * optimization: recognize more cases of useless LOGAND/LOGIOR with constants.
+  * optimization: comparisons between rationals and constant floats or between
+    integers and constant ratios are now converted to rationals/integers at
+    compile time.
   * bug fix: problems with NCONC type derivation (reported by Jerry James).
   * bug fix: EXPT type derivation no longer constructs bogus floating-point
     types.  (reported by Vsevolod Dyomkin)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index e13c30e..221eaf0 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -4032,6 +4032,48 @@
         `(values (the real ,arg0))
         `(let ((minrest (min ,@rest)))
           (if (<= ,arg0 minrest) ,arg0 minrest)))))
+
+;;; Simplify some cross-type comparisons
+(macrolet ((def (comparator round)
+             `(progn
+                (deftransform ,comparator
+                    ((x y) (rational (constant-arg float)))
+                  "open-code RATIONAL to FLOAT comparison"
+                  (let ((y (lvar-value y)))
+                    #-sb-xc-host
+                    (when (or (float-nan-p y)
+                              (float-infinity-p y))
+                      (give-up-ir1-transform))
+                    (setf y (rational y))
+                    `(,',comparator
+                      x ,(if (csubtypep (lvar-type x)
+                                        (specifier-type 'integer))
+                             (,round y)
+                             y))))
+                (deftransform ,comparator
+                    ((x y) (integer (constant-arg ratio)))
+                  "open-code INTEGER to RATIO comparison"
+                  `(,',comparator x ,(,round (lvar-value y)))))))
+  (def < ceiling)
+  (def > floor))
+
+(deftransform = ((x y) (rational (constant-arg float)))
+  "open-code RATIONAL to FLOAT comparison"
+  (let ((y (lvar-value y)))
+    #-sb-xc-host
+    (when (or (float-nan-p y)
+              (float-infinity-p y))
+      (give-up-ir1-transform))
+    (setf y (rational y))
+    (if (and (csubtypep (lvar-type x)
+                        (specifier-type 'integer))
+             (ratiop y))
+        nil
+        `(= x ,y))))
+
+(deftransform = ((x y) (integer (constant-arg ratio)))
+  "constant-fold INTEGER to RATIO comparison"
+  nil)
 \f
 ;;;; converting N-arg arithmetic functions
 ;;;;