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

Remove the member-fun from two-arg-derive-type.

Browse source 
Float zeros are no longer hiding in member types.
This commit is contained in:
Stas Boukarev 2025-09-12 00:43:03 +03:00
parent 8c81d9c770
commit 528fdf09a1
4 changed files with 103 additions and 204 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
src/compiler/bitops-derive-type.lisp
View file

@ -369,12 +369,12 @@
(macrolet ((deffrob (logfun) (macrolet ((deffrob (logfun)
(let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX"))) (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
`(defoptimizer (,logfun derive-type) ((x y)) `(defoptimizer (,logfun derive-type) ((x y))
(two-arg-derive-type x y #',fun-aux #',logfun))))) (two-arg-derive-type x y #',fun-aux)))))
(deffrob logand) (deffrob logand)
(deffrob logior)) (deffrob logior))
(defoptimizer (logxor derive-type) ((x y)) (defoptimizer (logxor derive-type) ((x y))
(let ((type (two-arg-derive-type x y #'logxor-derive-type-aux #'logxor))) (let ((type (two-arg-derive-type x y #'logxor-derive-type-aux)))
(flet ((try (x y) (flet ((try (x y)
;; If it's (logxor x (1- x)) then it will be a positive number, ;; If it's (logxor x (1- x)) then it will be a positive number,
;; except for 0 => -1. This is used to count unset bits. ;; except for 0 => -1. This is used to count unset bits.
@ -408,43 +408,36 @@
(defoptimizer (logeqv derive-type) ((x y)) (defoptimizer (logeqv derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(lognot-derive-type-aux (lognot-derive-type-aux
(logxor-derive-type-aux x y same-leaf))) (logxor-derive-type-aux x y same-leaf)))))
#'logeqv))
(defoptimizer (lognand derive-type) ((x y)) (defoptimizer (lognand derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(lognot-derive-type-aux (lognot-derive-type-aux
(logand-derive-type-aux x y same-leaf))) (logand-derive-type-aux x y same-leaf)))))
#'lognand))
(defoptimizer (lognor derive-type) ((x y)) (defoptimizer (lognor derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(lognot-derive-type-aux (lognot-derive-type-aux
(logior-derive-type-aux x y same-leaf))) (logior-derive-type-aux x y same-leaf)))))
#'lognor))
(defoptimizer (logandc1 derive-type) ((x y)) (defoptimizer (logandc1 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(if same-leaf (if same-leaf
(specifier-type '(eql 0)) (specifier-type '(eql 0))
(logand-derive-type-aux (logand-derive-type-aux
(lognot-derive-type-aux x) y))) (lognot-derive-type-aux x) y)))))
#'logandc1))
(defoptimizer (logandc2 derive-type) ((x y)) (defoptimizer (logandc2 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(if same-leaf (if same-leaf
(specifier-type '(eql 0)) (specifier-type '(eql 0))
(logand-derive-type-aux (logand-derive-type-aux
x (lognot-derive-type-aux y)))) x (lognot-derive-type-aux y))))))
#'logandc2))
(defoptimizer (logorc1 derive-type) ((x y)) (defoptimizer (logorc1 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(if same-leaf (if same-leaf
(specifier-type '(eql -1)) (specifier-type '(eql -1))
(logior-derive-type-aux (logior-derive-type-aux
(lognot-derive-type-aux x) y))) (lognot-derive-type-aux x) y)))))
#'logorc1))
(defoptimizer (logorc2 derive-type) ((x y)) (defoptimizer (logorc2 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf) (two-arg-derive-type x y (lambda (x y same-leaf)
(if same-leaf (if same-leaf
(specifier-type '(eql -1)) (specifier-type '(eql -1))
(logior-derive-type-aux (logior-derive-type-aux
x (lognot-derive-type-aux y)))) x (lognot-derive-type-aux y))))))
#'logorc2))

65
src/compiler/float-tran.lisp
View file

@ -335,11 +335,9 @@
:low new-lo :low new-lo
:high new-hi))))) :high new-hi)))))
(defoptimizer (scale-single-float derive-type) ((f ex)) (defoptimizer (scale-single-float derive-type) ((f ex))
(two-arg-derive-type f ex #'scale-float-derive-type-aux (two-arg-derive-type f ex #'scale-float-derive-type-aux))
#'scale-float))
(defoptimizer (scale-double-float derive-type) ((f ex)) (defoptimizer (scale-double-float derive-type) ((f ex))
(two-arg-derive-type f ex #'scale-float-derive-type-aux (two-arg-derive-type f ex #'scale-float-derive-type-aux))
#'scale-float))
;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the ;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
;;; FLOAT function return the correct ranges if the input has some ;;; FLOAT function return the correct ranges if the input has some
@ -372,7 +370,7 @@
(defoptimizer (,fun derive-type) ((num)) (defoptimizer (,fun derive-type) ((num))
(handler-case (handler-case
(one-arg-derive-type num #',aux-name (lambda (x) (,fun x))) (one-arg-derive-type num #',aux-name)
(type-error () (type-error ()
nil))))))) nil)))))))
(frob %single-float single-float (frob %single-float single-float
@ -386,10 +384,8 @@
(csubtypep type (specifier-type 'single-float))) (csubtypep type (specifier-type 'single-float)))
(handler-case (handler-case
(type-union (type-union
(one-arg-derive-type number #'%single-float-derive-type-aux (one-arg-derive-type number #'%single-float-derive-type-aux)
(lambda (x) (%single-float x))) (one-arg-derive-type number #'%double-float-derive-type-aux))
(one-arg-derive-type number #'%double-float-derive-type-aux
(lambda (x) (%double-float x))))
(type-error () (type-error ()
nil))))) nil)))))
@ -834,8 +830,7 @@
(elfun-derive-type-simple arg #',name (elfun-derive-type-simple arg #',name
,domain-low ,domain-high ,domain-low ,domain-high
,def-low-bnd ,def-high-bnd ,def-low-bnd ,def-high-bnd
,increasingp)) ,increasingp)))))))
#',name)))))
;; These functions are easy because they are defined for the whole ;; These functions are easy because they are defined for the whole
;; real line. ;; real line.
(frob exp nil nil 0 nil) (frob exp nil nil 0 nil)
@ -1110,7 +1105,7 @@
(float-or-complex-float-type (numeric-contagion x y))))) (float-or-complex-float-type (numeric-contagion x y)))))
(defoptimizer (expt derive-type) ((x y)) (defoptimizer (expt derive-type) ((x y))
(two-arg-derive-type x y #'expt-derive-type-aux #'expt)) (two-arg-derive-type x y #'expt-derive-type-aux))
;;; Note we must assume that a type including 0.0 may also include ;;; Note we must assume that a type including 0.0 may also include
;;; -0.0 and thus the result may be complex -infinity + i*pi. ;;; -0.0 and thus the result may be complex -infinity + i*pi.
@ -1136,16 +1131,8 @@
(defoptimizer (log derive-type) ((x &optional y)) (defoptimizer (log derive-type) ((x &optional y))
(if y (if y
(two-arg-derive-type x y #'log-derive-type-aux-2 nil) (two-arg-derive-type x y #'log-derive-type-aux-2)
(one-arg-derive-type x #'log-derive-type-aux-1 (one-arg-derive-type x #'log-derive-type-aux-1)))
(lambda (n)
(case n
(0f0
single-float-negative-infinity)
(0d0
double-float-negative-infinity)
(t
(log n)))))))
(defun atan-derive-type-aux-1 (y) (defun atan-derive-type-aux-1 (y)
(elfun-derive-type-simple y #'atan nil nil (sb-xc:- (sb-xc:/ pi 2)) (sb-xc:/ pi 2))) (elfun-derive-type-simple y #'atan nil nil (sb-xc:- (sb-xc:/ pi 2)) (sb-xc:/ pi 2)))
@ -1173,8 +1160,8 @@
(defoptimizer (atan derive-type) ((y &optional x)) (defoptimizer (atan derive-type) ((y &optional x))
(if x (if x
(two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan) (two-arg-derive-type y x #'atan-derive-type-aux-2)
(one-arg-derive-type y #'atan-derive-type-aux-1 #'atan))) (one-arg-derive-type y #'atan-derive-type-aux-1)))
(defun cosh-derive-type-aux (x) (defun cosh-derive-type-aux (x)
(%one-arg-derive-type (%one-arg-derive-type
@ -1182,11 +1169,10 @@
(if (numeric-type-real-p x) (if (numeric-type-real-p x)
(abs-derive-type-aux x) (abs-derive-type-aux x)
x) x)
(lambda (x) (elfun-derive-type-simple x #'cosh nil nil 0 nil)) (lambda (x) (elfun-derive-type-simple x #'cosh nil nil 0 nil))))
#'cosh))
(defoptimizer (cosh derive-type) ((num)) (defoptimizer (cosh derive-type) ((num))
(one-arg-derive-type num #'cosh-derive-type-aux #'cosh)) (one-arg-derive-type num #'cosh-derive-type-aux))
(defun phase-derive-type-aux (arg) (defun phase-derive-type-aux (arg)
(let* ((format (case (numeric-type-class arg) (let* ((format (case (numeric-type-class arg)
@ -1233,7 +1219,7 @@
:high (coerce pi bound-type)))))) :high (coerce pi bound-type))))))
(defoptimizer (phase derive-type) ((num)) (defoptimizer (phase derive-type) ((num))
(one-arg-derive-type num #'phase-derive-type-aux #'phase)) (one-arg-derive-type num #'phase-derive-type-aux))
(deftransform realpart ((x) ((complex rational)) * :important nil) (deftransform realpart ((x) ((complex rational)) * :important nil)
'(%realpart x)) '(%realpart x))
@ -1271,7 +1257,7 @@
:high (numeric-type-high type)))))) :high (numeric-type-high type))))))
(defoptimizer (realpart derive-type) ((num)) (defoptimizer (realpart derive-type) ((num))
(one-arg-derive-type num #'realpart-derive-type-aux #'realpart)) (one-arg-derive-type num #'realpart-derive-type-aux))
(defun imagpart-derive-type-aux (type) (defun imagpart-derive-type-aux (type)
(let ((class (numeric-type-class type)) (let ((class (numeric-type-class type))
@ -1296,7 +1282,7 @@
:high (numeric-type-high type)))))) :high (numeric-type-high type))))))
(defoptimizer (imagpart derive-type) ((num)) (defoptimizer (imagpart derive-type) ((num))
(one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart)) (one-arg-derive-type num #'imagpart-derive-type-aux))
(defun complex-derive-type-aux-1 (re-type) (defun complex-derive-type-aux-1 (re-type)
(if (numeric-type-p re-type) (if (numeric-type-p re-type)
@ -1344,8 +1330,8 @@
(defoptimizer (complex derive-type) ((re &optional im)) (defoptimizer (complex derive-type) ((re &optional im))
(if im (if im
(two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex) (two-arg-derive-type re im #'complex-derive-type-aux-2)
(one-arg-derive-type re #'complex-derive-type-aux-1 #'complex))) (one-arg-derive-type re #'complex-derive-type-aux-1)))
;;; Define some transforms for complex operations in lieu of complex operation ;;; Define some transforms for complex operations in lieu of complex operation
;;; VOPs for most backends. If vops exist, they must support the following ;;; VOPs for most backends. If vops exist, they must support the following
@ -1648,8 +1634,7 @@
arg arg
(specifier-type `(float ,(sb-xc:- (sb-xc:/ pi 2)) ,(sb-xc:/ pi 2))) (specifier-type `(float ,(sb-xc:- (sb-xc:/ pi 2)) ,(sb-xc:/ pi 2)))
#'sin #'sin
-1 1)) -1 1))))
#'sin))
(defoptimizer (cos derive-type) ((num)) (defoptimizer (cos derive-type) ((num))
(one-arg-derive-type (one-arg-derive-type
@ -1660,8 +1645,7 @@
(specifier-type `(float 0d0 ,pi)) (specifier-type `(float 0d0 ,pi))
#'cos #'cos
-1 1 -1 1
nil)) nil))))
#'cos))
(defoptimizer (tan derive-type) ((num)) (defoptimizer (tan derive-type) ((num))
(one-arg-derive-type (one-arg-derive-type
@ -1674,8 +1658,7 @@
;; 1.5707964 coerced back to double-float is greater than (/ pi 2) ;; 1.5707964 coerced back to double-float is greater than (/ pi 2)
(single-float -1.5707963 1.5707963))) (single-float -1.5707963 1.5707963)))
#'tan #'tan
nil nil)) nil nil))))
#'tan))
(defoptimizer (conjugate derive-type) ((num)) (defoptimizer (conjugate derive-type) ((num))
(one-arg-derive-type num (one-arg-derive-type num
@ -1696,15 +1679,13 @@
(high (numeric-type-high arg))) (high (numeric-type-high arg)))
(let ((new-low (most-negative-bound low high)) (let ((new-low (most-negative-bound low high))
(new-high (most-positive-bound low high))) (new-high (most-positive-bound low high)))
(modified-numeric-type arg :low new-low :high new-high)))))) (modified-numeric-type arg :low new-low :high new-high))))))))
#'conjugate))
(defoptimizer (cis derive-type) ((num)) (defoptimizer (cis derive-type) ((num))
(one-arg-derive-type num (one-arg-derive-type num
(lambda (arg) (lambda (arg)
(specifier-type (specifier-type
`(complex ,(or (numeric-type-format arg) 'float)))) `(complex ,(or (numeric-type-format arg) 'float))))))
#'cis))
;;;; TRUNCATE, FLOOR, CEILING, and ROUND ;;;; TRUNCATE, FLOOR, CEILING, and ROUND

2
src/compiler/modarith.lisp
View file

@ -765,7 +765,7 @@
(destructuring-bind (q r) (values-type-required res) (destructuring-bind (q r) (values-type-required res)
(make-values-type (list (%two-arg-derive-type q (make-values-type (list (%two-arg-derive-type q
(specifier-type `(eql ,(ldb (byte sb-vm:n-word-bits 0) -1))) (specifier-type `(eql ,(ldb (byte sb-vm:n-word-bits 0) -1)))
#'logand-derive-type-aux #'logand) #'logand-derive-type-aux)
r)))))) r))))))
(deftransform sb-vm::truncate-mod64 ((n d) * * :node node) (deftransform sb-vm::truncate-mod64 ((n d) * * :node node)

215
src/compiler/srctran.lisp
View file

@ -557,9 +557,7 @@
`(not (zerop (logand x y)))) `(not (zerop (logand x y))))
(defoptimizer (logtest derive-type) ((x y)) (defoptimizer (logtest derive-type) ((x y))
(let ((type (two-arg-derive-type x y (let ((type (two-arg-derive-type x y #'logand-derive-type-aux)))
#'logand-derive-type-aux
#'logand)))
(when type (when type
(multiple-value-bind (typep definitely) (multiple-value-bind (typep definitely)
(ctypep 0 type) (ctypep 0 type)
@ -609,9 +607,7 @@
(lambda (index integer same) (lambda (index integer same)
(declare (ignore same)) (declare (ignore same))
(logand-derive-type-aux integer (logand-derive-type-aux integer
(ash-derive-type-aux one index nil))) (ash-derive-type-aux one index nil))))))
(lambda (index integer)
(logand integer (ash 1 index))))))
(cond ((not and) (cond ((not and)
nil) nil)
((type= and (specifier-type '(eql 0))) ((type= and (specifier-type '(eql 0)))
@ -1584,22 +1580,18 @@
(t (t
(list arg))))) (list arg)))))
(unless (eq arg *empty-type*) (unless (eq arg *empty-type*)
;; Make sure all args are some type of numeric-type. For member ;; Make sure all args are some type of numeric-type.
;; types, convert the list of members into a union of equivalent
;; single-element member-type's.
(let ((new-args nil)) (let ((new-args nil))
(dolist (arg (split arg)) (dolist (arg (split arg) new-args)
(if (member-type-p arg) (if (member-type-p arg)
;; Run down the list of members and convert to a list of ;; Convert member types (i.e. complex numbers) to their supertypes
;; member types.
(mapc-member-type-members (mapc-member-type-members
(lambda (member) (lambda (x)
(push (if (numberp member) (make-eql-type member) *empty-type*) (if (numberp x)
new-args)) (pushnew (specifier-type (type-of x)) new-args :test #'eq)
(return)))
arg) arg)
(push arg new-args))) (push arg new-args)))))))
(unless (member *empty-type* new-args)
new-args)))))
;;; Take a list of types and return a canonical type specifier, ;;; Take a list of types and return a canonical type specifier,
;;; combining any MEMBER types together. If both positive and negative ;;; combining any MEMBER types together. If both positive and negative
@ -1667,14 +1659,6 @@
(apply #'type-union (make-member-type xset) (apply #'type-union (make-member-type xset)
numeric-type misc-types)))) numeric-type misc-types))))
;;; Convert a member type with a single member to a numeric type.
;;; It can only be a complex number
(defun convert-member-type (arg)
(let* ((members (member-type-members arg))
(member (first members)))
(aver (not (rest members)))
(specifier-type (type-of member))))
;;; This is used in defoptimizers for computing the resulting type of ;;; This is used in defoptimizers for computing the resulting type of
;;; a function. ;;; a function.
;;; ;;;
@ -1683,21 +1667,13 @@
;;; "atomic" lvar type like numeric-type or member-type (containing ;;; "atomic" lvar type like numeric-type or member-type (containing
;;; just one element). It should return the resulting type, which can ;;; just one element). It should return the resulting type, which can
;;; be a list of types. ;;; be a list of types.
;;; (defun %one-arg-derive-type (arg-type derive-fun)
;;; For the case of member types, if a MEMBER-FUN is given it is (declare (type function derive-fun))
;;; called to compute the result otherwise the member type is first
;;; converted to a numeric type and the DERIVE-FUN is called.
(defun %one-arg-derive-type (arg-type derive-fun member-fun)
(declare (type function derive-fun)
(ignore member-fun))
(let ((arg-list (prepare-arg-for-derive-type arg-type))) (let ((arg-list (prepare-arg-for-derive-type arg-type)))
(when arg-list (when arg-list
(labels ((deriver (x) (labels ((deriver (x)
(cond (when (numeric-type-p x)
((numeric-type-p x) (funcall derive-fun x))))
(funcall derive-fun x))
((member-type-p x)
(funcall derive-fun (convert-member-type x))))))
;; Run down the list of args and derive the type of each one, ;; Run down the list of args and derive the type of each one,
;; saving all of the results in a list. ;; saving all of the results in a list.
(let ((results nil)) (let ((results nil))
@ -1713,8 +1689,8 @@
(make-derived-union-type results) (make-derived-union-type results)
(first results))))))) (first results)))))))
(defun one-arg-derive-type (arg derive-fun member-fun) (defun one-arg-derive-type (arg derive-fun)
(%one-arg-derive-type (lvar-type arg) derive-fun member-fun)) (%one-arg-derive-type (lvar-type arg) derive-fun))
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
;;; two arguments. DERIVE-FUN takes 3 args in this case: the two ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
@ -1722,37 +1698,16 @@
;;; really represent the same lvar. This is useful for deriving the ;;; really represent the same lvar. This is useful for deriving the
;;; type of things like (* x x), which should always be positive. If ;;; type of things like (* x x), which should always be positive. If
;;; we didn't do this, we wouldn't be able to tell. ;;; we didn't do this, we wouldn't be able to tell.
(defun two-arg-derive-type (arg1 arg2 derive-fun member-fun) (defun two-arg-derive-type (arg1 arg2 derive-fun)
(%two-arg-derive-type (lvar-type arg1) (lvar-type arg2) (%two-arg-derive-type (lvar-type arg1) (lvar-type arg2)
derive-fun member-fun derive-fun (same-leaf-ref-p arg1 arg2)))
(same-leaf-ref-p arg1 arg2)))
(defun %two-arg-derive-type (arg1-type arg2-type derive-fun member-fun &optional same-leaf) (defun %two-arg-derive-type (arg1-type arg2-type derive-fun &optional same-leaf)
(declare (type function derive-fun) (declare (type function derive-fun))
(type (or function null) member-fun))
(labels ((deriver (x y same-arg) (labels ((deriver (x y same-arg)
(cond ((and (member-type-p x) (member-type-p y)) (if (and (numeric-type-p x) (numeric-type-p y))
(if member-fun (funcall derive-fun x y same-arg)
(funcall derive-fun (convert-member-type x) (convert-member-type y) same-arg) *universal-type*))
(let* ((x (first (member-type-members x)))
(y (first (member-type-members y)))
(result (ignore-errors
(funcall member-fun x y))))
(cond ((null result) *empty-type*)
((and (floatp result) (float-nan-p result))
(make-numeric-type :class 'float
:format (type-of result)
:complexp :real))
(t
(specifier-type `(eql ,result)))))))
((and (member-type-p x) (numeric-type-p y))
(funcall derive-fun (convert-member-type x) y same-arg))
((and (numeric-type-p x) (member-type-p y))
(funcall derive-fun x (convert-member-type y) same-arg))
((and (numeric-type-p x) (numeric-type-p y))
(funcall derive-fun x y same-arg))
(t
*universal-type*)))
(derive (type1 type2 same-arg) (derive (type1 type2 same-arg)
(let ((a1 (prepare-arg-for-derive-type type1)) (let ((a1 (prepare-arg-for-derive-type type1))
(a2 (prepare-arg-for-derive-type type2))) (a2 (prepare-arg-for-derive-type type2)))
@ -1821,7 +1776,7 @@
(numeric-contagion x y)))) (numeric-contagion x y))))
(defoptimizer (+ derive-type) ((x y)) (defoptimizer (+ derive-type) ((x y))
(two-arg-derive-type x y #'+-derive-type-aux #'sb-xc:+)) (two-arg-derive-type x y #'+-derive-type-aux))
(defun --derive-type-aux (x y same-arg) (defun --derive-type-aux (x y same-arg)
(cond ((and (integer-type-p x) (cond ((and (integer-type-p x)
@ -1873,7 +1828,7 @@
(numeric-contagion x y)))) (numeric-contagion x y))))
(defoptimizer (- derive-type) ((x y)) (defoptimizer (- derive-type) ((x y))
(two-arg-derive-type x y #'--derive-type-aux #'sb-xc:-)) (two-arg-derive-type x y #'--derive-type-aux))
(defun *-derive-type-aux (x y same-arg) (defun *-derive-type-aux (x y same-arg)
(cond ((and same-arg (cond ((and same-arg
@ -1940,14 +1895,14 @@
(return (return
(let ((result (%two-arg-derive-type (type-intersection x (specifier-type '(and integer (not (eql 0))))) (let ((result (%two-arg-derive-type (type-intersection x (specifier-type '(and integer (not (eql 0)))))
y y
#'*-derive-type-aux #'sb-xc:*))) #'*-derive-type-aux)))
(when result (when result
(type-union result (specifier-type '(eql 0))))))))) (type-union result (specifier-type '(eql 0)))))))))
;; If one of the integer arguments is non zero seperate the zero ;; If one of the integer arguments is non zero seperate the zero
;; result from the rest of the result range. ;; result from the rest of the result range.
(try-zero x-type y-type) (try-zero x-type y-type)
(try-zero y-type x-type) (try-zero y-type x-type)
(two-arg-derive-type x y #'*-derive-type-aux #'sb-xc:*))))) (two-arg-derive-type x y #'*-derive-type-aux)))))
(defoptimizer (%signed-multiply-high derive-type) ((x y)) (defoptimizer (%signed-multiply-high derive-type) ((x y))
(two-arg-derive-type x y (two-arg-derive-type x y
@ -1959,8 +1914,7 @@
(make-numeric-type :class 'integer (make-numeric-type :class 'integer
:low :low
(ash low (- sb-vm:n-word-bits)) (ash low (- sb-vm:n-word-bits))
:high (ash high (- sb-vm:n-word-bits)))))) :high (ash high (- sb-vm:n-word-bits))))))))
#'sb-xc:*))
(defoptimizer (%multiply-high derive-type) ((x y) node) (defoptimizer (%multiply-high derive-type) ((x y) node)
(%signed-multiply-high-derive-type-optimizer node)) (%signed-multiply-high-derive-type-optimizer node))
@ -2020,7 +1974,7 @@
(numeric-contagion x y)))) (numeric-contagion x y))))
(defoptimizer (/ derive-type) ((x y)) (defoptimizer (/ derive-type) ((x y))
(two-arg-derive-type x y #'/-derive-type-aux #'sb-xc:/)) (two-arg-derive-type x y #'/-derive-type-aux))
(defconstant +left-shift-derive-type-cutoff+ 256) (defconstant +left-shift-derive-type-cutoff+ 256)
@ -2067,7 +2021,7 @@
*universal-type*))) *universal-type*)))
(defoptimizer (ash derive-type) ((n shift)) (defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) (two-arg-derive-type n shift #'ash-derive-type-aux))
(defun lognot-derive-type-aux (int) (defun lognot-derive-type-aux (int)
(derive-integer-type-aux int int (derive-integer-type-aux int int
@ -2081,7 +2035,7 @@
(numeric-type-format type)))))) (numeric-type-format type))))))
(defoptimizer (lognot derive-type) ((int)) (defoptimizer (lognot derive-type) ((int))
(one-arg-derive-type int #'lognot-derive-type-aux #'lognot)) (one-arg-derive-type int #'lognot-derive-type-aux))
(defun %negate-derive-type-aux (type) (defun %negate-derive-type-aux (type)
(flet ((negate-bound (b) (flet ((negate-bound (b)
@ -2098,7 +2052,7 @@
r)))) r))))
(defoptimizer (%negate derive-type) ((num)) (defoptimizer (%negate derive-type) ((num))
(one-arg-derive-type num #'%negate-derive-type-aux #'sb-xc:-)) (one-arg-derive-type num #'%negate-derive-type-aux))
(defun abs-derive-type-aux (type) (defun abs-derive-type-aux (type)
(cond ((ratio-type-p type) (cond ((ratio-type-p type)
@ -2150,7 +2104,7 @@
type)))))) type))))))
(defoptimizer (abs derive-type) ((num)) (defoptimizer (abs derive-type) ((num))
(one-arg-derive-type num #'abs-derive-type-aux #'abs)) (one-arg-derive-type num #'abs-derive-type-aux))
(defun rem-result-type (number-type divisor-type) (defun rem-result-type (number-type divisor-type)
;; Figure out what the remainder type is. The remainder is an ;; Figure out what the remainder type is. The remainder is an
@ -2271,9 +2225,9 @@
(defoptimizer (truncate derive-type) ((number divisor)) (defoptimizer (truncate derive-type) ((number divisor))
(let ((quot (two-arg-derive-type number divisor (let ((quot (two-arg-derive-type number divisor
#'truncate-derive-type-quot-aux #'truncate)) #'truncate-derive-type-quot-aux))
(rem (two-arg-derive-type number divisor (rem (two-arg-derive-type number divisor
#'truncate-derive-type-rem-aux #'rem))) #'truncate-derive-type-rem-aux)))
(when (and quot rem) (when (and quot rem)
(make-values-type (list quot rem))))) (make-values-type (list quot rem)))))
@ -2282,28 +2236,23 @@
(defoptimizer (%unary-truncate derive-type) ((number)) (defoptimizer (%unary-truncate derive-type) ((number))
(one-arg-derive-type number (one-arg-derive-type number
#'%unary-truncate-derive-type-aux #'%unary-truncate-derive-type-aux))
#'truncate))
(defoptimizer (%unary-truncate/single-float derive-type) ((number)) (defoptimizer (%unary-truncate/single-float derive-type) ((number))
(one-arg-derive-type number (one-arg-derive-type number
#'%unary-truncate-derive-type-aux #'%unary-truncate-derive-type-aux))
#'truncate))
(defoptimizer (%unary-truncate/double-float derive-type) ((number)) (defoptimizer (%unary-truncate/double-float derive-type) ((number))
(one-arg-derive-type number (one-arg-derive-type number
#'%unary-truncate-derive-type-aux #'%unary-truncate-derive-type-aux))
#'truncate))
(defoptimizer (unary-truncate derive-type) ((number)) (defoptimizer (unary-truncate derive-type) ((number))
(let* ((one (specifier-type '(integer 1 1))) (let* ((one (specifier-type '(integer 1 1)))
(quot (one-arg-derive-type number (quot (one-arg-derive-type number
(lambda (x) (lambda (x)
(truncate-derive-type-quot-aux x one nil)) (truncate-derive-type-quot-aux x one nil))))
#'truncate))
(rem (one-arg-derive-type number (rem (one-arg-derive-type number
(lambda (x) (truncate-derive-type-rem-aux x one nil)) (lambda (x) (truncate-derive-type-rem-aux x one nil)))))
(lambda (x) (nth-value 1 (truncate x 1))))))
(when (and quot rem) (when (and quot rem)
(make-values-type (list quot rem))))) (make-values-type (list quot rem)))))
@ -2333,9 +2282,9 @@
(defoptimizer (ftruncate derive-type) ((number divisor)) (defoptimizer (ftruncate derive-type) ((number divisor))
(let ((quot (let ((quot
(two-arg-derive-type number divisor (two-arg-derive-type number divisor
#'ftruncate-derive-type-quot-aux #'ftruncate)) #'ftruncate-derive-type-quot-aux))
(rem (two-arg-derive-type number divisor (rem (two-arg-derive-type number divisor
#'truncate-derive-type-rem-aux #'rem))) #'truncate-derive-type-rem-aux)))
(when (and quot rem) (when (and quot rem)
(make-values-type (list quot rem))))) (make-values-type (list quot rem)))))
@ -2356,9 +2305,7 @@
'*) '*)
(if hi (if hi
(,fun (type-bound-number hi)) (,fun (type-bound-number hi))
'*)))))) '*))))))))))))
(lambda (x)
(values (,fun x)))))))))
(defoptimizer (round-single derive-type) ((number mode)) (defoptimizer (round-single derive-type) ((number mode))
(derive single-float)) (derive single-float))
(defoptimizer (round-double derive-type) ((number mode)) (defoptimizer (round-double derive-type) ((number mode))
@ -2383,8 +2330,7 @@
'*) '*)
,(if high ,(if high
(round high) (round high)
'*)))))) '*))))))))
#'round))
;;; Define optimizers for FLOOR and CEILING. ;;; Define optimizers for FLOOR and CEILING.
(macrolet (macrolet
@ -2452,9 +2398,9 @@
(t (t
(numeric-contagion num div))))) (numeric-contagion num div)))))
(let ((quot (two-arg-derive-type (let ((quot (two-arg-derive-type
number divisor #'derive-q #',name)) number divisor #'derive-q))
(rem (two-arg-derive-type (rem (two-arg-derive-type
number divisor #'derive-r #'mod))) number divisor #'derive-r)))
(when (and quot rem) (when (and quot rem)
(make-values-type (list quot rem)))))))))) (make-values-type (list quot rem))))))))))
@ -2827,7 +2773,7 @@
(t `(,high)))))) (t `(,high))))))
(defoptimizer (random derive-type) ((bound &optional state)) (defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux nil)) (one-arg-derive-type bound #'random-derive-type-aux))
;;;; miscellaneous derive-type methods ;;;; miscellaneous derive-type methods
@ -2857,8 +2803,7 @@
(specifier-type `(integer ,(integer-length lo))))) (specifier-type `(integer ,(integer-length lo)))))
(hi (hi
(when (< hi 0) (when (< hi 0)
(specifier-type `(integer ,(integer-length hi))))))))) (specifier-type `(integer ,(integer-length hi)))))))))))
#'integer-length))
(defoptimizer (%bignum-length derive-type) ((x)) (defoptimizer (%bignum-length derive-type) ((x))
(one-arg-derive-type (one-arg-derive-type
@ -2874,8 +2819,7 @@
(specifier-type `(integer ,(%bignum-length lo))))) (specifier-type `(integer ,(%bignum-length lo)))))
(hi (hi
(when (< hi 0) (when (< hi 0)
(specifier-type `(integer ,(%bignum-length hi)))))))) (specifier-type `(integer ,(%bignum-length hi))))))))))
nil))
(defoptimizer (logcount derive-type) ((x)) (defoptimizer (logcount derive-type) ((x))
(one-arg-derive-type (one-arg-derive-type
@ -2924,8 +2868,7 @@
(specifier-type `(integer 1)))) (specifier-type `(integer 1))))
(hi (hi
(when (< hi -1) (when (< hi -1)
(specifier-type `(integer 1))))))) (specifier-type `(integer 1)))))))))
#'logcount))
(defoptimizer (isqrt derive-type) ((x)) (defoptimizer (isqrt derive-type) ((x))
(one-arg-derive-type (one-arg-derive-type
@ -2939,8 +2882,7 @@
(hi-res (if (typep hi 'unsigned-byte) (hi-res (if (typep hi 'unsigned-byte)
(isqrt hi) (isqrt hi)
'*))) '*)))
(specifier-type `(integer ,lo-res ,hi-res)))) (specifier-type `(integer ,lo-res ,hi-res))))))
#'isqrt))
(defoptimizer (char-code derive-type) ((char)) (defoptimizer (char-code derive-type) ((char))
(let ((type (type-intersection (lvar-type char) (specifier-type 'character)))) (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
@ -2983,8 +2925,7 @@
((csubtypep type (specifier-type 'extended-char)) ((csubtypep type (specifier-type 'extended-char))
(specifier-type 'extended-char)) (specifier-type 'extended-char))
(t #+sb-xc-host (specifier-type 'character) (t #+sb-xc-host (specifier-type 'character)
#-sb-xc-host type)))) #-sb-xc-host type))))))
nil))
(deftransform code-char ((code)) (deftransform code-char ((code))
(splice-fun-args code 'char-code 1) (splice-fun-args code 'char-code 1)
@ -3083,7 +3024,7 @@
:high 1)))))))) :high 1))))))))
(defoptimizer (signum derive-type) ((num)) (defoptimizer (signum derive-type) ((num))
(one-arg-derive-type num #'signum-derive-type-aux nil)) (one-arg-derive-type num #'signum-derive-type-aux))
;;;; byte operations ;;;; byte operations
;;;; ;;;;
@ -3137,18 +3078,14 @@
(let* ((shifted (two-arg-derive-type num posn (let* ((shifted (two-arg-derive-type num posn
(lambda (num posn same) (lambda (num posn same)
(declare (ignore same)) (declare (ignore same))
(ash-derive-type-aux num (%negate-derive-type-aux posn) nil)) (ash-derive-type-aux num (%negate-derive-type-aux posn) nil))))
(lambda (num posn)
(ash num (- posn)))))
(minus-one (specifier-type '(eql -1))) (minus-one (specifier-type '(eql -1)))
(mask (one-arg-derive-type size (mask (one-arg-derive-type size
(lambda (x) (lambda (x)
(lognot-derive-type-aux (lognot-derive-type-aux
(ash-derive-type-aux minus-one x nil))) (ash-derive-type-aux minus-one x nil))))))
(lambda (x)
(lognot (ash -1 x))))))
(when (and shifted mask) (when (and shifted mask)
(%two-arg-derive-type shifted mask #'logand-derive-type-aux #'logand)))) (%two-arg-derive-type shifted mask #'logand-derive-type-aux))))
;; Handle (ldb (byte y (- 64 y)) x) ;; Handle (ldb (byte y (- 64 y)) x)
(minuend (related-byte-spec size posn))) (minuend (related-byte-spec size posn)))
(if (and minuend (if (and minuend
@ -3196,13 +3133,11 @@
(or (one-arg-derive-type size (or (one-arg-derive-type size
(lambda (x) (lambda (x)
(lognot-derive-type-aux (lognot-derive-type-aux
(ash-derive-type-aux minus-one x nil))) (ash-derive-type-aux minus-one x nil))))
(lambda (x)
(lognot (ash -1 x))))
(return))) (return)))
(mask-shifted (mask-shifted
(or (%two-arg-derive-type mask (lvar-type posn) (or (%two-arg-derive-type mask (lvar-type posn)
#'ash-derive-type-aux #'ash) #'ash-derive-type-aux)
(return))) (return)))
(int (int
(or (%two-arg-derive-type (lvar-type int) mask-shifted (or (%two-arg-derive-type (lvar-type int) mask-shifted
@ -3211,19 +3146,16 @@
(%two-arg-derive-type (%two-arg-derive-type
int int
(lognot-derive-type-aux mask) (lognot-derive-type-aux mask)
#'logand-derive-type-aux #'logand-derive-type-aux)))
#'logand))
(lambda (int mask)
(logandc2 int mask)))
(return))) (return)))
(new-masked (or (%two-arg-derive-type mask (lvar-type newbyte) (new-masked (or (%two-arg-derive-type mask (lvar-type newbyte)
#'logand-derive-type-aux #'logand) #'logand-derive-type-aux)
(return))) (return)))
(new (new
(or (%two-arg-derive-type new-masked (lvar-type posn) (or (%two-arg-derive-type new-masked (lvar-type posn)
#'ash-derive-type-aux #'ash) #'ash-derive-type-aux)
(return)))) (return))))
(%two-arg-derive-type int new #'logior-derive-type-aux #'logior)))) (%two-arg-derive-type int new #'logior-derive-type-aux))))
(int-interval (type-approximate-interval (lvar-type int)))) (int-interval (type-approximate-interval (lvar-type int))))
(or (or
(when (and int-interval (when (and int-interval
@ -3255,9 +3187,7 @@
(ash-derive-type-aux (ash-derive-type-aux
(lognot-derive-type-aux (lognot-derive-type-aux
(ash-derive-type-aux minus-one size nil)) (ash-derive-type-aux minus-one size nil))
posn nil)) posn nil)))
(lambda (x)
(lognot (ash -1 x))))
(return))) (return)))
(int (int
(or (%two-arg-derive-type (lvar-type int) mask (or (%two-arg-derive-type (lvar-type int) mask
@ -3266,15 +3196,12 @@
(%two-arg-derive-type (%two-arg-derive-type
int int
(lognot-derive-type-aux mask) (lognot-derive-type-aux mask)
#'logand-derive-type-aux #'logand-derive-type-aux)))
#'logand))
(lambda (int mask)
(logandc2 int mask)))
(return))) (return)))
(new (or (%two-arg-derive-type mask (lvar-type newbyte) (new (or (%two-arg-derive-type mask (lvar-type newbyte)
#'logand-derive-type-aux #'logand) #'logand-derive-type-aux)
(return)))) (return))))
(%two-arg-derive-type int new #'logior-derive-type-aux #'logior)))) (%two-arg-derive-type int new #'logior-derive-type-aux))))
(defmacro min-or-nil (&rest numbers-or-nil) (defmacro min-or-nil (&rest numbers-or-nil)
(let ((min-sym (gensym "MIN"))) (let ((min-sym (gensym "MIN")))
@ -3467,7 +3394,7 @@
*universal-type*)) *universal-type*))
(defoptimizer (%ash/right derive-type) ((n shift)) (defoptimizer (%ash/right derive-type) ((n shift))
(two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))) (two-arg-derive-type n shift #'%ash/right-derive-type-aux)))
(defmacro combination-typed-p (node name &rest types) (defmacro combination-typed-p (node name &rest types)
(labels ((gen (type) (labels ((gen (type)
@ -4788,7 +4715,7 @@
(if (and (not (or (csubtypep (lvar-type x) (specifier-type 'word)) (if (and (not (or (csubtypep (lvar-type x) (specifier-type 'word))
(csubtypep (lvar-type x) (specifier-type 'sb-vm:signed-word)))) (csubtypep (lvar-type x) (specifier-type 'sb-vm:signed-word))))
(csubtypep (lvar-type y) (specifier-type 'fixnum)) (csubtypep (lvar-type y) (specifier-type 'fixnum))
(csubtypep (one-arg-derive-type y #'lognot-derive-type-aux #'lognot) (csubtypep (one-arg-derive-type y #'lognot-derive-type-aux)
(specifier-type 'fixnum))) (specifier-type 'fixnum)))
`(logand x (lognot y)) `(logand x (lognot y))
(give-up-ir1-transform))) (give-up-ir1-transform)))
@ -6533,8 +6460,7 @@
(make-numeric-type (make-numeric-type
:class 'rational :class 'rational
:low (%rational (numeric-type-low type)) :low (%rational (numeric-type-low type))
:high (%rational (numeric-type-high type))))) :high (%rational (numeric-type-high type)))))))
#'rational))
(defoptimizer (rationalize derive-type) ((x)) (defoptimizer (rationalize derive-type) ((x))
(one-arg-derive-type x (lambda (type) (one-arg-derive-type x (lambda (type)
@ -6550,8 +6476,7 @@
(make-numeric-type (make-numeric-type
:class 'rational :class 'rational
:low (%rationalize (numeric-type-low type)) :low (%rationalize (numeric-type-low type))
:high (%rationalize (numeric-type-high type))))) :high (%rationalize (numeric-type-high type)))))))
#'rationalize))
;;;; transforming APPLY ;;;; transforming APPLY