** 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
;; 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):
(defun float-radix (x)
#!+sb-doc
"Return (as an integer) the radix b of its floating-point argument."
+ (declare (ignore x))
2)
\f
;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
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)
(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)
\f
;;; Modular functions
-;;; hash: name -> ({(width . fun)}*)
+;;; hash: name -> { ({(width . fun)}*) | :good }
(defvar *modular-funs*
(make-hash-table :test 'eq))
(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*)))
(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))
(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)
(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*)
(logior (logand new mask)
(logand int (lognot mask)))))
\f
-;;; 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)
(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)))
\f
;;;; 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
(: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))
(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))))
(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))))
;;; 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"
projects / sbcl.git / commitdiff