X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fgencgc.c;h=8f6012918048a72553d2bbd6ae17c85f6571cb08;hb=4c09711eca1c33e60ff30a8f47f9c03b429d5994;hp=92df103d8f98640cf5d0594930389229379d07dd;hpb=4023b1bec2412344e5eea4a33cd85dd662149c67;p=sbcl.git

diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
index 92df103..8f60129 100644
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -1071,9 +1071,9 @@ void
 gc_heap_exhausted_error_or_lose (long available, long requested)
 {
     /* Write basic information before doing anything else: if we don't
-     * call to lisp this is a must, and even if we do there is always the
-     * danger that we bounce back here before the error has been handled,
-     * or indeed even printed.
+     * call to lisp this is a must, and even if we do there is always
+     * the danger that we bounce back here before the error has been
+     * handled, or indeed even printed.
      */
     fprintf(stderr, "Heap exhausted during %s: %ld bytes available, %ld requested.\n",
             gc_active_p ? "garbage collection" : "allocation", available, requested);
@@ -1081,14 +1081,23 @@ gc_heap_exhausted_error_or_lose (long available, long requested)
         /* If we are in GC, or totally out of memory there is no way
          * to sanely transfer control to the lisp-side of things.
          */
+        struct thread *thread = arch_os_get_current_thread();
         print_generation_stats(1);
+        fprintf(stderr, "GC control variables:\n");
+        fprintf(stderr, "          *GC-INHIBIT* = %s\n          *GC-PENDING* = %s\n",
+                SymbolValue(GC_INHIBIT,thread)==NIL ? "false" : "true",
+                SymbolValue(GC_PENDING,thread)==NIL ? "false" : "true");
+#ifdef LISP_FEATURE_SB_THREAD
+        fprintf(stderr, " *STOP-FOR-GC-PENDING* = %s\n",
+                SymbolValue(STOP_FOR_GC_PENDING,thread)==NIL ? "false" : "true");
+#endif
         lose("Heap exhausted, game over.");
     }
     else {
         /* FIXME: assert free_pages_lock held */
         thread_mutex_unlock(&free_pages_lock);
         funcall2(SymbolFunction(HEAP_EXHAUSTED_ERROR),
-                 make_fixnum(available), make_fixnum(requested));
+                 alloc_number(available), alloc_number(requested));
         lose("HEAP-EXHAUSTED-ERROR fell through");
     }
 }
@@ -2118,37 +2127,28 @@ search_dynamic_space(void *pointer)
 
 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 
-/* Is there any possibility that pointer is a valid Lisp object
- * reference, and/or something else (e.g. subroutine call return
- * address) which should prevent us from moving the referred-to thing?
- * This is called from preserve_pointers() */
+/* 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
-possibly_valid_dynamic_space_pointer(lispobj *pointer)
+looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
 {
-    lispobj *start_addr;
-
-    /* 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) {
+    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.
-     */
+     * low tag. */
     switch (lowtag_of((lispobj)pointer)) {
     case FUN_POINTER_LOWTAG:
         /* Start_addr should be the enclosing code object, or a closure
@@ -2390,6 +2390,47 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
     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;
+}
+
+/* Is there any possibility that pointer is a valid Lisp object
+ * reference, and/or something else (e.g. subroutine call return
+ * address) which should prevent us from moving the referred-to thing?
+ * This is called from preserve_pointers() */
+static int
+possibly_valid_dynamic_space_pointer(lispobj *pointer)
+{
+    lispobj *start_addr;
+
+    /* Find the object start address. */
+    if ((start_addr = search_dynamic_space(pointer)) == NULL) {
+        return 0;
+    }
+
+    return looks_like_valid_lisp_pointer_p(pointer, start_addr);
+}
+
 /* Adjust large bignum and vector objects. This will adjust the
  * allocated region if the size has shrunk, and move unboxed objects
  * into unboxed pages. The pages are not promoted here, and the