0.9.13.36: global policy / null-lexenv confusion fix

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 69bc5e1..ca2c4d9 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -188,7 +188,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)
@@ -301,7 +306,7 @@
            (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
@@ -317,10 +322,12 @@
 (defmacro safely-binop (op x y)
   `(cond
     ((typep ,x 'single-float)
-     (if (<= most-negative-single-float ,y most-positive-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 (<= most-negative-double-float ,y most-positive-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)
@@ -3265,15 +3272,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))
@@ -3290,7 +3299,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))
@@ -3657,6 +3666,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)
@@ -4028,3 +4041,17 @@
     (give-up-ir1-transform "not a real transform"))
   (defun /report-lvar (x message)
     (declare (ignore x message))))
+
+\f
+;;;; 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))