;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.0.53:
+ * enchancement: on CHENEYGC targets, SB-KERNEL:MAKE-LISP-OBJ now does
+ the same validation of pointer objects as GENCGC does, instead of a
+ comparatively weak bounds-check against the heap spaces.
* bug fix: on 64-bit targets, atomic-incf/aref does index computation
correctly, even on wide-fixnum builds. (lp#887220)
* bug fix: (directory "foo/*/*.*") did not follow symlinks in foo/ that
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
-#!+gencgc (declaim (inline valid-lisp-pointer-p))
-#!+gencgc
+(declaim (inline valid-lisp-pointer-p))
(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
(pointer system-area-pointer))
;; unbound marker
(= val sb!vm:unbound-marker-widetag)
;; pointer
- #!+gencgc
- (not (zerop (valid-lisp-pointer-p (int-sap val))))
- ;; FIXME: There is no fundamental reason not to use the above
- ;; function on other platforms as well, but I didn't have
- ;; others available while doing this. --NS 2007-06-21
- #!-gencgc
- (and (logbitp 0 val)
- (or (< sb!vm:read-only-space-start val
- (ash sb!vm:*read-only-space-free-pointer*
- sb!vm:n-fixnum-tag-bits))
- (< sb!vm:static-space-start val
- (ash sb!vm:*static-space-free-pointer*
- sb!vm:n-fixnum-tag-bits))
- (< (current-dynamic-space-start) val
- (sap-int (dynamic-space-free-pointer))))))
+ (not (zerop (valid-lisp-pointer-p (int-sap val)))))
(values (%make-lisp-obj val) t)
(if errorp
(error "~S is not a valid argument to ~S"
return (NULL);
}
+/* Helper for valid_lisp_pointer_p (below) and
+ * possibly_valid_dynamic_space_pointer (gencgc).
+ *
+ * pointer is the pointer to validate, and start_addr is the address
+ * of the enclosing object.
+ */
+int
+looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
+{
+ if (!is_lisp_pointer((lispobj)pointer)) {
+ return 0;
+ }
+
+ /* Check that the object pointed to is consistent with the pointer
+ * low tag. */
+ switch (lowtag_of((lispobj)pointer)) {
+ case FUN_POINTER_LOWTAG:
+ /* Start_addr should be the enclosing code object, or a closure
+ * header. */
+ switch (widetag_of(*start_addr)) {
+ case CODE_HEADER_WIDETAG:
+ /* Make sure we actually point to a function in the code object,
+ * as opposed to a random point there. */
+ if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(*((lispobj *)(((unsigned long)pointer)-FUN_POINTER_LOWTAG))))
+ return 1;
+ else
+ return 0;
+ case CLOSURE_HEADER_WIDETAG:
+ case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
+ if ((unsigned long)pointer !=
+ ((unsigned long)start_addr+FUN_POINTER_LOWTAG)) {
+ return 0;
+ }
+ break;
+ default:
+ return 0;
+ }
+ break;
+ case LIST_POINTER_LOWTAG:
+ if ((unsigned long)pointer !=
+ ((unsigned long)start_addr+LIST_POINTER_LOWTAG)) {
+ return 0;
+ }
+ /* Is it plausible cons? */
+ if ((is_lisp_pointer(start_addr[0]) ||
+ is_lisp_immediate(start_addr[0])) &&
+ (is_lisp_pointer(start_addr[1]) ||
+ is_lisp_immediate(start_addr[1])))
+ break;
+ else {
+ return 0;
+ }
+ case INSTANCE_POINTER_LOWTAG:
+ if ((unsigned long)pointer !=
+ ((unsigned long)start_addr+INSTANCE_POINTER_LOWTAG)) {
+ return 0;
+ }
+ if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
+ return 0;
+ }
+ break;
+ case OTHER_POINTER_LOWTAG:
+
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
+ /* The all-architecture test below is good as far as it goes,
+ * but an LRA object is similar to a FUN-POINTER: It is
+ * embedded within a CODE-OBJECT pointed to by start_addr, and
+ * cannot be found by simply walking the heap, therefore we
+ * need to check for it. -- AB, 2010-Jun-04 */
+ if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
+ lispobj *potential_lra =
+ (lispobj *)(((unsigned long)pointer) - OTHER_POINTER_LOWTAG);
+ if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
+ ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
+ return 1; /* It's as good as we can verify. */
+ }
+ }
+#endif
+
+ if ((unsigned long)pointer !=
+ ((unsigned long)start_addr+OTHER_POINTER_LOWTAG)) {
+ return 0;
+ }
+ /* Is it plausible? Not a cons. XXX should check the headers. */
+ if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ return 0;
+ }
+ switch (widetag_of(start_addr[0])) {
+ case UNBOUND_MARKER_WIDETAG:
+ case NO_TLS_VALUE_MARKER_WIDETAG:
+ case CHARACTER_WIDETAG:
+#if N_WORD_BITS == 64
+ case SINGLE_FLOAT_WIDETAG:
+#endif
+ return 0;
+
+ /* only pointed to by function pointers? */
+ case CLOSURE_HEADER_WIDETAG:
+ case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
+ return 0;
+
+ case INSTANCE_HEADER_WIDETAG:
+ return 0;
+
+ /* the valid other immediate pointer objects */
+ case SIMPLE_VECTOR_WIDETAG:
+ case RATIO_WIDETAG:
+ case COMPLEX_WIDETAG:
+#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
+ case COMPLEX_SINGLE_FLOAT_WIDETAG:
+#endif
+#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
+ case COMPLEX_DOUBLE_FLOAT_WIDETAG:
+#endif
+#ifdef COMPLEX_LONG_FLOAT_WIDETAG
+ case COMPLEX_LONG_FLOAT_WIDETAG:
+#endif
+ case SIMPLE_ARRAY_WIDETAG:
+ case COMPLEX_BASE_STRING_WIDETAG:
+#ifdef COMPLEX_CHARACTER_STRING_WIDETAG
+ case COMPLEX_CHARACTER_STRING_WIDETAG:
+#endif
+ case COMPLEX_VECTOR_NIL_WIDETAG:
+ case COMPLEX_BIT_VECTOR_WIDETAG:
+ case COMPLEX_VECTOR_WIDETAG:
+ case COMPLEX_ARRAY_WIDETAG:
+ case VALUE_CELL_HEADER_WIDETAG:
+ case SYMBOL_HEADER_WIDETAG:
+ case FDEFN_WIDETAG:
+ case CODE_HEADER_WIDETAG:
+ case BIGNUM_WIDETAG:
+#if N_WORD_BITS != 64
+ case SINGLE_FLOAT_WIDETAG:
+#endif
+ case DOUBLE_FLOAT_WIDETAG:
+#ifdef LONG_FLOAT_WIDETAG
+ case LONG_FLOAT_WIDETAG:
+#endif
+ case SIMPLE_BASE_STRING_WIDETAG:
+#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
+ case SIMPLE_CHARACTER_STRING_WIDETAG:
+#endif
+ case SIMPLE_BIT_VECTOR_WIDETAG:
+ case SIMPLE_ARRAY_NIL_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+
+ case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
+
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+ case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
+ case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
+ case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
+#endif
+
+ case SIMPLE_ARRAY_FIXNUM_WIDETAG:
+
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
+ case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+ case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
+ case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
+ case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
+#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
+ case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
+ case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
+ case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
+ case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
+#endif
+ case SAP_WIDETAG:
+ case WEAK_POINTER_WIDETAG:
+ break;
+
+ default:
+ return 0;
+ }
+ break;
+ default:
+ return 0;
+ }
+
+ /* looks good */
+ return 1;
+}
+
+/* Used by the debugger to validate possibly bogus pointers before
+ * calling MAKE-LISP-OBJ on them.
+ *
+ * FIXME: We would like to make this perfect, because if the debugger
+ * constructs a reference to a bugs lisp object, and it ends up in a
+ * location scavenged by the GC all hell breaks loose.
+ *
+ * Whereas possibly_valid_dynamic_space_pointer has to be conservative
+ * and return true for all valid pointers, this could actually be eager
+ * and lie about a few pointers without bad results... but that should
+ * be reflected in the name.
+ */
+int
+valid_lisp_pointer_p(lispobj *pointer)
+{
+ lispobj *start;
+ if (((start=search_dynamic_space(pointer))!=NULL) ||
+ ((start=search_static_space(pointer))!=NULL) ||
+ ((start=search_read_only_space(pointer))!=NULL))
+ return looks_like_valid_lisp_pointer_p(pointer, start);
+ else
+ return 0;
+}
+
boolean
maybe_gc(os_context_t *context)
{
lispobj *gc_search_space(lispobj *start, size_t words, lispobj *pointer);
+extern int looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr);
+
extern void scrub_control_stack();
#include "fixnump.h"
(lispobj *)pointer));
}
-/* Helper for valid_lisp_pointer_p and
- * possibly_valid_dynamic_space_pointer.
- *
- * pointer is the pointer to validate, and start_addr is the address
- * of the enclosing object.
- */
-static int
-looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
-{
- if (!is_lisp_pointer((lispobj)pointer)) {
- return 0;
- }
-
- /* Check that the object pointed to is consistent with the pointer
- * low tag. */
- switch (lowtag_of((lispobj)pointer)) {
- case FUN_POINTER_LOWTAG:
- /* Start_addr should be the enclosing code object, or a closure
- * header. */
- switch (widetag_of(*start_addr)) {
- case CODE_HEADER_WIDETAG:
- /* Make sure we actually point to a function in the code object,
- * as opposed to a random point there. */
- if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(*((lispobj *)(((unsigned long)pointer)-FUN_POINTER_LOWTAG))))
- return 1;
- else
- return 0;
- case CLOSURE_HEADER_WIDETAG:
- case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
- if ((unsigned long)pointer !=
- ((unsigned long)start_addr+FUN_POINTER_LOWTAG)) {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wf2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- break;
- default:
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wf3: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- break;
- case LIST_POINTER_LOWTAG:
- if ((unsigned long)pointer !=
- ((unsigned long)start_addr+LIST_POINTER_LOWTAG)) {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wl1: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- /* Is it plausible cons? */
- if ((is_lisp_pointer(start_addr[0]) ||
- is_lisp_immediate(start_addr[0])) &&
- (is_lisp_pointer(start_addr[1]) ||
- is_lisp_immediate(start_addr[1])))
- break;
- else {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wl2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- case INSTANCE_POINTER_LOWTAG:
- if ((unsigned long)pointer !=
- ((unsigned long)start_addr+INSTANCE_POINTER_LOWTAG)) {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wi1: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wi2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- break;
- case OTHER_POINTER_LOWTAG:
-
-#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
- /* The all-architecture test below is good as far as it goes,
- * but an LRA object is similar to a FUN-POINTER: It is
- * embedded within a CODE-OBJECT pointed to by start_addr, and
- * cannot be found by simply walking the heap, therefore we
- * need to check for it. -- AB, 2010-Jun-04 */
- if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
- lispobj *potential_lra =
- (lispobj *)(((unsigned long)pointer) - OTHER_POINTER_LOWTAG);
- if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
- ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
- return 1; /* It's as good as we can verify. */
- }
- }
-#endif
-
- if ((unsigned long)pointer !=
- ((unsigned long)start_addr+OTHER_POINTER_LOWTAG)) {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wo1: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- /* Is it plausible? Not a cons. XXX should check the headers. */
- if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wo2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- switch (widetag_of(start_addr[0])) {
- case UNBOUND_MARKER_WIDETAG:
- case NO_TLS_VALUE_MARKER_WIDETAG:
- case CHARACTER_WIDETAG:
-#if N_WORD_BITS == 64
- case SINGLE_FLOAT_WIDETAG:
-#endif
- if (gencgc_verbose) {
- FSHOW((stderr,
- "*Wo3: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
-
- /* only pointed to by function pointers? */
- case CLOSURE_HEADER_WIDETAG:
- case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
- if (gencgc_verbose) {
- FSHOW((stderr,
- "*Wo4: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
-
- case INSTANCE_HEADER_WIDETAG:
- if (gencgc_verbose) {
- FSHOW((stderr,
- "*Wo5: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
-
- /* the valid other immediate pointer objects */
- case SIMPLE_VECTOR_WIDETAG:
- case RATIO_WIDETAG:
- case COMPLEX_WIDETAG:
-#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
- case COMPLEX_SINGLE_FLOAT_WIDETAG:
-#endif
-#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
- case COMPLEX_DOUBLE_FLOAT_WIDETAG:
-#endif
-#ifdef COMPLEX_LONG_FLOAT_WIDETAG
- case COMPLEX_LONG_FLOAT_WIDETAG:
-#endif
- case SIMPLE_ARRAY_WIDETAG:
- case COMPLEX_BASE_STRING_WIDETAG:
-#ifdef COMPLEX_CHARACTER_STRING_WIDETAG
- case COMPLEX_CHARACTER_STRING_WIDETAG:
-#endif
- case COMPLEX_VECTOR_NIL_WIDETAG:
- case COMPLEX_BIT_VECTOR_WIDETAG:
- case COMPLEX_VECTOR_WIDETAG:
- case COMPLEX_ARRAY_WIDETAG:
- case VALUE_CELL_HEADER_WIDETAG:
- case SYMBOL_HEADER_WIDETAG:
- case FDEFN_WIDETAG:
- case CODE_HEADER_WIDETAG:
- case BIGNUM_WIDETAG:
-#if N_WORD_BITS != 64
- case SINGLE_FLOAT_WIDETAG:
-#endif
- case DOUBLE_FLOAT_WIDETAG:
-#ifdef LONG_FLOAT_WIDETAG
- case LONG_FLOAT_WIDETAG:
-#endif
- case SIMPLE_BASE_STRING_WIDETAG:
-#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
- case SIMPLE_CHARACTER_STRING_WIDETAG:
-#endif
- case SIMPLE_BIT_VECTOR_WIDETAG:
- case SIMPLE_ARRAY_NIL_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
-
- case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
-
- case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
-#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
- case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
- case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
- case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
- case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
-#endif
-
- case SIMPLE_ARRAY_FIXNUM_WIDETAG:
-
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
- case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
- case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
-#endif
- case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
- case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
-#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
- case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
- case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
- case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
- case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
-#endif
- case SAP_WIDETAG:
- case WEAK_POINTER_WIDETAG:
- break;
-
- default:
- if (gencgc_verbose) {
- FSHOW((stderr,
- "/Wo6: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
- break;
- default:
- if (gencgc_verbose) {
- FSHOW((stderr,
- "*W?: %x %x %x\n",
- pointer, start_addr, *start_addr));
- }
- return 0;
- }
-
- /* looks good */
- return 1;
-}
-
-/* Used by the debugger to validate possibly bogus pointers before
- * calling MAKE-LISP-OBJ on them.
- *
- * FIXME: We would like to make this perfect, because if the debugger
- * constructs a reference to a bugs lisp object, and it ends up in a
- * location scavenged by the GC all hell breaks loose.
- *
- * Whereas possibly_valid_dynamic_space_pointer has to be conservative
- * and return true for all valid pointers, this could actually be eager
- * and lie about a few pointers without bad results... but that should
- * be reflected in the name.
- */
-int
-valid_lisp_pointer_p(lispobj *pointer)
-{
- lispobj *start;
- if (((start=search_dynamic_space(pointer))!=NULL) ||
- ((start=search_static_space(pointer))!=NULL) ||
- ((start=search_read_only_space(pointer))!=NULL))
- return looks_like_valid_lisp_pointer_p(pointer, start);
- else
- return 0;
-}
-
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
/* Is there any possibility that pointer is a valid Lisp object
(sb-kernel:get-lisp-obj-address
#'identity))))))
+;;; Older CHENEYGC systems didn't perform any real pointer validity
+;;; checks beyond "is this pointer to somewhere in heap space".
+(with-test (:name (make-lisp-obj :pointer-validation))
+ ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
+ ;; address, but we also need the GC to not pitch a fit if it sees an
+ ;; object with said bogus address. Thus, construct our known-bogus
+ ;; object within an area of unboxed storage (a vector) in static
+ ;; space. We'll make it a simple object, (CONS 0 0), which has an
+ ;; in-memory representation of two consecutive zero words. We
+ ;; allocate a three-word vector so that we can guarantee a
+ ;; double-word aligned double-word of zeros no matter what happens
+ ;; with the vector-data-offset (currently double-word aligned).
+ (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
+ :initial-element 0))
+ (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
+ (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
+ (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
+ (multiple-value-bind
+ (object valid-p)
+ (sb-kernel:make-lisp-obj object-tagged-address nil)
+ (assert (not valid-p)))))
+
(write-line "/debug.impure.lisp done")
projects / sbcl.git / commitdiff