Merge branch 'main' into trampolines

Author: drmeister

RELEASE_NOTES.md

@@ -1,3 +1,8 @@
+# Version 3.1.0 (LLVM15-20, 22) Pending
+
+## Optimized
+* Comparisons (`eq`, `<`, etc.) are optimized out based on type information.
+
 # Version 3.0.1 (LLVM15-20, 22) 2026-06-24
 
 ## Fixed

src/lisp/kernel/cleavir/bir-to-bmir.lisp

@@ -187,6 +187,8 @@
 (deftransform-f error (constantly 'type-error) (constantly t)
   (4 2) t (eql type-error) (eql :expected-type) t (eql :datum) t)
 
+(deftransform eq eq t t)
+
 (deftransform core:to-single-float core::double-to-single double-float)
 (deftransform core:to-single-float core::fixnum-to-single fixnum)
 (deftransform core:to-double-float core::single-to-double single-float)

src/lisp/kernel/cleavir/interval.lisp

@@ -5,6 +5,9 @@
   (low nil :type (or null real (cons real null)))
   (high nil :type (or null real (cons real null))))
 
+(defun make-unbounded-interval () (make-interval nil nil))
+(defun make-empty-interval () (make-interval '(0) '(0)))
+
 (defun bound-parts (finite-bound)
   (if (consp finite-bound)
       (values (car finite-bound) t)
@@ -21,6 +24,27 @@
     (let ((r (funcall unop b)))
       (if bxp (list r) r))))
 
+(defun empty-interval-p (interval)
+  (let ((low (interval-low interval)) (high (interval-high interval)))
+    (and low high
+         (multiple-value-bind (low lxp) (bound-parts low)
+           (multiple-value-bind (high hxp) (bound-parts high)
+             (or (> low high) (and (= low high) (or lxp hxp))))))))
+
+(defun intervals-disjoint-p (i1 i2)
+  (let ((i1l (interval-low i1)) (i2l (interval-low i2))
+        (i1h (interval-high i1)) (i2h (interval-high i2)))
+    (or (and i1h i2l
+             (multiple-value-bind (i1high i1hxp) (bound-parts i1h)
+               (multiple-value-bind (i2low i2lxp) (bound-parts i2l)
+                 (or (< i1high i2low)
+                     (and (= i1high i2low) (or i1hxp i2lxp))))))
+        (and i2h i1l
+             (multiple-value-bind (i2high i2hxp) (bound-parts i2h)
+               (multiple-value-bind (i1low i1lxp) (bound-parts i1l)
+                 (or (< i2high i1low)
+                     (and (= i2high i1low) (or i2hxp i1lxp)))))))))
+
 (defun interval+ (i1 i2)
   (make-interval
    (let ((l1 (interval-low i1)) (l2 (interval-low i2)))
@@ -35,6 +59,27 @@
    (let ((low (interval-low interval)))
      (if low (finite-bound-unop #'- low) nil))))
 
+(defun interval-= (i1 i2)
+  (let ((i1l (interval-low i1)) (i2l (interval-low i2))
+        (i1h (interval-high i1)) (i2h (interval-high i2)))
+    (and (realp i1l) (realp i2l) (realp i1h) (realp i2h)
+         (= i1l i2l i1h i2h))))
+(defun interval-/= (i1 i2) (intervals-disjoint-p i1 i2))
+
+(defun interval-< (i1 i2)
+  (let ((i1h (interval-high i1)) (i2l (interval-low i2)))
+    (and i1h i2l
+         (multiple-value-bind (i1high i1hxp) (bound-parts i1h)
+           (multiple-value-bind (i2low i2lxp) (bound-parts i2l)
+             (or (< i1high i2low)
+                 (and (= i1high i2low) (or i1hxp i2lxp))))))))
+(defun interval-<= (i1 i2)
+  (let ((i1h (interval-high i1)) (i2l (interval-low i2)))
+    (and i1h i2l (<= (bound-parts i1h) (bound-parts i2l)))))
+
+(defun interval-> (i1 i2) (interval-< i2 i1))
+(defun interval->= (i1 i2) (interval-<= i2 i1))
+
 ;; Return -1 if the number is below the interval, 1 if above, 0 if in the interval.
 (defun interval-num-compare (interval num)
   (let ((low (interval-low interval)) (high (interval-high interval)))
@@ -64,16 +109,34 @@
 (defun interval-merge (i1 i2)
   ;; Return the smallest interval including both input intervals.
   ;; If the inputs do not intersect, this will not be a strict join.
+  (labels ((lbmin (b1 b2)
+             (cond ((not b1) b1)
+                   ((not b2) b2)
+                   (t (multiple-value-bind (b1 xp1) (bound-parts b1)
+                        (multiple-value-bind (b2 xp2) (bound-parts b2)
+                          (if (and xp1 xp2) (list (min b1 b2)) (min b1 b2)))))))
+           (hbmax (b1 b2)
+             (cond ((not b1) b1)
+                   ((not b2) b2)
+                   (t (multiple-value-bind (b1 xp1) (bound-parts b1)
+                        (multiple-value-bind (b2 xp2) (bound-parts b2)
+                          (if (and xp1 xp2) (list (max b1 b2)) (max b1 b2))))))))
+    (make-interval (lbmin (interval-low i1) (interval-low i2))
+                   (hbmax (interval-high i1) (interval-high i2)))))
+
+(defun interval-intersect (i1 i2)
+  ;; Return the smallest interval included by both input intervals.
+  ;; If the inputs do not intersect, this will be empty.
   (labels ((fb< (b1 b2)
              (multiple-value-bind (b1 xp1) (bound-parts b1)
                (multiple-value-bind (b2 xp2) (bound-parts b2)
                  (or (< b1 b2) (and (= b1 b2) xp1 (not xp2))))))
-           (lbmin (b1 b2)
-             (if (and b2 (or (not b1) (fb< b1 b2))) b1 b2))
-           (hbmax (b1 b2)
-             (if (and b1 (or (not b2) (fb< b1 b2))) b2 b1)))
-    (make-interval (lbmin (interval-low i1) (interval-low i2))
-                   (hbmax (interval-high i1) (interval-high i2)))))
+           (lbmax (b1 b2)
+             (if (and b2 (or (not b1) (fb< b1 b2))) b2 b1))
+           (hbmin (b1 b2)
+             (if (and b1 (or (not b2) (fb< b1 b2))) b1 b2)))
+    (make-interval (lbmax (interval-low i1) (interval-low i2))
+                   (hbmin (interval-high i1) (interval-high i2)))))
 
 ;; Multiply a positive interval by any interval.
 (defun interval*-1-pos (i1 i2)

src/lisp/kernel/cleavir/primop.lisp

@@ -112,6 +112,12 @@
 (defvprimop-intrinsic core::etypecase-error ((:object) :object :object)
   "cc_etypecase_error")
 
+(defvprimop (eq :flags (:flushable))
+    ((:boolean) :object :object) (inst)
+  (assert (= 2 (length (bir:inputs inst))))
+  (cmp:irc-icmp-eq
+   (in (first (bir:inputs inst))) (in (second (bir:inputs inst)))))
+
 (macrolet ((def-float-compare (sfname dfname op reversep)
              `(progn
                 (deftprimop ,sfname (:single-float :single-float)

src/lisp/kernel/cleavir/transform.lisp

@@ -374,11 +374,47 @@ Optimizations are available for any of:
 
 (deftransform-type-predicate compiled-function-p compiled-function)
 
-(deftransform equal (((x number) (y t))) '(eql x y))
-(deftransform equal (((x t) (y number))) '(eql x y))
+;;; If the types of the arguments are disjoint, EQ (and EQL) are false.
+;;; (This is not generally true of EQUAL and EQUALP; consider e.g.
+;;;  the type (EQL "foo") compared to a distinct string "foo")
+(deftransform eq (((x t) (y t)) :argstype args)
+  (with-transformer-types (x y) args
+    (if (ctype:disjointp x y *clasp-system*)
+        'nil
+        (decline-transform "types not disjoint"))))
+
+(deftransform eql (((x t) (y t)) :argstype args)
+  (with-transformer-types (x y) args
+    (if (ctype:disjointp x y *clasp-system*)
+        'nil
+        (decline-transform "types not disjoint"))))
+;;; on clasp, eq of fixnums and singles and characters is ok
+;;; (i.e. is eql)
+;;; And of course pointers are tagged differently from fixnums and
+;;; characters, so raw comparison can't have any false positives.
+;;; Doubles and longs and bignums are boxed.
+;;; FIXME: conditionalize on compiler parameters?
+(deftransform eql (((x (or fixnum short-float single-float (not number)))
+                    (y t)))
+  '(eq x y))
+(deftransform eql (((x t)
+                    (y (or fixnum short-float single-float (not number)))))
+  '(eq x y))
+
+(deftransform equal (((x (not (or cons string bit-vector pathname
+                                  number character)))
+                      (y t)))
+  '(eq x y))
+(deftransform equal (((x t) (y (not (or cons string bit-vector pathname
+                                        number character)))))
+  '(eq x y))
+(deftransform equal (((x (not (or cons string bit-vector pathname))) (y t)))
+  '(eql x y))
+(deftransform equal (((x t) (y (not (or cons string bit-vector pathname)))))
+  '(eql x y))
 (deftransform equalp (((x number) (y number))) '(= x y))
 
-(deftransform equal (((x character) (y character))) '(char= x y))
+(deftransform equal (((x character) (y character))) '(eq x y))
 (deftransform equalp (((x character) (y character))) '(char-equal x y))
 
 #+(or) ; string= is actually slower atm due to keyword etc processing
@@ -413,6 +449,20 @@ Optimizations are available for any of:
 
 (deftransform-type-predicate random-state-p random-state)
 
+(macrolet ((def (comparator yes no)
+             `(deftransform ,comparator (((a1 real) (a2 real)) :argstype args)
+                (with-transformer-types (a1 a2) args
+                  (let ((interval1 (type-approximate-interval a1 *clasp-system*))
+                        (interval2 (type-approximate-interval a2 *clasp-system*)))
+                    (cond ((,yes interval1 interval2) 't)
+                          ((,no interval1 interval2) 'nil)
+                          (t (decline-transform "unable to fold by intervals"))))))))
+  (def core:two-arg-=  interval-=  interval-/=)
+  (def core:two-arg-<  interval-<  interval->=)
+  (def core:two-arg-<= interval-<= interval->)
+  (def core:two-arg->  interval->  interval-<=)
+  (def core:two-arg->= interval->= interval-<))
+
 (macrolet ((define-two-arg-f (name)
              `(progn
                 (deftransform ,name (((a1 single-float) (a2 double-float)))

src/lisp/kernel/cleavir/type.lisp

@@ -214,6 +214,24 @@
             (values nil nil)))
       (values nil nil)))
 
+;;; Reduce a type to a single interval. This is general worse than the original
+;;; type, e.g. (or (integer 0 4) (integer 12 19)) would become (integer 0 19),
+;;; but single intervals are way easier to work with.
+(defun type-approximate-interval (type sys)
+  (cond ((ctype:rangep type sys)
+         (range->interval type sys))
+        ((ctype:disjunctionp type sys)
+         (reduce #'interval-merge
+                 (loop for st in (ctype:disjunction-ctypes type sys)
+                       collect (type-approximate-interval st sys))
+                 :initial-value (make-empty-interval)))
+        ((ctype:conjunctionp type sys)
+         (reduce #'interval-intersect
+                 (loop for st in (ctype:conjunction-ctypes type sys)
+                       collect (type-approximate-interval st sys))
+                 :initial-value (make-unbounded-interval)))
+        (t (make-unbounded-interval)))) ; unknown
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; (4) TYPES AND CLASSES
@@ -383,6 +401,20 @@
 (define-deriver random-state-p (object)
   (derive-type-predicate object 'random-state *clasp-system*))
 
+(macrolet ((def (comparator yes no)
+             `(define-deriver ,comparator (num1 num2)
+                (sv (let* ((sys *clasp-system*)
+                           (interval1 (type-approximate-interval num1 sys))
+                           (interval2 (type-approximate-interval num2 sys)))
+                      (cond ((,yes interval1 interval2) (ctype:member sys t))
+                            ((,no interval1 interval2) (ctype:member sys nil))
+                            (t (ctype:member sys t nil))))))))
+  (def core:two-arg-=  interval-=  interval-/=)
+  (def core:two-arg-<  interval-<  interval->=)
+  (def core:two-arg-<= interval-<= interval->)
+  (def core:two-arg->  interval->  interval-<=)
+  (def core:two-arg->= interval->= interval-<))
+
 (defun contagion (ty1 ty2)
   (ecase ty1
     ((integer)