0.8.9.16:

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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4da5db1..71a2313 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2537,7 +2537,7 @@
            (cut-node (node &aux did-something)
              (when (and (not (block-delete-p (node-block node)))
                         (combination-p node)
-                        (fun-info-p (basic-combination-kind node)))
+                       (eq (basic-combination-kind node) :known))
                (let* ((fun-ref (lvar-use (combination-fun node)))
                       (fun-name (leaf-source-name (ref-leaf fun-ref)))
                       (modular-fun (find-modular-version fun-name width)))
@@ -2545,7 +2545,7 @@
                             (not (and (eq fun-name 'logand)
                                       (csubtypep
                                        (single-value-type (node-derived-type node))
-                                       (specifier-type `(unsigned-byte ,width))))))
+                                       (specifier-type `(unsigned-byte* ,width))))))
                    (binding* ((name (etypecase modular-fun
                                       ((eql :good) fun-name)
                                       (modular-fun-info
@@ -2612,22 +2612,22 @@
     (give-up-ir1-transform "BOOLE code is not a constant."))
   (let ((control (lvar-value op)))
     (case control
-      (#.boole-clr 0)
-      (#.boole-set -1)
-      (#.boole-1 'x)
-      (#.boole-2 'y)
-      (#.boole-c1 '(lognot x))
-      (#.boole-c2 '(lognot y))
-      (#.boole-and '(logand x y))
-      (#.boole-ior '(logior x y))
-      (#.boole-xor '(logxor x y))
-      (#.boole-eqv '(logeqv x y))
-      (#.boole-nand '(lognand x y))
-      (#.boole-nor '(lognor x y))
-      (#.boole-andc1 '(logandc1 x y))
-      (#.boole-andc2 '(logandc2 x y))
-      (#.boole-orc1 '(logorc1 x y))
-      (#.boole-orc2 '(logorc2 x y))
+      (#.sb!xc:boole-clr 0)
+      (#.sb!xc:boole-set -1)
+      (#.sb!xc:boole-1 'x)
+      (#.sb!xc:boole-2 'y)
+      (#.sb!xc:boole-c1 '(lognot x))
+      (#.sb!xc:boole-c2 '(lognot y))
+      (#.sb!xc:boole-and '(logand x y))
+      (#.sb!xc:boole-ior '(logior x y))
+      (#.sb!xc:boole-xor '(logxor x y))
+      (#.sb!xc:boole-eqv '(logeqv x y))
+      (#.sb!xc:boole-nand '(lognand x y))
+      (#.sb!xc:boole-nor '(lognor x y))
+      (#.sb!xc:boole-andc1 '(logandc1 x y))
+      (#.sb!xc:boole-andc2 '(logandc2 x y))
+      (#.sb!xc:boole-orc1 '(logorc1 x y))
+      (#.sb!xc:boole-orc2 '(logorc2 x y))
       (t
        (abort-ir1-transform "~S is an illegal control arg to BOOLE."
                            control)))))
@@ -3176,13 +3176,13 @@
     (if (null rest)
        `(values (the real ,arg0))
        `(let ((maxrest (max ,@rest)))
-         (if (> ,arg0 maxrest) ,arg0 maxrest)))))
+         (if (>= ,arg0 maxrest) ,arg0 maxrest)))))
 (define-source-transform min (arg0 &rest rest)
   (once-only ((arg0 arg0))
     (if (null rest)
        `(values (the real ,arg0))
        `(let ((minrest (min ,@rest)))
-         (if (< ,arg0 minrest) ,arg0 minrest)))))
+         (if (<= ,arg0 minrest) ,arg0 minrest)))))
 \f
 ;;;; converting N-arg arithmetic functions
 ;;;;
@@ -3583,7 +3583,17 @@
            (t
             *universal-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
+  ;; 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.
   `(macrolet ((%index (x) `(truly-the index ,x))
              (%parent (i) `(ash ,i -1))
              (%left (i) `(%index (ash ,i 1)))
@@ -3617,15 +3627,16 @@
                                      (%elt largest) i-elt
                                      i largest)))))))))
              (%sort-vector (keyfun &optional (vtype 'vector))
-              `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting
-                          ;; type inference to propagate all the way
-                          ;; through this tangled mess of
-                          ;; inlining. The TRULY-THE here works
-                          ;; around that. -- WHN
+              `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
+                          ;; trouble getting type inference to
+                          ;; propagate all the way through this
+                          ;; tangled mess of inlining. The TRULY-THE
+                          ;; here works around that. -- WHN
                           (%elt (i)
                            `(aref (truly-the ,',vtype ,',',vector)
                              (%index (+ (%index ,i) start-1)))))
-                (let ((start-1 (1- ,',start)) ; Heaps prefer 1-based addressing.
+                (let (;; Heaps prefer 1-based addressing.
+                      (start-1 (1- ,',start)) 
                       (current-heap-size (- ,',end ,',start))
                       (keyfun ,keyfun))
                   (declare (type (integer -1 #.(1- most-positive-fixnum))