From 7c8658966e98e90b189de333810cb54fed621ed7 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Mon, 7 Feb 2005 04:24:17 +0000 Subject: [PATCH] 0.8.19.17: * Fix bug: ANNOTATE-FIXED-VALUES-LVAR can be called on a DX LVAR (through CAST). (reported by Timmy Douglas). --- NEWS | 2 ++ src/compiler/ltn.lisp | 12 ++++++++---- src/compiler/x86/array.lisp | 3 ++- tests/dynamic-extent.impure.lisp | 18 ++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 31 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index e98bb1e..0c39013 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,8 @@ changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19: * fixed bug: COUNT and EQUAL on bit vectors with lengths divisible by the wordsize no longer ignore the last word. (reported by Lutz Euler) + * fixed bug in type checking of dynamic-extent variables. (reported + by Svein Ove Aas) * optimization: sequence traversal functions use their freedom to coerce function designators to functions. * optimization: code with many calls to CLOS methods specialized on diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 562825c..9eaa71f 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -225,10 +225,14 @@ ;;; specified primitive TYPES. (defun annotate-fixed-values-lvar (lvar types) (declare (type lvar lvar) (list types)) - (aver (not (lvar-dynamic-extent lvar))) ; XXX - (let ((res (make-ir2-lvar nil))) - (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types)) - (setf (lvar-info lvar) res)) + (let ((info (make-ir2-lvar nil))) + (setf (ir2-lvar-locs info) (mapcar #'make-normal-tn types)) + (setf (lvar-info lvar) info) + (when (lvar-dynamic-extent lvar) + (aver (proper-list-of-length-p types 1)) + #!+stack-grows-downward-not-upward + (setf (ir2-lvar-stack-pointer info) + (make-stack-pointer-tn)))) (ltn-annotate-casts lvar) (values)) diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp index 2cd1d08..493cd7d 100644 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -260,7 +260,8 @@ (mask ,(1- (ash 1 bits))) (shift (* extra ,bits))) (unless (= value mask) - (inst and old (ldb (byte 32 0) (lognot (ash mask shift))))) + (inst and old (ldb (byte n-word-bits 0) + (lognot (ash mask shift))))) (unless (zerop value) (inst or old (ash value shift))))) (unsigned-reg diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 33c6186..942be0d 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -127,5 +127,23 @@ a))) 'x 'y) 'x)) + + +;;; other bugs + +;;; bug reported by Svein Ove Aas +(defun svein-2005-ii-07 (x y) + (declare (optimize (speed 3) (space 2) (safety 0) (debug 0))) + (let ((args (list* y 1 2 x))) + (declare (dynamic-extent args)) + (apply #'aref args))) +(assert (eql + (svein-2005-ii-07 + '(0) + #3A(((1 1 1) (1 1 1) (1 1 1)) + ((1 1 1) (1 1 1) (4 1 1)) + ((1 1 1) (1 1 1) (1 1 1)))) + 4)) + (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 7ab83d2..a69e3a9 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.19.16" +"0.8.19.17" -- 1.7.10.4