master: Simplify numeric type construction
stassats via Sbcl-commits <[email protected]> Sun, 03 May 2026 21:59:58 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 0c21989ac51f144c127e1b718fd0534d1f9420f9 (commit)
from 206672bf256701de06ad574787186bec9ddcc1d3 (commit)
- Log -----------------------------------------------------------------
commit 0c21989ac51f144c127e1b718fd0534d1f9420f9
Author: Stas Boukarev <[email protected]>
Date: Mon May 4 00:42:24 2026 +0300
Simplify numeric type construction
Add a new function, make-numeric-type, which looks like
(make-numeric-type 'integer low high), not needing to construct a
list as for (specifier-type `(integer ,low ,high))
---
src/code/deftypes-for-target.lisp | 8 -
src/code/type.lisp | 92 ++++++--
src/cold/exports.lisp | 4 +-
src/compiler/arm64/c-call.lisp | 2 +-
src/compiler/array-tran.lisp | 27 ++-
src/compiler/bitops-derive-type.lisp | 180 +++++++--------
src/compiler/checkgen.lisp | 3 +-
src/compiler/constraint-back.lisp | 42 ++--
src/compiler/constraint.lisp | 18 +-
src/compiler/equality-constraints.lisp | 8 +-
src/compiler/float-tran.lisp | 241 +++++++-------------
src/compiler/generic/genesis.lisp | 2 +-
src/compiler/ir1opt.lisp | 8 +-
src/compiler/ir2tran.lisp | 2 +-
src/compiler/knownfun.lisp | 6 +-
src/compiler/loongarch64/c-call.lisp | 2 +-
src/compiler/modarith.lisp | 2 +-
src/compiler/seqtran.lisp | 41 ++--
src/compiler/srctran.lisp | 399 +++++++++++++++------------------
src/compiler/typetran.lisp | 2 +-
src/compiler/x86/arith.lisp | 11 +-
tests/type.pure.lisp | 28 +--
xperfecthash63.lisp-expr | 15 ++
23 files changed, 539 insertions(+), 604 deletions(-)
diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp
index a1b639ebc..dd7569809 100644
--- a/src/code/deftypes-for-target.lisp
+++ b/src/code/deftypes-for-target.lisp
@@ -53,14 +53,6 @@
~/sb-impl:print-type-specifier/"
s))))
-;;; ANSI got UNSIGNED-BYTE wrong, prohibiting (UNSIGNED-BYTE 0).
-;;; Since this is actually a substantial impediment to clarity...
-(sb-xc:deftype unsigned-byte* (&optional s)
- (cond
- ((eq s '*) '(integer 0))
- ((zerop s) '(integer 0 0))
- (t `(unsigned-byte ,s))))
-
(sb-xc:deftype bit () '(integer 0 1))
(sb-xc:deftype atom () '(not cons))
diff --git a/src/code/type.lisp b/src/code/type.lisp
index 8c91d3dfb..78f291d34 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -2678,7 +2678,7 @@ expansion happened."
(defun remove-integer-bounds (type)
(let ((low (numeric-type-low type))
(high (numeric-type-high type)))
- (make-numeric-type
+ (make-numeric-union-type
:class (numeric-type-class type)
:format (numeric-type-format type)
:complexp (numeric-type-complexp type)
@@ -2763,7 +2763,7 @@ expansion happened."
;;; exclusive bounds.
(defun coerce-numeric-bound (bound type)
(flet ((c (thing)
- (case type
+ (ecase type
(rational
(cond ((and (floatp thing) (float-infinity-p thing))
(return-from coerce-numeric-bound nil))
@@ -2793,7 +2793,7 @@ expansion happened."
(macrolet ((unionize (&rest specs)
`(type-union
,@(loop for (class format coerce simple-coerce) in specs
- collect `(make-numeric-type
+ collect `(make-numeric-union-type
:class ',class
:format ',format
:complexp complexp
@@ -2839,9 +2839,9 @@ expansion happened."
(specifier-type 'float))))
((and (null complexp)
(or class format low high))
- (type-union (make-numeric-type :class class :format format :complexp :complex
+ (type-union (make-numeric-union-type :class class :format format :complexp :complex
:low low :high high)
- (make-numeric-type :class class :format format :complexp :real
+ (make-numeric-union-type :class class :format format :complexp :real
:low low :high high))))))
(defun modified-numeric-type (base
@@ -2852,7 +2852,7 @@ expansion happened."
(low (numeric-type-low base))
(high (numeric-type-high base))
(normalize-zeros t))
- (make-numeric-type :class class
+ (make-numeric-union-type :class class
:format format
:complexp complexp
:low low
@@ -2954,13 +2954,13 @@ expansion happened."
(def-type-translator integer (&optional (low '*) (high '*))
(let ((lb (valid-bound low integer))
(hb (valid-bound high integer)))
- (make-numeric-type :class 'integer :complexp :real :low lb :high hb)))
+ (make-numeric-union-type :class 'integer :complexp :real :low lb :high hb)))
(defmacro !def-bounded-type (type class format)
`(def-type-translator ,type (&optional (low '*) (high '*))
(let ((lb (valid-bound low ,type))
(hb (valid-bound high ,type)))
- (make-numeric-type :class ',class :format ',format :low lb :high hb))))
+ (make-numeric-union-type :class ',class :format ',format :low lb :high hb))))
(!def-bounded-type rational rational nil)
@@ -3096,7 +3096,7 @@ expansion happened."
(complexp1 (numeric-type-complexp type1))
(complexp2 (numeric-type-complexp type2)))
(cond ((eq class1 'float)
- (make-numeric-type
+ (make-numeric-union-type
:class 'float
:format (ecase class2
(float (float-format-max format1 format2))
@@ -3128,10 +3128,10 @@ expansion happened."
(if (or rational
(or (neq class1 'integer)
(neq class2 'integer)))
- (make-numeric-type
+ (make-numeric-union-type
:class (and class1 class2 'rational)
:complexp :real)
- (make-numeric-type
+ (make-numeric-union-type
:class 'integer
:complexp :real
:low (and unsigned
@@ -4211,7 +4211,7 @@ expansion happened."
(float (values 'float (float-format-name elt)))
(ratio 'rational)
(t 'integer))
- (make-numeric-type :class class :format format :low elt :high elt
+ (make-numeric-union-type :class class :format format :low elt :high elt
:normalize-zeros nil))))
;; The thing is definitely implemented as a MEMBER type.
(make-member-type (let ((xset (alloc-xset)))
@@ -5495,7 +5495,7 @@ expansion happened."
(values :real nil nil))
(t
(values :real num num)))
- (make-numeric-type :class (etypecase num
+ (make-numeric-union-type :class (etypecase num
(integer (if (complexp x)
'rational
'integer))
@@ -5759,12 +5759,72 @@ expansion happened."
(defconstant range-ratio-run 2)
(defconstant range-rational-run 3)
-(defun make-numeric-type (&key class format (complexp :real) low high (normalize-zeros t))
+(declaim (ftype (sfunction ((member unsigned-byte signed-byte mod single-float
+ double-float nil real complex float
+ eql integer rational)
+ &optional t t t)
+ ctype)
+ make-numeric-type))
+(defun make-numeric-type (type &optional low high (normalize-zeros t))
+ (case type
+ (unsigned-byte
+ (make-numeric-union-type :class 'integer
+ :low 0
+ :high (and low
+ (1- (ash 1 low)))))
+ (signed-byte
+ (if low
+ (make-numeric-union-type :class 'integer
+ :low (- (ash 1 (1- low)))
+ :high (1- (ash 1 (1- low))))
+ (specifier-type 'integer)))
+ (mod
+ (if (zerop low)
+ *empty-type*
+ (make-numeric-union-type :class 'integer
+ :low 0
+ :high (1- low))))
+ ((single-float double-float)
+ (make-numeric-union-type :class 'float
+ :format type
+ :low (coerce-numeric-bound low type)
+ :high (coerce-numeric-bound high type)
+ :normalize-zeros normalize-zeros))
+ ((nil)
+ (error "Bad numeric type: ~s" type))
+ (real
+ (make-numeric-union-type :low low
+ :high high
+ :normalize-zeros normalize-zeros))
+ (complex
+ (multiple-value-bind (class format) (case low
+ ((integer rational)
+ (values 'rational nil))
+ ((float single-float double-float)
+ (values 'float low)))
+ (make-numeric-union-type :complexp :complex
+ :class class
+ :format format)))
+ (eql
+ (make-numeric-type
+ (etypecase low
+ (integer 'integer)
+ (ratio 'rational)
+ (single-float 'single-float)
+ (double-float 'double-float))
+ low low nil))
+ (t
+ (make-numeric-union-type :class type
+ :low low
+ :high high
+ :normalize-zeros normalize-zeros))))
+
+(defun make-numeric-union-type (&key class format (complexp :real) low high (normalize-zeros t))
(declare (type (member integer rational float nil) class))
(declare (inline !compute-numtype-aspect-id))
(let ((union-type (%make-union-numeric-type
class format complexp low high)))
- (when union-type (return-from make-numeric-type union-type)))
+ (when union-type (return-from make-numeric-union-type union-type)))
(multiple-value-bind (low high)
(case class
(integer
@@ -5780,7 +5840,7 @@ expansion happened."
(if (or (consp low) (consp high)) ; if either bound is exclusive
(sb-xc:>= (type-bound-number low) (type-bound-number high))
(sb-xc:> low high)))
- (return-from make-numeric-type *empty-type*))
+ (return-from make-numeric-union-type *empty-type*))
(when (and (eq class 'rational) (integerp low) (eql low high))
(setf class 'integer))
(flet ((normalize-low-zero (x)
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index ef458ec29..f5d0c1a93 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -774,7 +774,7 @@ possibly temporarily, because it might be used internally.")
"INDEX" "LOAD/STORE-INDEX"
"SIGNED-BYTE-WITH-A-BITE-OUT"
"UNSIGNED-BYTE-WITH-A-BITE-OUT"
- "SFUNCTION" "UNSIGNED-BYTE*"
+ "SFUNCTION"
"CONSTANT-DISPLACEMENT"
"EXTENDED-FUNCTION-DESIGNATOR"
"EXTENDED-FUNCTION-DESIGNATOR-P"
@@ -1841,7 +1841,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"MAKE-MEMBER-TYPE" "MAKE-NULL-LEXENV"
"MAKE-EQL-TYPE" "MEMBER-TYPE-FROM-LIST"
"MAKE-NEGATION-TYPE" "TYPE-NEGATION"
- "MAKE-NUMERIC-TYPE"
+ "MAKE-NUMERIC-TYPE" "MAKE-NUMERIC-UNION-TYPE"
"MAKE-SINGLE-FLOAT"
"MAKE-UNBOUND-MARKER"
"MAKE-SHORT-VALUES-TYPE" "MAKE-SINGLE-VALUE-TYPE"
diff --git a/src/compiler/arm64/c-call.lisp b/src/compiler/arm64/c-call.lisp
index 6318c56bb..67a8569c5 100644
--- a/src/compiler/arm64/c-call.lisp
+++ b/src/compiler/arm64/c-call.lisp
@@ -130,7 +130,7 @@
(defoptimizer (sign-extend derive-type) ((x size))
(when (sb-c:constant-lvar-p size)
- (specifier-type `(signed-byte ,(sb-c:lvar-value size)))))
+ (make-numeric-type 'signed-byte (sb-c:lvar-value size))))
(define-vop (sign-extend)
(:translate sign-extend)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index a3a1914e8..01d69bb8c 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -237,7 +237,7 @@
while (consp sequence))
t))
(if min
- (let ((int (make-numeric-type :class 'integer :low min :high max)))
+ (let ((int (make-numeric-type 'integer min max)))
(if union
(type-union union int)
int))
@@ -284,7 +284,7 @@
(setf max elt))
(when (< elt min)
(setf min elt))))
- (make-numeric-type :class 'integer :low min :high max)))))
+ (make-numeric-type 'integer min max)))))
(declare (inline int-min-max))
(macrolet ((test (type)
(let ((ctype (specifier-type type)))
@@ -414,7 +414,7 @@
(type-union union symbols)
symbols))))
(if min
- (let ((int (make-numeric-type :class 'integer :low min :high max)))
+ (let ((int (make-numeric-type 'integer min max)))
(if union
(type-union union int)
int))
@@ -1200,7 +1200,7 @@
fill-pointer
(csubtypep (lvar-type fill-pointer) (specifier-type 'index))
(not (types-equal-or-intersect (lvar-type fill-pointer)
- (specifier-type `(integer 0 ,c-length)))))
+ (make-numeric-type 'integer 0 c-length))))
(abort-ir1-transform "Invalid fill-pointer ~s for a vector of length ~s."
(type-specifier (lvar-type fill-pointer))
c-length))
@@ -1579,7 +1579,7 @@
(compiler-warn "Only vectors can have fill pointers."))
((and (csubtypep fp-type (specifier-type 'index))
(not (types-equal-or-intersect fp-type
- (specifier-type `(integer 0 ,length)))))
+ (make-numeric-type 'integer 0 length))))
(compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
(type-specifier fp-type)
length))))))
@@ -2132,8 +2132,7 @@
(when (or (not max-length)
(> length max-length))
(setf max-length length)))))
- (specifier-type `(integer ,(or min-length 0)
- ,max-length)))))))
+ (make-numeric-type 'integer (or min-length 0) max-length))))))
(defoptimizer (vector-length derive-type) ((vector))
(vector-length-type (lvar-conservative-type vector)))
@@ -2202,12 +2201,12 @@
(defun check-bound-empty-p (bound index)
(let* ((bound-type (lvar-type bound))
(bound-type
- (specifier-type `(integer 0
- (,(cond ((constant-lvar-p bound)
- (lvar-value bound))
- ((and (integer-type-p bound-type)
- (nth-value 1 (integer-type-numeric-bounds bound-type))))
- (array-dimension-limit))))))
+ (make-numeric-type 'mod
+ (cond ((constant-lvar-p bound)
+ (lvar-value bound))
+ ((and (integer-type-p bound-type)
+ (nth-value 1 (integer-type-numeric-bounds bound-type))))
+ (array-dimension-limit))))
(index-type (lvar-type index)))
(eq (type-intersection bound-type index-type)
*empty-type*)))
@@ -2708,7 +2707,7 @@
(let ((eltype (array-type-upgraded-element-type object)))
(if (and (csubtypep object (specifier-type 'vector))
(neq eltype *wild-type*))
- (specifier-type `(eql ,(sb-vm:saetp-typecode (find-saetp-by-ctype eltype))))
+ (make-numeric-type 'eql (sb-vm:saetp-typecode (find-saetp-by-ctype eltype)))
(specifier-type `(integer ,sb-vm:simple-array-widetag (,sb-vm:complex-base-string-widetag))))))
((csubtypep object (specifier-type '(not (simple-array * (*)))))
(specifier-type `(and (not (integer (,sb-vm:simple-array-widetag)
diff --git a/src/compiler/bitops-derive-type.lisp b/src/compiler/bitops-derive-type.lisp
index 71c0f51dc..2b8a96f0f 100644
--- a/src/compiler/bitops-derive-type.lisp
+++ b/src/compiler/bitops-derive-type.lisp
@@ -156,23 +156,24 @@
(cond ((and (null x-len) (null y-len))
(specifier-type 'unsigned-byte))
((null x-len)
- (specifier-type `(unsigned-byte* ,y-len)))
+ (make-numeric-type 'unsigned-byte y-len))
((null y-len)
- (specifier-type `(unsigned-byte* ,x-len)))
+ (make-numeric-type 'unsigned-byte x-len))
(t
(multiple-value-bind (low high)
(logand-derive-unsigned-bounds x y)
- (specifier-type `(integer ,low ,high)))))
+ (make-numeric-type 'integer low high))))
;; X is positive, but Y might be negative.
(cond ((and x-len y-low y-high (< y-high 0))
(multiple-value-bind (low high)
(let ((len (max x-len y-len)))
- (logand-derive-unsigned-bounds x (make-numeric-type :class 'integer
- :low (ldb (byte len 0) y-low)
- :high (ldb (byte len 0) y-high))))
- (specifier-type `(integer ,low ,high))))
+ (logand-derive-unsigned-bounds x
+ (make-numeric-type 'integer
+ (ldb (byte len 0) y-low)
+ (ldb (byte len 0) y-high))))
+ (make-numeric-type 'integer low high)))
(x-high
- (specifier-type `(integer 0 ,x-high)))
+ (make-numeric-type 'integer 0 x-high))
(t
(specifier-type 'unsigned-byte))))
;; X might be negative.
@@ -181,23 +182,22 @@
(cond ((and y-len x-low x-high (< x-high 0))
(multiple-value-bind (low high)
(let ((len (max x-len y-len)))
- (logand-derive-unsigned-bounds y (make-numeric-type :class 'integer
- :low (ldb (byte len 0) x-low)
- :high (ldb (byte len 0) x-high))))
- (specifier-type `(integer ,low ,high))))
+ (logand-derive-unsigned-bounds y (make-numeric-type 'integer
+ (ldb (byte len 0) x-low)
+ (ldb (byte len 0) x-high))))
+ (make-numeric-type 'integer low high)))
(y-high
- (specifier-type `(integer 0 ,y-high)))
+ (make-numeric-type 'integer 0 y-high))
(t
(specifier-type 'unsigned-byte)))
;; Either might be negative.
(cond ((and x-low y-low)
- (specifier-type `(integer ,(zeroes (integer-length (min x-low y-low)))
- ,(if (and x-high y-high)
- (max x-high y-high -1)
- '*))))
+ (make-numeric-type 'integer
+ (zeroes (integer-length (min x-low y-low)))
+ (and x-high y-high
+ (max x-high y-high -1))))
((and x-high y-high)
- (specifier-type `(integer *
- ,(max x-high y-high -1))))
+ (make-numeric-type 'integer nil (max x-high y-high -1)))
(t
(if (and (not y-pos)
(not x-pos))
@@ -238,9 +238,9 @@
(cond ((and x-len y-len)
(multiple-value-bind (low high)
(logior-derive-unsigned-bounds x y)
- (specifier-type `(integer ,low ,high))))
+ (make-numeric-type 'integer low high)))
(t
- (specifier-type `(integer ,(max y-low x-low))))))
+ (make-numeric-type 'integer (max y-low x-low)))))
((not x-pos)
;; X must be negative.
(if (not y-pos)
@@ -248,14 +248,12 @@
;; and be the same length or shorter than the smaller.
(if (and x-len y-len)
;; It's bounded.
- (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
+ (make-numeric-type 'integer (ash -1 (min x-len y-len)) -1)
;; It's unbounded.
(specifier-type '(integer * -1)))
;; X is negative, but we don't know about Y. The result
;; will be negative, but no more negative than X.
- (specifier-type
- `(integer ,(or x-low '*)
- -1))))
+ (make-numeric-type 'integer x-low -1)))
(t
;; X might be either positive or negative.
(flet ((add-one (a-low b-low b-high)
@@ -276,39 +274,40 @@
a-low)))))
(cond ((not y-pos)
;; But Y is negative. The result will be negative.
- (specifier-type
- `(integer ,(or y-low '*)
- -1)))
+ (make-numeric-type 'integer y-low -1))
((and y-low
(> y-low 0))
- (specifier-type `(or (integer ,(if x-low
- (add-one x-low y-low y-high)
- '*) -1)
- ,(if (and x-high
- y-len)
- (multiple-value-bind (low high)
- (logior-derive-unsigned-bounds (specifier-type `(integer 0 ,x-high))
- y)
- `(integer ,low ,high))
- `(integer ,y-low)))))
+ (type-union (make-numeric-type 'integer (and x-low
+ (add-one x-low y-low y-high))
+ -1)
+ (if (and x-high
+ y-len)
+ (multiple-value-bind (low high)
+ (logior-derive-unsigned-bounds (make-numeric-type 'integer 0 x-high)
+ y)
+ (make-numeric-type 'integer low high))
+ (make-numeric-type 'integer y-low))))
((and x-low
(> x-low 0))
- (specifier-type `(or (integer ,(if y-low
- (add-one y-low x-low x-high)
- '*) -1)
- ,(if (and y-high
- x-len)
- (multiple-value-bind (low high)
- (logior-derive-unsigned-bounds (specifier-type `(integer 0 ,y-high))
- x)
- `(integer ,low ,high))
- `(integer ,x-low)))))
+ (type-union (make-numeric-type 'integer (and y-low
+ (add-one y-low x-low x-high))
+ -1)
+ (if (and y-high
+ x-len)
+ (multiple-value-bind (low high)
+ (logior-derive-unsigned-bounds (make-numeric-type 'integer 0 y-high)
+ x)
+ (make-numeric-type 'integer low high))
+ (make-numeric-type 'integer x-low))))
(t
(cond ((and x-len y-len)
- (specifier-type `(integer ,(min x-low y-low)
- ,(nth-value 1 (logior-derive-unsigned-bounds x y)))))
+ (make-numeric-type 'integer
+ (min x-low y-low)
+ (nth-value 1 (logior-derive-unsigned-bounds x y))))
((and x-high y-high)
- (specifier-type `(integer * ,(nth-value 1 (logior-derive-unsigned-bounds x y)))))
+ (make-numeric-type 'integer
+ nil
+ (nth-value 1 (logior-derive-unsigned-bounds x y))))
(t
(specifier-type 'integer)))))))))))
@@ -343,26 +342,24 @@
(if (and x-len y-len)
(multiple-value-bind (low high)
(logxor-derive-unsigned-bounds x y)
- (specifier-type `(integer ,low ,high)))
- (specifier-type '(unsigned-byte* *))))
+ (make-numeric-type 'integer low high))
+ (specifier-type 'unsigned-byte)))
((and (not x-pos) (not y-pos))
;; Both are negative. The result will be positive, and as long
;; as the longer.
- (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
- (max x-len y-len)
- '*))))
+ (make-numeric-type 'unsigned-byte (and x-len y-len
+ (max x-len y-len))))
((or (and (not x-pos) (not y-neg))
(and (not y-pos) (not x-neg)))
;; Either X is negative and Y is positive or vice-versa. The
;; result will be negative.
- (specifier-type `(integer ,(if (and x-len y-len)
- (ash -1 (max x-len y-len))
- '*)
- -1)))
+ (make-numeric-type 'integer (and x-len y-len
+ (ash -1 (max x-len y-len)))
+ -1))
;; We can't tell what the sign of the result is going to be.
;; All we know is that we don't create new bits.
((and x-len y-len)
- (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
+ (make-numeric-type 'signed-byte (1+ (max x-len y-len))))
(t
(specifier-type 'integer))))))
@@ -401,12 +398,11 @@
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
(declare (ignore pos neg))
(let* ((int (if len
- (make-numeric-type :class 'integer
- :complexp :real
- :low (ash -1 (integer-length (max (abs low) (abs high))))
- :high (if (<= low 0 high)
- 0
- -2))
+ (make-numeric-type 'integer
+ (ash -1 (integer-length (max (abs low) (abs high))))
+ (if (<= low 0 high)
+ 0
+ -2))
(if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
(specifier-type '(integer * 0))
(specifier-type '(integer * -2))))))
@@ -427,18 +423,17 @@
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
(declare (ignore pos neg))
(let ((int (if len
- (make-numeric-type :class 'integer
- :complexp :real
- :low (let ((positive (if (plusp high)
- (1- (integer-length high))
- 0))
- (negative (if (minusp low)
- (if (= low (- (ash 1 len)))
- len
- (1- len))
- 0)))
- (- (ash 1 (max positive negative))))
- :high 0)
+ (make-numeric-type 'integer
+ (let ((positive (if (plusp high)
+ (1- (integer-length high))
+ 0))
+ (negative (if (minusp low)
+ (if (= low (- (ash 1 len)))
+ len
+ (1- len))
+ 0)))
+ (- (ash 1 (max positive negative))))
+ 0)
(specifier-type '(integer * 0)))))
(if type
(type-intersection type int)
@@ -457,20 +452,19 @@
(multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
(declare (ignore pos neg))
(let ((int (if len
- (make-numeric-type :class 'integer
- :complexp :real
- :low (if (<= low 0 high)
- 0
- 1)
- :high (let ((positive (if (plusp high)
- (1- (integer-length high))
- 0))
- (negative (if (minusp low)
- (if (= low (- (ash 1 len)))
- (1+ len)
- (1- len))
- 0)))
- (ash 1 (max positive negative))))
+ (make-numeric-type 'integer
+ (if (<= low 0 high)
+ 0
+ 1)
+ (let ((positive (if (plusp high)
+ (1- (integer-length high))
+ 0))
+ (negative (if (minusp low)
+ (if (= low (- (ash 1 len)))
+ (1+ len)
+ (1- len))
+ 0)))
+ (ash 1 (max positive negative))))
(if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
(specifier-type '(integer 0))
(specifier-type '(integer 1))))))
diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 02efd2969..7754c401b 100644
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -61,8 +61,7 @@
(if (eq t low)
rest
(type-union rest
- (specifier-type
- `(integer ,(or low '*) ,(or high '*)))))))
+ (make-numeric-type 'integer low high)))))
(t
type))))
(weaken-integer-type-part type 'integer)))
diff --git a/src/compiler/constraint-back.lisp b/src/compiler/constraint-back.lisp
index 05a0036bd..97bb7ac76 100644
--- a/src/compiler/constraint-back.lisp
+++ b/src/compiler/constraint-back.lisp
@@ -196,10 +196,7 @@
(let* ((y-interval (type-approximate-interval (lvar-type y) t))
(int (and c-interval y-interval
(interval-sub c-interval y-interval))))
- (add x (specifier-type (if int
- `(integer ,(or (interval-low int) '*)
- ,(or (interval-high int) '*))
- 'integer))))))
+ (add x (interval-to-type int 'integer)))))
(when (or y-integerp x-integerp)
(let ((interval (type-approximate-interval constraint t)))
(int interval y x)
@@ -226,18 +223,12 @@
(int (and c-interval
y-interval
(interval-add c-interval y-interval))))
- (add x (specifier-type (if int
- `(integer ,(or (interval-low int) '*)
- ,(or (interval-high int) '*))
- 'integer))))
+ (add x (interval-to-type int 'integer)))
(let* ((x-interval (type-approximate-interval x-type t))
(int (and c-interval
x-interval
(interval-sub x-interval c-interval))))
- (add y (specifier-type (if int
- `(integer ,(or (interval-low int) '*)
- ,(or (interval-high int) '*))
- 'integer)))))
+ (add y (interval-to-type int 'integer))))
t)))
(numeric-contagion-constraint-back x y gen constraint nil alternative
:x-type x-type :y-type y-type
@@ -366,11 +357,11 @@
(1- (interval-high x-int)))))
(when (or new-low new-high)
(setf x-type
- (make-numeric-type :class 'integer
- :low (or new-low
- (interval-low x-int))
- :high (or new-high
- (interval-high x-int)))))))
+ (make-numeric-type 'integer
+ (or new-low
+ (interval-low x-int))
+ (or new-high
+ (interval-high x-int)))))))
(when sign
(setf x-type (type-intersection x-type sign)))
@@ -421,8 +412,7 @@
(interval-low c-interval) (interval-high c-interval)
(interval-low d-interval) (interval-high d-interval))
(let ((m (interval-untruncate c-interval d-interval)))
- (add x (specifier-type `(integer ,(interval-low m)
- ,(interval-high m)))))))))))))))
+ (add x (interval-to-type m 'integer)))))))))))))
(defoptimizer (unary-truncate constraint-propagate-back) ((x) node nth-value kind constraint gen consequent alternative)
(case kind
@@ -442,7 +432,9 @@
(let ((range (type-approximate-interval (lvar-type constraint))))
(when (and range
(numberp (interval-high range)))
- (add-back-constraint gen 'typep x (specifier-type `(rational (,(- (interval-high range))))) consequent)))))
+ (add-back-constraint gen 'typep x
+ (make-numeric-type 'rational (list (- (interval-high range))))
+ consequent)))))
(typep
(-constraint-propagate-back nil x (specifier-type '(eql 0)) (lvar-type x) kind constraint gen consequent alternative))))
@@ -454,11 +446,11 @@
(add-back-constraint gen 'typep lvar type consequent)))
(cond ((csubtypep constraint (specifier-type 'integer))
(let ((int (type-approximate-interval constraint t)))
- (add x (specifier-type (if (and int
- (typep (interval-high int) 'unsigned-byte))
- `(integer ,(- (interval-high int))
- ,(interval-high int))
- 'integer)))
+ (add x (if (and int
+ (typep (interval-high int) 'unsigned-byte))
+ (make-numeric-type 'integer
+ (- (interval-high int)) (interval-high int))
+ (specifier-type 'integer)))
t))
((csubtypep constraint (specifier-type 'rational))
(add x (specifier-type 'rational)))
diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index fd1b9cc51..dacdbb836 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -971,8 +971,8 @@
(let ((bound (exclude (bound y))))
(when bound
(if greater
- (make-numeric-type :low bound)
- (make-numeric-type :high bound))))))
+ (make-numeric-union-type :low bound)
+ (make-numeric-union-type :high bound))))))
(defun constrain-real (y greater or-equal)
(let ((int (type-approximate-interval y)))
@@ -989,8 +989,8 @@
(let ((bound (exclude (bound int))))
(when bound
(if greater
- (make-numeric-type :low bound)
- (make-numeric-type :high bound))))))))
+ (make-numeric-union-type :low bound)
+ (make-numeric-union-type :high bound))))))))
;;; Return true if LEAF is "visible" from NODE.
(defun leaf-visible-from-node-p (leaf node)
@@ -1024,10 +1024,10 @@
(setf max value)))
xset)
(when (= (- max min) (1- count))
- (make-numeric-type :class 'integer :low min :high max)))))
+ (make-numeric-type 'integer min max)))))
;; It's useful to know when something is not zero
((xset-member-p 0 xset)
- (make-numeric-type :class 'integer :low 0 :high 0))))
+ (specifier-type '(eql 0)))))
;;; Compute the tightest type possible for a variable given a set of
;;; CONSTRAINTS.
@@ -1157,11 +1157,11 @@
(when (and c-lo
(= hi c-lo))
(type-intersection current-type
- (make-numeric-type :low (1+ lo))))))
+ (make-numeric-union-type :low (1+ lo))))))
(when (or lo hi)
(type-intersection current-type
- (type-union (make-numeric-type :low lo
- :high hi)
+ (type-union (make-numeric-union-type :low lo
+ :high hi)
(specifier-type 'complex)))))))
(t
(multiple-value-bind (greater equal)
diff --git a/src/compiler/equality-constraints.lisp b/src/compiler/equality-constraints.lisp
index e2e7d4949..9c7e59be9 100644
--- a/src/compiler/equality-constraints.lisp
+++ b/src/compiler/equality-constraints.lisp
@@ -646,7 +646,7 @@
(add-equality-constraint '< index dimension gen gen nil)
(let ((var (ok-lvar-lambda-var index gen))
(type (if (constant-lvar-p dimension)
- (specifier-type `(integer 0 (,(lvar-value dimension))))
+ (make-numeric-type 'mod (lvar-value dimension))
(specifier-type 'index))))
(when var
(list (list 'typep var type nil)))))
@@ -967,7 +967,7 @@
(multiple-value-bind (l h) (subseq-bounds sequence start end gen)
(when (or h
(> l 0))
- (push (list 'vector-length (specifier-type `(integer ,l ,(or h '*))))
+ (push (list 'vector-length (make-numeric-type 'integer l h))
c)))
c))
@@ -1021,11 +1021,11 @@
(t
(setf max nil))))))))
(when (plusp min-sum)
- (push (list 'vector-length>= (specifier-type `(eql ,min-sum)))
+ (push (list 'vector-length>= (make-numeric-type 'eql min-sum))
r))
(when (and max
(plusp max-sum))
- (push (list 'vector-length<= (specifier-type `(eql ,max-sum)))
+ (push (list 'vector-length<= (make-numeric-type 'eql max-sum))
r))
r))
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index dc448cc29..176d0895c 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -355,11 +355,10 @@
(setf new-lo (scale-bound f-lo ex-hi)))
(when ex-lo
(setf new-lo (scale-bound f-lo ex-lo)))))
- (make-numeric-type :class (numeric-type-class f)
- :format (numeric-type-format f)
- :complexp :real
- :low new-lo
- :high new-hi)))))
+ (make-numeric-union-type :class (numeric-type-class f)
+ :format (numeric-type-format f)
+ :low new-lo
+ :high new-hi)))))
(defoptimizer (scale-single-float derive-type) ((f ex))
(two-arg-derive-type f ex #'scale-float-derive-type-aux))
(defoptimizer (scale-double-float derive-type) ((f ex))
@@ -392,7 +391,7 @@
(coerce x ',type)))
(numeric-type-high num)
nil)))
- (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
+ (make-numeric-type ',type lo hi)))
(defoptimizer (,fun derive-type) ((num))
(handler-case
@@ -711,7 +710,7 @@
((integer rational) 'single-float)
(t (numeric-type-format arg))))
(float-type (or format 'float)))
- (specifier-type `(complex ,float-type))))
+ (make-numeric-type 'complex float-type)))
;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
;;; should be the right kind of float. Allow bounds for the float
@@ -719,14 +718,11 @@
(defun float-or-complex-float-type (arg &optional lo hi)
(typecase arg
(numeric-type
- (let* ((format (case (numeric-type-class arg)
- ((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (float-type (or format 'float))
- (lo (coerce-numeric-bound lo float-type))
- (hi (coerce-numeric-bound hi float-type)))
- (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
- (complex ,float-type)))))
+ (let ((format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg)))))
+ (type-union (make-numeric-type format lo hi)
+ (make-numeric-type 'complex format))))
((or union-type numeric-union-type)
(apply #'type-union
(loop for type in (sb-kernel::flatten-numeric-union-types arg)
@@ -823,13 +819,8 @@
'double-float
'single-float))
(t (numeric-type-format arg))))
- (bound-type (or format 'float))
(result-type
- (make-numeric-type
- :class 'float
- :format format
- :low (coerce-numeric-bound res-lo bound-type)
- :high (coerce-numeric-bound res-hi bound-type))))
+ (make-numeric-type format res-lo res-hi)))
;; If the ARG is a subset of the domain, we don't
;; have to worry about the difference, because that
;; can't occur.
@@ -838,7 +829,7 @@
(domain-subtypep arg domain-low domain-high))
result-type
(list result-type
- (specifier-type `(complex ,bound-type))))))
+ (make-numeric-type 'complex format)))))
(t
;; No intersection so the result must be purely complex.
(complex-float-type arg)))))
@@ -992,38 +983,33 @@
(integer
;; Positive integer to an integer power is either an
;; integer or a rational.
- (let ((lo (or (interval-low bnd) '*))
- (hi (or (interval-high bnd) '*))
+ (let ((lo (interval-low bnd))
+ (hi (interval-high bnd))
(y-lo (interval-low y-int))
(y-hi (interval-high y-int)))
- (cond ((and (eq lo '*)
+ (cond ((and (not lo)
(eql y-lo y-hi)
(typep y-lo 'unsigned-byte)
(evenp y-lo))
- (specifier-type `(integer 0 ,hi)))
+ (make-numeric-type 'integer 0 hi))
((and (interval-low y-int)
(>= (type-bound-number y-lo) 0))
-
- (specifier-type `(integer ,lo ,hi)))
+ (make-numeric-type 'integer lo hi))
(t
- (specifier-type `(rational ,lo ,hi))))))
+ (make-numeric-type 'rational lo hi)))))
(rational
;; Positive integer to rational power is either a rational
;; or a single-float.
(let* ((lo (interval-low bnd))
(hi (interval-high bnd))
- (int-lo (if lo
- (floor (type-bound-number lo))
- '*))
- (int-hi (if hi
- (ceiling (type-bound-number hi))
- '*))
- (f-lo (or (bound-func #'float lo nil)
- '*))
- (f-hi (or (bound-func #'float hi nil)
- '*)))
- (specifier-type `(or (rational ,int-lo ,int-hi)
- (single-float ,f-lo, f-hi)))))
+ (int-lo (and lo
+ (floor (type-bound-number lo))))
+ (int-hi (and hi
+ (ceiling (type-bound-number hi))))
+ (f-lo (bound-func #'float lo nil))
+ (f-hi (bound-func #'float hi nil)))
+ (type-union (make-numeric-type 'rational int-lo int-hi)
+ (make-numeric-type 'single-float f-lo f-hi))))
(float
;; A positive integer to a float power is a float.
(let ((format (numeric-type-format y-type)))
@@ -1040,29 +1026,23 @@
(case (numeric-type-class y-type)
(integer
;; A positive rational to an integer power is always a rational.
- (specifier-type `(rational ,(or (interval-low bnd) '*)
- ,(or (interval-high bnd) '*))))
+ (interval-to-type bnd 'rational))
(rational
;; A positive rational to rational power is either a rational
;; or a single-float.
(let* ((lo (interval-low bnd))
(hi (interval-high bnd))
- (int-lo (if lo
- (floor (type-bound-number lo))
- '*))
- (int-hi (if hi
- (ceiling (type-bound-number hi))
- '*))
- (f-lo (or (bound-func #'float lo nil)
- '*))
- (f-hi (or (bound-func #'float hi nil)
- '*)))
- (specifier-type `(or (rational ,int-lo ,int-hi)
- (single-float ,f-lo, f-hi)))))
+ (int-lo (and lo
+ (floor (type-bound-number lo))))
+ (int-hi (and hi
+ (ceiling (type-bound-number hi))))
+ (f-lo (bound-func #'float lo nil))
+ (f-hi (bound-func #'float hi nil)))
+ (type-union (make-numeric-type 'rational int-lo int-hi)
+ (make-numeric-type 'single-float f-lo f-hi))))
(float
;; A positive rational to a float power is a float.
(let ((format (numeric-type-format y-type)))
- (aver format)
(modified-numeric-type
y-type
:low (coerce-numeric-bound (interval-low bnd) format)
@@ -1076,25 +1056,14 @@
((or integer rational)
;; A positive float to an integer or rational power is
;; always a float.
- (let ((format (numeric-type-format x-type)))
- (aver format)
- (make-numeric-type
- :class 'float
- :format format
- :low (coerce-numeric-bound (interval-low bnd) format)
- :high (coerce-numeric-bound (interval-high bnd) format))))
+ (interval-to-type bnd (numeric-type-format x-type)))
(float
;; A positive float to a float power is a float of the
;; higher type.
- (let ((format (float-format-max (numeric-type-format x-type)
- (numeric-type-format y-type))))
- (aver format)
- (make-numeric-type
- :class 'float
- :format format
- :low (coerce-numeric-bound (interval-low bnd) format)
- :high (coerce-numeric-bound (interval-high bnd) format)
- :normalize-zeros nil)))
+ (let ((format (or (float-format-max (numeric-type-format x-type)
+ (numeric-type-format y-type))
+ 'float)))
+ (interval-to-type bnd format nil)))
(t
;; A positive float to a number is a number (for now)
(specifier-type 'number))))
@@ -1144,11 +1113,11 @@
((eq (numeric-type-format type) format)
type)
(t
- (make-numeric-type :class 'float
- :format format
- :complexp (numeric-type-complexp type)
- :low (coerce-for-bound (numeric-type-low type) format)
- :high (coerce-for-bound (numeric-type-high type) format)))))
+ (make-numeric-union-type :class 'float
+ :format format
+ :complexp (numeric-type-complexp type)
+ :low (coerce-for-bound (numeric-type-low type) format)
+ :high (coerce-for-bound (numeric-type-high type) format)))))
(defun log-derive-type-aux-1 (x &optional (fun #'log) double-float-for-integers)
(elfun-derive-type-simple x fun
@@ -1222,13 +1191,8 @@
;; appear multiple times, and should be factored out.
(format (case (numeric-type-class result-type)
((integer rational) 'single-float)
- (t (numeric-type-format result-type))))
- (bound-format (or format 'float)))
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce (sb-xc:- pi) bound-format)
- :high (coerce pi bound-format))))
+ (t (numeric-type-format result-type)))))
+ (make-numeric-type format (sb-xc:- pi) pi)))
(t
;; The result is a float or a complex number
(float-or-complex-float-type result-type)))))
@@ -1252,47 +1216,26 @@
(defun phase-derive-type-aux (arg)
(let* ((format (case (numeric-type-class arg)
((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (bound-type (or format 'float)))
+ (t (numeric-type-format arg)))))
(cond ((numeric-type-real-p arg)
(case (let ((int (numeric-type->interval arg)))
(interval-range-info int (interval-zero int 0.0)))
(+
;; The number is positive, so the phase is 0.
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce 0 bound-type)
- :high (coerce 0 bound-type)))
+ (make-numeric-type format 0 0))
(-
;; The number is always negative, so the phase is pi.
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce pi bound-type)
- :high (coerce pi bound-type)))
+ (make-numeric-type format pi pi))
(t
;; We can't tell. The result is 0 or pi. Use a union
;; type for this.
(list
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce 0 bound-type)
- :high (coerce 0 bound-type))
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce pi bound-type)
- :high (coerce pi bound-type))))))
+ (make-numeric-type format 0 0)
+ (make-numeric-type format pi pi)))))
(t
;; We have a complex number. The answer is the range -pi
;; to pi. (-pi is included because we have -0.)
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce (sb-xc:- pi) bound-type)
- :high (coerce pi bound-type))))))
+ (make-numeric-type format (sb-xc:- pi) pi)))))
(defoptimizer (phase derive-type) ((num))
(one-arg-derive-type num #'phase-derive-type-aux))
@@ -1318,20 +1261,18 @@
(cond ((numeric-type-real-p type)
;; The realpart of a real has the same type and range as
;; the input.
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (numeric-type-low type)
- :high (numeric-type-high type)))
+ (make-numeric-union-type :class class
+ :format format
+ :low (numeric-type-low type)
+ :high (numeric-type-high type)))
(t
;; We have a complex number. The result has the same type
;; as the real part, except that it's real, not complex,
;; obviously.
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (numeric-type-low type)
- :high (numeric-type-high type))))))
+ (make-numeric-union-type :class class
+ :format format
+ :low (numeric-type-low type)
+ :high (numeric-type-high type))))))
(defoptimizer (realpart derive-type) ((num))
(one-arg-derive-type num #'realpart-derive-type-aux))
@@ -1343,33 +1284,31 @@
;; The imagpart of a real has the same type as the input,
;; except that it's zero.
(let ((bound-format (or format class 'real)))
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (coerce 0 bound-format)
- :high (coerce 0 bound-format)
- :normalize-zeros nil)))
+ (make-numeric-union-type :class class
+ :format format
+ :low (coerce 0 bound-format)
+ :high (coerce 0 bound-format)
+ :normalize-zeros nil)))
(t
;; We have a complex number. The result has the same type as
;; the imaginary part, except that it's real, not complex,
;; obviously.
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (numeric-type-low type)
- :high (numeric-type-high type))))))
+ (make-numeric-union-type :class class
+ :format format
+ :low (numeric-type-low type)
+ :high (numeric-type-high type))))))
(defoptimizer (imagpart derive-type) ((num))
(one-arg-derive-type num #'imagpart-derive-type-aux))
(defun complex-derive-type-aux-1 (re-type)
(if (numeric-type-p re-type)
- (make-numeric-type :class (numeric-type-class re-type)
- :format (numeric-type-format re-type)
- :complexp (if (csubtypep re-type
- (specifier-type 'rational))
- :real
- :complex))
+ (make-numeric-union-type :class (numeric-type-class re-type)
+ :format (numeric-type-format re-type)
+ :complexp (if (csubtypep re-type
+ (specifier-type 'rational))
+ :real
+ :complex))
(specifier-type 'complex)))
(defun complex-derive-type-aux-2 (re-type im-type same-arg)
@@ -1401,9 +1340,9 @@
(type-union element-type complex)
complex)))
(t
- (make-numeric-type :class (numeric-type-class element-type)
- :format (numeric-type-format element-type)
- :complexp :complex))))
+ (make-numeric-union-type :class (numeric-type-class element-type)
+ :format (numeric-type-format element-type)
+ :complexp :complex))))
(specifier-type 'complex)))
(defoptimizer (complex derive-type) ((re &optional im))
@@ -1729,12 +1668,10 @@
((integer rational) 'single-float)
(t (numeric-type-format arg)))))
(cond ((eq (numeric-type-complexp arg) :complex)
- (make-numeric-type :class 'float
- :format (floatify-format)
- :complexp :complex))
+ (make-numeric-type 'complex
+ (floatify-format)))
((numeric-type-real-p arg)
- (let* ((format (floatify-format))
- (bound-type (or format 'float)))
+ (let* ((format (floatify-format)))
;; If the argument is a subset of the "principal" domain
;; of the function, we can compute the bounds because
;; the function is monotonic. We can't do this in
@@ -1747,16 +1684,8 @@
(res-hi (bound-func fun (numeric-type-high arg) nil)))
(unless increasingp
(rotatef res-lo res-hi))
- (make-numeric-type
- :class 'float
- :format format
- :low (coerce-numeric-bound res-lo bound-type)
- :high (coerce-numeric-bound res-hi bound-type)))
- (make-numeric-type
- :class 'float
- :format format
- :low (and def-lo (coerce def-lo bound-type))
- :high (and def-hi (coerce def-hi bound-type))))))
+ (make-numeric-type format res-lo res-hi))
+ (make-numeric-type format def-lo def-hi))))
(t
(float-or-complex-float-type arg def-lo def-hi)))))))
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index df57432f2..6e0654473 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -3069,7 +3069,7 @@ Legal values for OFFSET are -4, -8, -12, ..."
(return-from check))
(unless (< start end)
(error "Space bounds look bad: ~A = ~X..~X" space start end))
- (let ((type (specifier-type `(integer ,start (,end)))))
+ (let ((type (make-numeric-type 'integer start (1- end))))
(dolist (other types)
(unless (eq *empty-type* (type-intersection (cdr other) type))
(error "Space overlap: ~A with ~A" space (car other))))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 5afeea978..a0cba11c1 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -2169,10 +2169,10 @@
class
(format :no))
(dolist (part (union-type-types type)
- (make-numeric-type :class class
- :format format
- :low low
- :high high))
+ (make-numeric-union-type :class class
+ :format format
+ :low low
+ :high high))
(unless (and (numeric-type-real-p part)
(if class
(eql (numeric-type-class part) class)
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 99d25586a..41cb4c2e4 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -745,7 +745,7 @@
do (setf (label-usedp
(setf (aref vector (- index min)) (block-label target)))
t))
- (list vector (cond ((csubtypep (lvar-type index) (specifier-type `(integer ,min ,max)))
+ (list vector (cond ((csubtypep (lvar-type index) (make-numeric-type 'integer min max))
nil)
(otherwise))
min max)))
diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp
index 1efa63d64..3f6716da6 100644
--- a/src/compiler/knownfun.lisp
+++ b/src/compiler/knownfun.lisp
@@ -506,7 +506,7 @@
(union-type
(mapc #'max-dim (union-type-types type)))
(array-type (if (array-type-complexp type)
- (return '*)
+ (return)
(process-dim (array-type-dimensions type))))
(t
(cond ((csubtypep type (specifier-type 'cons))
@@ -515,13 +515,13 @@
((csubtypep type (specifier-type 'null))
(setf min 0))
(t
- (return '*))))))
+ (return))))))
(process-dim (dim)
(if (typep dim '(cons integer null))
(let ((length (car dim)))
(setf max (max max length)
min (min min length)))
- (return '*))))
+ (return))))
;; If type derivation were able to notice that non-simple arrays can
;; be mutated (changing the type), we could safely use LVAR-TYPE on
;; any vector type. But it doesn't notice.
diff --git a/src/compiler/loongarch64/c-call.lisp b/src/compiler/loongarch64/c-call.lisp
index eec1a40d1..2fce19545 100644
--- a/src/compiler/loongarch64/c-call.lisp
+++ b/src/compiler/loongarch64/c-call.lisp
@@ -343,7 +343,7 @@
(defoptimizer (sign-extend derive-type) ((x size))
(when (sb-c:constant-lvar-p size)
- (specifier-type `(signed-byte ,(sb-c:lvar-value size)))))
+ (make-numeric-type 'signed-byte (sb-c:lvar-value size))))
(define-vop (sign-extend)
(:translate sign-extend)
diff --git a/src/compiler/modarith.lisp b/src/compiler/modarith.lisp
index ac5df950b..e7be97e61 100644
--- a/src/compiler/modarith.lisp
+++ b/src/compiler/modarith.lisp
@@ -797,7 +797,7 @@
',name)
#+(or arm64 x86-64)
((not (word-sized-type-p integer-type))
- (cond ((csubtypep count-type (specifier-type `(integer ,(- result-width width) ,most-positive-fixnum)))
+ (cond ((csubtypep count-type (make-numeric-type 'integer (- result-width width) most-positive-fixnum))
;; Uses the bits from the first word when shifting right
(cut-to-width integer ,kind width ,signedp)
',name)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 10d6ab51e..7b9e984c3 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1457,7 +1457,7 @@
(> high high2))
(setf high high2))))
(when (or low high)
- (let ((type (make-numeric-type :class 'integer :high high :low low)))
+ (let ((type (make-numeric-type 'integer low high)))
(if (and equality length1 length2
(/= length1 length2))
(if (eq equality '%sp-string-compare)
@@ -2257,9 +2257,8 @@
1))
(t
min1))))
- (specifier-type `(or (integer ,min-result
- ,(- max-result min-sequence1-length))
- null))))
+ (type-union (make-numeric-type 'integer min-result (- max-result min-sequence1-length))
+ (specifier-type 'null))))
(defun index-into-sequence-derive-type (sequence start end &key (inclusive t))
(let* ((int-s (and start
@@ -2287,7 +2286,8 @@
(declare (ignorable sequence2))
;; Could be as smart as the SEARCH one above but I ran out of steam.
(multiple-value-bind (min max) (index-into-sequence-derive-type sequence1 start1 end1)
- (specifier-type `(or (integer ,min ,max) null))))
+ (type-union (make-numeric-type 'integer min max)
+ (specifier-type 'null))))
(defun position-derive-type (item sequence start end key test test-not)
(if (eq (lvar-type sequence) (specifier-type 'null))
@@ -2295,7 +2295,7 @@
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end :inclusive nil)
(when (>= max min)
- (let ((integer-range `(integer ,min ,max))
+ (let ((integer-range (make-numeric-type 'integer min max))
(definitely-foundp nil))
;; Figure out whether this call will not return NIL.
;; This could be smarter about the keywords args, but the primary intent
@@ -2318,9 +2318,9 @@
(setq definitely-foundp nil)
(return)))
item-type))))))
- (specifier-type (if definitely-foundp
- integer-range
- `(or ,integer-range null))))))))
+ (if definitely-foundp
+ integer-range
+ (type-union integer-range (specifier-type 'null))))))))
(defun equal-type (type)
(let ((result type))
@@ -2421,7 +2421,8 @@
(declare (ignore function))
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end :inclusive nil)
- (specifier-type `(or (integer ,min ,max) null))))
+ (type-union (make-numeric-type 'integer min max)
+ (specifier-type 'null))))
(defoptimizer (position-if-not derive-type) ((function sequence
&key start end
@@ -2429,7 +2430,8 @@
(declare (ignore function))
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end :inclusive nil)
- (specifier-type `(or (integer ,min ,max) null))))
+ (type-union (make-numeric-type 'integer min max)
+ (specifier-type 'null))))
(defoptimizer (%find-position derive-type) ((item sequence from-end start end key test))
(let ((find (find-derive-type item sequence key test start end from-end))
@@ -2458,7 +2460,7 @@
(declare (ignore item))
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end)
- (specifier-type `(integer 0 ,(- max min)))))
+ (make-numeric-type 'integer 0 (- max min))))
(defoptimizer (count-if derive-type) ((function sequence
&key start end
@@ -2466,7 +2468,7 @@
(declare (ignore function))
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end)
- (specifier-type `(integer 0 ,(- max min)))))
+ (make-numeric-type 'integer 0 (- max min))))
(defoptimizer (count-if-not derive-type) ((function sequence
&key start end
@@ -2474,14 +2476,15 @@
(declare (ignore function))
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end)
- (specifier-type `(integer 0 ,(- max min)))))
+ (make-numeric-type 'integer 0 (- max min))))
(defoptimizer (sb-impl::length-remove-duplicates derive-type) ((sequence &key &allow-other-keys))
(multiple-value-bind (max min) (sequence-lvar-dimensions sequence)
- (specifier-type `(integer ,(if min
- (min 1 min)
- 0)
- ,(or max '*)))))
+ (make-numeric-type 'integer
+ (if min
+ (min 1 min)
+ 0)
+ max)))
(defoptimizer (subseq derive-type) ((sequence start &optional end) node)
(let* ((sequence-type (lvar-type sequence))
@@ -4214,7 +4217,7 @@
(defoptimizer (read-sequence derive-type) ((sequence stream &key start end))
(multiple-value-bind (min max)
(index-into-sequence-derive-type sequence start end)
- (specifier-type `(integer ,min ,max))))
+ (make-numeric-type 'integer min max)))
(defoptimizers constants
(hairy-data-vector-ref hairy-data-vector-ref/check-bounds
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 1af378318..fceec29fa 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1718,6 +1718,12 @@
(and (numberp low)
(eql low high)
low)))
+
+(defun interval-to-type (interval type &optional (normalize-zeros t))
+ (multiple-value-bind (low high) (and interval
+ (values (interval-low interval)
+ (interval-high interval)))
+ (make-numeric-type type low high normalize-zeros)))
;;;; numeric DERIVE-TYPE methods
@@ -1733,10 +1739,7 @@
(eq (numeric-type-complexp x) :real)
(eq (numeric-type-complexp y) :real))
(multiple-value-bind (low high) (funcall fun x y)
- (make-numeric-type :class 'integer
- :complexp :real
- :low low
- :high high))
+ (make-numeric-type 'integer low high))
(numeric-contagion x y)))
(defun derive-integer-type (x y fun)
@@ -1965,7 +1968,7 @@
(coerce-for-bound x (or (numeric-type-format result-type)
'float)))
result)))
- (let ((numeric (make-numeric-type
+ (let ((numeric (make-numeric-union-type
:class (if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
;; The sum of integers is always an integer.
@@ -2018,7 +2021,7 @@
'float)))
result)))
(let ((numeric
- (make-numeric-type
+ (make-numeric-union-type
:class (if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
;; The difference of integers is always an integer.
@@ -2065,7 +2068,7 @@
'float)))
result)))
(let ((numeric
- (make-numeric-type
+ (make-numeric-union-type
:class (if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
;; The product of integers is always an integer.
@@ -2122,10 +2125,9 @@
(low (numeric-type-low type))
(high (numeric-type-high type)))
(when (and low high)
- (make-numeric-type :class 'integer
- :low
+ (make-numeric-type 'integer
(ash low (- sb-vm:n-word-bits))
- :high (ash high (- sb-vm:n-word-bits))))))))
+ (ash high (- sb-vm:n-word-bits))))))))
(defoptimizer (%multiply-high derive-type) ((x y) node)
(%signed-multiply-high-derive-type-optimizer node))
@@ -2158,16 +2160,16 @@
(cond ((null result)
*empty-type*)
((consp result)
- (type-union (make-numeric-type :class (numeric-type-class result-type)
- :format (numeric-type-format result-type)
- :low (interval-low (first result))
- :high (interval-high (first result))
- :normalize-zeros nil)
- (make-numeric-type :class (numeric-type-class result-type)
- :format (numeric-type-format result-type)
- :low (interval-low (second result))
- :high (interval-high (second result))
- :normalize-zeros nil)))
+ (type-union (make-numeric-union-type :class (numeric-type-class result-type)
+ :format (numeric-type-format result-type)
+ :low (interval-low (first result))
+ :high (interval-high (first result))
+ :normalize-zeros nil)
+ (make-numeric-union-type :class (numeric-type-class result-type)
+ :format (numeric-type-format result-type)
+ :low (interval-low (second result))
+ :high (interval-high (second result))
+ :normalize-zeros nil)))
(t
;; If the result type is a float, we need to be sure to coerce
;; the bounds into the correct type.
@@ -2177,11 +2179,11 @@
(coerce-for-bound x (or (numeric-type-format result-type)
'float)))
result)))
- (let ((numeric (make-numeric-type :class (numeric-type-class result-type)
- :format (numeric-type-format result-type)
- :low (interval-low result)
- :high (interval-high result)
- :normalize-zeros nil)))
+ (let ((numeric (make-numeric-union-type :class (numeric-type-class result-type)
+ :format (numeric-type-format result-type)
+ :low (interval-low result)
+ :high (interval-high result)
+ :normalize-zeros nil)))
(if (and y-integerp
(interval-ratio-p x-interval))
(type-intersection numeric (specifier-type 'ratio))
@@ -2218,15 +2220,15 @@
(s-low (numeric-type-low shift))
(s-high (numeric-type-high shift)))
(flet ((make (n-low n-high s-low s-high)
- (make-numeric-type :class 'integer
- :low (when n-low
- (if (minusp n-low)
- (ash-outer n-low s-high)
- (ash-inner n-low s-low)))
- :high (when n-high
- (if (minusp n-high)
- (ash-inner n-high s-low)
- (ash-outer n-high s-high))))))
+ (make-numeric-type 'integer
+ (when n-low
+ (if (minusp n-low)
+ (ash-outer n-low s-high)
+ (ash-inner n-low s-low)))
+ (when n-high
+ (if (minusp n-high)
+ (ash-inner n-high s-low)
+ (ash-outer n-high s-high))))))
(cond ((eql n-low 0)
(type-union (specifier-type '(eql 0))
(make (1+ n-low) n-high s-low s-high)))
@@ -2313,12 +2315,9 @@
((integer rational) 'single-float)
(t (numeric-type-format type))))
(bound-format (or format 'float)))
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce 0 bound-format)
- :high nil
- :normalize-zeros nil)))
+ (make-numeric-type format
+ (coerce 0 bound-format) nil
+ nil)))
(t
;; The absolute value of a real number is a non-negative real
;; of the same type.
@@ -2328,12 +2327,11 @@
(bound-type (or format class 'real))
(low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type))
(high (coerce-and-truncate-floats (interval-high abs-bnd) bound-type)))
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low low
- :high high
- :normalize-zeros nil)))))
+ (make-numeric-union-type :class class
+ :format format
+ :low low
+ :high high
+ :normalize-zeros nil)))))
(defoptimizer (abs derive-type) ((num))
(one-arg-derive-type num #'abs-derive-type-aux))
@@ -2422,10 +2420,9 @@
(let ((div (interval-div number-interval divisor-interval t)))
(flet ((make-quot (div)
(let ((quot (truncate-quotient-bound div)))
- (make-numeric-type :class 'integer
- :low (interval-low quot)
- :high (interval-high quot)
- :normalize-zeros nil))))
+ (make-numeric-type 'integer
+ (interval-low quot)
+ (interval-high quot)))))
(cond ((null div)
*empty-type*)
((listp div)
@@ -2448,13 +2445,11 @@
(quot (if float
(ftruncate-quotient-bound quot number-interval divisor-interval)
(truncate-quotient-bound quot))))
- (make-numeric-type :class (if float
- 'float
- 'rational)
- :format float
- :low (interval-low quot)
- :high (interval-high quot)
- :normalize-zeros nil)))))))
+ (make-numeric-type (or float
+ 'integer)
+ (interval-low quot)
+ (interval-high quot)
+ nil)))))))
(defun truncate-derive-type-rem (number-type divisor-type)
(let* ((rem-type (rem-result-type number-type divisor-type))
@@ -2469,37 +2464,22 @@
((eq rem-type 'integer)
;; Since the remainder type is INTEGER, both args are
;; INTEGERs.
- (specifier-type `(,rem-type ,(or (interval-low rem) '*)
- ,(or (interval-high rem) '*))))
+ (make-numeric-type 'integer (interval-low rem) (interval-high rem)))
(t
- (multiple-value-bind (class format)
- (ecase rem-type
- (rational
- (values 'rational nil))
- ((single-float double-float #+long-float long-float)
- (values 'float rem-type))
- (float
- (values 'float nil))
- (real
- (values nil nil)))
- (when (member rem-type '(float single-float double-float
- #+long-float long-float))
- (setf rem (interval-func #'(lambda (x)
- (coerce-for-bound x rem-type))
- rem)))
- ;; KLUDGE: the interval arithmetic doesn't handle -0.0 well
- (let ((low (interval-low rem))
- (high (interval-high rem)))
- (when (and (or (eql high -0f0)
- (eql high -0d0))
- (or (eql low 0f0)
- (eql low 0d0)))
- (rotatef low high))
- (make-numeric-type :class class
- :format format
- :low low
- :high high
- :normalize-zeros nil)))))))
+ (when (member rem-type '(float single-float double-float
+ #+long-float long-float))
+ (setf rem (interval-func #'(lambda (x)
+ (coerce-for-bound x rem-type))
+ rem)))
+ ;; KLUDGE: the interval arithmetic doesn't handle -0.0 well
+ (let ((low (interval-low rem))
+ (high (interval-high rem)))
+ (when (and (or (eql high -0f0)
+ (eql high -0d0))
+ (or (eql low 0f0)
+ (eql low 0d0)))
+ (rotatef low high))
+ (make-numeric-type rem-type low high nil))))))
(defun truncate-derive-type-quot-aux (num div same-arg)
(declare (ignore same-arg))
@@ -2643,13 +2623,11 @@
(when (numeric-type-p type)
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
- (specifier-type (list ',type
- (if lo
- (,fun (type-bound-number lo))
- '*)
- (if hi
- (,fun (type-bound-number hi))
- '*))))))))))))
+ (make-numeric-type ',type
+ (and lo
+ (,fun (type-bound-number lo)))
+ (and hi
+ (,fun (type-bound-number hi)))))))))))))
(defoptimizer (round-single derive-type) ((number mode))
(derive single-float))
(defoptimizer (round-double derive-type) ((number mode))
@@ -2668,13 +2646,9 @@
(setf low (car low)))
(when (consp high)
(setf high (car high)))
- (specifier-type
- `(integer ,(if low
- (round low)
- '*)
- ,(if high
- (round high)
- '*))))))))
+ (make-numeric-type 'integer
+ (and low (round low))
+ (and high (round high))))))))
;;; Define optimizers for FLOOR and CEILING.
(macrolet
@@ -2693,13 +2667,10 @@
(let ((quot (if float
(,(symbolicate "F" q-name) div number-interval divisor-interval)
(,q-name div))))
- (make-numeric-type :class (if float
- 'float
- 'rational)
- :format float
- :low (interval-low quot)
- :high (interval-high quot)
- :normalize-zeros nil))))
+ (make-numeric-type (or float 'integer)
+ (interval-low quot)
+ (interval-high quot)
+ nil))))
(cond ((null div)
*empty-type*)
((listp div)
@@ -2721,29 +2692,15 @@
(numeric-type->interval number-type))
(rem (,r-name number-interval divisor-interval))
(result-type (rem-result-type number-type divisor-type)))
- (multiple-value-bind (class format)
- (ecase result-type
- (integer
- (values 'integer nil))
- (rational
- (values 'rational nil))
- ((single-float double-float #+long-float long-float)
- (values 'float result-type))
- (float
- (values 'float nil))
- (real
- (values nil nil)))
- (when (member result-type '(float single-float double-float
- #+long-float long-float))
- ;; Make sure that the limits on the interval have
- ;; the right type.
- (setf rem (interval-func (lambda (x)
- (coerce-for-bound x result-type))
- rem)))
- (make-numeric-type :class class
- :format format
- :low (interval-low rem)
- :high (interval-high rem))))
+ (when (member result-type '(float single-float double-float
+ #+long-float long-float))
+ ;; Make sure that the limits on the interval have
+ ;; the right type.
+ (setf rem (interval-func (lambda (x)
+ (coerce-for-bound x result-type))
+ rem)))
+ (make-numeric-type result-type
+ (interval-low rem) (interval-high rem)))
(numeric-contagion number-type divisor-type)))
;; the optimizer itself
(defoptimizer (,name derive-type) ((number divisor))
@@ -3155,14 +3112,14 @@
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
(format (numeric-type-format type)))
- (make-numeric-type
- :class class
- :format format
- :low (coerce 0 (or format class 'real))
- :high (cond ((not high) nil)
- ((eq class 'integer) (max (1- high) 0))
- ((or (consp high) (zerop high)) high)
- (t `(,high))))))
+ (make-numeric-union-type
+ :class class
+ :format format
+ :low (coerce 0 (or format class 'real))
+ :high (cond ((not high) nil)
+ ((eq class 'integer) (max (1- high) 0))
+ ((or (consp high) (zerop high)) high)
+ (t `(,high))))))
(defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux))
@@ -3186,16 +3143,17 @@
(let ((lo (numeric-type-low x-type))
(hi (numeric-type-high x-type)))
(cond ((and lo hi)
- (specifier-type `(integer ,(if (<= lo 0 hi)
- 0
- (min-il lo hi))
- ,(max-il lo hi))))
+ (make-numeric-type 'integer
+ (if (<= lo 0 hi)
+ 0
+ (min-il lo hi))
+ (max-il lo hi)))
(lo
(when (> lo 0)
- (specifier-type `(integer ,(integer-length lo)))))
+ (make-numeric-type 'integer (integer-length lo))))
(hi
(when (< hi 0)
- (specifier-type `(integer ,(integer-length hi)))))))))))
+ (make-numeric-type 'integer (integer-length hi))))))))))
;; (integer-length (ldb (byte 64 0) (lognor n (- n)))) => ctz
(when-vop-existsp (:translate count-trailing-zeros)
@@ -3227,13 +3185,13 @@
(hi (%bignum-length hi)))
(when (> lo hi)
(rotatef lo hi))
- (specifier-type `(integer ,lo ,hi))))
+ (make-numeric-type 'integer lo hi)))
(lo
(when (> lo 0)
- (specifier-type `(integer ,(%bignum-length lo)))))
+ (make-numeric-type 'integer (%bignum-length lo))))
(hi
(when (< hi 0)
- (specifier-type `(integer ,(%bignum-length hi))))))))))
+ (make-numeric-type 'integer (%bignum-length hi)))))))))
(defoptimizer (logcount derive-type) ((x))
(one-arg-derive-type
@@ -3243,8 +3201,7 @@
(hi (numeric-type-high x-type)))
(cond ((and lo hi)
(let ((adjust 0))
- (make-numeric-type :class 'integer
- :low
+ (make-numeric-type 'integer
(cond ((<= lo 0 hi)
0)
((progn
@@ -3267,7 +3224,6 @@
0)
(t
1))
- :high
(let ((l (max (integer-length lo)
(integer-length hi))))
(+ adjust
@@ -3279,10 +3235,10 @@
-1))))))
(lo
(when (> lo 0)
- (specifier-type `(integer 1))))
+ (specifier-type '(integer 1))))
(hi
(when (< hi -1)
- (specifier-type `(integer 1)))))))))
+ (specifier-type '(integer 1)))))))))
(defoptimizer (isqrt derive-type) ((x))
(one-arg-derive-type
@@ -3294,9 +3250,8 @@
(isqrt lo)
0))
(hi-res (if (typep hi 'unsigned-byte)
- (isqrt hi)
- '*)))
- (specifier-type `(integer ,lo-res ,hi-res))))))
+ (isqrt hi))))
+ (make-numeric-type 'integer lo-res hi-res)))))
(defoptimizer (char-code derive-type) ((char))
(let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
@@ -3314,10 +3269,10 @@
collect `(integer ,low ,high)))))
((csubtypep type (specifier-type 'base-char))
(specifier-type
- `(mod ,base-char-code-limit)))
+ (make-numeric-type 'mod base-char-code-limit)))
(t
(specifier-type
- `(mod ,char-code-limit))))))
+ (make-numeric-type 'mod char-code-limit))))))
(defoptimizer (code-char derive-type) ((code))
(one-arg-derive-type code
@@ -3360,7 +3315,9 @@
(if radix
(let ((max (type-approximate-interval (lvar-type radix))))
(when (interval-high max)
- (specifier-type `(or null (mod ,(interval-high max))))))
+ (type-union
+ (specifier-type 'null)
+ (make-numeric-type 'mod (interval-high max)))))
(specifier-type '(or null (mod 10)))))
(defoptimizer (values derive-type) ((&rest values))
@@ -3398,9 +3355,9 @@
(let* ((format (case (numeric-type-class type)
((integer rational) 'single-float)
(t (numeric-type-format type)))))
- (make-numeric-type :class 'float
- :format format
- :complexp :complex)))
+ (make-numeric-union-type :class 'float
+ :format format
+ :complexp :complex)))
(t
(let* ((interval (numeric-type->interval type))
(range-info (interval-range-info interval))
@@ -3410,12 +3367,12 @@
(one (coerce 1 (or format class 'real)))
(zero (coerce 0 (or format class 'real)))
(minus-one (coerce -1 (or format class 'real)))
- (plus (make-numeric-type :class class :format format
- :low one :high one))
- (minus (make-numeric-type :class class :format format
- :low minus-one :high minus-one))
- (zero (make-numeric-type :class class :format format
- :low zero :high zero)))
+ (plus (make-numeric-union-type :class class :format format
+ :low one :high one))
+ (minus (make-numeric-union-type :class class :format format
+ :low minus-one :high minus-one))
+ (zero (make-numeric-union-type :class class :format format
+ :low zero :high zero)))
(let ((result
(case range-info
(+ (if contains-0-p (type-union plus zero) plus))
@@ -3493,10 +3450,7 @@
(if (and minuend
(<= (interval-high minuend)
+left-shift-derive-type-cutoff+))
- (type-intersection (make-numeric-type :class 'integer
- :low 0
- :high
- (1- (ash 1 (interval-high minuend))))
+ (type-intersection (make-numeric-type 'unsigned-byte (interval-high minuend))
(or computed *universal-type*))
computed)))
@@ -3505,7 +3459,7 @@
(posn-high (nth-value 1 (integer-type-numeric-bounds (lvar-type posn)))))
(if (and size-high posn-high
(<= (+ size-high posn-high) sb-vm:n-word-bits))
- (specifier-type `(unsigned-byte* ,(+ size-high posn-high)))
+ (make-numeric-type 'unsigned-byte (+ size-high posn-high))
(specifier-type 'unsigned-byte))))
(defun related-byte-spec (size posn)
@@ -3568,9 +3522,8 @@
(size-interval (type-approximate-interval (lvar-type size))))
(when (and posn-minuend-interval
size-interval)
- (type-intersection (make-numeric-type :class 'integer
- :low 0
- :high
+ (type-intersection (make-numeric-type 'integer
+ 0
(max (interval-high int-interval)
(1- (ash 1 (interval-high posn-minuend-interval)))))
(or computed *universal-type*)))))
@@ -3664,7 +3617,8 @@
(cut (ldb (byte size 0) new)))
(cond ((/= new cut)
`(%dpb ,cut ,size posn int))
- ((not (csubtypep (lvar-type posn) (specifier-type `(integer 0 (,(- sb-vm:n-fixnum-bits size))))))
+ ((not (csubtypep (lvar-type posn)
+ (make-numeric-type 'mod (- sb-vm:n-fixnum-bits size))))
(give-up-ir1-transform))
((= (logcount new) size)
;; Move the cast after the ash for cast-externally-checkable-p to work.
@@ -3708,7 +3662,7 @@
(if (numeric-type-p size)
(let ((size-high (numeric-type-high size)))
(if (and size-high (<= 1 size-high sb-vm:n-word-bits))
- (specifier-type `(signed-byte ,size-high))
+ (make-numeric-type 'signed-byte size-high)
*universal-type*))
*universal-type*)))
@@ -3789,15 +3743,15 @@
(n-high (numeric-type-high n-type))
(s-low (numeric-type-low shift))
(s-high (numeric-type-high shift)))
- (make-numeric-type :class 'integer :complexp :real
- :low (when n-low
- (if (minusp n-low)
- (ash n-low (- s-low))
- (ash n-low (- s-high))))
- :high (when n-high
- (if (minusp n-high)
- (ash n-high (- s-high))
- (ash n-high (- s-low)))))))
+ (make-numeric-type 'integer
+ (when n-low
+ (if (minusp n-low)
+ (ash n-low (- s-low))
+ (ash n-low (- s-high))))
+ (when n-high
+ (if (minusp n-high)
+ (ash n-high (- s-high))
+ (ash n-high (- s-low)))))))
*universal-type*))
(defoptimizer (%ash/right derive-type) ((n shift))
@@ -4120,9 +4074,8 @@
(1- (integer-length m))))))
(when (and shift
(<= shift sb-vm:n-word-bits)
- (csubtypep (lvar-type b) (make-numeric-type :class 'integer
- :low 0
- :high (1- (ash 1 shift)))))
+ (csubtypep (lvar-type b)
+ (make-numeric-type 'unsigned-byte shift)))
(delay-ir1-transform node :ir1-phases)
(splice-fun-args a name #'first)
`(lambda ,ll
@@ -4730,19 +4683,19 @@
(lvar-single-value-p result)
(csubtypep (single-value-type (node-derived-type node)) (specifier-type 'word))
(not (csubtypep (lvar-type x)
- (make-numeric-type :class 'integer :low 0 :high (- sb-ext:most-positive-word delta)))))
+ (make-numeric-type 'integer 0 (- sb-ext:most-positive-word delta)))))
;; Avoid overflowing word-sized arithmetic
`(if (= x 0)
(values 0 0)
(values (1+ (ash (1- x) ,shift)) 0)))
((or (and (csubtypep (lvar-type x) (specifier-type 'sb-vm:signed-word))
(not (csubtypep (lvar-type x)
- (make-numeric-type :class 'integer
- :low (- (expt 2 (1- sb-vm:n-word-bits)))
- :high (- (1- (expt 2 (1- sb-vm:n-word-bits))) delta)))))
+ (make-numeric-type 'integer
+ (- (expt 2 (1- sb-vm:n-word-bits)))
+ (- (1- (expt 2 (1- sb-vm:n-word-bits))) delta)))))
(and (csubtypep (lvar-type x) (specifier-type 'word))
(not (csubtypep (lvar-type x)
- (make-numeric-type :class 'integer :low 0 :high (- sb-ext:most-positive-word delta))))))
+ (make-numeric-type 'integer 0 (- sb-ext:most-positive-word delta))))))
;; Transforming to truncate is better
(give-up-ir1-transform))
(t
@@ -5315,10 +5268,10 @@
(deftransform logand ((x y) (t (constant-arg integer)) *)
"fold identity operation"
(let* ((y (lvar-value y))
- (width (or (least-zero-bit y) '*)))
+ (width (least-zero-bit y)))
(unless (and (neq width 0) ; (logand x 0) handled elsewhere
(csubtypep (lvar-type x)
- (specifier-type `(unsigned-byte ,width))))
+ (make-numeric-type 'unsigned-byte width)))
(give-up-ir1-transform))
'x))
@@ -5342,7 +5295,7 @@
"fold identity operation"
(let ((size (lvar-value size)))
(cond ((= size 0) 0)
- ((csubtypep (lvar-type x) (specifier-type `(signed-byte ,size)))
+ ((csubtypep (lvar-type x) (make-numeric-type 'signed-byte size))
'x)
(t
(give-up-ir1-transform)))))
@@ -5353,7 +5306,7 @@
(width (or (least-zero-bit (lognot y))
(give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
(unless (csubtypep (lvar-type x)
- (specifier-type `(integer ,(- (ash 1 width)) -1)))
+ (make-numeric-type 'integer (- (ash 1 width)) -1))
(give-up-ir1-transform))
'x))
@@ -5775,7 +5728,7 @@
(size (integer-length constant)))
(when (and (= (logcount constant) 1)
(<= size sb-vm:n-word-bits)
- (csubtypep (lvar-type a) (specifier-type `(unsigned-byte ,size)))
+ (csubtypep (lvar-type a) (make-numeric-type 'unsigned-byte size))
(same-leaf-ref-p a a2))
`(mask-signed-field ,size ,a-var)))))))))))))
(or (transform a b 'a)
@@ -8110,18 +8063,18 @@
(t
(setf min low
max high)))))
- (specifier-type (cond ((not primes)
- `(integer ,(if includes-zero
- 0
- 1)
- ,(if unbounded
- '*
- (max (abs min)
- (abs max)))))
- ((cdr primes)
- '(eql 1))
- (t
- `(or (eql 1) (eql ,(car primes))))))))
+ (cond ((not primes)
+ (make-numeric-type 'integer (if includes-zero
+ 0
+ 1)
+ (unless unbounded
+ (max (abs min)
+ (abs max)))))
+ ((cdr primes)
+ (specifier-type '(eql 1)))
+ (t
+ (type-union (specifier-type '(eql 1))
+ (make-numeric-type 'eql (car primes)))))))
(defoptimizer (gcd derive-type) ((&rest args))
(derive-gcd args))
@@ -8147,7 +8100,7 @@
(setf min (min min low))
(setf min low))
(push high maxes))))
- (specifier-type `(integer ,min ,(reduce #'* maxes)))))
+ (make-numeric-type 'integer min (reduce #'* maxes))))
;;; Do source transformations for intransitive n-arg functions such as
;;; /. With one arg, we form the inverse. With two args we pass.
@@ -8260,9 +8213,9 @@
(null nil)
(t (%%rational bound)))))
(make-numeric-type
- :class 'rational
- :low (%rational (numeric-type-low type))
- :high (%rational (numeric-type-high type)))))))
+ 'rational
+ (%rational (numeric-type-low type))
+ (%rational (numeric-type-high type)))))))
(defoptimizer (rationalize derive-type) ((x))
(one-arg-derive-type x (lambda (type)
@@ -8276,9 +8229,9 @@
(null nil)
(t (%%rationalize bound)))))
(make-numeric-type
- :class 'rational
- :low (%rationalize (numeric-type-low type))
- :high (%rationalize (numeric-type-high type)))))))
+ 'rational
+ (%rationalize (numeric-type-low type))
+ (%rationalize (numeric-type-high type)))))))
;;;; transforming APPLY
@@ -9804,7 +9757,7 @@
(let* ((type (lvar-type x))
(l (+ (lvar-value l) ,ld))
(h (+ (lvar-value h) ,hd))
- (range-type (specifier-type `(integer ,l ,h)))
+ (range-type (make-numeric-type 'integer l h))
(intersect (type-intersection type (specifier-type 'fixnum))))
(cond ((eq intersect *empty-type*)
nil)
@@ -9826,7 +9779,7 @@
(let* ((type (lvar-type x))
(l (+ (lvar-value l) ,ld))
(h (+ (lvar-value h) ,hd))
- (range-type (specifier-type `(integer ,l ,h)))
+ (range-type (make-numeric-type 'integer l h))
(unsigned-type (type-intersection type (specifier-type 'unsigned-byte)))
(diff (type-difference type range-type)))
(cond ((> l h)
@@ -9853,8 +9806,8 @@
(defoptimizer (check-range<= constraint-propagate-if) ((l x h))
(let ((l-int (type-approximate-interval (lvar-type l)))
(h-int (type-approximate-interval (lvar-type h))))
- (values x (specifier-type `(integer ,(interval-low l-int)
- ,(interval-high h-int)))))))
+ (values x
+ (make-numeric-type 'integer (interval-low l-int) (interval-high h-int))))))
(defun find-or-chains (node op)
(let ((chains (make-array 1 :adjustable t :fill-pointer 1 :initial-element nil)))
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index b198c1f35..4f1892c98 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -2006,7 +2006,7 @@
(when-vop-existsp (:translate unsigned-byte-x-p)
(deftransform unsigned-byte-x-p
((object x) (t t) * :important nil :node node)
- (ir1-transform-type-predicate object (specifier-type `(unsigned-byte ,(lvar-value x))) node)))
+ (ir1-transform-type-predicate object (make-numeric-type 'unsigned-byte (lvar-value x)) node)))
(deftransform %other-pointer-p ((object))
(let ((type (lvar-type object)))
diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 12eae5b25..e3cd30964 100644
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -957,12 +957,11 @@
(base-hi (numeric-type-high base-type))
(index-lo (numeric-type-low index-type))
(index-hi (numeric-type-high index-type)))
- (make-numeric-type :class 'integer
- :complexp :real
- :low (when (and base-lo index-lo)
- (+ base-lo (* index-lo scale) disp))
- :high (when (and base-hi index-hi)
- (+ base-hi (* index-hi scale) disp))))))))
+ (make-numeric-type 'integer
+ (when (and base-lo index-lo)
+ (+ base-lo (* index-lo scale) disp))
+ (when (and base-hi index-hi)
+ (+ base-hi (* index-hi scale) disp))))))))
(defun %lea (base index scale disp)
(+ base (* index scale) disp))
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index a558bd962..15da6bbd4 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -590,7 +590,7 @@
sb-kernel:type=
sb-kernel:type/=
sb-kernel:find-classoid
- sb-kernel:make-numeric-type
+ sb-kernel:make-numeric-union-type
sb-kernel:types-equal-or-intersect
sb-kernel:*empty-type*))
@@ -671,40 +671,40 @@
(assert (eq (sb-int:info :type :kind s) :primitive))
(assert (eq (sb-int:info :type :kind s) :instance)))))))
-(with-test (:name (make-numeric-type :smoke))
- (assert (eq (make-numeric-type :class 'integer :low '(4) :high '(5))
+(with-test (:name (make-numeric-union-type :smoke))
+ (assert (eq (make-numeric-union-type :class 'integer :low '(4) :high '(5))
*empty-type*)))
-(with-test (:name (make-numeric-type :union))
- (assert (equal (type-specifier (make-numeric-type :low '(-79106810381456307)))
+(with-test (:name (make-numeric-union-type :union))
+ (assert (equal (type-specifier (make-numeric-union-type :low '(-79106810381456307)))
`(or (rational (-79106810381456307))
(single-float (-7.910681e16))
(double-float (-7.91068103814563d16))))))
-(with-test (:name (make-numeric-type :infinities))
+(with-test (:name (make-numeric-union-type :infinities))
;; Without class
(assert (equal (type-specifier
- (make-numeric-type :low sb-ext:single-float-negative-infinity
- :high sb-ext:single-float-negative-infinity))
+ (make-numeric-union-type :low sb-ext:single-float-negative-infinity
+ :high sb-ext:single-float-negative-infinity))
`(or (single-float ,sb-ext:single-float-negative-infinity
,sb-ext:single-float-negative-infinity)
(double-float ,sb-ext:double-float-negative-infinity
,sb-ext:double-float-negative-infinity))))
(assert (equal (type-specifier
- (make-numeric-type :low sb-ext:single-float-negative-infinity))
+ (make-numeric-union-type :low sb-ext:single-float-negative-infinity))
'real))
;; With FLOAT class
(assert (equal (type-specifier
- (make-numeric-type :class 'float
- :low sb-ext:single-float-negative-infinity
- :high sb-ext:single-float-negative-infinity))
+ (make-numeric-union-type :class 'float
+ :low sb-ext:single-float-negative-infinity
+ :high sb-ext:single-float-negative-infinity))
`(or (single-float ,sb-ext:single-float-negative-infinity
,sb-ext:single-float-negative-infinity)
(double-float ,sb-ext:double-float-negative-infinity
,sb-ext:double-float-negative-infinity))))
(assert (equal (type-specifier
- (make-numeric-type :class 'float
- :low sb-ext:single-float-negative-infinity))
+ (make-numeric-union-type :class 'float
+ :low sb-ext:single-float-negative-infinity))
`float)))
(with-test (:name :prettier-union-types :skipped-on (not :sb-unicode))
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index f5376b4cb..5651ee9cd 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1691,5 +1691,20 @@
(#(359CB801 4D28C61A 53351B33 A2DD0906 B9B79FF6)
"(FUNCTION SB-IMPL::PREDICATE SB-IMPL::KEY SB-IMPL::TEST SB-IMPL::TEST-NOT)"
"((& (^ (>> val 3) (>> val 6)) 7))")
+(#(0 2BCE7F62 4A8C210D 56B428A2 80D0C591 9BAC0C5C A8892768 AC841474 E48D4754)
+ "(EQL COMPLEX REAL NIL DOUBLE-FLOAT SINGLE-FLOAT MOD SIGNED-BYTE UNSIGNED-BYTE)"
+ "((let ((tab #a((8) (unsigned-byte 8) 3 12 0 0 0 2 0 0)))
+ (let ((b (& val #x7)))
+ (let ((a (>> val 29)))
+ (^ a (aref tab b))))))")
+(#(235ED22C 72E2CBDA 75E7305A 80D0C591 AC841474)
+ "(DOUBLE-FLOAT SINGLE-FLOAT FLOAT RATIONAL INTEGER)"
+ "((& (+ (>> val 1) (>> val 23)) 7))")
+(#(0 235ED22C 2BCE7F62 4A8C210D 56B428A2 72E2CBDA 75E7305A 80D0C591 9BAC0C5C A8892768 AC841474 E48D4754)
+ "(RATIONAL INTEGER EQL FLOAT COMPLEX REAL NIL DOUBLE-FLOAT SINGLE-FLOAT MOD SIGNED-BYTE UNSIGNED-BYTE)"
+ "((let ((tab #a((8) (unsigned-byte 8) 8 8 0 2 0 15 5 0)))
+ (let ((b (& (>> val 5) #x7)))
+ (let ((a (>> (<< val 5) 29)))
+ (^ a (aref tab b))))))")
)
;; EOF
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL