From ba02429b75951fc407be01c44fdcb01ff2908707 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Fri, 12 Sep 2003 09:16:53 +0000 Subject: [PATCH] 0.8.3.54: * Fix type derivers for %DPB and %DEPOSIT-FIELD: SIGNED-BYTE representation requires extra sign bit. (reported by Paul Dietz) --- NEWS | 2 ++ src/compiler/srctran.lisp | 63 +++++++++++++++------------------------------ tests/arith.pure.lisp | 8 ++++++ version.lisp-expr | 2 +- 4 files changed, 32 insertions(+), 43 deletions(-) diff --git a/NEWS b/NEWS index ce1611e..4b33b2d 100644 --- a/NEWS +++ b/NEWS @@ -2053,6 +2053,8 @@ changes in sbcl-0.8.4 relative to sbcl-0.8.3: ** unsigned addition of a 32-bit constant with the high bit set no longer causes an internal compiler error on the x86. ** LOGBITP accepts a non-negative bignum as its INDEX argument. + ** compiler incorrectly derived types of DPB and DEPOSIT-FIELD + with negative last argument. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index f675b2e..e2cb897 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2346,53 +2346,32 @@ (specifier-type 'unsigned-byte))) *universal-type*))) -(defoptimizer (%dpb derive-type) ((newbyte size posn int)) +(defun %deposit-field-derive-type-aux (size posn int) (let ((size (continuation-type size)) (posn (continuation-type posn)) (int (continuation-type int))) - (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer)) - (numeric-type-p posn) - (csubtypep posn (specifier-type 'integer)) - (numeric-type-p int) - (csubtypep int (specifier-type 'integer))) - (let ((size-high (numeric-type-high size)) - (posn-high (numeric-type-high posn)) - (high (numeric-type-high int)) - (low (numeric-type-low int))) - (if (and size-high posn-high high low - (<= (+ size-high posn-high) sb!vm:n-word-bits)) - (specifier-type - (list (if (minusp low) 'signed-byte 'unsigned-byte) - (max (integer-length high) - (integer-length low) - (+ size-high posn-high)))) - *universal-type*)) - *universal-type*))) + (when (and (numeric-type-p size) + (numeric-type-p posn) + (numeric-type-p int)) + (let ((size-high (numeric-type-high size)) + (posn-high (numeric-type-high posn)) + (high (numeric-type-high int)) + (low (numeric-type-low int))) + (when (and size-high posn-high high low + (<= (+ size-high posn-high) sb!vm:n-word-bits)) + (let ((raw-bit-count (max (integer-length high) + (integer-length low) + (+ size-high posn-high)))) + (specifier-type + (if (minusp low) + `(signed-byte ,(1+ raw-bit-count)) + `(unsigned-byte ,raw-bit-count))))))))) + +(defoptimizer (%dpb derive-type) ((newbyte size posn int)) + (%deposit-field-derive-type-aux size posn int)) (defoptimizer (%deposit-field derive-type) ((newbyte size posn int)) - (let ((size (continuation-type size)) - (posn (continuation-type posn)) - (int (continuation-type int))) - (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer)) - (numeric-type-p posn) - (csubtypep posn (specifier-type 'integer)) - (numeric-type-p int) - (csubtypep int (specifier-type 'integer))) - (let ((size-high (numeric-type-high size)) - (posn-high (numeric-type-high posn)) - (high (numeric-type-high int)) - (low (numeric-type-low int))) - (if (and size-high posn-high high low - (<= (+ size-high posn-high) sb!vm:n-word-bits)) - (specifier-type - (list (if (minusp low) 'signed-byte 'unsigned-byte) - (max (integer-length high) - (integer-length low) - (+ size-high posn-high)))) - *universal-type*)) - *universal-type*))) + (%deposit-field-derive-type-aux size posn int)) (deftransform %ldb ((size posn int) (fixnum fixnum integer) diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index 563f369..3452abe 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -137,3 +137,11 @@ (65 (ash most-negative-fixnum 36) t))) (destructuring-bind (index int result) x (assert (eq (eval `(logbitp ,index ,int)) result)))) + +;;; off-by-1 type inference error for %DPB and %DEPOSIT-FIELD: +(let ((f (compile nil '(lambda (b) + (integer-length (dpb b (byte 4 28) -1005)))))) + (assert (= (funcall f 1230070) 32))) +(let ((f (compile nil '(lambda (b) + (integer-length (deposit-field b (byte 4 28) -1005)))))) + (assert (= (funcall f 1230070) 32))) diff --git a/version.lisp-expr b/version.lisp-expr index 698941d..54ac710 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.3.53" +"0.8.3.54" -- 1.7.10.4