master: Faster compilation of TYPEP on disjoint numeric types
stassats via Sbcl-commits <[email protected]> Fri, 08 May 2026 02:55:41 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 9ce4f6ccc4a20abe3161ab68ac60d0f654611f25 (commit)
from 453d81b41290aca8ff787d1897c16d5760248e07 (commit)
- Log -----------------------------------------------------------------
commit 9ce4f6ccc4a20abe3161ab68ac60d0f654611f25
Author: Stas Boukarev <[email protected]>
Date: Fri May 8 05:24:15 2026 +0300
Faster compilation of TYPEP on disjoint numeric types
Fixes lp#2151818
---
src/code/macros.lisp | 9 +++++++
src/code/type.lisp | 48 ++++++++++++++++++++------------------
src/cold/exports.lisp | 1 +
src/compiler/typetran.lisp | 58 +++++++++++++++++++++++++++++++++++++++++-----
4 files changed, 88 insertions(+), 28 deletions(-)
diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index dbe8d53eb..ddc269b96 100644
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -562,6 +562,15 @@ evaluated as a PROGN."
,n-result
,(expand-forms t (rest forms)))))))))
+;;; Just return T, simplifying compilation by not needing LETs
+(sb-xc:defmacro boolean-or (&rest forms)
+ (named-let expand-forms ((forms forms))
+ (cond ((endp forms) nil)
+ (t
+ `(if ,(first forms)
+ t
+ ,(expand-forms (rest forms)))))))
+
;;;; Multiple value macros:
diff --git a/src/code/type.lisp b/src/code/type.lisp
index aa34eb5b0..bed1a6ab0 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -7095,35 +7095,39 @@ expansion happened."
(values (aref ranges 1) (aref ranges (1- (length ranges))))
(values (aref ranges 0) (aref ranges (1- (length ranges)))))))
+(defun map-numeric-union-ranges (function type)
+ (declare (dynamic-extent function))
+ (let ((ranges (numeric-union-type-ranges type))
+ (aspects (numeric-union-type-aspects type)))
+ (if (memq (numtype-aspects-class aspects) '(integer rational))
+ (loop for i below (length ranges) by 3
+ for low = (aref ranges (+ i 1))
+ for high = (aref ranges (+ i 2))
+ do (funcall function low high))
+ (loop for i below (length ranges) by 2
+ for low = (aref ranges i)
+ for high = (aref ranges (1+ i))
+ do (funcall function low high)))))
+
;; (or (integer * -3) (integer 5)) => -3, 5
;; (integer 5) => nil, 5
;; (integer * -5) => -5, nil
;; (integer -5 5) => 0, 0
(defun numeric-union-min-abs-bounds (type)
- (let ((ranges (numeric-union-type-ranges type))
- (aspects (numeric-union-type-aspects type))
- min-left
+ (let (min-left
min-right)
(block nil
- (flet ((process (low high)
- (cond ((not (fp-high-ge-high-p high 0))
- (setf min-left high))
- ((not (fp-low-le-low-p low 0))
- (setf min-right low)
- (return))
- (t
- (setf min-left 0
- min-right 0)
- (return)))))
- (if (memq (numtype-aspects-class aspects) '(integer rational))
- (loop for i below (length ranges) by 3
- for low = (aref ranges (+ i 1))
- for high = (aref ranges (+ i 2))
- do (process low high))
- (loop for i below (length ranges) by 2
- for low = (aref ranges i)
- for high = (aref ranges (1+ i))
- do (process low high)))))
+ (map-numeric-union-ranges (lambda (low high)
+ (cond ((not (fp-high-ge-high-p high 0))
+ (setf min-left high))
+ ((not (fp-low-le-low-p low 0))
+ (setf min-right low)
+ (return))
+ (t
+ (setf min-left 0
+ min-right 0)
+ (return))))
+ type))
(values min-left min-right)))
(defun weaken-numeric-union (type)
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index fb1213168..62ca3ca2f 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -1687,6 +1687,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"BIND" "BINDING-STACK-POINTER-SAP"
"BOGUS-ARG-TO-VALUES-LIST-ERROR" "BOOLE-CODE"
"BOUNDING-INDICES-BAD-ERROR" "BYTE-SPECIFIER" "%BYTE-BLT"
+ "BOOLEAN-OR"
"FUNCTION-DESIGNATOR"
"CAR-EQ-IF-LISTP"
"CASE-BODY-ERROR"
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 1a099e50d..8243b6353 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -864,6 +864,51 @@
(or (add-missing (specifier-type 'real) 'realp)
(add-missing (specifier-type 'number) 'numberp)
(add-missing (specifier-type 'rational) 'rationalp)))))))
+ ;; Turn disjoint singlegton numeric types into a single
+ ;; call to MEMBER
+ ((flet ((transform-numeric (type)
+ (when (eq (numeric-type-complexp type) :real)
+ (let ((singletons))
+ (sb-kernel::map-numeric-union-ranges
+ (lambda (low high)
+ (when (and low high
+ (eql low high))
+ (push low singletons)))
+ type)
+ (when singletons
+ (let* (left-over
+ (class (numeric-type-class type))
+ (type-name (ecase class
+ ((integer rational)
+ class)
+ (float
+ (numeric-type-format type)))))
+ (sb-kernel::map-numeric-union-ranges
+ (lambda (low high)
+ (unless (and low high
+ (eql low high))
+ (push (list type-name (or low '*) (or high '*)) left-over)))
+ type)
+ `(boolean-or (member ,object '(,@singletons))
+ ,@ (and left-over
+ `((typep ,object '(or ,@left-over)))))))))))
+ (if (numeric-union-type-p type)
+ (transform-numeric type)
+ (let (tests
+ tested)
+ (loop for type in (union-type-types type)
+ when (numeric-union-type-p type)
+ do (let ((test (transform-numeric type)))
+ (when test
+ (push test tests)
+ (push type tested))))
+ (when tests
+ (let ((left-over (mapcar #'type-specifier
+ (set-difference (union-type-types type) tested))))
+ `(boolean-or ,@tests
+ ,@(and left-over
+ `((typep ,object
+ '(or ,@left-over)))))))))))
(t
(let* ((types (sb-kernel::flatten-numeric-union-types type))
(type-cons (specifier-type 'cons))
@@ -930,7 +975,7 @@
,@(loop for type in sub-types
do (setf types (remove type types :test #'eq :count 1))
collect `(typep ,object ',(type-specifier type)))))))))
- `(or
+ `(boolean-or
,@(and #+64-bit
(not (every #'type-singleton-p single-floats)) ;; tested using EQL
(check single-floats 'single-float-p))
@@ -946,11 +991,12 @@
(cond ((and predicate
(< (length more-union-types)
(length more-types)))
- `(or (,predicate ,object)
- (typep ,object '(or ,@(mapcar #'type-specifier more-union-types)))))
+ `(boolean-or (,predicate ,object)
+ (typep ,object '(or ,@(mapcar #'type-specifier more-union-types)))))
(widetags
- `(or (%other-pointer-subtype-p ,object ',widetags)
- (typep ,object '(or ,@(mapcar #'type-specifier more-types)))))
+ `(boolean-or
+ (%other-pointer-subtype-p ,object ',widetags)
+ (typep ,object '(or ,@(mapcar #'type-specifier more-types)))))
((and (cdr more-types)
(every #'intersection-type-p more-types)
(let ((common (intersection-type-types (car more-types))))
@@ -968,7 +1014,7 @@
`(typep ,object '(and ,@(mapcar #'type-specifier
(set-difference types common))))))))))))
(t
- `(or
+ `(boolean-or
,@(mapcar (lambda (x)
`(typep ,object ',(type-specifier x)))
more-types)))))))))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL