(defun make-interval (&key low high)
(labels ((normalize-bound (val)
- (cond ((and (floatp val)
+ (cond #-sb-xc-host
+ ((and (floatp val)
(float-infinity-p val))
;; Handle infinities.
nil)
(make-interval :low (numeric-type-low x)
:high (numeric-type-high x)))
+(defun type-approximate-interval (type)
+ (declare (type ctype type))
+ (let ((types (prepare-arg-for-derive-type type))
+ (result nil))
+ (dolist (type types)
+ (let ((type (if (member-type-p type)
+ (convert-member-type type)
+ type)))
+ (unless (numeric-type-p type)
+ (return-from type-approximate-interval nil))
+ (let ((interval (numeric-type->interval type)))
+ (setq result
+ (if result
+ (interval-approximate-union result interval)
+ interval)))))
+ result))
+
(defun copy-interval-limit (limit)
(if (numberp limit)
limit
(make-interval :low (select-bound x-lo y-lo #'< #'>)
:high (select-bound x-hi y-hi #'> #'<))))))
+;;; return the minimal interval, containing X and Y
+(defun interval-approximate-union (x y)
+ (cond ((interval-merge-pair x y))
+ ((interval-< x y)
+ (make-interval :low (copy-interval-limit (interval-low x))
+ :high (copy-interval-limit (interval-high y))))
+ (t
+ (make-interval :low (copy-interval-limit (interval-low y))
+ :high (copy-interval-limit (interval-high x))))))
+
;;; basic arithmetic operations on intervals. We probably should do
;;; true interval arithmetic here, but it's complicated because we
;;; have float and integer types and bounds can be open or closed.
(defoptimizer (integer-length derive-type) ((x))
(let ((x-type (lvar-type x)))
- (when (and (numeric-type-p x-type)
- (csubtypep x-type (specifier-type 'integer)))
+ (when (numeric-type-p x-type)
;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
;; careful about LO or HI being NIL, though. Also, if 0 is
(setf min-len 0))
(specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
+(defoptimizer (isqrt derive-type) ((x))
+ (let ((x-type (lvar-type x)))
+ (when (numeric-type-p x-type)
+ (let* ((lo (numeric-type-low x-type))
+ (hi (numeric-type-high x-type))
+ (lo-res (if lo (isqrt lo) '*))
+ (hi-res (if hi (isqrt hi) '*)))
+ (specifier-type `(integer ,lo-res ,hi-res))))))
+
(defoptimizer (code-char derive-type) ((code))
(specifier-type 'base-char))
(setf (block-reoptimize (node-block node)) t)
(setf (component-reoptimize (node-component node)) t))
(cut-node (node &aux did-something)
- (when (and (combination-p node)
+ (when (and (not (block-delete-p (node-block node)))
+ (combination-p node)
(fun-info-p (basic-combination-kind node)))
(let* ((fun-ref (lvar-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
;;; information. If X's high bound is < Y's low, then X < Y.
;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
;;; NIL). If not, at least make sure any constant arg is second.
-;;;
-;;; FIXME: Why should constant argument be second? It would be nice to
-;;; find out and explain.
-#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(defun ir1-transform-< (x y first second inverse)
- (if (same-leaf-ref-p x y)
- nil
- (let* ((x-type (numeric-type-or-lose x))
- (x-lo (numeric-type-low x-type))
- (x-hi (numeric-type-high x-type))
- (y-type (numeric-type-or-lose y))
- (y-lo (numeric-type-low y-type))
- (y-hi (numeric-type-high y-type)))
- (cond ((and x-hi y-lo (< x-hi y-lo))
- t)
- ((and y-hi x-lo (>= x-lo y-hi))
- nil)
- ((and (constant-lvar-p first)
- (not (constant-lvar-p second)))
- `(,inverse y x))
- (t
- (give-up-ir1-transform))))))
-#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(defun ir1-transform-< (x y first second inverse)
- (if (same-leaf-ref-p x y)
- nil
- (let ((xi (numeric-type->interval (numeric-type-or-lose x)))
- (yi (numeric-type->interval (numeric-type-or-lose y))))
- (cond ((interval-< xi yi)
- t)
- ((interval->= xi yi)
- nil)
- ((and (constant-lvar-p first)
- (not (constant-lvar-p second)))
- `(,inverse y x))
- (t
- (give-up-ir1-transform))))))
-
-(deftransform < ((x y) (integer integer) *)
- (ir1-transform-< x y x y '>))
-
-(deftransform > ((x y) (integer integer) *)
- (ir1-transform-< y x x y '<))
-
-#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform < ((x y) (float float) *)
- (ir1-transform-< x y x y '>))
-
-#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform > ((x y) (float float) *)
- (ir1-transform-< y x x y '<))
+(macrolet ((def (name inverse reflexive-p surely-true surely-false)
+ `(deftransform ,name ((x y))
+ (if (same-leaf-ref-p x y)
+ ,reflexive-p
+ (let ((ix (or (type-approximate-interval (lvar-type x))
+ (give-up-ir1-transform)))
+ (iy (or (type-approximate-interval (lvar-type y))
+ (give-up-ir1-transform))))
+ (cond (,surely-true
+ t)
+ (,surely-false
+ nil)
+ ((and (constant-lvar-p x)
+ (not (constant-lvar-p y)))
+ `(,',inverse y x))
+ (t
+ (give-up-ir1-transform))))))))
+ (def < > nil (interval-< ix iy) (interval->= ix iy))
+ (def > < nil (interval-< iy ix) (interval->= iy ix))
+ (def <= >= t (interval->= iy ix) (interval-< iy ix))
+ (def >= <= t (interval->= ix iy) (interval-< ix iy)))
(defun ir1-transform-char< (x y first second inverse)
(cond
((same-leaf-ref-p x y) nil)
;; If we had interval representation of character types, as we
;; might eventually have to to support 2^21 characters, then here
- ;; we could do some compile-time computation as in IR1-TRANSFORM-<
- ;; above. -- CSR, 2003-07-01
+ ;; we could do some compile-time computation as in transforms for
+ ;; < above. -- CSR, 2003-07-01
((and (constant-lvar-p first)
(not (constant-lvar-p second)))
`(,inverse y x))
projects / sbcl.git / blobdiff