- /* Find the object start address. */
- if ((start_addr = search_dynamic_space(pointer)) == NULL) {
- return 0;
- }
-
- /* We need to allow raw pointers into Code objects for return
- * addresses. This will also pick up pointers to functions in code
- * objects. */
- if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
- /* XXX could do some further checks here */
- return 1;
- }
-
- /* If it's not a return address then it needs to be a valid Lisp
- * pointer. */
- if (!is_lisp_pointer((lispobj)pointer)) {
- return 0;
- }
-
- /* Check that the object pointed to is consistent with the pointer
- * low tag.
- *
- * FIXME: It's not safe to rely on the result from this check
- * before an object is initialized. Thus, if we were interrupted
- * just as an object had been allocated but not initialized, the
- * GC relying on this result could bogusly reclaim the memory.
- * However, we can't really afford to do without this check. So
- * we should make it safe somehow.
- * (1) Perhaps just review the code to make sure
- * that WITHOUT-GCING or WITHOUT-INTERRUPTS or some such
- * thing is wrapped around critical sections where allocated
- * memory type bits haven't been set.
- * (2) Perhaps find some other hack to protect against this, e.g.
- * recording the result of the last call to allocate-lisp-memory,
- * and returning true from this function when *pointer is
- * a reference to that result.
- *
- * (surely pseudo-atomic is supposed to be used for exactly this?)
- */
- 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:
- /* This case is probably caught above. */
- break;
- case CLOSURE_HEADER_WIDETAG:
- case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
- if ((unsigned)pointer !=
- ((unsigned)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)pointer !=
- ((unsigned)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])
- || ((start_addr[0] & 3) == 0) /* fixnum */
- || (widetag_of(start_addr[0]) == BASE_CHAR_WIDETAG)
- || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
- && (is_lisp_pointer(start_addr[1])
- || ((start_addr[1] & 3) == 0) /* fixnum */
- || (widetag_of(start_addr[1]) == BASE_CHAR_WIDETAG)
- || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG)))
- 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)pointer !=
- ((unsigned)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 ((unsigned)pointer !=
- ((int)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 BASE_CHAR_WIDETAG:
- 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_STRING_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:
- case SINGLE_FLOAT_WIDETAG:
- case DOUBLE_FLOAT_WIDETAG:
-#ifdef LONG_FLOAT_WIDETAG
- case LONG_FLOAT_WIDETAG:
-#endif
- case SIMPLE_STRING_WIDETAG:
- 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_8_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
-#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
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
- case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
- case SIMPLE_ARRAY_SIGNED_BYTE_32_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;