X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=4da5db16a02d8d3ae4f314500785bda4bc8030db;hb=85c1cf858999279da6f4f470c4f3c582ad9f2dbf;hp=a403e2895a8bf47e51cf1bb9e650428c917e03f6;hpb=504959cef381a69a727263ba2a70108f133f8900;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index a403e28..4da5db1 100644
--- 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
@@ -1023,10 +1022,9 @@
 		  (if member-fun
 		      (with-float-traps-masked
 			  (:underflow :overflow :divide-by-zero)
-			(make-member-type
-			 :members (list
-				   (funcall member-fun
-					    (first (member-type-members x))))))
+			(specifier-type
+			 `(eql ,(funcall member-fun
+					 (first (member-type-members x))))))
 		      ;; Otherwise convert to a numeric type.
 		      (let ((result-type-list
 			     (funcall derive-fun (convert-member-type x))))
@@ -1065,17 +1063,18 @@
 	   (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)
 					      :complexp :real))
 			  (t
-			   (make-member-type :members (list result))))))
+			   (specifier-type `(eql ,result))))))
 		 ((and (member-type-p x) (numeric-type-p y))
 		  (let* ((x (convert-member-type x))
 			 (y (if convert-type (convert-numeric-type y) y))
@@ -2287,11 +2286,59 @@
             (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))
 
 (defoptimizer (values derive-type) ((&rest values))
   (make-values-type :required (mapcar #'lvar-type values)))
+
+(defun signum-derive-type-aux (type)
+  (if (eq (numeric-type-complexp type) :complex)
+      (let* ((format (case (numeric-type-class type)
+			  ((integer rational) 'single-float)
+			  (t (numeric-type-format type))))
+		(bound-format (or format 'float)))
+	   (make-numeric-type :class 'float
+			      :format format
+			      :complexp :complex
+			      :low (coerce -1 bound-format)
+			      :high (coerce 1 bound-format)))
+      (let* ((interval (numeric-type->interval type))
+	     (range-info (interval-range-info interval))
+	     (contains-0-p (interval-contains-p 0 interval))
+	     (class (numeric-type-class type))
+	     (format (numeric-type-format type))
+	     (one (coerce 1 (or format class 'real)))
+	     (zero (coerce 0 (or format class 'real)))
+	     (minus-one (coerce -1 (or format class 'real)))
+	     (plus (make-numeric-type :class class :format format
+				      :low one :high one))
+	     (minus (make-numeric-type :class class :format format
+				       :low minus-one :high minus-one))
+	     ;; KLUDGE: here we have a fairly horrible hack to deal
+	     ;; with the schizophrenia in the type derivation engine.
+	     ;; The problem is that the type derivers reinterpret
+	     ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
+	     ;; 0d0) within the derivation mechanism doesn't include
+	     ;; -0d0.  Ugh.  So force it in here, instead.
+	     (zero (make-numeric-type :class class :format format
+				      :low (- zero) :high zero)))
+	(case range-info
+	  (+ (if contains-0-p (type-union plus zero) plus))
+	  (- (if contains-0-p (type-union minus zero) minus))
+	  (t (type-union minus zero plus))))))
+
+(defoptimizer (signum derive-type) ((num))
+  (one-arg-derive-type num #'signum-derive-type-aux nil))
 
 ;;;; byte operations
 ;;;;
@@ -2471,8 +2518,12 @@
 ;;; "goodness" means that the result will not increase (in the
 ;;; (unsigned-byte +infinity) sense). An ordinary modular function is
 ;;; replaced with the version, cutting its result to WIDTH or more
-;;; bits. If we have changed anything, we need to flush old derived
-;;; types, because they have nothing in common with the new code.
+;;; bits. For most functions (e.g. for +) we cut all arguments; for
+;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
+;;; arguments (maybe to a different width) and returning the name of a
+;;; modular version, if it exists, or NIL. If we have changed
+;;; anything, we need to flush old derived types, because they have
+;;; nothing in common with the new code.
 (defun cut-to-width (lvar width)
   (declare (type lvar lvar) (type (integer 0) width))
   (labels ((reoptimize-node (node name)
@@ -2484,30 +2535,37 @@
              (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)))
-                      (modular-fun (find-modular-version fun-name width))
-                      (name (and (modular-fun-info-p modular-fun)
-                                 (modular-fun-info-name modular-fun))))
+                      (modular-fun (find-modular-version fun-name width)))
                  (when (and modular-fun
-                            (not (and (eq name 'logand)
+                            (not (and (eq fun-name 'logand)
                                       (csubtypep
                                        (single-value-type (node-derived-type node))
                                        (specifier-type `(unsigned-byte ,width))))))
-                   (unless (eq modular-fun :good)
-                     (setq did-something t)
-                     (change-ref-leaf
+                   (binding* ((name (etypecase modular-fun
+                                      ((eql :good) fun-name)
+                                      (modular-fun-info
+                                       (modular-fun-info-name modular-fun))
+                                      (function
+                                       (funcall modular-fun node width)))
+                                :exit-if-null))
+                     (unless (eql modular-fun :good)
+                       (setq did-something t)
+                       (change-ref-leaf
                         fun-ref
                         (find-free-fun name "in a strange place"))
                        (setf (combination-kind node) :full))
-                   (dolist (arg (basic-combination-args node))
-                     (when (cut-lvar arg)
-                       (setq did-something t)))
-                   (when did-something
-                     (reoptimize-node node fun-name))
-                   did-something))))
+                     (unless (functionp modular-fun)
+                       (dolist (arg (basic-combination-args node))
+                         (when (cut-lvar arg)
+                           (setq did-something t))))
+                     (when did-something
+                       (reoptimize-node node name))
+                     did-something)))))
            (cut-lvar (lvar &aux did-something)
              (do-uses (node lvar)
                (when (cut-node node)
@@ -2650,7 +2708,7 @@
 			`(- (ash (- x) ,shift)))
 		   (- (logand (- x) ,mask)))
 	   (values ,(if (minusp y)
-			`(- (ash (- x) ,shift))
+			`(ash (- ,mask x) ,shift)
 			`(ash x ,shift))
 		   (logand x ,mask))))))
 
@@ -2972,27 +3030,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