(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)))
(return-from best-modular-version
(values (car ugt) :untagged (cdr ugt))))))))
+(defun integer-type-numeric-bounds (type)
+ (typecase type
+ (numeric-type (values (numeric-type-low type)
+ (numeric-type-high type)))
+ (union-type
+ (let ((low nil)
+ (high nil))
+ (dolist (type (union-type-types type) (values low high))
+ (unless (and (numeric-type-p type)
+ (eql (numeric-type-class type) 'integer))
+ (return (values nil nil)))
+ (let ((this-low (numeric-type-low type))
+ (this-high (numeric-type-high type)))
+ (setf low (min this-low (or low this-low))
+ high (max this-high (or high this-high)))))))))
+
(defoptimizer (logand optimizer) ((x y) node)
(let ((result-type (single-value-type (node-derived-type node))))
- (when (numeric-type-p result-type)
- (let ((low (numeric-type-low result-type))
- (high (numeric-type-high result-type)))
- (when (and (numberp low)
- (numberp high)
- (>= low 0))
- (let ((width (integer-length high)))
- (multiple-value-bind (w kind signedp)
- (best-modular-version width nil)
- (when w
- ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
- ;;
- ;; FIXME: I think the FIXME (which is from APD) above
- ;; implies that CUT-TO-WIDTH should do /everything/
- ;; that's required, including reoptimizing things
- ;; itself that it knows are necessary. At the moment,
- ;; CUT-TO-WIDTH sets up some new calls with
- ;; combination-type :FULL, which later get noticed as
- ;; known functions and properly converted.
- ;;
- ;; We cut to W not WIDTH if SIGNEDP is true, because
- ;; signed constant replacement needs to know which bit
- ;; in the field is the signed bit.
- (let ((xact (cut-to-width x kind (if signedp w width) signedp))
- (yact (cut-to-width y kind (if signedp w width) signedp)))
- (declare (ignore xact yact))
- nil) ; After fixing above, replace with T, meaning
- ; "don't reoptimize this (LOGAND) node any more".
- ))))))))
+ (multiple-value-bind (low high)
+ (integer-type-numeric-bounds result-type)
+ (when (and (numberp low)
+ (numberp high)
+ (>= low 0))
+ (let ((width (integer-length high)))
+ (multiple-value-bind (w kind signedp)
+ (best-modular-version width nil)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
+ ;;
+ ;; FIXME: I think the FIXME (which is from APD) above
+ ;; implies that CUT-TO-WIDTH should do /everything/
+ ;; that's required, including reoptimizing things
+ ;; itself that it knows are necessary. At the moment,
+ ;; CUT-TO-WIDTH sets up some new calls with
+ ;; combination-type :FULL, which later get noticed as
+ ;; known functions and properly converted.
+ ;;
+ ;; We cut to W not WIDTH if SIGNEDP is true, because
+ ;; signed constant replacement needs to know which bit
+ ;; in the field is the signed bit.
+ (let ((xact (cut-to-width x kind (if signedp w width) signedp))
+ (yact (cut-to-width y kind (if signedp w width) signedp)))
+ (declare (ignore xact yact))
+ nil) ; After fixing above, replace with T, meaning
+ ; "don't reoptimize this (LOGAND) node any more".
+ )))))))
(defoptimizer (mask-signed-field optimizer) ((width x) node)
(let ((result-type (single-value-type (node-derived-type node))))
- (when (numeric-type-p result-type)
- (let ((low (numeric-type-low result-type))
- (high (numeric-type-high result-type)))
- (when (and (numberp low) (numberp high))
- (let ((width (max (integer-length high) (integer-length low))))
- (multiple-value-bind (w kind)
- (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 ]
- (cut-to-width x kind w t)
- nil ; After fixing above, replace with T.
- ))))))))
+ (multiple-value-bind (low high)
+ (integer-type-numeric-bounds result-type)
+ (when (and (numberp low) (numberp high))
+ (let ((width (max (integer-length high) (integer-length low))))
+ (multiple-value-bind (w kind)
+ (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 ]
+ (cut-to-width x kind w t)
+ nil ; After fixing above, replace with T.
+ )))))))
+
+(defoptimizer (logior optimizer) ((x y) node)
+ (let ((result-type (single-value-type (node-derived-type node))))
+ (multiple-value-bind (low high)
+ (integer-type-numeric-bounds result-type)
+ (when (and (numberp low)
+ (numberp high)
+ (<= high 0))
+ (let ((width (integer-length low)))
+ (multiple-value-bind (w kind)
+ (best-modular-version (1+ width) t)
+ (when w
+ ;; FIXME: see comment in LOGAND optimizer
+ (let ((xact (cut-to-width x kind w t))
+ (yact (cut-to-width y kind w t)))
+ (declare (ignore xact yact))
+ nil) ; After fixing above, replace with T
+ )))))))
\f
;;; miscellanous numeric transforms
(def logxor -1 (lognot x))
(def logxor 0 x))
+(defun least-zero-bit (x)
+ (and (/= x -1)
+ (1- (integer-length (logxor x (1+ x))))))
+
(deftransform logand ((x y) (* (constant-arg t)) *)
"fold identity operation"
- (let ((y (lvar-value y)))
- (unless (and (plusp y)
- (= y (1- (ash 1 (integer-length y)))))
- (give-up-ir1-transform))
- (unless (csubtypep (lvar-type x)
- (specifier-type `(integer 0 ,y)))
+ (let* ((y (lvar-value y))
+ (width (or (least-zero-bit y) '*)))
+ (unless (and (neq width 0) ; (logand x 0) handled elsewhere
+ (csubtypep (lvar-type x)
+ (specifier-type `(unsigned-byte ,width))))
(give-up-ir1-transform))
'x))
(give-up-ir1-transform))
'x))
+(deftransform logior ((x y) (* (constant-arg t)) *)
+ "fold identity operation"
+ (let* ((y (lvar-value y))
+ (width (or (least-zero-bit (lognot y))
+ (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
+ (unless (csubtypep (lvar-type x)
+ (specifier-type `(integer ,(- (ash 1 width)) -1)))
+ (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
(splice-fun-args x ',folded 2)
`(lambda (x y z)
(declare (ignore y z))
- (,',operator x ',(,folded y (lvar-value z))))))))
+ ;; (operator (folded x y) z)
+ ;; == (operator x (folded z y))
+ (,',operator x ',(,folded (lvar-value z) y)))))))
(def logand)
(def logior)
(def logxor)
(def logtest :folded logand)
(def + :type rational)
- (def * :type rational))
+ (def + :type rational :folded -)
+ (def * :type rational)
+ (def * :type rational :folded /))
(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
"Fold mask-signed-field/mask-signed-field of constant width"
projects / sbcl.git / blobdiff