0.8.3.94:
[sbcl.git] / src / compiler / srctran.lisp
index 43e8dbe..56439e4 100644 (file)
   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
   (deffrob ceiling))
 
-(define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
-(define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
-(define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
-(define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
-(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
-(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
 (define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
 
 (deftransform logbitp
 
 (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.
 ;;; 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.
+(defun derive-integer-type-aux (x y fun)
+  (declare (type function fun))
+  (if (and (numeric-type-p x) (numeric-type-p y)
+          (eq (numeric-type-class x) 'integer)
+          (eq (numeric-type-class y) 'integer)
+          (eq (numeric-type-complexp x) :real)
+          (eq (numeric-type-complexp y) :real))
+      (multiple-value-bind (low high) (funcall fun x y)
+       (make-numeric-type :class 'integer
+                          :complexp :real
+                          :low low
+                          :high high))
+      (numeric-contagion x y)))
+
 (defun derive-integer-type (x y fun)
   (declare (type lvar x y) (type function fun))
   (let ((x (lvar-type x))
        (y (lvar-type y)))
-    (if (and (numeric-type-p x) (numeric-type-p y)
-            (eq (numeric-type-class x) 'integer)
-            (eq (numeric-type-class y) 'integer)
-            (eq (numeric-type-complexp x) :real)
-            (eq (numeric-type-complexp y) :real))
-       (multiple-value-bind (low high) (funcall fun x y)
-         (make-numeric-type :class 'integer
-                            :complexp :real
-                            :low low
-                            :high high))
-       (numeric-contagion x y))))
+    (derive-integer-type-aux x y fun)))
 
 ;;; simple utility to flatten a list
 (defun flatten-list (x)
                                      (flatten-helper (cdr x) r))))))
     (flatten-helper x nil)))
 
-;;; Take some type of continuation and massage it so that we get a
-;;; list of the constituent types. If ARG is *EMPTY-TYPE*, return NIL
-;;; to indicate failure.
+;;; 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
+;;; failure.
 (defun prepare-arg-for-derive-type (arg)
   (flet ((listify (arg)
           (typecase arg
 ;;; This is used in defoptimizers for computing the resulting type of
 ;;; a function.
 ;;;
-;;; Given the continuation ARG, derive the resulting type using the
+;;; Given the lvar ARG, derive the resulting type using the
 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
-;;; "atomic" continuation type like numeric-type or member-type
-;;; (containing just one element). It should return the resulting
-;;; type, which can be a list of types.
+;;; "atomic" lvar type like numeric-type or member-type (containing
+;;; just one element). It should return the resulting type, which can
+;;; be a list of types.
 ;;;
 ;;; For the case of member types, if a MEMBER-FUN is given it is
 ;;; called to compute the result otherwise the member type is first
 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
 ;;; original args and a third which is T to indicate if the two args
-;;; really represent the same continuation. This is useful for
-;;; deriving the type of things like (* x x), which should always be
-;;; positive. If we didn't do this, we wouldn't be able to tell.
+;;; really represent the same lvar. This is useful for deriving the
+;;; type of things like (* x x), which should always be positive. If
+;;; we didn't do this, we wouldn't be able to tell.
 (defun two-arg-derive-type (arg1 arg2 derive-fun fun
                                 &optional (convert-type t))
   (declare (type function derive-fun fun))
       (when (and a1 a2)
        (let ((results nil))
          (if same-arg
-             ;; Since the args are the same continuation, just run
-             ;; down the lists.
+             ;; Since the args are the same LVARs, just run down the
+             ;; lists.
              (dolist (x a1)
                (let ((result (deriver x x same-arg)))
                  (if (listp result)
   (defoptimizer (%negate derive-type) ((num))
     (derive-integer-type num num (frob -))))
 
+(defun lognot-derive-type-aux (int)
+  (derive-integer-type-aux int int
+                          (lambda (type type2)
+                            (declare (ignore type2))
+                            (let ((lo (numeric-type-low type))
+                                  (hi (numeric-type-high type)))
+                              (values (if hi (lognot hi) nil)
+                                      (if lo (lognot lo) nil)
+                                      (numeric-type-class type)
+                                      (numeric-type-format type))))))
+
 (defoptimizer (lognot derive-type) ((int))
-  (derive-integer-type int int
-                      (lambda (type type2)
-                        (declare (ignore type2))
-                        (let ((lo (numeric-type-low type))
-                              (hi (numeric-type-high type)))
-                          (values (if hi (lognot hi) nil)
-                                  (if lo (lognot lo) nil)
-                                  (numeric-type-class type)
-                                  (numeric-type-format type))))))
+  (lognot-derive-type-aux (lvar-type int)))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (%negate derive-type) ((num))
                                              '*))))
        ((or (and (not x-pos) (not y-neg))
            (and (not y-neg) (not y-pos)))
-       ;; Either X is negative and Y is positive of vice-versa. The
+       ;; Either X is negative and Y is positive or vice-versa. The
        ;; result will be negative.
        (specifier-type `(integer ,(if (and x-len y-len)
                                       (ash -1 (max x-len y-len))
   (deffrob logand)
   (deffrob logior)
   (deffrob logxor))
+
+;;; FIXME: could actually do stuff with SAME-LEAF
+(defoptimizer (logeqv derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (lognot-derive-type-aux 
+                             (logxor-derive-type-aux x y same-leaf))) 
+                      #'logeqv))
+(defoptimizer (lognand derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (lognot-derive-type-aux
+                             (logand-derive-type-aux x y same-leaf)))
+                      #'lognand))
+(defoptimizer (lognor derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (lognot-derive-type-aux
+                             (logior-derive-type-aux x y same-leaf)))
+                      #'lognor))
+(defoptimizer (logandc1 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (logand-derive-type-aux
+                             (lognot-derive-type-aux x) y nil))
+                      #'logandc1))
+(defoptimizer (logandc2 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (logand-derive-type-aux
+                             x (lognot-derive-type-aux y) nil))
+                      #'logandc2))
+(defoptimizer (logorc1 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (logior-derive-type-aux
+                             (lognot-derive-type-aux x) y nil))
+                      #'logorc1))
+(defoptimizer (logorc2 derive-type) ((x y))
+  (two-arg-derive-type x y (lambda (x y same-leaf)
+                            (logior-derive-type-aux
+                             x (lognot-derive-type-aux y) nil))
+                      #'logorc2))
 \f
 ;;;; miscellaneous derive-type methods
 
 (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))
 
 ;;;
 ;;; and similar for other arguments.
 
-;;; Try to recursively cut all uses of the continuation CONT to WIDTH
-;;; bits.
+;;; Try to recursively cut all uses of LVAR to WIDTH bits.
 ;;;
 ;;; For good functions, we just recursively cut arguments; their
 ;;; "goodness" means that the result will not increase (in the
              (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)))
   "convert (* x 0) to 0"
   0)
 
-;;; Return T if in an arithmetic op including continuations X and Y,
-;;; the result type is not affected by the type of X. That is, Y is at
+;;; Return T if in an arithmetic op including lvars X and Y, the
+;;; result type is not affected by the type of X. That is, Y is at
 ;;; least as contagious as X.
 #+nil
 (defun not-more-contagious (x y)
 \f
 ;;;; equality predicate transforms
 
-;;; Return true if X and Y are continuations whose only use is a
+;;; Return true if X and Y are lvars whose only use is a
 ;;; reference to the same leaf, and the value of the leaf cannot
 ;;; change.
 (defun same-leaf-ref-p (x y)
        (give-up-ir1-transform
         "The operands might not be the same type."))))
 
-;;; If CONT's type is a numeric type, then return the type, otherwise
+;;; If LVAR's type is a numeric type, then return the type, otherwise
 ;;; GIVE-UP-IR1-TRANSFORM.
 (defun numeric-type-or-lose (lvar)
   (declare (type lvar lvar))
 ;;; 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))
   (source-transform-transitive 'logxor args 0 'integer))
 (define-source-transform logand (&rest args)
   (source-transform-transitive 'logand args -1 'integer))
-
 (define-source-transform logeqv (&rest args)
-  (if (evenp (length args))
-      `(lognot (logxor ,@args))
-      `(logxor ,@args)))
+  (source-transform-transitive 'logeqv args -1 'integer))
 
 ;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM
 ;;; because when they are given one argument, they return its absolute
 ;;; "optimizer" (say, DEFOPTIMIZER CONSISTENCY-CHECK).
 ;;;
 ;;; FIXME II: In some cases, type information could be correlated; for
-;;; instance, ~{ ... ~} requires a list argument, so if the
-;;; continuation-type of a corresponding argument is known and does
-;;; not intersect the list type, a warning could be signalled.
+;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
+;;; of a corresponding argument is known and does not intersect the
+;;; list type, a warning could be signalled.
 (defun check-format-args (string args fun)
   (declare (type string string))
   (unless (typep string 'simple-string)
 ;;; for debugging when transforms are behaving mysteriously,
 ;;; e.g. when debugging a problem with an ASH transform
 ;;;   (defun foo (&optional s)
-;;;     (sb-c::/report-continuation s "S outside WHEN")
+;;;     (sb-c::/report-lvar s "S outside WHEN")
 ;;;     (when (and (integerp s) (> s 3))
-;;;       (sb-c::/report-continuation s "S inside WHEN")
+;;;       (sb-c::/report-lvar s "S inside WHEN")
 ;;;       (let ((bound (ash 1 (1- s))))
-;;;         (sb-c::/report-continuation bound "BOUND")
+;;;         (sb-c::/report-lvar bound "BOUND")
 ;;;         (let ((x (- bound))
 ;;;              (y (1- bound)))
-;;;          (sb-c::/report-continuation x "X")
-;;;           (sb-c::/report-continuation x "Y"))
+;;;          (sb-c::/report-lvar x "X")
+;;;           (sb-c::/report-lvar x "Y"))
 ;;;         `(integer ,(- bound) ,(1- bound)))))
 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
 ;;; and the function doesn't do anything at all.)