(def-source-transform not (x) `(if ,x nil t))
(def-source-transform null (x) `(if ,x nil t))
-;;; ENDP is just NULL with a LIST assertion.
+;;; 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)))
-;;; FIXME: Is THE LIST a strong enough assertion for ANSI's "should
-;;; return an error"? (THE LIST is optimized away when safety is low;
-;;; does that satisfy the spec?)
;;; 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
(def-source-transform values (x) `(prog1 ,x))
;;; Bind the values and make a closure that returns them.
-(def-source-transform constantly (value &rest values)
- (let ((temps (make-gensym-list (1+ (length values))))
- (dum (gensym)))
- `(let ,(loop for temp in temps and
- value in (list* value values)
- collect `(,temp ,value))
- #'(lambda (&rest ,dum)
- (declare (ignore ,dum))
- (values ,@temps)))))
+(def-source-transform constantly (value)
+ (let ((rest (gensym "CONSTANTLY-REST-")))
+ `(lambda (&rest ,rest)
+ (declare (ignore ,rest))
+ ,value)))
;;; If the function has a known number of arguments, then return a
;;; lambda with the appropriate fixed number of args. If the
;;; 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.
-(defstruct (interval
- (:constructor %make-interval))
+(defstruct (interval (:constructor %make-interval)
+ (:copier nil))
low high)
(defun make-interval (&key low high)
(t
type-list)))
-;;; Make-Canonical-Union-Type
-;;;
;;; Take a list of types and return a canonical type specifier,
-;;; combining any members types together. If both positive and
-;;; negative members types are present they are converted to a float
-;;; type. X This would be far simpler if the type-union methods could
+;;; combining any MEMBER types together. If both positive and
+;;; negative MEMBER types are present they are converted to a float
+;;; type. XXX This would be far simpler if the type-union methods could
;;; handle member/number unions.
(defun make-canonical-union-type (type-list)
(let ((members '())
) ; PROGN
+
+;;; ASH derive type optimizer
+;;;
+;;; 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.
+;;;
;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
(progn
#!-propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
+ (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))
(make-numeric-type :class 'integer
:complexp :real)))))))))
*universal-type*))
+
#!+propagate-fun-type
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
- (or (and (csubtypep n-type (specifier-type 'integer))
- (csubtypep shift (specifier-type 'integer))
- (let ((n-low (numeric-type-low n-type))
- (n-high (numeric-type-high n-type))
- (s-low (numeric-type-low shift))
- (s-high (numeric-type-high shift)))
- ;; KLUDGE: The bare 64's here should be related to
- ;; symbolic machine word size values somehow.
- (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*))
+ (flet ((ash-outer (n s)
+ (when (and (fixnump s)
+ (<= s 64)
+ (> s sb!vm:*target-most-negative-fixnum*))
+ (ash n s)))
+ ;; KLUDGE: The bare 64's here should be related to
+ ;; symbolic machine word size values somehow.
+
+ (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 (and (csubtypep n-type (specifier-type 'integer))
+ (csubtypep shift (specifier-type 'integer))
+ (let ((n-low (numeric-type-low n-type))
+ (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-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))))))
+ *universal-type*)))
+
#!+propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
;;;; functions into boolean operations when the size and position are constant
;;;; and the operands are fixnums.
-(macrolet (;; Evaluate body with Size-Var and Pos-Var bound to expressions that
- ;; evaluate to the Size and Position of the byte-specifier form
- ;; Spec. We may wrap a let around the result of the body to bind
+(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to expressions that
+ ;; evaluate to the SIZE and POSITION of the byte-specifier form
+ ;; SPEC. We may wrap a let around the result of the body to bind
;; some variables.
;;
- ;; If the spec is a Byte form, then bind the vars to the subforms.
- ;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position.
+ ;; If the spec is a BYTE form, then bind the vars to the subforms.
+ ;; otherwise, evaluate SPEC and use the BYTE-SIZE and BYTE-POSITION.
;; The goal of this transformation is to avoid consing up byte
;; specifiers and then immediately throwing them away.
(with-byte-specifier ((size-var pos-var spec) &body body)
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(logand (ash int (- posn))
(ash ,(1- (ash 1 sb!vm:word-bits))
(- size ,sb!vm:word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(logand int
(ash (ash ,(1- (ash 1 sb!vm:word-bits))
(- size ,sb!vm:word-bits))
(deftransform %dpb ((new size posn int)
*
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %dpb ((new size posn int)
*
(signed-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %deposit-field ((new size posn int)
*
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
(deftransform %deposit-field ((new size posn int)
*
(signed-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
;;; Handle the case of a constant BOOLE-CODE.
(deftransform boole ((op x y) * * :when :both)
- "convert to inline logical ops"
+ "convert to inline logical operations"
(unless (constant-continuation-p op)
(give-up-ir1-transform "BOOLE code is not a constant."))
(let ((control (continuation-value op)))
;;; 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)
;;; If X and Y are the same leaf, then the result is true. Otherwise, if
;;; there is no intersection between the types of the arguments, then the
;;; result is definitely false.
-(deftransform simple-equality-transform ((x y) * * :defun-only t
+(deftransform simple-equality-transform ((x y) * *
+ :defun-only t
:when :both)
(cond ((same-leaf-ref-p x y)
't)
(dolist (x '(eq char= equal))
(%deftransform x '(function * *) #'simple-equality-transform))
-;;; 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.
-;;; -- If either arg is definitely not a number, then we can compare with EQ.
-;;; -- Otherwise, we try to put the arg we know more about second. If X is
-;;; constant then we put it second. If X is a subtype of Y, we put 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.
+;;; 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.
+;;; -- If either arg is definitely not a number, then we can compare
+;;; with EQ.
+;;; -- Otherwise, we try to put the arg we know more about second. If X
+;;; is constant then we put it second. If X is a subtype of Y, we put
+;;; 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.
(deftransform eql ((x y) * * :when :both)
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
+(def-source-transform char-greaterp (&rest args)
+ (multi-compare 'char-greaterp args nil))
+(def-source-transform char-not-greaterp (&rest args)
+ (multi-compare 'char-greaterp args t))
(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
;;; This function does source transformation of N-arg inequality
;;; Do source transformations for transitive functions such as +.
;;; One-arg cases are replaced with the arg and zero arg cases with
-;;; the identity. If Leaf-Fun is true, then replace two-arg calls with
+;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
;;; a call to that function.
(defun source-transform-transitive (fun args identity &optional leaf-fun)
(declare (symbol fun leaf-fun) (list 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) (source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
+(def-source-transform logior (&rest args)
+ (source-transform-transitive 'logior args 0))
+(def-source-transform logxor (&rest args)
+ (source-transform-transitive 'logxor args 0))
+(def-source-transform logand (&rest args)
+ (source-transform-transitive 'logand args -1))
(def-source-transform logeqv (&rest args)
(if (evenp (length args))
projects / sbcl.git / blobdiff