X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=34117f5c42ed44b92fcd1fe53eaca96d93bf787a;hb=6535ee98644b8fd1cea3581adb25d4d8bf7c1110;hp=3d06bd0aab0bee14026f92b8e9d0d7f089b7646f;hpb=cb79d726de3e18c660f84c58a43f00d22b459037;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 3d06bd0..34117f5 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -681,21 +681,7 @@
 		    ;; function arguments. -- WHN 19990918
 		    (not (ir1-attributep attr call))
 		    (every #'constant-lvar-p args)
-		    (node-lvar node)
-		    ;; Even if the function is foldable in principle,
-		    ;; it might be one of our low-level
-		    ;; implementation-specific functions. Such
-		    ;; functions don't necessarily exist at runtime on
-		    ;; a plain vanilla ANSI Common Lisp
-		    ;; cross-compilation host, in which case the
-		    ;; cross-compiler can't fold it because the
-		    ;; cross-compiler doesn't know how to evaluate it.
-		    #+sb-xc-host
-		    (or (fboundp (combination-fun-source-name node))
-                        (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
-                                       (combination-fun-source-name node)
-                                       (mapcar #'lvar-value args))
-                               nil)))
+		    (node-lvar node))
 	   (constant-fold-call node)
 	   (return-from ir1-optimize-combination)))
 
@@ -1088,9 +1074,7 @@
                                 (block-next (node-block call)))
       (let ((new-fun (ir1-convert-inline-lambda
 		      res
-		      :debug-name (debug-namify "LAMBDA-inlined "
-						source-name
-						"<unknown function>")))
+		      :debug-name (debug-name 'lambda-inlined source-name)))
 	    (ref (lvar-use (combination-fun call))))
 	(change-ref-leaf ref new-fun)
 	(setf (combination-kind call) :full)
@@ -1142,7 +1126,15 @@
 		      ;; COMPILER-WARNING (and thus return FAILURE-P=T
 		      ;; from COMPILE-FILE) for legal code, so we we
 		      ;; use a wimpier COMPILE-STYLE-WARNING instead.
-		      #'compiler-style-warn
+		      #-sb-xc-host #'compiler-style-warn
+		      ;; On the other hand, for code we control, we
+		      ;; should be able to work around any bug
+		      ;; 173-related problems, and in particular we
+		      ;; want to be alerted to calls to our own
+		      ;; functions which aren't being folded away; a
+		      ;; COMPILER-WARNING is butch enough to stop the
+		      ;; SBCL build itself in its tracks.
+		      #+sb-xc-host #'compiler-warn
 		      "constant folding")
       (cond ((not win)
              (setf (combination-kind call) :error))
@@ -1218,23 +1210,42 @@
     (when (and (numeric-type-p initial-type)
                (numeric-type-p step-type)
                (numeric-type-equal initial-type step-type))
-      (multiple-value-bind (low high)
-          (cond ((csubtypep step-type (specifier-type '(real 0 *)))
-                 (values (numeric-type-low initial-type)
-                         (when (and (numeric-type-p set-type)
-                                    (numeric-type-equal set-type initial-type))
-                           (numeric-type-high set-type))))
-                ((csubtypep step-type (specifier-type '(real * 0)))
-                 (values (when (and (numeric-type-p set-type)
-                                    (numeric-type-equal set-type initial-type))
-                           (numeric-type-low set-type))
-                         (numeric-type-high initial-type)))
-                (t
-                 (values nil nil)))
-        (modified-numeric-type initial-type
-                               :low low
-                               :high high
-                               :enumerable nil)))))
+      (labels ((leftmost (x y cmp cmp=)
+                 (cond ((eq x nil) nil)
+                       ((eq y nil) nil)
+                       ((listp x)
+                        (let ((x1 (first x)))
+                          (cond ((listp y)
+                                 (let ((y1 (first y)))
+                                   (if (funcall cmp x1 y1) x y)))
+                                (t
+                                 (if (funcall cmp x1 y) x y)))))
+                       ((listp y)
+                        (let ((y1 (first y)))
+                          (if (funcall cmp= x y1) x y)))
+                       (t (if (funcall cmp x y) x y))))
+               (max* (x y) (leftmost x y #'> #'>=))
+               (min* (x y) (leftmost x y #'< #'<=)))
+        (declare (inline compare))
+        (multiple-value-bind (low high)
+            (cond ((csubtypep step-type (specifier-type '(real 0 *)))
+                   (values (numeric-type-low initial-type)
+                           (when (and (numeric-type-p set-type)
+                                      (numeric-type-equal set-type initial-type))
+                             (max* (numeric-type-high initial-type)
+                                   (numeric-type-high set-type)))))
+                  ((csubtypep step-type (specifier-type '(real * 0)))
+                   (values (when (and (numeric-type-p set-type)
+                                      (numeric-type-equal set-type initial-type))
+                             (min* (numeric-type-low initial-type)
+                                   (numeric-type-low set-type)))
+                           (numeric-type-high initial-type)))
+                  (t
+                   (values nil nil)))
+          (modified-numeric-type initial-type
+                                 :low low
+                                 :high high
+                                 :enumerable nil))))))
 (deftransform + ((x y) * * :result result)
   "check for iteration variable reoptimization"
   (let ((dest (principal-lvar-end result))