common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Better type transform for rational/integer types with different bounds

Browse source 
Check integers first instead of splitting things into ranges.
This commit is contained in:
Stas Boukarev 2026-09-08 07:40:55 +03:00
parent 4df6bfd828
commit 8faeac79a9
2 changed files with 41 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
src/code/type.lisp
View file

@ -7176,6 +7176,19 @@ expansion happened."
for high = (aref ranges (1+ i))
do (funcall function low high format)))))))
(defun numeric-union-remove-integers (type)
(let ((ranges (numeric-union-type-ranges type))
(aspects (numeric-union-type-aspects type)))
(new-numeric-union-type
aspects
(coerce (loop for i below (length ranges) by 3
for run = (aref ranges i)
unless (eq run #.range-integer-run)
collect run
and collect (aref ranges (+ i 1))
and collect (aref ranges (+ i 2)))
'vector))))
;; (or (integer * -3) (integer 5)) => -3, 5
;; (integer 5) => nil, 5
;; (integer * -5) => -5, nil

46
src/compiler/typetran.lisp
View file

@ -880,24 +880,34 @@
;; Turn disjoint singlegton numeric types into a single
;; call to MEMBER
((flet ((transform-numeric (type)
(when (eq (numeric-type-complexp type) :real)
(let (singletons left-over)
(sb-kernel::map-numeric-union-ranges
(lambda (low high class)
(if (and low
(eql low high))
(push low singletons)
(push
(let ((bounds (list (or low '*) (or high '*))))
(if (eq class 'ratio)
`(and (rational ,@bounds) (not integer))
(list* class bounds)))
left-over)))
type)
(when singletons
`(boolean-or (member ,object '(,@singletons))
,@(and left-over
`((typep ,object '(or ,@left-over))))))))))
;; Check for rationals and integer separately if they do not have the same bounds
(cond ((and (eq (sb-kernel::numtype-aspects-class (sb-kernel::numeric-union-type-aspects type))
'rational)
(let ((integer (type-intersection type (specifier-type 'integer))))
(when (numeric-type-p integer)
(let ((rest (sb-kernel::numeric-union-remove-integers type)))
(unless (eq rest type)
`(boolean-or
(typep ,object ',(type-specifier integer))
(typep ,object ',(type-specifier rest)))))))))
((eq (numeric-type-complexp type) :real)
(let (singletons left-over)
(sb-kernel::map-numeric-union-ranges
(lambda (low high class)
(if (and low
(eql low high))
(push low singletons)
(push
(let ((bounds (list (or low '*) (or high '*))))
(if (eq class 'ratio)
`(and (rational ,@bounds) (not integer))
(list* class bounds)))
left-over)))
type)
(when singletons
`(boolean-or (member ,object '(,@singletons))
,@(and left-over
`((typep ,object '(or ,@left-over)))))))))))
(if (numeric-union-type-p type)
(transform-numeric type)
(let (tests