From a7a9b1029e8b9e45a5b66d62e161cc476cb7b60c Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Wed, 9 Nov 2011 12:49:28 -0500 Subject: [PATCH] Make MAKE-LISP-OBJ pickier on CHENEYGC. * Move the valid_lisp_pointer_p() guts from gencgc.c to gc-common.c, updating header files and staticness as required. Also remove all of the debug output conditional on gencgc_verbose (which is obviously gencgc-specific). * Make the lisp-side VALID-LISP-POINTER-P not-gencgc-specific. * Always use VALID-LISP-POINTER-P in MAKE-LISP-OBJ instead of using some simple bounds-check on CHENEYGC. --- NEWS | 3 + src/code/debug-int.lisp | 19 +-- src/runtime/gc-common.c | 230 +++++++++++++++++++++++++++++++++++ src/runtime/gc-internal.h | 2 + src/runtime/gencgc.c | 295 --------------------------------------------- tests/debug.impure.lisp | 22 ++++ 6 files changed, 259 insertions(+), 312 deletions(-) diff --git a/NEWS b/NEWS index ff33e74..70dcf9b 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,8 @@ ;;;; -*- 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 diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 7411bc5..ac460c3 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -539,8 +539,7 @@ (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)) @@ -1987,21 +1986,7 @@ register." ;; 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" diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index a3eb313..96de172 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -2409,6 +2409,236 @@ gc_search_space(lispobj *start, size_t words, lispobj *pointer) 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) { diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h index d45764d..72222bd 100644 --- a/src/runtime/gc-internal.h +++ b/src/runtime/gc-internal.h @@ -130,6 +130,8 @@ lispobj *search_dynamic_space(void *pointer); 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" diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 1023b6f..27ad418 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -2107,301 +2107,6 @@ search_dynamic_space(void *pointer) (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 diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 9d8c34b..94241be 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -576,4 +576,26 @@ (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") -- 1.7.10.4