From: Alexey Dejneka Date: Fri, 15 Aug 2003 08:21:07 +0000 (+0000) Subject: 0.8.2.29: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f6f238261f95e8ffff2870ed3ac6fc00ddf09ef2;p=sbcl.git 0.8.2.29: * Fix bug in ASSQ, reported by Paul Dietz; * FLOAT-RADIX IGNOREs its argument as was suggested by Clemens Heitzinger; * fix return type declaration for FFLOOR and friends (reported by Paul Dietz); * SB-C::DESCRIBE-COMPONENT prints blocks in IR1 component "as is"; * introduced "good" (transparent) modular functions; ... LOGAND and LOGIOR are :GOOD; * on X86: transform 32BIT-LOGICAL-xxx into LOGXXX; implement LOGXOR-MOD32; change implementation of FAST-+-MOD32: inherit without changes from FAST-+/UNSIGNED=>UNSIGNED :-). (On X86 SB-MD5 may be implemented without 32BIT-LOGICAL-xxx and evil TRULY-THE.) --- diff --git a/NEWS b/NEWS index b156efd..b9817ef 100644 --- a/NEWS +++ b/NEWS @@ -1965,6 +1965,8 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: ** The system now obeys the constraint imposed by UPGRADED-ARRAY-ELEMENT-TYPE that the upgraded array element types form a lattice under type intersection. + ** FFLOOR, FTRUNCATE, FCEILING and FROUND work with integers. + ** ASSOC now ignores NIL elements in an alist. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index e195215..c5cf3b2 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -288,7 +288,7 @@ ;; just define ASSQ explicitly in terms of more primitive ;; operations: (dolist (pair alist) - (when (eq (car pair) item) + (when (and pair (eq (car pair) item)) (return pair)))) ;;; like (DELETE .. :TEST #'EQ): diff --git a/src/code/float.lisp b/src/code/float.lisp index 14c1a79..407b309 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -314,6 +314,7 @@ (defun float-radix (x) #!+sb-doc "Return (as an integer) the radix b of its floating-point argument." + (declare (ignore x)) 2) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 0539b31..ff3e6d5 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1355,6 +1355,7 @@ collect `(prepare-argument ,arg))))))) (loop for infos being each hash-value of sb!c::*modular-funs* ;; FIXME: We need to process only "toplevel" functions + unless (eq infos :good) do (loop for info in infos for name = (sb!c::modular-fun-info-name info) and width = (sb!c::modular-fun-info-width info) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index ca85fa7..cc6cd91 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -336,7 +336,7 @@ (movable foldable flushable explicit-check)) (defknown (ffloor fceiling fround ftruncate) - (real &optional real) (values float float) + (real &optional real) (values float real) (movable foldable flushable explicit-check)) (defknown decode-float (float) (values float float-exponent float) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 2984db4..e9f6a01 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -152,7 +152,7 @@ ;;; Modular functions -;;; hash: name -> ({(width . fun)}*) +;;; hash: name -> { ({(width . fun)}*) | :good } (defvar *modular-funs* (make-hash-table :test 'eq)) @@ -166,9 +166,11 @@ (defun find-modular-version (fun-name width) (let ((infos (gethash fun-name *modular-funs*))) - (find-if (lambda (item-width) (>= item-width width)) - infos - :key #'modular-fun-info-width))) + (if (eq infos :good) + :good + (find-if (lambda (item-width) (>= item-width width)) + infos + :key #'modular-fun-info-width)))) (defun %define-modular-fun (name lambda-list prototype width) (let* ((infos (the list (gethash prototype *modular-funs*))) @@ -206,3 +208,11 @@ (defknown ,name ,(mapcar (constantly 'integer) lambda-list) (unsigned-byte ,width) (foldable flushable movable)))) + +(defun %define-good-modular-fun (name) + (setf (gethash name *modular-funs*) :good) + name) + +(defmacro define-good-modular-fun (name) + (check-type name symbol) + `(%define-good-modular-fun ',name)) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index d5937ba..bc21fbe 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -409,3 +409,6 @@ (setf (node-derived-type node) (values-specifier-type '(values (unsigned-byte 32) &optional))) '(32bit-logical-not x))) + +(define-good-modular-fun logand) +(define-good-modular-fun logior) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index e79babe..d5db2d6 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -631,7 +631,7 @@ (defun describe-component (component *standard-output*) (declare (type component component)) (format t "~|~%;;;; component: ~S~2%" (component-name component)) - (print-blocks component) + (print-all-blocks component) (values)) (defun describe-ir2-component (component *standard-output*) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a05a91a..531f97b 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2440,39 +2440,60 @@ (logior (logand new mask) (logand int (lognot mask))))) -;;; modular functions +;;; Modular functions + +;;; (ldb (byte s 0) (foo x y ...)) = +;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...)) +;;; +;;; and similar for other arguments. If +;;; +;;; (ldb (byte s 0) (foo x y ...)) = +;;; (foo (ldb (byte s 0) x) (ldb (byte s 0) y) ...) ;;; -;;; -- lower N bits of a result depend only on lower N bits of -;;; arguments. +;;; the function FOO is :GOOD. ;;; Try to recursively cut all uses of the continuation CONT to WIDTH ;;; bits. (defun cut-to-width (cont width) (declare (type continuation cont) (type (integer 0) width)) - (labels ((cut-node (node) + (labels ((reoptimize-node (node name) + (setf (node-derived-type node) + (fun-type-returns + (info :function :type name))) + (setf (continuation-%derived-type (node-cont node)) nil) + (setf (node-reoptimize node) t) + (setf (block-reoptimize (node-block node)) t) + (setf (component-reoptimize (node-component node)) t)) + (cut-node (node &aux did-something) (when (and (combination-p node) (fun-info-p (basic-combination-kind node))) (let* ((fun-ref (continuation-use (combination-fun node))) (fun-name (leaf-source-name (ref-leaf fun-ref))) (modular-fun (find-modular-version fun-name width)) - (name (and modular-fun + (name (and (modular-fun-info-p modular-fun) (modular-fun-info-name modular-fun)))) - (when modular-fun - (change-ref-leaf fun-ref - (find-free-fun name "in a strange place")) - (setf (combination-kind node) :full) - (setf (node-derived-type node) - (fun-type-returns - (info :function :type name))) - (setf (continuation-%derived-type (node-cont node)) nil) - (setf (node-reoptimize node) t) - (setf (block-reoptimize (node-block node)) t) - (setf (component-reoptimize (node-component node)) t) + (when (and modular-fun + (not (and (eq name 'logand) + (csubtypep + (single-value-type (node-derived-type node)) + (specifier-type `(unsigned-byte ,width)))))) + (unless (eq modular-fun :good) + (setq did-something t) + (change-ref-leaf + fun-ref + (find-free-fun name "in a strange place")) + (setf (combination-kind node) :full)) (dolist (arg (basic-combination-args node)) - (cut-continuation arg)))))) - (cut-continuation (cont) + (when (cut-continuation arg) + (setq did-something t))) + (when did-something + (reoptimize-node node fun-name)) + did-something)))) + (cut-continuation (cont &aux did-something) (do-uses (node cont) - (cut-node node)))) + (when (cut-node node) + (setq did-something t))) + did-something)) (cut-continuation cont))) (defoptimizer (logand optimizer) ((x y) node) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index c4444e0..dc00bd5 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -978,51 +978,23 @@ (move result prev) (inst shrd result next :cl))) -(define-vop (32bit-logical) - (:args (x :scs (unsigned-reg) :target r - :load-if (not (and (sc-is x unsigned-stack) - (sc-is r unsigned-stack) - (location= x r)))) - (y :scs (unsigned-reg) - :load-if (or (not (sc-is y unsigned-stack)) - (and (sc-is x unsigned-stack) - (sc-is y unsigned-stack) - (location= x r))))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg) - :from (:argument 0) - :load-if (not (and (sc-is x unsigned-stack) - (sc-is r unsigned-stack) - (location= x r))))) - (:result-types unsigned-num) - (:policy :fast-safe)) - (define-source-transform 32bit-logical-not (x) `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32)))) -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (move r x) - (inst and r y))) +(deftransform 32bit-logical-and ((x y)) + '(logand x y)) (define-source-transform 32bit-logical-nand (x y) `(32bit-logical-not (32bit-logical-and ,x ,y))) -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (move r x) - (inst or r y))) +(deftransform 32bit-logical-or ((x y)) + '(logior x y)) (define-source-transform 32bit-logical-nor (x y) `(32bit-logical-not (32bit-logical-or ,x ,y))) -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (move r x) - (inst xor r y))) +(deftransform 32bit-logical-xor ((x y)) + '(logxor x y)) (define-source-transform 32bit-logical-eqv (x y) `(32bit-logical-not (32bit-logical-xor ,x ,y))) @@ -1378,33 +1350,13 @@ ;;;; Modular functions (define-modular-fun +-mod32 (x y) + 32) - -(define-vop (fast-+-mod32/unsigned=>unsigned fast-safe-arith-op) - (:translate +-mod32) - (:args (x :scs (unsigned-reg) :target r - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg) - (sc-is r unsigned-stack) - (location= x r)))) - (y :scs (unsigned-reg unsigned-stack))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg) :from (:argument 0) - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg) - (location= x r))))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic") - (:generator 5 - (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg) (sc-is r unsigned-reg) - (not (location= x r))) - (inst lea r (make-ea :dword :base x :index y :scale 1))) - (t - (move r x) - (inst add r y))))) +(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned) + (:translate +-mod32)) +(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned) + (:translate +-mod32)) ;;; logical operations (define-modular-fun lognot-mod32 (x) lognot 32) - (define-vop (lognot-mod32/unsigned=>unsigned) (:translate lognot-mod32) (:args (x :scs (unsigned-reg) :target r @@ -1421,3 +1373,11 @@ (:generator 1 (move r x) (inst not r))) + +(define-modular-fun logxor-mod32 (x y) logxor 32) +(define-vop (fast-logxor-mod32/unsigned=>unsigned + fast-logxor/unsigned=>unsigned) + (:translate logxor-mod32)) +(define-vop (fast-logxor-mod32-c/unsigned=>unsigned + fast-logxor-c/unsigned=>unsigned) + (:translate logxor-mod32)) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index c957c9f..5195bbb 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -64,3 +64,12 @@ (integer-decode-float f) (scale-float (float signif f) expon)) f))) + +;;; bug found by Paul Dietz: FFLOOR and similar did not work for integers +(let ((tests '(((ffloor -8 3) (-3.0 1)) + ((fround -8 3) (-3.0 1)) + ((ftruncate -8 3) (-2.0 -2)) + ((fceiling -8 3) (-2.0 -2))))) + (loop for (exp res) in tests + for real-res = (multiple-value-list (eval exp)) + do (assert (equal real-res res)))) diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index caf0bb5..b1f588e 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -129,3 +129,10 @@ (assert (eq s (last s (* 1440 most-positive-fixnum)))) (assert (null (butlast s (* 1440 most-positive-fixnum)))) (assert (null (nbutlast s (* 1440 most-positive-fixnum))))) + +;;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a +;;; alist +(let ((f (compile nil '(lambda (x) + (assoc x '(nil (a . b) nil (nil . c) (c . d)) + :test #'eq))))) + (assert (equal (funcall f 'nil) '(nil . c)))) diff --git a/version.lisp-expr b/version.lisp-expr index 8513e96..9ecc77c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.2.28" +"0.8.2.29"