;;; Convert into an IF so that IF optimizations will eliminate redundant
;;; negations.
-(def-source-transform not (x) `(if ,x nil t))
-(def-source-transform null (x) `(if ,x nil t))
+(define-source-transform not (x) `(if ,x nil t))
+(define-source-transform null (x) `(if ,x nil t))
;;; ENDP is just NULL with a LIST assertion. The assertion will be
;;; optimized away when SAFETY optimization is low; hopefully that
;;; is consistent with ANSI's "should return an error".
-(def-source-transform endp (x) `(null (the list ,x)))
+(define-source-transform endp (x) `(null (the list ,x)))
;;; We turn IDENTITY into PROG1 so that it is obvious that it just
;;; returns the first value of its argument. Ditto for VALUES with one
;;; arg.
-(def-source-transform identity (x) `(prog1 ,x))
-(def-source-transform values (x) `(prog1 ,x))
+(define-source-transform identity (x) `(prog1 ,x))
+(define-source-transform values (x) `(prog1 ,x))
;;; Bind the values and make a closure that returns them.
-(def-source-transform constantly (value)
+(define-source-transform constantly (value)
(let ((rest (gensym "CONSTANTLY-REST-")))
`(lambda (&rest ,rest)
(declare (ignore ,rest))
(deftransform complement ((fun) * * :node node :when :both)
"open code"
(multiple-value-bind (min max)
- (function-type-nargs (continuation-type fun))
+ (fun-type-nargs (continuation-type fun))
(cond
((and min (eql min max))
(let ((dums (make-gensym-list min)))
;;; Translate CxR into CAR/CDR combos.
(defun source-transform-cxr (form)
- (if (or (byte-compiling) (/= (length form) 2))
+ (if (/= (length form) 2)
(values nil t)
(let ((name (symbol-name (car form))))
(do ((i (- (length name) 2) (1- i))
;;; whatever is right for them is right for us. FIFTH..TENTH turn into
;;; Nth, which can be expanded into a CAR/CDR later on if policy
;;; favors it.
-(def-source-transform first (x) `(car ,x))
-(def-source-transform rest (x) `(cdr ,x))
-(def-source-transform second (x) `(cadr ,x))
-(def-source-transform third (x) `(caddr ,x))
-(def-source-transform fourth (x) `(cadddr ,x))
-(def-source-transform fifth (x) `(nth 4 ,x))
-(def-source-transform sixth (x) `(nth 5 ,x))
-(def-source-transform seventh (x) `(nth 6 ,x))
-(def-source-transform eighth (x) `(nth 7 ,x))
-(def-source-transform ninth (x) `(nth 8 ,x))
-(def-source-transform tenth (x) `(nth 9 ,x))
+(define-source-transform first (x) `(car ,x))
+(define-source-transform rest (x) `(cdr ,x))
+(define-source-transform second (x) `(cadr ,x))
+(define-source-transform third (x) `(caddr ,x))
+(define-source-transform fourth (x) `(cadddr ,x))
+(define-source-transform fifth (x) `(nth 4 ,x))
+(define-source-transform sixth (x) `(nth 5 ,x))
+(define-source-transform seventh (x) `(nth 6 ,x))
+(define-source-transform eighth (x) `(nth 7 ,x))
+(define-source-transform ninth (x) `(nth 8 ,x))
+(define-source-transform tenth (x) `(nth 9 ,x))
;;; Translate RPLACx to LET and SETF.
-(def-source-transform rplaca (x y)
+(define-source-transform rplaca (x y)
(once-only ((n-x x))
`(progn
(setf (car ,n-x) ,y)
,n-x)))
-(def-source-transform rplacd (x y)
+(define-source-transform rplacd (x y)
(once-only ((n-x x))
`(progn
(setf (cdr ,n-x) ,y)
,n-x)))
-(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
+(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)
\f
;;;; arithmetic and numerology
-(def-source-transform plusp (x) `(> ,x 0))
-(def-source-transform minusp (x) `(< ,x 0))
-(def-source-transform zerop (x) `(= ,x 0))
+(define-source-transform plusp (x) `(> ,x 0))
+(define-source-transform minusp (x) `(< ,x 0))
+(define-source-transform zerop (x) `(= ,x 0))
-(def-source-transform 1+ (x) `(+ ,x 1))
-(def-source-transform 1- (x) `(- ,x 1))
+(define-source-transform 1+ (x) `(+ ,x 1))
+(define-source-transform 1- (x) `(- ,x 1))
-(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
-(def-source-transform evenp (x) `(zerop (logand ,x 1)))
+(define-source-transform oddp (x) `(not (zerop (logand ,x 1))))
+(define-source-transform evenp (x) `(zerop (logand ,x 1)))
;;; Note that all the integer division functions are available for
;;; inline expansion.
-;;; FIXME: DEF-FROB instead of FROB
-(macrolet ((frob (fun)
- `(def-source-transform ,fun (x &optional (y nil y-p))
+(macrolet ((deffrob (fun)
+ `(define-source-transform ,fun (x &optional (y nil y-p))
(declare (ignore y))
(if y-p
(values nil t)
`(,',fun ,x 1)))))
- (frob truncate)
- (frob round)
- #!+sb-propagate-float-type
- (frob floor)
- #!+sb-propagate-float-type
- (frob ceiling))
-
-(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
-(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
-(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
-(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
-(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
-(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
-(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(def-source-transform logbitp (index integer)
+ (deffrob truncate)
+ (deffrob round)
+ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+ (deffrob floor)
+ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+ (deffrob ceiling))
+
+(define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
+(define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
+(define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
+(define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
+(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
+(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
+(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+(define-source-transform logbitp (index integer)
`(not (zerop (logand (ash 1 ,index) ,integer))))
-(def-source-transform byte (size position) `(cons ,size ,position))
-(def-source-transform byte-size (spec) `(car ,spec))
-(def-source-transform byte-position (spec) `(cdr ,spec))
-(def-source-transform ldb-test (bytespec integer)
+(define-source-transform byte (size position) `(cons ,size ,position))
+(define-source-transform byte-size (spec) `(car ,spec))
+(define-source-transform byte-position (spec) `(cdr ,spec))
+(define-source-transform ldb-test (bytespec integer)
`(not (zerop (mask-field ,bytespec ,integer))))
;;; With the ratio and complex accessors, we pick off the "identity"
;;; case, and use a primitive to handle the cell access case.
-(def-source-transform numerator (num)
+(define-source-transform numerator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%numerator ,n-num)
,n-num)))
-(def-source-transform denominator (num)
+(define-source-transform denominator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%denominator ,n-num)
;;;; numeric-type has everything we want to know. Reason 2 wins for
;;;; now.
-#!+sb-propagate-float-type
-(progn
-
;;; The basic interval type. It can handle open and closed intervals.
;;; A bound is open if it is a list containing a number, just like
;;; Lisp says. NIL means unbounded.
;; The bound exists, so keep it open still.
(list new-val))))
(t
- (error "Unknown bound type in make-interval!")))))
+ (error "unknown bound type in MAKE-INTERVAL")))))
(%make-interval :low (normalize-bound low)
:high (normalize-bound high))))
((eq y-range '-)
(interval-neg (interval-mul x (interval-neg y))))
((and (eq x-range '+) (eq y-range '+))
- ;; If we are here, X and Y are both positive
- (make-interval :low (bound-mul (interval-low x) (interval-low y))
- :high (bound-mul (interval-high x) (interval-high y))))
+ ;; If we are here, X and Y are both positive.
+ (make-interval
+ :low (bound-mul (interval-low x) (interval-low y))
+ :high (bound-mul (interval-high x) (interval-high y))))
(t
- (error "This shouldn't happen!"))))))
+ (error "internal error in INTERVAL-MUL"))))))
;;; Divide two intervals.
(defun interval-div (top bot)
;; sign of the result.
(interval-neg (interval-div (interval-neg top) bot)))
((and (eq top-range '+) (eq bot-range '+))
- ;; The easy case
- (make-interval :low (bound-div (interval-low top) (interval-high bot) t)
- :high (bound-div (interval-high top) (interval-low bot) nil)))
+ ;; the easy case
+ (make-interval
+ :low (bound-div (interval-low top) (interval-high bot) t)
+ :high (bound-div (interval-high top) (interval-low bot) nil)))
(t
- (error "This shouldn't happen!"))))))
+ (error "internal error in INTERVAL-DIV"))))))
;;; Apply the function F to the interval X. If X = [a, b], then the
;;; result is [f(a), f(b)]. It is up to the user to make sure the
;;; Compute the square of an interval.
(defun interval-sqr (x)
(declare (type interval x))
- (interval-func #'(lambda (x) (* x x))
+ (interval-func (lambda (x) (* x x))
(interval-abs x)))
-) ; PROGN
\f
;;;; numeric DERIVE-TYPE methods
:high high))
(numeric-contagion x y))))
-#!+(or sb-propagate-float-type sb-propagate-fun-type)
-(progn
-
;;; simple utility to flatten a list
(defun flatten-list (x)
(labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
(if (rest results)
(make-canonical-union-type results)
(first results)))))))
-
-) ; PROGN
\f
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defoptimizer (+ derive-type) ((x y))
(derive-integer-type
) ; PROGN
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun +-derive-type-aux (x y same-arg)
(if (and (numeric-type-real-p x)
;;; and it's hard to avoid that calculation in here.
#-(and cmu sb-xc-host)
(progn
-#!-sb-propagate-fun-type
-(defoptimizer (ash derive-type) ((n shift))
- ;; Large resulting bounds are easy to generate but are not
- ;; particularly useful, so an open outer bound is returned for a
- ;; shift greater than 64 - the largest word size of any of the ports.
- ;; Large negative shifts are also problematic as the ASH
- ;; implementation only accepts shifts greater than
- ;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local
- ;; functions:
- ;; ASH-OUTER: Perform the shift when within an acceptable range,
- ;; otherwise return an open bound.
- ;; ASH-INNER: Perform the shift when within range, limited to a
- ;; maximum of 64, otherwise returns the inner limit.
- ;;
- ;; FIXME: The magic number 64 should be given a mnemonic name as a
- ;; symbolic constant -- perhaps +MAX-REGISTER-SIZE+. And perhaps is
- ;; should become an architecture-specific SB!VM:+MAX-REGISTER-SIZE+
- ;; instead of trying to have a single magic number which covers
- ;; all possible ports.
- (flet ((ash-outer (n s)
- (when (and (fixnump s)
- (<= s 64)
- (> s sb!vm:*target-most-negative-fixnum*))
- (ash n s)))
- (ash-inner (n s)
- (if (and (fixnump s)
- (> s sb!vm:*target-most-negative-fixnum*))
- (ash n (min s 64))
- (if (minusp n) -1 0))))
- (or (let ((n-type (continuation-type n)))
- (when (numeric-type-p n-type)
- (let ((n-low (numeric-type-low n-type))
- (n-high (numeric-type-high n-type)))
- (if (constant-continuation-p shift)
- (let ((shift (continuation-value shift)))
- (make-numeric-type :class 'integer
- :complexp :real
- :low (when n-low (ash n-low shift))
- :high (when n-high (ash n-high shift))))
- (let ((s-type (continuation-type shift)))
- (when (numeric-type-p s-type)
- (let* ((s-low (numeric-type-low s-type))
- (s-high (numeric-type-high s-type))
- (low-slot (when n-low
- (if (minusp n-low)
- (ash-outer n-low s-high)
- (ash-inner n-low s-low))))
- (high-slot (when n-high
- (if (minusp n-high)
- (ash-inner n-high s-low)
- (ash-outer n-high s-high)))))
- (make-numeric-type :class 'integer
- :complexp :real
- :low low-slot
- :high high-slot))))))))
- *universal-type*))
- (or (let ((n-type (continuation-type n)))
- (when (numeric-type-p n-type)
- (let ((n-low (numeric-type-low n-type))
- (n-high (numeric-type-high n-type)))
- (if (constant-continuation-p shift)
- (let ((shift (continuation-value shift)))
- (make-numeric-type :class 'integer
- :complexp :real
- :low (when n-low (ash n-low shift))
- :high (when n-high (ash n-high shift))))
- (let ((s-type (continuation-type shift)))
- (when (numeric-type-p s-type)
- (let ((s-low (numeric-type-low s-type))
- (s-high (numeric-type-high s-type)))
- (if (and s-low s-high (<= s-low 64) (<= s-high 64))
- (make-numeric-type :class 'integer
- :complexp :real
- :low (when n-low
- (min (ash n-low s-high)
- (ash n-low s-low)))
- :high (when n-high
- (max (ash n-high s-high)
- (ash n-high s-low))))
- (make-numeric-type :class 'integer
- :complexp :real)))))))))
- *universal-type*))
-
-#!+sb-propagate-fun-type
+
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
(flet ((ash-outer (n s)
(ash-outer n-high s-high))))))
*universal-type*)))
-#!+sb-propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
) ; PROGN
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(macrolet ((frob (fun)
`#'(lambda (type type2)
(declare (ignore type2))
(values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
(defoptimizer (%negate derive-type) ((num))
- (derive-integer-type num num (frob -)))
-
- (defoptimizer (lognot derive-type) ((int))
- (derive-integer-type int int (frob lognot))))
+ (derive-integer-type num num (frob -))))
-#!+sb-propagate-float-type
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int
(lambda (type type2)
(numeric-type-class type)
(numeric-type-format type))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (%negate derive-type) ((num))
(flet ((negate-bound (b)
(and b
:high (negate-bound (numeric-type-low type))))
#'-)))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (abs derive-type) ((num))
(let ((type (continuation-type num)))
(if (and (numeric-type-p type)
nil)))
(numeric-contagion type type))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun abs-derive-type-aux (type)
(cond ((eq (numeric-type-complexp type) :complex)
;; The absolute value of a complex number is always a
:high (coerce-numeric-bound
(interval-high abs-bnd) bound-type))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (abs derive-type) ((num))
(one-arg-derive-type num #'abs-derive-type-aux #'abs))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
divisor-low divisor-high))))
*universal-type*)))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun rem-result-type (number-type divisor-type)
;; anything about the result.
`integer)))))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun integer-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
0
'*))))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (random derive-type) ((bound &optional state))
(let ((type (continuation-type bound)))
(when (numeric-type-p type)
((or (consp high) (zerop high)) high)
(t `(,high))))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun random-derive-type-aux (type)
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
((or (consp high) (zerop high)) high)
(t `(,high))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux nil))
\f
-;;;; logical derive-type methods
+;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
;;; Return the maximum number of bits an integer of the supplied type
;;; can take up, or NIL if it is unbounded. The second (third) value
(or (null min) (minusp min))))
(values nil t t)))
-#!-sb-propagate-fun-type
-(progn
-
-(defoptimizer (logand derive-type) ((x y))
- (multiple-value-bind (x-len x-pos x-neg)
- (integer-type-length (continuation-type x))
- (declare (ignore x-pos))
- (multiple-value-bind (y-len y-pos y-neg)
- (integer-type-length (continuation-type y))
- (declare (ignore y-pos))
- (if (not x-neg)
- ;; X must be positive.
- (if (not y-neg)
- ;; The must both be positive.
- (cond ((or (null x-len) (null y-len))
- (specifier-type 'unsigned-byte))
- ((or (zerop x-len) (zerop y-len))
- (specifier-type '(integer 0 0)))
- (t
- (specifier-type `(unsigned-byte ,(min x-len y-len)))))
- ;; X is positive, but Y might be negative.
- (cond ((null x-len)
- (specifier-type 'unsigned-byte))
- ((zerop x-len)
- (specifier-type '(integer 0 0)))
- (t
- (specifier-type `(unsigned-byte ,x-len)))))
- ;; X might be negative.
- (if (not y-neg)
- ;; Y must be positive.
- (cond ((null y-len)
- (specifier-type 'unsigned-byte))
- ((zerop y-len)
- (specifier-type '(integer 0 0)))
- (t
- (specifier-type
- `(unsigned-byte ,y-len))))
- ;; Either might be negative.
- (if (and x-len y-len)
- ;; The result is bounded.
- (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
- ;; We can't tell squat about the result.
- (specifier-type 'integer)))))))
-
-(defoptimizer (logior derive-type) ((x y))
- (multiple-value-bind (x-len x-pos x-neg)
- (integer-type-length (continuation-type x))
- (multiple-value-bind (y-len y-pos y-neg)
- (integer-type-length (continuation-type y))
- (cond
- ((and (not x-neg) (not y-neg))
- ;; Both are positive.
- (specifier-type `(unsigned-byte ,(if (and x-len y-len)
- (max x-len y-len)
- '*))))
- ((not x-pos)
- ;; X must be negative.
- (if (not y-pos)
- ;; Both are negative. The result is going to be negative 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))
- ;; 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 (numeric-type-low (continuation-type x)) '*)
- -1))))
- (t
- ;; X might be either positive or negative.
- (if (not y-pos)
- ;; But Y is negative. The result will be negative.
- (specifier-type
- `(integer ,(or (numeric-type-low (continuation-type y)) '*)
- -1))
- ;; We don't know squat about either. It won't get any bigger.
- (if (and x-len y-len)
- ;; Bounded.
- (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
- ;; Unbounded.
- (specifier-type 'integer))))))))
-
-(defoptimizer (logxor derive-type) ((x y))
- (multiple-value-bind (x-len x-pos x-neg)
- (integer-type-length (continuation-type x))
- (multiple-value-bind (y-len y-pos y-neg)
- (integer-type-length (continuation-type y))
- (cond
- ((or (and (not x-neg) (not y-neg))
- (and (not x-pos) (not y-pos)))
- ;; Either both are negative or both are positive. 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)
- '*))))
- ((or (and (not x-pos) (not y-neg))
- (and (not y-neg) (not y-pos)))
- ;; Either X is negative and Y is positive of vice-versa. The
- ;; result will be negative.
- (specifier-type `(integer ,(if (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)))))
- (t
- (specifier-type 'integer))))))
-
-) ; PROGN
-
-#!+sb-propagate-fun-type
-(progn
-
(defun logand-derive-type-aux (x y &optional same-leaf)
(declare (ignore same-leaf))
(multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
'*)))))
((or (and (not x-pos) (not y-neg))
(and (not y-neg) (not y-pos)))
- ;; Either X is negative and Y is positive of vice-verca. The
+ ;; Either X is negative and Y is positive of vice-versa. The
;; result will be negative.
(specifier-type `(integer ,(if (and x-len y-len)
(ash -1 (max x-len y-len))
(t
(specifier-type 'integer))))))
-(macrolet ((frob (logfcn)
+(macrolet ((deffrob (logfcn)
(let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
`(defoptimizer (,logfcn derive-type) ((x y))
(two-arg-derive-type x y #',fcn-aux #',logfcn)))))
- ;; FIXME: DEF-FROB, not just FROB
- (frob logand)
- (frob logior)
- (frob logxor))
+ (deffrob logand)
+ (deffrob logior)
+ (deffrob logxor))
+\f
+;;;; miscellaneous derive-type methods
(defoptimizer (integer-length derive-type) ((x))
(let ((x-type (continuation-type x)))
(when (and (numeric-type-p x-type)
(csubtypep x-type (specifier-type 'integer)))
- ;; If the X is of type (INTEGER LO HI), then the integer-length
- ;; of X is (INTEGER (min lo hi) (max lo hi), basically. Be
+ ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
+ ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
;; careful about LO or HI being NIL, though. Also, if 0 is
;; contained in X, the lower bound is obviously 0.
(flet ((null-or-min (a b)
(when (ctypep 0 x-type)
(setf min-len 0))
(specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
-) ; PROGN
-\f
-;;;; miscellaneous derive-type methods
(defoptimizer (code-char derive-type) ((code))
(specifier-type 'base-char))
`(let ((,,temp ,,spec))
,,@body))))))
- (def-source-transform ldb (spec int)
+ (define-source-transform ldb (spec int)
(with-byte-specifier (size pos spec)
`(%ldb ,size ,pos ,int)))
- (def-source-transform dpb (newbyte spec int)
+ (define-source-transform dpb (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%dpb ,newbyte ,size ,pos ,int)))
- (def-source-transform mask-field (spec int)
+ (define-source-transform mask-field (spec int)
(with-byte-specifier (size pos spec)
`(%mask-field ,size ,pos ,int)))
- (def-source-transform deposit-field (newbyte spec int)
+ (define-source-transform deposit-field (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%deposit-field ,newbyte ,size ,pos ,int))))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer)))
(let ((size-high (numeric-type-high size)))
- (if (and size-high (<= size-high sb!vm:word-bits))
+ (if (and size-high (<= size-high sb!vm:n-word-bits))
(specifier-type `(unsigned-byte ,size-high))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn)))
(if (and size-high posn-high
- (<= (+ size-high posn-high) sb!vm:word-bits))
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
(specifier-type `(unsigned-byte ,(+ size-high posn-high)))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:word-bits))
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:word-bits))
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(logand (ash int (- posn))
- (ash ,(1- (ash 1 sb!vm:word-bits))
- (- size ,sb!vm:word-bits))))
+ (ash ,(1- (ash 1 sb!vm:n-word-bits))
+ (- size ,sb!vm:n-word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(logand int
- (ash (ash ,(1- (ash 1 sb!vm:word-bits))
- (- size ,sb!vm:word-bits))
+ (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
+ (- size ,sb!vm:n-word-bits))
posn)))
;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
(deftransform %dpb ((new size posn int)
*
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(deftransform %dpb ((new size posn int)
*
- (signed-byte #.sb!vm:word-bits))
+ (signed-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(deftransform %deposit-field ((new size posn int)
*
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(deftransform %deposit-field ((new size posn int)
*
- (signed-byte #.sb!vm:word-bits))
+ (signed-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
(if (and (constant-continuation-p x)
(not (constant-continuation-p y)))
- `(,(continuation-function-name (basic-combination-fun node))
+ `(,(continuation-fun-name (basic-combination-fun node))
y
,(continuation-value x))
(give-up-ir1-transform)))
(dolist (x '(= char= + * logior logand logxor))
(%deftransform x '(function * *) #'commutative-arg-swap
- "place constant arg last."))
+ "place constant arg last"))
;;; Handle the case of a constant BOOLE-CODE.
(deftransform boole ((op x y) * * :when :both)
(logand x ,mask)))))
\f
;;;; arithmetic and logical identity operation elimination
-;;;;
-;;;; Flush calls to various arith functions that convert to the
-;;;; identity function or a constant.
-
-(dolist (stuff '((ash 0 x)
- (logand -1 x)
- (logand 0 0)
- (logior 0 x)
- (logior -1 -1)
- (logxor -1 (lognot x))
- (logxor 0 x)))
- (destructuring-bind (name identity result) stuff
- (deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
- :eval-name t :when :both)
- "fold identity operations"
- result)))
+
+;;; Flush calls to various arith functions that convert to the
+;;; identity function or a constant.
+(macrolet ((def-frob (name identity result)
+ `(deftransform ,name ((x y) (* (constant-argument (member ,identity)))
+ * :when :both)
+ "fold identity operations"
+ ',result)))
+ (def-frob ash 0 x)
+ (def-frob logand -1 x)
+ (def-frob logand 0 0)
+ (def-frob logior 0 x)
+ (def-frob logior -1 -1)
+ (def-frob logxor -1 (lognot x))
+ (def-frob logxor 0 x))
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
'(%negate y))
(deftransform * ((x y) (rational (constant-argument (member 0))) *
:when :both)
- "convert (* x 0) to 0."
+ "convert (* x 0) to 0"
0)
;;; Return T if in an arithmetic op including continuations X and Y,
'x)
;;; Fold (OP x +/-1)
-(dolist (stuff '((* x (%negate x))
- (/ x (%negate x))
- (expt x (/ 1 x))))
- (destructuring-bind (name result minus-result) stuff
- (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t
- :when :both)
- "fold identity operations"
- (let ((val (continuation-value y)))
- (unless (and (= (abs val) 1)
- (not-more-contagious y x))
- (give-up-ir1-transform))
- (if (minusp val) minus-result result)))))
+(macrolet ((def-frob (name result minus-result)
+ `(deftransform ,name ((x y) (t (constant-argument real))
+ * :when :both)
+ "fold identity operations"
+ (let ((val (continuation-value y)))
+ (unless (and (= (abs val) 1)
+ (not-more-contagious y x))
+ (give-up-ir1-transform))
+ (if (minusp val) ',minus-result ',result)))))
+ (def-frob * x (%negate x))
+ (def-frob / x (%negate x))
+ (def-frob expt x (/ 1 x)))
;;; Fold (expt x n) into multiplications for small integral values of
;;; N; convert (expt x 1/2) to sqrt.
;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
;;; transformations?
;;; Perhaps we should have to prove that the denominator is nonzero before
-;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps
-;;; just FROB?) -- WHN 19990917
-;;;
-;;; FIXME: What gives with the single quotes in the argument lists
-;;; for DEFTRANSFORMs here? Does that work? Is it needed? Why?
-(dolist (name '(ash /))
- (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
- :eval-name t :when :both)
- "fold zero arg"
- 0))
-(dolist (name '(truncate round floor ceiling))
- (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
- :eval-name t :when :both)
- "fold zero arg"
- '(values 0 0)))
+;;; doing them? -- WHN 19990917
+(macrolet ((def-frob (name)
+ `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ 0)))
+ (def-frob ash)
+ (def-frob /))
+
+(macrolet ((def-frob (name)
+ `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ '(values 0 0))))
+ (def-frob truncate)
+ (def-frob round)
+ (def-frob floor)
+ (def-frob ceiling))
+
\f
;;;; character operations
(t
(give-up-ir1-transform))))
-(dolist (x '(eq char= equal))
- (%deftransform x '(function * *) #'simple-equality-transform))
+(macrolet ((def-frob (x)
+ `(%deftransform ',x '(function * *) #'simple-equality-transform)))
+ (def-frob eq)
+ (def-frob char=)
+ (def-frob equal))
-;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to
-;;; convert to a type-specific predicate or EQ:
+;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
+;;; try to convert to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than
;;; just converting to EQ, since CHAR= may have special compilation
;;; strategies for non-standard representations, etc.
;;; it second. These rules make it easier for the back end to match
;;; these interesting cases.
;;; -- If Y is a fixnum, then we quietly pass because the back end can
-;;; handle that case, otherwise give an efficency note.
+;;; handle that case, otherwise give an efficiency note.
(deftransform eql ((x y) * * :when :both)
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
;;;
;;; FIXME: Why should constant argument be second? It would be nice to
;;; find out and explain.
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
nil
`(,inverse y x))
(t
(give-up-ir1-transform))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
nil
(deftransform > ((x y) (integer integer) * :when :both)
(ir1-transform-< y x x y '<))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deftransform < ((x y) (float float) * :when :both)
(ir1-transform-< x y x y '>))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deftransform > ((x y) (float float) * :when :both)
(ir1-transform-< y x x y '<))
\f
((zerop i)
`((lambda ,vars ,result) . ,args)))))))
-(def-source-transform = (&rest args) (multi-compare '= args nil))
-(def-source-transform < (&rest args) (multi-compare '< args nil))
-(def-source-transform > (&rest args) (multi-compare '> args nil))
-(def-source-transform <= (&rest args) (multi-compare '> args t))
-(def-source-transform >= (&rest args) (multi-compare '< args t))
+(define-source-transform = (&rest args) (multi-compare '= args nil))
+(define-source-transform < (&rest args) (multi-compare '< args nil))
+(define-source-transform > (&rest args) (multi-compare '> args nil))
+(define-source-transform <= (&rest args) (multi-compare '> args t))
+(define-source-transform >= (&rest args) (multi-compare '< args t))
-(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
-(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
-(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
-(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
-(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
+(define-source-transform char= (&rest args) (multi-compare 'char= args nil))
+(define-source-transform char< (&rest args) (multi-compare 'char< args nil))
+(define-source-transform char> (&rest args) (multi-compare 'char> args nil))
+(define-source-transform char<= (&rest args) (multi-compare 'char> args t))
+(define-source-transform char>= (&rest args) (multi-compare 'char< args t))
-(def-source-transform char-equal (&rest args)
+(define-source-transform char-equal (&rest args)
(multi-compare 'char-equal args nil))
-(def-source-transform char-lessp (&rest args)
+(define-source-transform char-lessp (&rest args)
(multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args)
+(define-source-transform char-greaterp (&rest args)
(multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args)
+(define-source-transform char-not-greaterp (&rest args)
(multi-compare 'char-greaterp args t))
-(def-source-transform char-not-lessp (&rest args)
+(define-source-transform char-not-lessp (&rest args)
(multi-compare 'char-lessp args t))
;;; This function does source transformation of N-arg inequality
((= nargs 1) `(progn ,@args t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
- ((not (policy nil (and (>= speed space)
- (>= speed compilation-speed))))
+ ((not (policy *lexenv*
+ (and (>= speed space)
+ (>= speed compilation-speed))))
(values nil t))
(t
(let ((vars (make-gensym-list nargs)))
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
-(def-source-transform /= (&rest args) (multi-not-equal '= args))
-(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
-(def-source-transform char-not-equal (&rest args)
+(define-source-transform /= (&rest args) (multi-not-equal '= args))
+(define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
+(define-source-transform char-not-equal (&rest args)
(multi-not-equal 'char-equal args))
;;; Expand MAX and MIN into the obvious comparisons.
-(def-source-transform max (arg &rest more-args)
+(define-source-transform max (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(max ,@more-args)))
`(if (> ,arg1 ,arg2)
,arg1 ,arg2))))
-(def-source-transform min (arg &rest more-args)
+(define-source-transform min (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(t
(associate-arguments fun (first args) (rest args)))))
-(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
-(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
-(def-source-transform logior (&rest args)
+(define-source-transform + (&rest args)
+ (source-transform-transitive '+ args 0))
+(define-source-transform * (&rest args)
+ (source-transform-transitive '* args 1))
+(define-source-transform logior (&rest args)
(source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args)
+(define-source-transform logxor (&rest args)
(source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args)
+(define-source-transform logand (&rest args)
(source-transform-transitive 'logand args -1))
-(def-source-transform logeqv (&rest args)
+(define-source-transform logeqv (&rest args)
(if (evenp (length args))
`(lognot (logxor ,@args))
`(logxor ,@args)))
;;; because when they are given one argument, they return its absolute
;;; value.
-(def-source-transform gcd (&rest args)
+(define-source-transform gcd (&rest args)
(case (length args)
(0 0)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'gcd (first args) (rest args)))))
-(def-source-transform lcm (&rest args)
+(define-source-transform lcm (&rest args)
(case (length args)
(0 1)
(1 `(abs (the integer ,(first args))))
(1 `(,@inverse ,(first args)))
(t (associate-arguments function (first args) (rest args)))))
-(def-source-transform - (&rest args)
+(define-source-transform - (&rest args)
(source-transform-intransitive '- args '(%negate)))
-(def-source-transform / (&rest args)
+(define-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
\f
;;;; transforming APPLY
;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
;;; only needs to understand one kind of variable-argument call. It is
;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
-(def-source-transform apply (fun arg &rest more-args)
+(define-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
,@(mapcar #'(lambda (x)
(declare (ignore tee))
(funcall control *standard-output* ,@arg-names)
nil)))
+
+(defoptimizer (coerce derive-type) ((value type))
+ (let ((value-type (continuation-type value))
+ (type-type (continuation-type type)))
+ (labels
+ ((good-cons-type-p (cons-type)
+ ;; Make sure the cons-type we're looking at is something
+ ;; we're prepared to handle which is basically something
+ ;; that array-element-type can return.
+ (or (and (member-type-p cons-type)
+ (null (rest (member-type-members cons-type)))
+ (null (first (member-type-members cons-type))))
+ (let ((car-type (cons-type-car-type cons-type)))
+ (and (member-type-p car-type)
+ (null (rest (member-type-members car-type)))
+ (or (symbolp (first (member-type-members car-type)))
+ (numberp (first (member-type-members car-type)))
+ (and (listp (first (member-type-members car-type)))
+ (numberp (first (first (member-type-members
+ car-type))))))
+ (good-cons-type-p (cons-type-cdr-type cons-type))))))
+ (unconsify-type (good-cons-type)
+ ;; Convert the "printed" respresentation of a cons
+ ;; specifier into a type specifier. That is, the specifier
+ ;; (cons (eql signed-byte) (cons (eql 16) null)) is
+ ;; converted to (signed-byte 16).
+ (cond ((or (null good-cons-type)
+ (eq good-cons-type 'null))
+ nil)
+ ((and (eq (first good-cons-type) 'cons)
+ (eq (first (second good-cons-type)) 'member))
+ `(,(second (second good-cons-type))
+ ,@(unconsify-type (caddr good-cons-type))))))
+ (coerceable-p (c-type)
+ ;; Can the value be coerced to the given type? Coerce is
+ ;; complicated, so we don't handle every possible case
+ ;; here---just the most common and easiest cases:
+ ;;
+ ;; o Any real can be coerced to a float type.
+ ;; o Any number can be coerced to a complex single/double-float.
+ ;; o An integer can be coerced to an integer.
+ (let ((coerced-type c-type))
+ (or (and (subtypep coerced-type 'float)
+ (csubtypep value-type (specifier-type 'real)))
+ (and (subtypep coerced-type
+ '(or (complex single-float)
+ (complex double-float)))
+ (csubtypep value-type (specifier-type 'number)))
+ (and (subtypep coerced-type 'integer)
+ (csubtypep value-type (specifier-type 'integer))))))
+ (process-types (type)
+ ;; FIXME:
+ ;; This needs some work because we should be able to derive
+ ;; the resulting type better than just the type arg of
+ ;; coerce. That is, if x is (integer 10 20), the (coerce x
+ ;; 'double-float) should say (double-float 10d0 20d0)
+ ;; instead of just double-float.
+ (cond ((member-type-p type)
+ (let ((members (member-type-members type)))
+ (if (every #'coerceable-p members)
+ (specifier-type `(or ,@members))
+ *universal-type*)))
+ ((and (cons-type-p type)
+ (good-cons-type-p type))
+ (let ((c-type (unconsify-type (type-specifier type))))
+ (if (coerceable-p c-type)
+ (specifier-type c-type)
+ *universal-type*)))
+ (t
+ *universal-type*))))
+ (cond ((union-type-p type-type)
+ (apply #'type-union (mapcar #'process-types
+ (union-type-types type-type))))
+ ((or (member-type-p type-type)
+ (cons-type-p type-type))
+ (process-types type-type))
+ (t
+ *universal-type*)))))
+
+(defoptimizer (array-element-type derive-type) ((array))
+ (let* ((array-type (continuation-type array)))
+ (labels ((consify (list)
+ (if (endp list)
+ '(eql nil)
+ `(cons (eql ,(car list)) ,(consify (rest list)))))
+ (get-element-type (a)
+ (let ((element-type
+ (type-specifier (array-type-specialized-element-type a))))
+ (cond ((eq element-type '*)
+ (specifier-type 'type-specifier))
+ ((symbolp element-type)
+ (make-member-type :members (list element-type)))
+ ((consp element-type)
+ (specifier-type (consify element-type)))
+ (t
+ (error "can't understand type ~S~%" element-type))))))
+ (cond ((array-type-p array-type)
+ (get-element-type array-type))
+ ((union-type-p array-type)
+ (apply #'type-union
+ (mapcar #'get-element-type (union-type-types array-type))))
+ (t
+ *universal-type*)))))
\f
;;;; debuggers' little helpers
projects / sbcl.git / blobdiff