X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=83fcba21a6c77d2dbf6013f2eab8aaeeb3fa34fe;hb=6a9bbe6f36179cee92001a1f9ed5ff38be512644;hp=67c89560dd1936d2d7ee3ebd70f85abdd45f603a;hpb=01807e5203a1c27c98c93b26eea3bd6562817f4f;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 67c8956..83fcba2 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2121,7 +2121,8 @@ (values nil t t))) (defun logand-derive-type-aux (x y &optional same-leaf) - (declare (ignore same-leaf)) + (when same-leaf + (return-from logand-derive-type-aux x)) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (declare (ignore x-pos)) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) @@ -2153,7 +2154,8 @@ (specifier-type 'integer))))))) (defun logior-derive-type-aux (x y &optional same-leaf) - (declare (ignore same-leaf)) + (when same-leaf + (return-from logior-derive-type-aux x)) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (cond @@ -2192,7 +2194,8 @@ (specifier-type 'integer)))))))) (defun logxor-derive-type-aux (x y &optional same-leaf) - (declare (ignore same-leaf)) + (when same-leaf + (return-from logxor-derive-type-aux (specifier-type '(eql 0)))) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (cond @@ -2230,7 +2233,7 @@ (defoptimizer (logeqv derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) (lognot-derive-type-aux - (logxor-derive-type-aux x y same-leaf))) + (logxor-derive-type-aux x y same-leaf))) #'logeqv)) (defoptimizer (lognand derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) @@ -2242,25 +2245,34 @@ (lognot-derive-type-aux (logior-derive-type-aux x y same-leaf))) #'lognor)) +;;; FIXME: use SAME-LEAF instead of ignoring it. (defoptimizer (logandc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logand-derive-type-aux - (lognot-derive-type-aux x) y nil)) + (if same-leaf + (specifier-type '(eql 0)) + (logand-derive-type-aux + (lognot-derive-type-aux x) y nil))) #'logandc1)) (defoptimizer (logandc2 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logand-derive-type-aux - x (lognot-derive-type-aux y) nil)) + (if same-leaf + (specifier-type '(eql 0)) + (logand-derive-type-aux + x (lognot-derive-type-aux y) nil))) #'logandc2)) (defoptimizer (logorc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logior-derive-type-aux - (lognot-derive-type-aux x) y nil)) + (if same-leaf + (specifier-type '(eql -1)) + (logior-derive-type-aux + (lognot-derive-type-aux x) y nil))) #'logorc1)) (defoptimizer (logorc2 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logior-derive-type-aux - x (lognot-derive-type-aux y) nil)) + (if same-leaf + (specifier-type '(eql -1)) + (logior-derive-type-aux + x (lognot-derive-type-aux y) nil))) #'logorc2)) ;;;; miscellaneous derive-type methods @@ -2537,7 +2549,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))) @@ -3176,13 +3188,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))))) ;;;; converting N-arg arithmetic functions ;;;; @@ -3583,7 +3595,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 +3639,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))