1.0.15.36: fix bug 423

 * TRULY-THE no longer eagerly annotates the LVAR, but rather acts
   like THE in unsafe code. (Inserts a cast for which no type-check is
   generated.)

 * ALLOC-NUMBER-STACK-SPACE and ALLOC-ALIEN-STACK-SPACE were missing
   :RESULT-TYPES, which was masked by the old TRULY-THE
   implementation. (Tested on x86, x86-64, PPC, but all backends
   updated -- hopefully correctly.)

 * Docstrings for THE and TRULY-THE.

 FWIW, this patch seems to make PPC+GENCGC build happy once again: but
 I don't know if that means the problems there were/are related to bug
 423 -- or if the exact memory layout just happens to change subtly so
 that whatever corruption occurs, just happens to occur in a place
 where the GC doesn't see it anymore. (Or if the exact point at which
 GC runs is now just slightly different so that the problem pointers
 are not live anymore, or...)

diff --git a/BUGS b/BUGS
index 0c152ac..0ec868e 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1889,26 +1889,6 @@ behaves ...erratically. Reported by Kevin Reid on sbcl-devel
 2007-07-06. (We don't _have_ to check things like this, but we
 generally try to check returns in safe code, so we should here too.)
 
-423: TRULY-THE and *CHECK-CONSISTENCY*
-
- The following signals errors due to TRULY-THEs in dead code:
-
- (let ((sb-c::*check-consistency* t))
-  (handler-bind ((warning #'error))
-    (flet ((make-lambda (type)
-             `(lambda (x)
-                ((lambda (z)
-                   (if (listp z)
-                       (let ((q (truly-the list z)))
-                         (length q))
-                       (if (arrayp z)
-                           (let ((q (truly-the vector z)))
-                             (length q))
-                           (error "oops"))))
-                 (the ,type x)))))
-      (compile nil (make-lambda 'list))
-      (compile nil (make-lambda 'vector)))))
-
 424: toplevel closures and *CHECK-CONSISTENCY*
 
  The following breaks under COMPILE-FILE if *CHECK-CONSISTENCY* is true.

diff --git a/NEWS b/NEWS
index 6752da1..ccab6c5 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,7 @@ changes in sbcl-1.0.16 relative to 1.0.15:
   * optimization: modular arithmetic for a particular requested width
     is implemented using a tagged representation unless a better 
     representation is available.
+  * fixed bug 423: TRULY-THE and *CHECK-CONSISTENCY* interaction.
   * bug fix: SB-BSD-SOCKETS:MAKE-INET-ADDRESS checks the input string
     for wellformedness and returns a specialized vector. (reported by
     Francois-Rene Rideau)

diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index 15e7ccc..e5d7cd1 100644 (file)
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -10,7 +10,7 @@
 (assert (equal (function-arglist 'cl-user::one)
                '(cl-user::a cl-user::b cl-user::c)))
 (assert (equal (function-arglist 'the)
-               '(type sb-c::value)))
+               '(sb-c::value-type sb-c::form)))
 
 (assert (equal (function-arglist #'(sb-pcl::slow-method cl-user::j (t)))
                '(sb-pcl::method-args sb-pcl::next-methods)))
@@ -81,7 +81,7 @@
 (assert (equal (function-arglist 'cl-user::one)
                '(cl-user::a cl-user::b cl-user::c)))
 (assert (equal (function-arglist 'the)
-               '(type sb-c::value)))
+               '(sb-c::value-type sb-c::form)))
 
 ;;; Check wrt. interplay of generic functions and their methods.
 

diff --git a/src/compiler/alpha/c-call.lisp b/src/compiler/alpha/c-call.lisp
index c49fd6c..f56225d 100644 (file)
--- a/src/compiler/alpha/c-call.lisp
+++ b/src/compiler/alpha/c-call.lisp
@@ -142,6 +142,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:generator 0
     (unless (zerop amount)

diff --git a/src/compiler/hppa/c-call.lisp b/src/compiler/hppa/c-call.lisp
index 69a5d31..088393a 100644 (file)
--- a/src/compiler/hppa/c-call.lisp
+++ b/src/compiler/hppa/c-call.lisp
@@ -149,6 +149,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:generator 0
     (move nsp-tn result)

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index d68a632..a6a6f64 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -860,26 +860,34 @@ other."
 
 ;;; Assert that FORM evaluates to the specified type (which may be a
 ;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
-(def-ir1-translator the ((type value) start next result)
-  (the-in-policy type value (lexenv-policy *lexenv*) start next result))
+(def-ir1-translator the ((value-type form) start next result)
+  #!+sb-doc
+  "Specifies that the values returned by FORM conform to the VALUE-TYPE.
+
+CLHS specifies that the consequences are undefined if any result is
+not of the declared type, but SBCL treats declarations as assertions
+as long as SAFETY is at least 2, in which case incorrect type
+information will result in a runtime type-error instead of leading to
+eg. heap corruption. This is however expressly non-portable: use
+CHECK-TYPE instead of THE to catch type-errors at runtime. THE is best
+considered an optimization tool to inform the compiler about types it
+is unable to derive from other declared types."
+  (the-in-policy value-type form (lexenv-policy *lexenv*) start next result))
 
 ;;; This is like the THE special form, except that it believes
 ;;; whatever you tell it. It will never generate a type check, but
 ;;; will cause a warning if the compiler can prove the assertion is
 ;;; wrong.
-(def-ir1-translator truly-the ((type value) start next result)
+(def-ir1-translator truly-the ((value-type form) start next result)
   #!+sb-doc
-  ""
-  #-nil
-  (let ((type (coerce-to-values (compiler-values-specifier-type type)))
-        (old (when result (find-uses result))))
-    (ir1-convert start next result value)
-    (when result
-      (do-uses (use result)
-        (unless (memq use old)
-          (derive-node-type use type)))))
-  #+nil
-  (the-in-policy type value '((type-check . 0)) start cont))
+  "Specifies that the values returned by FORM conform to the
+VALUE-TYPE, and causes the compiler to trust this information
+unconditionally.
+
+Consequences are undefined if any result is not of the declared type
+-- typical symptoms including memory corruptions. Use with great
+care."
+  (the-in-policy value-type form '((type-check . 0)) start next result))
 \f
 ;;;; SETQ
 

diff --git a/src/compiler/mips/c-call.lisp b/src/compiler/mips/c-call.lisp
index 32c8f1d..eae4850 100644 (file)
--- a/src/compiler/mips/c-call.lisp
+++ b/src/compiler/mips/c-call.lisp
@@ -271,6 +271,7 @@
 
 (define-vop (alloc-number-stack-space)
   (:info amount)
+  (:result-types system-area-pointer)
   (:results (result :scs (sap-reg any-reg)))
   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:generator 0

diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp
index 52db97f..1d75529 100644 (file)
--- a/src/compiler/ppc/c-call.lisp
+++ b/src/compiler/ppc/c-call.lisp
@@ -428,6 +428,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:generator 0
     (unless (zerop amount)

diff --git a/src/compiler/sparc/c-call.lisp b/src/compiler/sparc/c-call.lisp
index 03ff1c9..87f3a00 100644 (file)
--- a/src/compiler/sparc/c-call.lisp
+++ b/src/compiler/sparc/c-call.lisp
@@ -235,6 +235,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:generator 0
     (unless (zerop amount)

diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 04814f4..c9d4861 100644 (file)
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -269,6 +269,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:generator 0
     (aver (location= result rsp-tn))
     (unless (zerop amount)
@@ -289,6 +290,7 @@
   (:info amount)
   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   #!+sb-thread
   (:generator 0
     (aver (not (location= result rsp-tn)))

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 023c99b..ae98e18 100644 (file)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -279,6 +279,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:generator 0
     (aver (location= result esp-tn))
     (unless (zerop amount)
@@ -291,6 +292,7 @@
   (:info amount)
   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   #!+sb-thread
   (:generator 0
     (aver (not (location= result esp-tn)))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index ce69513..88463e1 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2323,3 +2323,22 @@
                (declare (fixnum y) (character x))
                (sb-sys:with-pinned-objects (x y)
                  (some-random-function))))
+
+;;; *CHECK-CONSISTENCY* and TRULY-THE
+
+(with-test (:name :bug-423)
+  (let ((sb-c::*check-consistency* t))
+    (handler-bind ((warning #'error))
+      (flet ((make-lambda (type)
+               `(lambda (x)
+                  ((lambda (z)
+                     (if (listp z)
+                         (let ((q (truly-the list z)))
+                           (length q))
+                         (if (arrayp z)
+                             (let ((q (truly-the vector z)))
+                               (length q))
+                             (error "oops"))))
+                   (the ,type x)))))
+        (compile nil (make-lambda 'list))
+        (compile nil (make-lambda 'vector))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 7c3cd9a..954d985 100644 (file)
--- 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".)
-"1.0.15.35"
+"1.0.15.36"