;;; Make source transforms to turn CxR forms into combinations of CAR
;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
;;; defined.
+;;; Don't transform CAD*R, they are treated specially for &more args
+;;; optimizations
+
(/show0 "about to set CxR source transforms")
(loop for i of-type index from 2 upto 4 do
;; Iterate over BUF = all names CxR where x = an I-element
(declare (type index k))
(setf (aref buf (1+ k))
(if (logbitp k j) #\A #\D)))
- (setf (info :function :source-transform (intern buf))
- #'source-transform-cxr))))
+ (unless (member buf '("CADR" "CADDR" "CADDDR")
+ :test #'equal)
+ (setf (info :function :source-transform (intern buf))
+ #'source-transform-cxr)))))
(/show0 "done setting CxR source transforms")
;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
;;; Nth, which can be expanded into a CAR/CDR later on if policy
;;; favors it.
(define-source-transform rest (x) `(cdr ,x))
+(define-source-transform first (x) `(car ,x))
(define-source-transform second (x) `(cadr ,x))
(define-source-transform third (x) `(caddr ,x))
(define-source-transform fourth (x) `(cadddr ,x))
(1 `(cons ,(first args) nil))
(t (values nil t))))
+(defoptimizer (list derive-type) ((&rest args) node)
+ (if args
+ (specifier-type 'cons)
+ (specifier-type 'null)))
+
;;; And similarly for LIST*.
(define-source-transform list* (arg &rest others)
(cond ((not others) arg)
(specifier-type 'cons)
(lvar-type arg)))
+;;;
+
+(define-source-transform nconc (&rest args)
+ (case (length args)
+ (0 ())
+ (1 (car args))
+ (t (values nil t))))
+
+;;; (append nil nil nil fixnum) => fixnum
+;;; (append x x cons x x) => cons
+;;; (append x x x x list) => list
+;;; (append x x x x sequence) => sequence
+;;; (append fixnum x ...) => nil
+(defun derive-append-type (args)
+ (cond ((not args)
+ (specifier-type 'null))
+ (t
+ (let ((cons-type (specifier-type 'cons))
+ (null-type (specifier-type 'null))
+ (list-type (specifier-type 'list))
+ (last (lvar-type (car (last args)))))
+ (or
+ ;; Check that all but the last arguments are lists first
+ (loop for (arg next) on args
+ while next
+ do
+ (let ((lvar-type (lvar-type arg)))
+ (unless (or (csubtypep list-type lvar-type)
+ (csubtypep lvar-type list-type)
+ ;; Check for NIL specifically, because
+ ;; SYMBOL or ATOM won't satisfie the above
+ (csubtypep null-type lvar-type))
+ (assert-lvar-type arg list-type
+ (lexenv-policy *lexenv*))
+ (return *empty-type*))))
+ (loop with all-nil = t
+ for (arg next) on args
+ for lvar-type = (lvar-type arg)
+ while next
+ do
+ (cond
+ ;; Cons in the middle guarantees the result will be a cons
+ ((csubtypep lvar-type cons-type)
+ (return cons-type))
+ ;; If all but the last are NIL the type of the last arg
+ ;; can be used
+ ((csubtypep lvar-type null-type))
+ (all-nil
+ (setf all-nil nil)))
+ finally
+ (return
+ (cond (all-nil
+ last)
+ ((csubtypep last cons-type)
+ cons-type)
+ ((csubtypep last list-type)
+ list-type)
+ ;; If the last is SEQUENCE (or similar) it'll
+ ;; be either that sequence or a cons, which is a
+ ;; sequence
+ ((csubtypep list-type last)
+ last)))))))))
+
+(defoptimizer (append derive-type) ((&rest args))
+ (derive-append-type args))
+
+(defoptimizer (sb!impl::append2 derive-type) ((&rest args))
+ (derive-append-type args))
+
+(defoptimizer (nconc derive-type) ((&rest args))
+ (derive-append-type args))
+
;;; Translate RPLACx to LET and SETF.
(define-source-transform rplaca (x y)
(once-only ((n-x x))
;;; on the argument types), but we make it a regular transform so that
;;; the VM has a chance to see the bare LOGTEST and potentiall choose
;;; to implement it differently. --njf, 06-02-2006
-(deftransform logtest ((x y) * *)
- `(not (zerop (logand x y))))
+;;;
+;;; Other transforms may be useful even with direct LOGTEST VOPs; let
+;;; them fire (including the type-directed constant folding below), but
+;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
+(deftransform logtest ((x y) * * :node node)
+ (let ((type (two-arg-derive-type x y
+ #'logand-derive-type-aux
+ #'logand)))
+ (multiple-value-bind (typep definitely)
+ (ctypep 0 type)
+ (cond ((and (not typep) definitely)
+ t)
+ ((type= type (specifier-type '(eql 0)))
+ nil)
+ ((neq :default (combination-implementation-style node))
+ (give-up-ir1-transform))
+ (t
+ `(not (zerop (logand x y))))))))
(deftransform logbitp
((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
(defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux nil))
\f
-;;;; 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
-;;; is T if the integer can be positive (negative) and NIL if not.
-;;; Zero counts as positive.
-(defun integer-type-length (type)
- (if (numeric-type-p type)
- (let ((min (numeric-type-low type))
- (max (numeric-type-high type)))
- (values (and min max (max (integer-length min) (integer-length max)))
- (or (null max) (not (minusp max)))
- (or (null min) (minusp min))))
- (values nil t t)))
-
-;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
-;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
-;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
-;;; versions in CMUCL, from which these functions copy liberally.
-
-(defun logand-derive-unsigned-low-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
- until (zerop m) do
- (unless (zerop (logand m (lognot a) (lognot c)))
- (let ((temp (logandc2 (logior a m) (1- m))))
- (when (<= temp b)
- (setf a temp)
- (loop-finish))
- (setf temp (logandc2 (logior c m) (1- m)))
- (when (<= temp d)
- (setf c temp)
- (loop-finish))))
- finally (return (logand a c)))))
-
-(defun logand-derive-unsigned-high-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
- until (zerop m) do
- (cond
- ((not (zerop (logand b (lognot d) m)))
- (let ((temp (logior (logandc2 b m) (1- m))))
- (when (>= temp a)
- (setf b temp)
- (loop-finish))))
- ((not (zerop (logand (lognot b) d m)))
- (let ((temp (logior (logandc2 d m) (1- m))))
- (when (>= temp c)
- (setf d temp)
- (loop-finish)))))
- finally (return (logand b d)))))
-
-(defun logand-derive-type-aux (x y &optional same-leaf)
- (when same-leaf
- (return-from logand-derive-type-aux x))
- (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
- (declare (ignore x-pos))
- (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
- (declare (ignore y-pos))
- (if (not x-neg)
- ;; X must be positive.
- (if (not y-neg)
- ;; They must both be positive.
- (cond ((and (null x-len) (null y-len))
- (specifier-type 'unsigned-byte))
- ((null x-len)
- (specifier-type `(unsigned-byte* ,y-len)))
- ((null y-len)
- (specifier-type `(unsigned-byte* ,x-len)))
- (t
- (let ((low (logand-derive-unsigned-low-bound x y))
- (high (logand-derive-unsigned-high-bound x y)))
- (specifier-type `(integer ,low ,high)))))
- ;; X is positive, but Y might be negative.
- (cond ((null x-len)
- (specifier-type 'unsigned-byte))
- (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))
- (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)))))))
-
-(defun logior-derive-unsigned-low-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
- until (zerop m) do
- (cond
- ((not (zerop (logandc2 (logand c m) a)))
- (let ((temp (logand (logior a m) (1+ (lognot m)))))
- (when (<= temp b)
- (setf a temp)
- (loop-finish))))
- ((not (zerop (logandc2 (logand a m) c)))
- (let ((temp (logand (logior c m) (1+ (lognot m)))))
- (when (<= temp d)
- (setf c temp)
- (loop-finish)))))
- finally (return (logior a c)))))
-
-(defun logior-derive-unsigned-high-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
- until (zerop m) do
- (unless (zerop (logand b d m))
- (let ((temp (logior (- b m) (1- m))))
- (when (>= temp a)
- (setf b temp)
- (loop-finish))
- (setf temp (logior (- d m) (1- m)))
- (when (>= temp c)
- (setf d temp)
- (loop-finish))))
- finally (return (logior b d)))))
-
-(defun logior-derive-type-aux (x y &optional same-leaf)
- (when same-leaf
- (return-from logior-derive-type-aux x))
- (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
- (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
- (cond
- ((and (not x-neg) (not y-neg))
- ;; Both are positive.
- (if (and x-len y-len)
- (let ((low (logior-derive-unsigned-low-bound x y))
- (high (logior-derive-unsigned-high-bound x y)))
- (specifier-type `(integer ,low ,high)))
- (specifier-type `(unsigned-byte* *))))
- ((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 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 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))))))))
-
-(defun logxor-derive-unsigned-low-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
- until (zerop m) do
- (cond
- ((not (zerop (logandc2 (logand c m) a)))
- (let ((temp (logand (logior a m)
- (1+ (lognot m)))))
- (when (<= temp b)
- (setf a temp))))
- ((not (zerop (logandc2 (logand a m) c)))
- (let ((temp (logand (logior c m)
- (1+ (lognot m)))))
- (when (<= temp d)
- (setf c temp)))))
- finally (return (logxor a c)))))
-
-(defun logxor-derive-unsigned-high-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
- until (zerop m) do
- (unless (zerop (logand b d m))
- (let ((temp (logior (- b m) (1- m))))
- (cond
- ((>= temp a) (setf b temp))
- (t (let ((temp (logior (- d m) (1- m))))
- (when (>= temp c)
- (setf d temp)))))))
- finally (return (logxor b d)))))
-
-(defun logxor-derive-type-aux (x y &optional same-leaf)
- (when same-leaf
- (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
- (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
- (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
- (cond
- ((and (not x-neg) (not y-neg))
- ;; Both are positive
- (if (and x-len y-len)
- (let ((low (logxor-derive-unsigned-low-bound x y))
- (high (logxor-derive-unsigned-high-bound x y)))
- (specifier-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)
- '*))))
- ((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)))
- ;; 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))))))
-
-(macrolet ((deffrob (logfun)
- (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
- `(defoptimizer (,logfun derive-type) ((x y))
- (two-arg-derive-type x y #',fun-aux #',logfun)))))
- (deffrob logand)
- (deffrob logior)
- (deffrob logxor))
-
-(defoptimizer (logeqv derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (lognot-derive-type-aux
- (logxor-derive-type-aux x y same-leaf)))
- #'logeqv))
-(defoptimizer (lognand derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (lognot-derive-type-aux
- (logand-derive-type-aux x y same-leaf)))
- #'lognand))
-(defoptimizer (lognor derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (lognot-derive-type-aux
- (logior-derive-type-aux x y same-leaf)))
- #'lognor))
-(defoptimizer (logandc1 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql 0))
- (logand-derive-type-aux
- (lognot-derive-type-aux x) y nil)))
- #'logandc1))
-(defoptimizer (logandc2 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql 0))
- (logand-derive-type-aux
- x (lognot-derive-type-aux y) nil)))
- #'logandc2))
-(defoptimizer (logorc1 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql -1))
- (logior-derive-type-aux
- (lognot-derive-type-aux x) y nil)))
- #'logorc1))
-(defoptimizer (logorc2 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql -1))
- (logior-derive-type-aux
- x (lognot-derive-type-aux y) nil)))
- #'logorc2))
-\f
;;;; miscellaneous derive-type methods
(defoptimizer (integer-length derive-type) ((x))
(specifier-type `(signed-byte ,size-high))
*universal-type*))
*universal-type*)))
+\f
+;;; Rightward ASH
+#!+ash-right-vops
+(progn
+ (defun %ash/right (integer amount)
+ (ash integer (- amount)))
+
+ (deftransform ash ((integer amount) (sb!vm:signed-word (integer * 0)))
+ "Convert ASH of signed word to %ASH/RIGHT"
+ (when (constant-lvar-p amount)
+ (give-up-ir1-transform))
+ (let ((use (lvar-uses amount)))
+ (cond ((and (combination-p use)
+ (eql '%negate (lvar-fun-name (combination-fun use))))
+ (splice-fun-args amount '%negate 1)
+ `(lambda (integer amount)
+ (declare (type unsigned-byte amount))
+ (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
+ ,(1- sb!vm:n-word-bits)
+ amount))))
+ (t
+ `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
+ ,(1- sb!vm:n-word-bits)
+ (- amount)))))))
+
+ (deftransform ash ((integer amount) (word (integer * 0)))
+ "Convert ASH of word to %ASH/RIGHT"
+ (when (constant-lvar-p amount)
+ (give-up-ir1-transform))
+ (let ((use (lvar-uses amount)))
+ (cond ((and (combination-p use)
+ (eql '%negate (lvar-fun-name (combination-fun use))))
+ (splice-fun-args amount '%negate 1)
+ `(lambda (integer amount)
+ (declare (type unsigned-byte amount))
+ (if (>= amount ,sb!vm:n-word-bits)
+ 0
+ (%ash/right integer amount))))
+ (t
+ `(if (<= amount ,(- sb!vm:n-word-bits))
+ 0
+ (%ash/right integer (- amount)))))))
+
+ (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
+ "Convert %ASH/RIGHT by constant back to ASH"
+ `(ash integer ,(- (lvar-value amount))))
+
+ (deftransform %ash/right ((integer amount) * * :node node)
+ "strength reduce large variable right shift"
+ (let ((return-type (single-value-type (node-derived-type node))))
+ (cond ((type= return-type (specifier-type '(eql 0)))
+ 0)
+ ((type= return-type (specifier-type '(eql -1)))
+ -1)
+ ((csubtypep return-type (specifier-type '(member -1 0)))
+ `(ash integer ,(- sb!vm:n-word-bits)))
+ (t
+ (give-up-ir1-transform)))))
+ (defun %ash/right-derive-type-aux (n-type shift same-arg)
+ (declare (ignore same-arg))
+ (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word))
+ (csubtypep n-type (specifier-type 'word)))
+ (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits)))
+ (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 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)))))))
+ *universal-type*))
+
+ (defoptimizer (%ash/right derive-type) ((n shift))
+ (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))
+ )
\f
;;; Modular functions
(setf (block-reoptimize (node-block node)) t)
(reoptimize-component (node-component node) :maybe))
(cut-node (node &aux did-something)
- (when (and (not (block-delete-p (node-block node)))
- (ref-p node)
- (constant-p (ref-leaf node)))
- (let* ((constant-value (constant-value (ref-leaf node)))
- (new-value (if signedp
- (mask-signed-field width constant-value)
- (ldb (byte width 0) constant-value))))
- (unless (= constant-value new-value)
- (change-ref-leaf node (make-constant new-value))
- (setf (lvar-%derived-type (node-lvar node)) (make-values-type :required (list (ctype-of new-value))))
- (setf (block-reoptimize (node-block node)) t)
- (reoptimize-component (node-component node) :maybe)
- (return-from cut-node t))))
- (when (and (not (block-delete-p (node-block node)))
- (combination-p node)
- (eq (basic-combination-kind node) :known))
- (let* ((fun-ref (lvar-use (combination-fun node)))
- (fun-name (leaf-source-name (ref-leaf fun-ref)))
- (modular-fun (find-modular-version fun-name kind signedp width)))
- (when (and modular-fun
- (not (and (eq fun-name 'logand)
- (csubtypep
- (single-value-type (node-derived-type node))
- type))))
- (binding* ((name (etypecase modular-fun
- ((eql :good) fun-name)
- (modular-fun-info
- (modular-fun-info-name modular-fun))
- (function
- (funcall modular-fun node width)))
- :exit-if-null))
- (unless (eql modular-fun :good)
- (setq did-something t)
- (change-ref-leaf
- fun-ref
- (find-free-fun name "in a strange place"))
- (setf (combination-kind node) :full))
- (unless (functionp modular-fun)
- (dolist (arg (basic-combination-args node))
- (when (cut-lvar arg)
- (setq did-something t))))
- (when did-something
- (reoptimize-node node name))
- did-something)))))
+ (when (block-delete-p (node-block node))
+ (return-from cut-node))
+ (typecase node
+ (ref
+ (typecase (ref-leaf node)
+ (constant
+ (let* ((constant-value (constant-value (ref-leaf node)))
+ (new-value (if signedp
+ (mask-signed-field width constant-value)
+ (ldb (byte width 0) constant-value))))
+ (unless (= constant-value new-value)
+ (change-ref-leaf node (make-constant new-value)
+ :recklessly t)
+ (let ((lvar (node-lvar node)))
+ (setf (lvar-%derived-type lvar)
+ (and (lvar-has-single-use-p lvar)
+ (make-values-type :required (list (ctype-of new-value))))))
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe)
+ t)))
+ (lambda-var
+ (binding* ((dest (lvar-dest lvar) :exit-if-null)
+ (nil (combination-p dest) :exit-if-null)
+ (name (lvar-fun-name (combination-fun dest))))
+ ;; we're about to insert an m-s-f/logand between a ref to
+ ;; a variable and another m-s-f/logand. No point in doing
+ ;; that; the parent m-s-f/logand was already cut to width
+ ;; anyway.
+ (unless (or (cond (signedp
+ (and (eql name 'mask-signed-field)
+ (eql lvar (second
+ (combination-args
+ dest)))))
+ (t
+ (eql name 'logand)))
+ (csubtypep (lvar-type lvar) type))
+ (filter-lvar lvar
+ (if signedp
+ `(mask-signed-field ,width 'dummy)
+ `(logand 'dummy ,(ldb (byte width 0) -1))))
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe)
+ t)))))
+ (combination
+ (when (eq (basic-combination-kind node) :known)
+ (let* ((fun-ref (lvar-use (combination-fun node)))
+ (fun-name (lvar-fun-name (combination-fun node)))
+ (modular-fun (find-modular-version fun-name kind
+ signedp width)))
+ (when (and modular-fun
+ (not (and (eq fun-name 'logand)
+ (csubtypep
+ (single-value-type (node-derived-type node))
+ type))))
+ (binding* ((name (etypecase modular-fun
+ ((eql :good) fun-name)
+ (modular-fun-info
+ (modular-fun-info-name modular-fun))
+ (function
+ (funcall modular-fun node width)))
+ :exit-if-null))
+ (unless (eql modular-fun :good)
+ (setq did-something t)
+ (change-ref-leaf
+ fun-ref
+ (find-free-fun name "in a strange place"))
+ (setf (combination-kind node) :full))
+ (unless (functionp modular-fun)
+ (dolist (arg (basic-combination-args node))
+ (when (cut-lvar arg)
+ (setq did-something t))))
+ (when did-something
+ (reoptimize-node node name))
+ did-something)))))))
(cut-lvar (lvar &aux did-something)
(do-uses (node lvar)
(when (cut-node node)
(when (and (numberp low) (numberp high))
(let ((width (max (integer-length high) (integer-length low))))
(multiple-value-bind (w kind)
- (best-modular-version width t)
+ (best-modular-version (1+ width) t)
(when w
;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
;; [ see comment above in LOGAND optimizer ]
(if (and (constant-lvar-p x)
(not (constant-lvar-p y)))
`(,(lvar-fun-name (basic-combination-fun node))
- y
+ (truly-the ,(lvar-type y) y)
,(lvar-value x))
(give-up-ir1-transform)))
-(dolist (x '(= char= + * logior logand logxor))
+(dolist (x '(= char= + * logior logand logxor logtest))
(%deftransform x '(function * *) #'commutative-arg-swap
"place constant arg last"))
(give-up-ir1-transform))
'x))
+;;; Pick off easy association opportunities for constant folding.
+;;; More complicated stuff that also depends on commutativity
+;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
+;;; probably be handled with a more general tree-rewriting pass.
+(macrolet ((def (operator &key (type 'integer) (folded operator))
+ `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
+ ,(format nil "associate ~A/~A of constants"
+ operator folded)
+ (binding* ((node (if (lvar-has-single-use-p x)
+ (lvar-use x)
+ (give-up-ir1-transform)))
+ (nil (or (and (combination-p node)
+ (eq (lvar-fun-name
+ (combination-fun node))
+ ',folded))
+ (give-up-ir1-transform)))
+ (y (second (combination-args node)))
+ (nil (or (constant-lvar-p y)
+ (give-up-ir1-transform)))
+ (y (lvar-value y)))
+ (unless (typep y ',type)
+ (give-up-ir1-transform))
+ (splice-fun-args x ',folded 2)
+ `(lambda (x y z)
+ (declare (ignore y z))
+ (,',operator x ',(,folded y (lvar-value z))))))))
+ (def logand)
+ (def logior)
+ (def logxor)
+ (def logtest :folded logand)
+ (def + :type rational)
+ (def * :type rational))
+
+(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
+ "Fold mask-signed-field/mask-signed-field of constant width"
+ (binding* ((node (if (lvar-has-single-use-p x)
+ (lvar-use x)
+ (give-up-ir1-transform)))
+ (nil (or (combination-p node)
+ (give-up-ir1-transform)))
+ (nil (or (eq (lvar-fun-name (combination-fun node))
+ 'mask-signed-field)
+ (give-up-ir1-transform)))
+ (x-width (first (combination-args node)))
+ (nil (or (constant-lvar-p x-width)
+ (give-up-ir1-transform)))
+ (x-width (lvar-value x-width)))
+ (unless (typep x-width 'unsigned-byte)
+ (give-up-ir1-transform))
+ (splice-fun-args x 'mask-signed-field 2)
+ `(lambda (width x-width x)
+ (declare (ignore width x-width))
+ (mask-signed-field ,(min (lvar-value width) x-width) x))))
+
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
"convert (* x 0) to 0"
0)
+(deftransform %negate ((x) (rational))
+ "Eliminate %negate/%negate of rationals"
+ (splice-fun-args x '%negate 1)
+ '(the rational x))
+
+(deftransform %negate ((x) (number))
+ "Combine %negate/*"
+ (let ((use (lvar-uses x))
+ arg)
+ (unless (and (combination-p use)
+ (eql '* (lvar-fun-name (combination-fun use)))
+ (constant-lvar-p (setf arg (second (combination-args use))))
+ (numberp (setf arg (lvar-value arg))))
+ (give-up-ir1-transform))
+ (splice-fun-args x '* 2)
+ `(lambda (x y)
+ (declare (ignore y))
+ (* x ,(- arg)))))
+
;;; Return T if in an arithmetic op including lvars X and Y, the
;;; result type is not affected by the type of X. That is, Y is at
;;; least as contagious as X.
((and (csubtypep x-type char-type)
(csubtypep y-type char-type))
'(char= x y))
- ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
- (commutative-arg-swap node))
((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
- '(eq x y))
+ (if (and (constant-lvar-p x) (not (constant-lvar-p y)))
+ '(eq y x)
+ '(eq x y)))
((and (not (constant-lvar-p y))
(or (constant-lvar-p x)
(and (csubtypep x-type y-type)
`(car (nthcdr ,n ,list)))))
(define-source-transform elt (seq n)
- (multiple-value-bind (context count) (possible-rest-arg-context seq)
- (if context
- `(%rest-ref ,n ,seq ,context ,count)
- (values nil t))))
+ (if (policy *lexenv* (= safety 3))
+ (values nil t)
+ (multiple-value-bind (context count) (possible-rest-arg-context seq)
+ (if context
+ `(%rest-ref ,n ,seq ,context ,count)
+ (values nil t)))))
-;;; CAR -> %REST-REF
-(defun source-transform-car (list)
+;;; CAxR -> %REST-REF
+(defun source-transform-car (list nth)
(multiple-value-bind (context count) (possible-rest-arg-context list)
(if context
- `(%rest-ref 0 ,list ,context ,count)
+ `(%rest-ref ,nth ,list ,context ,count)
(values nil t))))
-(define-source-transform car (list) (source-transform-car list))
-(define-source-transform first (list) (source-transform-car list))
+
+(define-source-transform car (list)
+ (source-transform-car list 0))
+
+(define-source-transform cadr (list)
+ (or (source-transform-car list 1)
+ `(car (cdr ,list))))
+
+(define-source-transform caddr (list)
+ (or (source-transform-car list 2)
+ `(car (cdr (cdr ,list)))))
+
+(define-source-transform cadddr (list)
+ (or (source-transform-car list 3)
+ `(car (cdr (cdr (cdr ,list))))))
;;; LENGTH -> %REST-LENGTH
(defun source-transform-length (list)
(deftransform %rest-ref ((n list context count))
(cond ((rest-var-more-context-ok list)
- `(%more-arg context n))
+ `(and (< (the index n) count)
+ (%more-arg context n)))
((and (constant-lvar-p n) (zerop (lvar-value n)))
`(car list))
(t
(policy-quality-name-p (lvar-value quality-name)))
(give-up-ir1-transform))
'(%policy-quality policy quality-name))
+\f
+(deftransform encode-universal-time
+ ((second minute hour date month year &optional time-zone)
+ ((constant-arg (mod 60)) (constant-arg (mod 60))
+ (constant-arg (mod 24))
+ (constant-arg (integer 1 31))
+ (constant-arg (integer 1 12))
+ (constant-arg (integer 1899))
+ (constant-arg (rational -24 24))))
+ (let ((second (lvar-value second))
+ (minute (lvar-value minute))
+ (hour (lvar-value hour))
+ (date (lvar-value date))
+ (month (lvar-value month))
+ (year (lvar-value year))
+ (time-zone (lvar-value time-zone)))
+ (if (zerop (rem time-zone 1/3600))
+ (encode-universal-time second minute hour date month year time-zone)
+ (give-up-ir1-transform))))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
+ `(sb!unix:nanosleep seconds 0))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((constant-arg (real 0))))
+ (let ((seconds-value (lvar-value seconds)))
+ (multiple-value-bind (seconds nano)
+ (sb!impl::split-seconds-for-sleep seconds-value)
+ (if (> seconds (expt 10 8))
+ (give-up-ir1-transform)
+ `(sb!unix:nanosleep ,seconds ,nano)))))
projects / sbcl.git / blobdiff