(defun %ash/right (integer amount)
(ash integer (- amount)))
- (deftransform ash ((integer amount) (sb!vm:signed-word (integer * 0)))
+ (deftransform ash ((integer amount))
"Convert ASH of signed word to %ASH/RIGHT"
+ (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid
+ (specifier-type 'sb!vm:signed-word)) ; optimization
+ (csubtypep (lvar-type amount) ; notes.
+ (specifier-type '(integer * 0))))
+ (give-up-ir1-transform))
(when (constant-lvar-p amount)
(give-up-ir1-transform))
(let ((use (lvar-uses amount)))
,(1- sb!vm:n-word-bits)
(- amount)))))))
- (deftransform ash ((integer amount) (word (integer * 0)))
+ (deftransform ash ((integer amount))
"Convert ASH of word to %ASH/RIGHT"
+ (unless (and (csubtypep (lvar-type integer)
+ (specifier-type 'sb!vm:word))
+ (csubtypep (lvar-type amount)
+ (specifier-type '(integer * 0))))
+ (give-up-ir1-transform))
(when (constant-lvar-p amount)
(give-up-ir1-transform))
(let ((use (lvar-uses amount)))
(setf (block-reoptimize (node-block node)) t)
(reoptimize-component (node-component node) :maybe))
t)
- (cut-node (node &aux did-something)
+ (cut-node (node &aux did-something over-wide)
"Try to cut a node to width. The primary return value is
whether we managed to cut (cleverly), and the second whether
- anything was changed."
+ anything was changed. The third return value tells whether
+ the cut value might be wider than expected."
(when (block-delete-p (node-block node))
(return-from cut-node (values t nil)))
(typecase 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))
- (values t did-something))))))))
- (cut-lvar (lvar &aux did-something must-insert)
+ (cond ((not modular-fun)
+ ;; don't know what to do here
+ (values nil nil))
+ ((let ((dtype (single-value-type
+ (node-derived-type node))))
+ (and
+ (case fun-name
+ (logand
+ (csubtypep dtype
+ (specifier-type 'unsigned-byte)))
+ (logior
+ (csubtypep dtype
+ (specifier-type '(integer * 0))))
+ (mask-signed-field
+ t)
+ (t nil))
+ (csubtypep dtype type)))
+ ;; nothing to do
+ (values t nil))
+ (t
+ (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
+ over-wide 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))
+ (multiple-value-bind (change wide)
+ (cut-lvar arg)
+ (setf did-something (or did-something change)
+ over-wide (or over-wide wide)))))
+ (when did-something
+ (reoptimize-node node name))
+ (values t did-something over-wide)))))))))
+ (cut-lvar (lvar &key head
+ &aux did-something must-insert over-wide)
"Cut all the LVAR's use nodes. If any of them wasn't handled
and its type is too wide for the operation we wish to perform
insert an explicit bit-width narrowing operation (LOGAND or
destination is already such an operation, to avoid endless
recursion.
+ If we're at the head, forcibly insert a cut operation if the
+ result might be too wide.
+
(*) We can't easily do that for each node, and doing so might
result in code bloat, anyway. (I'm also not sure it would be
correct for complicated C/D FG)"
(do-uses (node lvar)
- (multiple-value-bind (handled any-change)
+ (multiple-value-bind (handled any-change wide)
(cut-node node)
(setf did-something (or did-something any-change)
must-insert (or must-insert
(not (or handled
(csubtypep (single-value-type
(node-derived-type node))
- type)))))))
- (when must-insert
- (setf did-something (or (insert-lvar-cut lvar) did-something)))
- did-something))
- (cut-lvar lvar))))
+ type))))
+ over-wide (or over-wide wide))))
+ (when (or must-insert
+ (and head over-wide))
+ (setf did-something (or (insert-lvar-cut lvar) did-something)
+ ;; we're just the right width after an explicit cut.
+ over-wide nil))
+ (values did-something over-wide)))
+ (cut-lvar lvar :head t))))
(defun best-modular-version (width signedp)
;; 1. exact width-matched :untagged
;; 3. >/>= width-matched :untagged
(let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
(uswidths (modular-class-widths *untagged-signed-modular-class*))
- (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+ (uwidths (if (and uuwidths uswidths)
+ (merge 'list (copy-list uuwidths) (copy-list uswidths)
+ #'< :key #'car)
+ (or uuwidths uswidths)))
(twidths (modular-class-widths *tagged-modular-class*)))
(let ((exact (find (cons width signedp) uwidths :test #'equal)))
(when exact
(return (values nil nil)))
(let ((this-low (numeric-type-low type))
(this-high (numeric-type-high type)))
+ (unless (and this-low this-high)
+ (return (values nil nil)))
(setf low (min this-low (or low this-low))
high (max this-high (or high this-high)))))))))
`(values (the real ,arg0))
`(let ((minrest (min ,@rest)))
(if (<= ,arg0 minrest) ,arg0 minrest)))))
+
+;;; Simplify some cross-type comparisons
+(macrolet ((def (comparator round)
+ `(progn
+ (deftransform ,comparator
+ ((x y) (rational (constant-arg float)))
+ "open-code RATIONAL to FLOAT comparison"
+ (let ((y (lvar-value y)))
+ #-sb-xc-host
+ (when (or (float-nan-p y)
+ (float-infinity-p y))
+ (give-up-ir1-transform))
+ (setf y (rational y))
+ `(,',comparator
+ x ,(if (csubtypep (lvar-type x)
+ (specifier-type 'integer))
+ (,round y)
+ y))))
+ (deftransform ,comparator
+ ((x y) (integer (constant-arg ratio)))
+ "open-code INTEGER to RATIO comparison"
+ `(,',comparator x ,(,round (lvar-value y)))))))
+ (def < ceiling)
+ (def > floor))
+
+(deftransform = ((x y) (rational (constant-arg float)))
+ "open-code RATIONAL to FLOAT comparison"
+ (let ((y (lvar-value y)))
+ #-sb-xc-host
+ (when (or (float-nan-p y)
+ (float-infinity-p y))
+ (give-up-ir1-transform))
+ (setf y (rational y))
+ (if (and (csubtypep (lvar-type x)
+ (specifier-type 'integer))
+ (ratiop y))
+ nil
+ `(= x ,y))))
+
+(deftransform = ((x y) (integer (constant-arg ratio)))
+ "constant-fold INTEGER to RATIO comparison"
+ nil)
\f
;;;; converting N-arg arithmetic functions
;;;;
projects / sbcl.git / blobdiff