(defun safe-single-coercion-p (x)
(or (typep x 'single-float)
- ;; Fix for bug 420, and related issues: during type derivation we often
- ;; end up deriving types for both
- ;;
- ;; (some-op <int> <single>)
- ;; and
- ;; (some-op (coerce <int> 'single-float) <single>)
- ;;
- ;; or other equivalent transformed forms. The problem with this is that
- ;; on some platforms like x86 (+ <int> <single>) is on the machine level
- ;; equivalent of
- ;;
- ;; (coerce (+ (coerce <int> 'double-float)
- ;; (coerce <single> 'double-float))
- ;; 'single-float)
- ;;
- ;; so if the result of (coerce <int> 'single-float) is not exact, the
- ;; derived types for the transformed forms will have an empty
- ;; intersection -- which in turn means that the compiler will conclude
- ;; that the call never returns, and all hell breaks lose when it *does*
- ;; return at runtime. (This affects not just +, but other operators are
- ;; well.)
- (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
- (integer (,most-positive-exactly-single-float-fixnum) *))))
- (<= most-negative-single-float x most-positive-single-float))))
+ (and
+ ;; Fix for bug 420, and related issues: during type derivation we often
+ ;; end up deriving types for both
+ ;;
+ ;; (some-op <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this
+ ;; is that on x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> 'single-float) is not exact, the
+ ;; derived types for the transformed forms will have an empty
+ ;; intersection -- which in turn means that the compiler will conclude
+ ;; that the call never returns, and all hell breaks lose when it *does*
+ ;; return at runtime. (This affects not just +, but other operators are
+ ;; well.)
+ ;;
+ ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P
+ ;;
+ ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
+ ;; change.
+ #!+x86
+ (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
+ (integer (,most-positive-exactly-single-float-fixnum) *))))
+ (<= most-negative-single-float x most-positive-single-float))))
;;; Apply a binary operator OP to two bounds X and Y. The result is
;;; NIL if either is NIL. Otherwise bound is computed and the result
(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)))
(best-modular-version width nil)
(when w
;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
- (cut-to-width x kind width signedp)
- (cut-to-width y kind width signedp)
- nil ; After fixing above, replace with T.
+ ;;
+ ;; 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)
(multiple-value-bind (w kind)
(best-modular-version width t)
(when w
- ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
- (cut-to-width x kind width t)
+ ;; 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.
))))))))
\f
projects / sbcl.git / blobdiff