** Printing with *PRINT-READABLY* targets the standard readtable, not
the readtable currently in effect.
+changes in sbcl-0.8.10 relative to sbcl-0.8.9:
+ * bug fix: compiler emitted division in optimized DEREF. (thanks for
+ the test case to Dave Roberts)
+
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
down, it might impact TRACE. They both encapsulate functions, and
(flushable movable))
(defknown deport (alien alien-type) t
(flushable movable))
-(defknown extract-alien-value (system-area-pointer index alien-type) t
+(defknown extract-alien-value (system-area-pointer unsigned-byte alien-type) t
(flushable))
-(defknown deposit-alien-value (system-area-pointer index alien-type t) t
+(defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t
())
(defknown alien-funcall (alien-value &rest *) *
(count-low-order-zeros (lvar-value thing))
(count-low-order-zeros (lvar-uses thing))))
(combination
- (case (lvar-fun-name (combination-fun thing))
+ (case (let ((name (lvar-fun-name (combination-fun thing))))
+ (or (modular-version-info name) name))
((+ -)
(let ((min most-positive-fixnum)
(itype (specifier-type 'integer)))
(do ((result 0 (1+ result))
(num thing (ash num -1)))
((logbitp 0 num) result))))
+ (cast
+ (count-low-order-zeros (cast-value thing)))
(t
0)))
(deftransform / ((numerator denominator) (integer integer))
+ "convert x/2^k to shift"
(unless (constant-lvar-p denominator)
(give-up-ir1-transform))
(let* ((denominator (lvar-value denominator))
(deftransform ash ((value amount))
(let ((value-node (lvar-uses value)))
- (unless (and (combination-p value-node)
- (eq (lvar-fun-name (combination-fun value-node))
- 'ash))
+ (unless (combination-p value-node)
(give-up-ir1-transform))
- (let ((inside-args (combination-args value-node)))
- (unless (= (length inside-args) 2)
- (give-up-ir1-transform))
- (let ((inside-amount (second inside-args)))
- (unless (and (constant-lvar-p inside-amount)
- (not (minusp (lvar-value inside-amount))))
- (give-up-ir1-transform)))))
- (extract-fun-args value 'ash 2)
- '(lambda (value amount1 amount2)
- (ash value (+ amount1 amount2))))
+ (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
+ (multiple-value-bind (prototype width)
+ (modular-version-info inside-fun-name)
+ (unless (eq (or prototype inside-fun-name) 'ash)
+ (give-up-ir1-transform))
+ (when (and width (not (constant-lvar-p amount)))
+ (give-up-ir1-transform))
+ (let ((inside-args (combination-args value-node)))
+ (unless (= (length inside-args) 2)
+ (give-up-ir1-transform))
+ (let ((inside-amount (second inside-args)))
+ (unless (and (constant-lvar-p inside-amount)
+ (not (minusp (lvar-value inside-amount))))
+ (give-up-ir1-transform)))
+ (extract-fun-args value inside-fun-name 2)
+ (if width
+ `(lambda (value amount1 amount2)
+ (logand (ash value (+ amount1 amount2))
+ ,(1- (ash 1 (+ width (lvar-value amount))))))
+ `(lambda (value amount1 amount2)
+ (ash value (+ amount1 amount2)))))))))
\f
;;;; ALIEN-FUNCALL support
(defvar *modular-funs*
(make-hash-table :test 'eq))
+;;; hash: modular-variant -> (prototype width)
+;;;
+;;; FIXME: Reimplement with generic function names of kind
+;;; (MODULAR-VERSION prototype width)
+(defvar *modular-versions* (make-hash-table :test 'eq))
+
;;; List of increasing widths
(defvar *modular-funs-widths* nil)
(defstruct modular-fun-info
:key #'modular-fun-info-width)
infos)))
+;;; Return (VALUES prototype-name width)
+(defun modular-version-info (name)
+ (values-list (gethash name *modular-versions*)))
+
(defun %define-modular-fun (name lambda-list prototype width)
(let* ((infos (the list (gethash prototype *modular-funs*)))
(info (find-if (lambda (item-width) (= item-width width))
:lambda-list lambda-list
:prototype prototype))
infos
- #'< :key #'modular-fun-info-width))))
+ #'< :key #'modular-fun-info-width)
+ (gethash name *modular-versions*)
+ (list prototype width))))
(setq *modular-funs-widths*
(merge 'list (list width) *modular-funs-widths* #'<)))
#!-alpha
(progn
- (defknown sb!vm::ash-left-mod32 (integer (integer 0)) (unsigned-byte 32)
+ (defknown #1=sb!vm::ash-left-mod32 (integer (integer 0)) (unsigned-byte 32)
(foldable flushable movable))
(define-modular-fun-optimizer ash ((integer count) :width width)
(when (and (<= width 32)
(constant-lvar-p count) ; ?
(plusp (lvar-value count)))
(cut-to-width integer width)
- 'sb!vm::ash-left-mod32)))
+ '#1#))
+ (setf (gethash '#1# *modular-versions*) '(ash 32)))
#!+alpha
(progn
- (defknown sb!vm::ash-left-mod64 (integer (integer 0)) (unsigned-byte 64)
+ (defknown #1=sb!vm::ash-left-mod64 (integer (integer 0)) (unsigned-byte 64)
(foldable flushable movable))
(define-modular-fun-optimizer ash ((integer count) :width width)
(when (and (<= width 64)
(constant-lvar-p count) ; ?
(plusp (lvar-value count)))
(cut-to-width integer width)
- 'sb!vm::ash-left-mod64)))
+ '#1#)
+ (setf (gethash '#1# *modular-versions*) '(ash 64))))
\f
;;; There are two different ways the multiplier can be recoded. The
(return :minus)))))))))
(assert (eql (funcall f -1d0) :minus))
(assert (eql (funcall f 4d0) 2d0)))
+
+;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
+(handler-case
+ (compile nil '(lambda (a i)
+ (locally
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+ (inhibit-warnings 0)))
+ (declare (type (alien (* (unsigned 8))) a)
+ (type (unsigned-byte 32) i))
+ (deref a i))))
+ (compiler-note () (error "The code is not optimized.")))
;;; 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.9.3"
+"0.8.9.4"
projects / sbcl.git / commitdiff