X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=76d880aa71056fae635e660118028020cca8a334;hb=997959cc458b00ff7faae526511533d24bdc0fde;hp=eca0cc251edfa0d079d8ae83cd1ee10d4c9e05da;hpb=f5522c7149744e4faf34313b18d0d3588d2a9d98;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index eca0cc2..76d880a 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1096,7 +1096,7 @@
              (t
               ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
               ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
-              (list (make-member-type :members (list (float -0.0 hi-val)))
+              (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)))
                     (make-numeric-type :class (numeric-type-class type)
                                        :format (numeric-type-format type)
                                        :complexp :real
@@ -1789,6 +1789,16 @@
                        #'%unary-truncate-derive-type-aux
                        #'%unary-truncate))
 
+(defoptimizer (%unary-truncate/single-float derive-type) ((number))
+  (one-arg-derive-type number
+                       #'%unary-truncate-derive-type-aux
+                       #'%unary-truncate))
+
+(defoptimizer (%unary-truncate/double-float derive-type) ((number))
+  (one-arg-derive-type number
+                       #'%unary-truncate-derive-type-aux
+                       #'%unary-truncate))
+
 (defoptimizer (%unary-ftruncate derive-type) ((number))
   (let ((divisor (specifier-type '(integer 1 1))))
     (one-arg-derive-type number
@@ -1796,6 +1806,28 @@
                              (ftruncate-derive-type-quot-aux n divisor nil))
                          #'%unary-ftruncate)))
 
+(defoptimizer (%unary-round derive-type) ((number))
+  (one-arg-derive-type number
+                       (lambda (n)
+                         (block nil
+                           (unless (numeric-type-real-p n)
+                             (return *empty-type*))
+                           (let* ((interval (numeric-type->interval n))
+                                  (low      (interval-low interval))
+                                  (high     (interval-high interval)))
+                             (when (consp low)
+                               (setf low (car low)))
+                             (when (consp high)
+                               (setf high (car high)))
+                             (specifier-type
+                              `(integer ,(if low
+                                             (round low)
+                                             '*)
+                                        ,(if high
+                                             (round high)
+                                             '*))))))
+                       #'%unary-round))
+
 ;;; Define optimizers for FLOOR and CEILING.
 (macrolet
     ((def (name q-name r-name)
@@ -2616,6 +2648,27 @@
              (hi-res (if hi (isqrt hi) '*)))
         (specifier-type `(integer ,lo-res ,hi-res))))))
 
+(defoptimizer (char-code derive-type) ((char))
+  (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
+    (cond ((member-type-p type)
+           (specifier-type
+            `(member
+              ,@(loop for member in (member-type-members type)
+                      when (characterp member)
+                      collect (char-code member)))))
+          ((sb!kernel::character-set-type-p type)
+           (specifier-type
+            `(or
+              ,@(loop for (low . high)
+                      in (character-set-type-pairs type)
+                      collect `(integer ,low ,high)))))
+          ((csubtypep type (specifier-type 'base-char))
+           (specifier-type
+            `(mod ,base-char-code-limit)))
+          (t
+           (specifier-type
+            `(mod ,char-code-limit))))))
+
 (defoptimizer (code-char derive-type) ((code))
   (let ((type (lvar-type code)))
     ;; FIXME: unions of integral ranges?  It ought to be easier to do
@@ -3231,41 +3284,32 @@
           (values (type= (numeric-contagion x y)
                          (numeric-contagion y y)))))))
 
+(def!type exact-number ()
+  '(or rational (complex rational)))
+
 ;;; Fold (+ x 0).
 ;;;
-;;; If y is not constant, not zerop, or is contagious, or a positive
-;;; float +0.0 then give up.
-(deftransform + ((x y) (t (constant-arg t)) *)
+;;; Only safely applicable for exact numbers. For floating-point
+;;; x, one would have to first show that neither x or y are signed
+;;; 0s, and that x isn't an SNaN.
+(deftransform + ((x y) (exact-number (constant-arg (eql 0))) *)
   "fold zero arg"
-  (let ((val (lvar-value y)))
-    (unless (and (zerop val)
-                 (not (and (floatp val) (plusp (float-sign val))))
-                 (not-more-contagious y x))
-      (give-up-ir1-transform)))
   'x)
 
 ;;; Fold (- x 0).
-;;;
-;;; If y is not constant, not zerop, or is contagious, or a negative
-;;; float -0.0 then give up.
-(deftransform - ((x y) (t (constant-arg t)) *)
+(deftransform - ((x y) (exact-number (constant-arg (eql 0))) *)
   "fold zero arg"
-  (let ((val (lvar-value y)))
-    (unless (and (zerop val)
-                 (not (and (floatp val) (minusp (float-sign val))))
-                 (not-more-contagious y x))
-      (give-up-ir1-transform)))
   'x)
 
 ;;; Fold (OP x +/-1)
-(macrolet ((def (name result minus-result)
-             `(deftransform ,name ((x y) (t (constant-arg real)) *)
-                "fold identity operations"
-                (let ((val (lvar-value y)))
-                  (unless (and (= (abs val) 1)
-                               (not-more-contagious y x))
-                    (give-up-ir1-transform))
-                  (if (minusp val) ',minus-result ',result)))))
+;;;
+;;; %NEGATE might not always signal correctly.
+(macrolet
+    ((def (name result minus-result)
+         `(deftransform ,name ((x y)
+                               (exact-number (constant-arg (member 1 -1))))
+            "fold identity operations"
+            (if (minusp (lvar-value y)) ',minus-result ',result))))
   (def * x (%negate x))
   (def / x (%negate x))
   (def expt x (/ 1 x)))
@@ -3302,6 +3346,15 @@
           ((= val -1/2) '(/ (sqrt x)))
           (t (give-up-ir1-transform)))))
 
+(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *)
+  "recode as an ODDP check"
+  (let ((val (lvar-value x)))
+    (if (eql -1 val)
+        '(- 1 (* 2 (logand 1 y)))
+        `(if (oddp y)
+             ,val
+             ,(abs val)))))
+
 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
 ;;; transformations?
 ;;; Perhaps we should have to prove that the denominator is nonzero before
@@ -3469,7 +3522,13 @@
     (cond ((or (and (csubtypep x-type (specifier-type 'float))
                     (csubtypep y-type (specifier-type 'float)))
                (and (csubtypep x-type (specifier-type '(complex float)))
-                    (csubtypep y-type (specifier-type '(complex float)))))
+                    (csubtypep y-type (specifier-type '(complex float))))
+               #!+complex-float-vops
+               (and (csubtypep x-type (specifier-type '(or single-float (complex single-float))))
+                    (csubtypep y-type (specifier-type '(or single-float (complex single-float)))))
+               #!+complex-float-vops
+               (and (csubtypep x-type (specifier-type '(or double-float (complex double-float))))
+                    (csubtypep y-type (specifier-type '(or double-float (complex double-float))))))
            ;; They are both floats. Leave as = so that -0.0 is
            ;; handled correctly.
            (give-up-ir1-transform))
@@ -3897,7 +3956,7 @@
                            :format-arguments
                            (list nargs 'cerror y x (max max1 max2))))))))))))))
 
-(defoptimizer (coerce derive-type) ((value type))
+(defoptimizer (coerce derive-type) ((value type) node)
   (cond
     ((constant-lvar-p type)
      ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
@@ -3942,7 +4001,17 @@
              (type-union result-typeoid
                          (type-intersection (lvar-type value)
                                             (specifier-type 'rational))))))
-         (t result-typeoid))))
+         ((and (policy node (zerop safety))
+               (csubtypep result-typeoid (specifier-type '(array * (*)))))
+          ;; At zero safety the deftransform for COERCE can elide dimension
+          ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
+          ;; need to simplify the type to drop the dimension information.
+          (let ((vtype (simplify-vector-type result-typeoid)))
+            (if vtype
+                (specifier-type vtype)
+                result-typeoid)))
+         (t
+          result-typeoid))))
     (t
      ;; OK, the result-type argument isn't constant.  However, there
      ;; are common uses where we can still do better than just
@@ -4083,11 +4152,6 @@
                          *universal-type*))))
         (recurse array-type)))))
 
-;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
-;;; isn't really related to the CMU CL code, since instead of trying
-;;; to generalize the CMU CL code to allow START and END values, this
-;;; code has been written from scratch following Chapter 7 of
-;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
 (define-source-transform sb!impl::sort-vector (vector start end predicate key)
   ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
   ;; isn't really related to the CMU CL code, since instead of trying
@@ -4139,7 +4203,7 @@
                        (start-1 (1- ,',start))
                        (current-heap-size (- ,',end ,',start))
                        (keyfun ,keyfun))
-                   (declare (type (integer -1 #.(1- most-positive-fixnum))
+                   (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum))
                                   start-1))
                    (declare (type index current-heap-size))
                    (declare (type function keyfun))