0.8.4.2:

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index cd22846..e43395a 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -750,7 +750,7 @@
 ;;; a utility for defining derive-type methods of integer operations. If
 ;;; the types of both X and Y are integer types, then we compute a new
 ;;; integer type with bounds determined Fun when applied to X and Y.
-;;; Otherwise, we use Numeric-Contagion.
+;;; Otherwise, we use NUMERIC-CONTAGION.
 (defun derive-integer-type-aux (x y fun)
   (declare (type function fun))
   (if (and (numeric-type-p x) (numeric-type-p y)
@@ -773,13 +773,12 @@
 
 ;;; simple utility to flatten a list
 (defun flatten-list (x)
-  (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
-            (cond ((null x) r)
-                  ((atom x)
-                   (cons x r))
-                  (t (flatten-helper (car x)
-                                     (flatten-helper (cdr x) r))))))
-    (flatten-helper x nil)))
+  (labels ((flatten-and-append (tree list)
+            (cond ((null tree) list)
+                  ((atom tree) (cons tree list))
+                  (t (flatten-and-append
+                       (car tree) (flatten-and-append (cdr tree) list))))))
+    (flatten-and-append x nil)))
 
 ;;; Take some type of lvar and massage it so that we get a list of the
 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
@@ -1065,11 +1064,12 @@
           (cond ((and (member-type-p x) (member-type-p y))
                  (let* ((x (first (member-type-members x)))
                         (y (first (member-type-members y)))
-                        (result (with-float-traps-masked
-                                    (:underflow :overflow :divide-by-zero
-                                     :invalid)
-                                  (funcall fun x y))))
-                   (cond ((null result))
+                        (result (ignore-errors
+                                   (with-float-traps-masked
+                                       (:underflow :overflow :divide-by-zero
+                                                   :invalid)
+                                     (funcall fun x y)))))
+                   (cond ((null result) *empty-type*)
                          ((and (floatp result) (float-nan-p result))
                           (make-numeric-type :class 'float
                                              :format (type-of result)
@@ -2268,8 +2268,7 @@
 
 (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
@@ -2288,6 +2287,15 @@
             (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))
 
@@ -2485,7 +2493,8 @@
              (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)))
@@ -2651,7 +2660,7 @@
                        `(- (ash (- x) ,shift)))
                   (- (logand (- x) ,mask)))
           (values ,(if (minusp y)
-                       `(- (ash (- x) ,shift))
+                       `(ash (- ,mask x) ,shift)
                        `(ash x ,shift))
                   (logand x ,mask))))))
 
@@ -2973,27 +2982,27 @@
 ;;; 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.
-(macrolet ((def (name reflexive-p surely-true surely-false)
+(macrolet ((def (name inverse reflexive-p surely-true surely-false)
              `(deftransform ,name ((x y))
                 (if (same-leaf-ref-p x y)
                     ,reflexive-p
-                    (let ((x (or (type-approximate-interval (lvar-type x))
-                                 (give-up-ir1-transform)))
-                          (y (or (type-approximate-interval (lvar-type y))
-                                 (give-up-ir1-transform))))
+                    (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)))
-                             `(,',name y x))
+                             `(,',inverse y x))
                             (t
                              (give-up-ir1-transform))))))))
-  (def < nil (interval-< x y) (interval->= x y))
-  (def > nil (interval-< y x) (interval->= y x))
-  (def <= t (interval->= y x) (interval-< y x))
-  (def >= t (interval->= x y) (interval-< x y)))
+  (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