X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=d93c0825b6e274aba736cbdb38efd0b042dac705;hb=631ecfcd29ecabd40c3bc5579496e635b30a142e;hp=7383e72a9646b33f33c8e532c2e4741887bd45f2;hpb=f98d63ddb86859259bf12f2e276fb577cbe168eb;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 7383e72..d93c082 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -114,6 +114,20 @@
 (define-source-transform ninth (x) `(nth 8 ,x))
 (define-source-transform tenth (x) `(nth 9 ,x))
 
+;;; LIST with one arg is an extremely common operation (at least inside
+;;; SBCL itself); translate it to CONS to take advantage of common
+;;; allocation routines.
+(define-source-transform list (&rest args)
+  (case (length args)
+    (1 `(cons ,(first args) nil))
+    (t (values nil t))))
+
+;;; And similarly for LIST*.
+(define-source-transform list* (&rest args)
+  (case (length args)
+    (2 `(cons ,(first args) ,(second args)))
+    (t (values nil t))))
+
 ;;; Translate RPLACx to LET and SETF.
 (define-source-transform rplaca (x y)
   (once-only ((n-x x))
@@ -134,6 +148,11 @@
    (2 `(sb!impl::gethash2 ,@args))
    (3 `(sb!impl::gethash3 ,@args))
    (t (values nil t))))
+(define-source-transform get (&rest args)
+  (case (length args)
+   (2 `(sb!impl::get2 ,@args))
+   (3 `(sb!impl::get3 ,@args))
+   (t (values nil t))))
 
 (defvar *default-nthcdr-open-code-limit* 6)
 (defvar *extreme-nthcdr-open-code-limit* 20)
@@ -164,8 +183,8 @@
 (define-source-transform 1+ (x) `(+ ,x 1))
 (define-source-transform 1- (x) `(- ,x 1))
 
-(define-source-transform oddp (x) `(not (zerop (logand ,x 1))))
-(define-source-transform evenp (x) `(zerop (logand ,x 1)))
+(define-source-transform oddp (x) `(logtest ,x 1))
+(define-source-transform evenp (x) `(not (logtest ,x 1)))
 
 ;;; Note that all the integer division functions are available for
 ;;; inline expansion.
@@ -183,7 +202,12 @@
   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
   (deffrob ceiling))
 
-(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+;;; This used to be a source transform (hence the lack of restrictions
+;;; on the argument types), but we make it a regular transform so that
+;;; the VM has a chance to see the bare LOGTEST and potentiall choose
+;;; to implement it differently.  --njf, 06-02-2006
+(deftransform logtest ((x y) * *)
+  `(not (zerop (logand x y))))
 
 (deftransform logbitp
     ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
@@ -296,20 +320,75 @@
            (if (and (floatp y)
                     (float-infinity-p y))
                nil
-               (set-bound (funcall f (type-bound-number x)) (consp x)))))))
+               (set-bound y (consp x)))))))
 
 ;;; Apply a binary operator OP to two bounds X and Y. The result is
 ;;; NIL if either is NIL. Otherwise bound is computed and the result
 ;;; is open if either X or Y is open.
 ;;;
 ;;; FIXME: only used in this file, not needed in target runtime
+
+;;; ANSI contaigon specifies coercion to floating point if one of the
+;;; arguments is floating point. Here we should check to be sure that
+;;; the other argument is within the bounds of that floating point
+;;; type.
+
+(defmacro safely-binop (op x y)
+  `(cond
+    ((typep ,x 'single-float)
+     (if (or (typep ,y 'single-float)
+             (<= most-negative-single-float ,y most-positive-single-float))
+         (,op ,x ,y)))
+    ((typep ,x 'double-float)
+     (if (or (typep ,y 'double-float)
+             (<= most-negative-double-float ,y most-positive-double-float))
+         (,op ,x ,y)))
+    ((typep ,y 'single-float)
+     (if (<= most-negative-single-float ,x most-positive-single-float)
+         (,op ,x ,y)))
+    ((typep ,y 'double-float)
+     (if (<= most-negative-double-float ,x most-positive-double-float)
+         (,op ,x ,y)))
+    (t (,op ,x ,y))))
+
 (defmacro bound-binop (op x y)
   `(and ,x ,y
        (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
-         (set-bound (,op (type-bound-number ,x)
-                         (type-bound-number ,y))
+         (set-bound (safely-binop ,op (type-bound-number ,x)
+                                  (type-bound-number ,y))
                     (or (consp ,x) (consp ,y))))))
 
+(defun coerce-for-bound (val type)
+  (if (consp val)
+      (list (coerce-for-bound (car val) type))
+      (cond
+        ((subtypep type 'double-float)
+         (if (<= most-negative-double-float val most-positive-double-float)
+             (coerce val type)))
+        ((or (subtypep type 'single-float) (subtypep type 'float))
+         ;; coerce to float returns a single-float
+         (if (<= most-negative-single-float val most-positive-single-float)
+             (coerce val type)))
+        (t (coerce val type)))))
+
+(defun coerce-and-truncate-floats (val type)
+  (when val
+    (if (consp val)
+        (list (coerce-and-truncate-floats (car val) type))
+        (cond
+          ((subtypep type 'double-float)
+           (if (<= most-negative-double-float val most-positive-double-float)
+               (coerce val type)
+               (if (< val most-negative-double-float)
+                   most-negative-double-float most-positive-double-float)))
+          ((or (subtypep type 'single-float) (subtypep type 'float))
+           ;; coerce to float returns a single-float
+           (if (<= most-negative-single-float val most-positive-single-float)
+               (coerce val type)
+               (if (< val most-negative-single-float)
+                   most-negative-single-float most-positive-single-float)))
+          (t (coerce val type))))))
+
 ;;; Convert a numeric-type object to an interval object.
 (defun numeric-type->interval (x)
   (declare (type numeric-type x))
@@ -1202,8 +1281,8 @@
         (when (eq (numeric-type-class result-type) 'float)
           (setf result (interval-func
                         #'(lambda (x)
-                            (coerce x (or (numeric-type-format result-type)
-                                          'float)))
+                            (coerce-for-bound x (or (numeric-type-format result-type)
+                                                    'float)))
                         result)))
         (make-numeric-type
          :class (if (and (eq (numeric-type-class x) 'integer)
@@ -1235,8 +1314,8 @@
         (when (eq (numeric-type-class result-type) 'float)
           (setf result (interval-func
                         #'(lambda (x)
-                            (coerce x (or (numeric-type-format result-type)
-                                          'float)))
+                            (coerce-for-bound x (or (numeric-type-format result-type)
+                                                    'float)))
                         result)))
         (make-numeric-type
          :class (if (and (eq (numeric-type-class x) 'integer)
@@ -1268,8 +1347,8 @@
         (when (eq (numeric-type-class result-type) 'float)
           (setf result (interval-func
                         #'(lambda (x)
-                            (coerce x (or (numeric-type-format result-type)
-                                          'float)))
+                            (coerce-for-bound x (or (numeric-type-format result-type)
+                                                    'float)))
                         result)))
         (make-numeric-type
          :class (if (and (eq (numeric-type-class x) 'integer)
@@ -1304,8 +1383,8 @@
         (when (eq (numeric-type-class result-type) 'float)
           (setf result (interval-func
                         #'(lambda (x)
-                            (coerce x (or (numeric-type-format result-type)
-                                          'float)))
+                            (coerce-for-bound x (or (numeric-type-format result-type)
+                                                    'float)))
                         result)))
         (make-numeric-type :class (numeric-type-class result-type)
                            :format (numeric-type-format result-type)
@@ -1448,8 +1527,8 @@
             :class class
             :format format
             :complexp :real
-            :low (coerce-numeric-bound (interval-low abs-bnd) bound-type)
-            :high (coerce-numeric-bound
+            :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type)
+            :high (coerce-and-truncate-floats
                    (interval-high abs-bnd) bound-type))))))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
@@ -1563,7 +1642,7 @@
              (when (member rem-type '(float single-float double-float
                                             #!+long-float long-float))
                (setf rem (interval-func #'(lambda (x)
-                                            (coerce x rem-type))
+                                            (coerce-for-bound x rem-type))
                                         rem)))
              (make-numeric-type :class class
                                 :format format
@@ -1673,7 +1752,7 @@
                    ;; Make sure that the limits on the interval have
                    ;; the right type.
                    (setf rem (interval-func (lambda (x)
-                                              (coerce x result-type))
+                                              (coerce-for-bound x result-type))
                                             rem)))
                  (make-numeric-type :class class
                                     :format format
@@ -3207,15 +3286,17 @@
 ;;; -- If both args are characters, convert to CHAR=. This is better than
 ;;;    just converting to EQ, since CHAR= may have special compilation
 ;;;    strategies for non-standard representations, etc.
-;;; -- If either arg is definitely a fixnum we punt and let the backend
-;;;    deal with it.
+;;; -- If either arg is definitely a fixnum, we check to see if X is
+;;;    constant and if so, put X second. Doing this results in better
+;;;    code from the backend, since the backend assumes that any constant
+;;;    argument comes second.
 ;;; -- If either arg is definitely not a number or a fixnum, then we
 ;;;    can compare with EQ.
 ;;; -- Otherwise, we try to put the arg we know more about second. If X
 ;;;    is constant then we put it second. If X is a subtype of Y, we put
 ;;;    it second. These rules make it easier for the back end to match
 ;;;    these interesting cases.
-(deftransform eql ((x y) * *)
+(deftransform eql ((x y) * * :node node)
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
@@ -3232,7 +3313,7 @@
               (csubtypep y-type char-type))
          '(char= x y))
         ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
-         (give-up-ir1-transform))
+         (commutative-arg-swap node))
         ((or (simple-type-p x-type) (simple-type-p y-type))
          '(eq x y))
         ((and (not (constant-lvar-p y))
@@ -3599,6 +3680,10 @@
       (when (stringp x)
         (check-format-args x args 'format)))))
 
+;;; We disable this transform in the cross-compiler to save memory in
+;;; the target image; most of the uses of FORMAT in the compiler are for
+;;; error messages, and those don't need to be particularly fast.
+#+sb-xc
 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
                       :policy (> speed space))
   (unless (constant-lvar-p control)
@@ -3623,6 +3708,12 @@
        (funcall control *standard-output* ,@arg-names)
        nil)))
 
+(deftransform pathname ((pathspec) (pathname) *)
+  'pathspec)
+
+(deftransform pathname ((pathspec) (string) *)
+  '(values (parse-namestring pathspec)))
+
 (macrolet
     ((def (name)
          `(defoptimizer (,name optimizer) ((control &rest args))
@@ -3970,3 +4061,18 @@
     (give-up-ir1-transform "not a real transform"))
   (defun /report-lvar (x message)
     (declare (ignore x message))))
+
+
+;;;; Transforms for internal compiler utilities
+
+;;; If QUALITY-NAME is constant and a valid name, don't bother
+;;; checking that it's still valid at run-time.
+(deftransform policy-quality ((policy quality-name)
+                              (t symbol))
+  (unless (and (constant-lvar-p quality-name)
+               (policy-quality-name-p (lvar-value quality-name)))
+    (give-up-ir1-transform))
+  `(let* ((acons (assoc quality-name policy))
+          (result (or (cdr acons) 1)))
+     result))
+