X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b570192f847428bf9fae5a95e34ece62d692f0f4;hb=930a0e019b4c823da04d52e907d322a296fb9ae3;hp=db475c1f1f2b00681a33122818f97004251fc249;hpb=a157ed0be79751f85b8243c06102eea95af06aa3;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index db475c1..b570192 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -29,13 +29,11 @@
 (define-source-transform identity (x) `(prog1 ,x))
 (define-source-transform values (x) `(prog1 ,x))
 
-;;; Bind the value and make a closure that returns it.
-(define-source-transform constantly (value)
-  (with-unique-names (rest n-value)
-    `(let ((,n-value ,value))
-      (lambda (&rest ,rest)
-        (declare (ignore ,rest))
-        ,n-value))))
+
+;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type.
+(defoptimizer (constantly derive-type) ((value))
+  (specifier-type
+   `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional))))
 
 ;;; If the function has a known number of arguments, then return a
 ;;; lambda with the appropriate fixed number of args. If the
@@ -1127,21 +1125,26 @@
     (t
      type-list)))
 
-;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
-;;; belong in the kernel's type logic, invoked always, instead of in
-;;; the compiler, invoked only during some type optimizations. (In
-;;; fact, as of 0.pre8.100 or so they probably are, under
-;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)
-
 ;;; Take a list of types and return a canonical type specifier,
 ;;; combining any MEMBER types together. If both positive and negative
 ;;; MEMBER types are present they are converted to a float type.
 ;;; XXX This would be far simpler if the type-union methods could handle
 ;;; member/number unions.
-(defun make-canonical-union-type (type-list)
+;;;
+;;; If we're about to generate an overly complex union of numeric types, start
+;;; collapse the ranges together.
+;;;
+;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
+;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
+;;; invoked always, instead of in the compiler, invoked only during some type
+;;; optimizations.
+(defvar *derived-numeric-union-complexity-limit* 6)
+
+(defun make-derived-union-type (type-list)
   (let ((xset (alloc-xset))
         (fp-zeroes '())
-        (misc-types '()))
+        (misc-types '())
+        (numeric-type *empty-type*))
     (dolist (type type-list)
       (cond ((member-type-p type)
              (mapc-member-type-members
@@ -1151,11 +1154,19 @@
                       (pushnew member fp-zeroes))
                     (add-to-xset member xset)))
               type))
+            ((numeric-type-p type)
+             (let ((*approximate-numeric-unions*
+                    (when (and (union-type-p numeric-type)
+                               (nthcdr *derived-numeric-union-complexity-limit*
+                                       (union-type-types numeric-type)))
+                      t)))
+               (setf numeric-type (type-union type numeric-type))))
             (t
              (push type misc-types))))
     (if (and (xset-empty-p xset) (not fp-zeroes))
-        (apply #'type-union misc-types)
-        (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types))))
+        (apply #'type-union numeric-type misc-types)
+        (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes)
+               numeric-type misc-types))))
 
 ;;; Convert a member type with a single member to a numeric type.
 (defun convert-member-type (arg)
@@ -1220,7 +1231,7 @@
                   (setf results (append results result))
                   (push result results))))
           (if (rest results)
-              (make-canonical-union-type results)
+              (make-derived-union-type results)
               (first results)))))))
 
 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
@@ -1293,7 +1304,7 @@
                         (setf results (append results result))
                         (push result results))))))
           (if (rest results)
-              (make-canonical-union-type results)
+              (make-derived-union-type results)
               (first results)))))))
 
 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
@@ -1789,6 +1800,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 +1817,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)
@@ -3252,41 +3295,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)))
@@ -3720,34 +3754,57 @@
 ;;;; versions, and degenerate cases are flushed.
 
 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
-(declaim (ftype (function (symbol t list) list) associate-args))
-(defun associate-args (function first-arg more-args)
+(declaim (ftype (sfunction (symbol t list t) list) associate-args))
+(defun associate-args (fun first-arg more-args identity)
   (let ((next (rest more-args))
         (arg (first more-args)))
     (if (null next)
-        `(,function ,first-arg ,arg)
-        (associate-args function `(,function ,first-arg ,arg) next))))
+        `(,fun ,first-arg ,(if arg arg identity))
+        (associate-args fun `(,fun ,first-arg ,arg) next identity))))
+
+;;; Reduce constants in ARGS list.
+(declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants))
+(defun reduce-constants (fun args identity one-arg-result-type)
+  (let ((one-arg-constant-p (ecase one-arg-result-type
+                              (number #'numberp)
+                              (integer #'integerp)))
+        (reduced-value identity)
+        (reduced-p nil))
+    (collect ((not-constants))
+      (dolist (arg args)
+        (if (funcall one-arg-constant-p arg)
+            (setf reduced-value (funcall fun reduced-value arg)
+                  reduced-p t)
+            (not-constants arg)))
+      ;; It is tempting to drop constants reduced to identity here,
+      ;; but if X is SNaN in (* X 1), we cannot drop the 1.
+      (if (not-constants)
+          (if reduced-p
+              `(,reduced-value ,@(not-constants))
+              (not-constants))
+          `(,reduced-value)))))
 
 ;;; Do source transformations for transitive functions such as +.
 ;;; One-arg cases are replaced with the arg and zero arg cases with
-;;; the identity.  ONE-ARG-RESULT-TYPE is, if non-NIL, the type to
-;;; ensure (with THE) that the argument in one-argument calls is.
+;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
+;;; that the argument in one-argument calls is.
+(declaim (ftype (function (symbol list t &optional symbol list)
+                          (values t &optional (member nil t)))
+                source-transform-transitive))
 (defun source-transform-transitive (fun args identity
-                                    &optional one-arg-result-type)
-  (declare (symbol fun) (list args))
+                                    &optional (one-arg-result-type 'number)
+                                              (one-arg-prefixes '(values)))
   (case (length args)
     (0 identity)
-    (1 (if one-arg-result-type
-           `(values (the ,one-arg-result-type ,(first args)))
-           `(values ,(first args))))
+    (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
     (2 (values nil t))
-    (t
-     (associate-args fun (first args) (rest args)))))
+    (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type)))
+         (associate-args fun (first reduced-args) (rest reduced-args) identity)))))
 
 (define-source-transform + (&rest args)
-  (source-transform-transitive '+ args 0 'number))
+  (source-transform-transitive '+ args 0))
 (define-source-transform * (&rest args)
-  (source-transform-transitive '* args 1 'number))
+  (source-transform-transitive '* args 1))
 (define-source-transform logior (&rest args)
   (source-transform-transitive 'logior args 0 'integer))
 (define-source-transform logxor (&rest args)
@@ -3756,41 +3813,30 @@
   (source-transform-transitive 'logand args -1 'integer))
 (define-source-transform logeqv (&rest 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
-;;; value.
-
 (define-source-transform gcd (&rest args)
-  (case (length args)
-    (0 0)
-    (1 `(abs (the integer ,(first args))))
-    (2 (values nil t))
-    (t (associate-args 'gcd (first args) (rest args)))))
-
+  (source-transform-transitive 'gcd args 0 'integer '(abs)))
 (define-source-transform lcm (&rest args)
-  (case (length args)
-    (0 1)
-    (1 `(abs (the integer ,(first args))))
-    (2 (values nil t))
-    (t (associate-args 'lcm (first args) (rest args)))))
+  (source-transform-transitive 'lcm args 1 'integer '(abs)))
 
 ;;; Do source transformations for intransitive n-arg functions such as
 ;;; /. With one arg, we form the inverse. With two args we pass.
 ;;; Otherwise we associate into two-arg calls.
-(declaim (ftype (function (symbol list t)
+(declaim (ftype (function (symbol symbol list t list &optional symbol)
                           (values list &optional (member nil t)))
                 source-transform-intransitive))
-(defun source-transform-intransitive (function args inverse)
+(defun source-transform-intransitive (fun fun* args identity one-arg-prefixes
+                                      &optional (one-arg-result-type 'number))
   (case (length args)
     ((0 2) (values nil t))
-    (1 `(,@inverse ,(first args)))
-    (t (associate-args function (first args) (rest args)))))
+    (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
+    (t (let ((reduced-args
+              (reduce-constants fun* (rest args) identity one-arg-result-type)))
+         (associate-args fun (first args) reduced-args identity)))))
 
 (define-source-transform - (&rest args)
-  (source-transform-intransitive '- args '(%negate)))
+  (source-transform-intransitive '- '+ args 0 '(%negate)))
 (define-source-transform / (&rest args)
-  (source-transform-intransitive '/ args '(/ 1)))
+  (source-transform-intransitive '/ '* args 1 '(/ 1)))
 
 ;;;; transforming APPLY
 
@@ -3933,7 +3979,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),
@@ -3978,7 +4024,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