From: Alexey Dejneka Date: Thu, 25 Mar 2004 18:22:50 +0000 (+0000) Subject: 0.8.9.4: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5dcf5905dc38232b3cc5ec6b309ea5c6424db957;p=sbcl.git 0.8.9.4: * Fix bug 304: ** combine ASH with ASH-MODx; ** declare OFFSET arguments of EXTRACT-ALIEN-VALUE and DEPOSIT-ALIEN-VALUE to be unbounded UNSIGNED-BYTE; ** COUNT-LOW-ORDER-ZEROS looks through CASTs; ** provide modular-version => prototype translation. --- diff --git a/NEWS b/NEWS index 61d8a4b..717ac6d 100644 --- a/NEWS +++ b/NEWS @@ -2363,6 +2363,10 @@ changes in sbcl-0.8.9 relative to sbcl-0.8.8: ** 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 diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 697410a..56ff0f3 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -61,9 +61,9 @@ (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 *) * @@ -520,7 +520,8 @@ (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))) @@ -553,10 +554,13 @@ (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)) @@ -570,20 +574,29 @@ (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))))))))) ;;;; ALIEN-FUNCALL support diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index b86d04d..ef031a9 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -158,6 +158,12 @@ (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 @@ -174,6 +180,10 @@ :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)) @@ -193,7 +203,9 @@ :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* #'<))) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 1d93eba..fa3bee3 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -446,24 +446,26 @@ #!-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)))) ;;; There are two different ways the multiplier can be recoded. The diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 53d6b4d..41d58f4 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1152,3 +1152,14 @@ (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."))) diff --git a/version.lisp-expr b/version.lisp-expr index 0116881..df7e8d7 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.9.3" +"0.8.9.4"