1.0.25.21: handling of potential corruptions
[sbcl.git] / src / runtime / gencgc.c
index 49b7a16..9680743 100644 (file)
@@ -507,7 +507,8 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */
                 generations[i].num_gc,
                 gen_av_mem_age(i));
     }
-    fprintf(stderr,"   Total bytes allocated=%ld\n", bytes_allocated);
+    fprintf(stderr,"   Total bytes allocated    = %lu\n", bytes_allocated);
+    fprintf(stderr,"   Dynamic-space-size bytes = %u\n", dynamic_space_size);
 
     fpu_restore(fpu_state);
 }
@@ -1045,7 +1046,7 @@ gc_alloc_large(long nbytes, int page_type_flag, struct alloc_region *alloc_regio
     int orig_first_page_bytes_used;
     long byte_cnt;
     int more;
-    long bytes_used;
+    unsigned long bytes_used;
     page_index_t next_page;
     int ret;
 
@@ -1153,6 +1154,7 @@ static page_index_t gencgc_alloc_start_page = -1;
 void
 gc_heap_exhausted_error_or_lose (long available, long requested)
 {
+    struct thread *thread = arch_os_get_current_thread();
     /* 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
@@ -1165,7 +1167,6 @@ 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",
@@ -1180,6 +1181,18 @@ gc_heap_exhausted_error_or_lose (long available, long requested)
     else {
         /* FIXME: assert free_pages_lock held */
         (void)thread_mutex_unlock(&free_pages_lock);
+        gc_assert(get_pseudo_atomic_atomic(thread));
+        clear_pseudo_atomic_atomic(thread);
+        if (get_pseudo_atomic_interrupted(thread))
+            do_pending_interrupt();
+        /* Another issue is that signalling HEAP-EXHAUSTED error leads
+         * to running user code at arbitrary places, even in a
+         * WITHOUT-INTERRUPTS which may lead to a deadlock without
+         * running out of the heap. So at this point all bets are
+         * off. */
+        if (SymbolValue(INTERRUPTS_ENABLED,thread) == NIL)
+            corruption_warning_and_maybe_lose
+                ("Signalling HEAP-EXHAUSTED in a WITHOUT-INTERRUPTS.");
         funcall2(StaticSymbolFunction(HEAP_EXHAUSTED_ERROR),
                  alloc_number(available), alloc_number(requested));
         lose("HEAP-EXHAUSTED-ERROR fell through");
@@ -1187,7 +1200,8 @@ gc_heap_exhausted_error_or_lose (long available, long requested)
 }
 
 page_index_t
-gc_find_freeish_pages(page_index_t *restart_page_ptr, long nbytes, int page_type_flag)
+gc_find_freeish_pages(page_index_t *restart_page_ptr, long nbytes,
+                      int page_type_flag)
 {
     page_index_t first_page, last_page;
     page_index_t restart_page = *restart_page_ptr;
@@ -1200,7 +1214,8 @@ gc_find_freeish_pages(page_index_t *restart_page_ptr, long nbytes, int page_type
         restart_page = gencgc_alloc_start_page;
     }
 
-    if (nbytes>=PAGE_BYTES) {
+    gc_assert(nbytes>=0);
+    if (((unsigned long)nbytes)>=PAGE_BYTES) {
         /* Search for a contiguous free space of at least nbytes,
          * aligned on a page boundary. The page-alignment is strictly
          * speaking needed only for objects at least large_object_size
@@ -1514,9 +1529,10 @@ copy_large_unboxed_object(lispobj object, long nwords)
     gc_assert(from_space_p(object));
     gc_assert((nwords & 0x01) == 0);
 
-    if ((nwords > 1024*1024) && gencgc_verbose)
+    if ((nwords > 1024*1024) && gencgc_verbose) {
         FSHOW((stderr, "/copy_large_unboxed_object: %d bytes\n",
                nwords*N_WORD_BYTES));
+    }
 
     /* Check whether it's a large object. */
     first_page = find_page_index((void *)object);
@@ -1585,10 +1601,11 @@ copy_large_unboxed_object(lispobj object, long nwords)
             next_page++;
         }
 
-        if ((bytes_freed > 0) && gencgc_verbose)
+        if ((bytes_freed > 0) && gencgc_verbose) {
             FSHOW((stderr,
                    "/copy_large_unboxed bytes_freed=%d\n",
                    bytes_freed));
+        }
 
         generations[from_space].bytes_allocated -=
             nwords*N_WORD_BYTES + bytes_freed;
@@ -2230,28 +2247,31 @@ looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
             if ((unsigned long)pointer !=
                 ((unsigned long)start_addr+FUN_POINTER_LOWTAG)) {
-                if (gencgc_verbose)
+                if (gencgc_verbose) {
                     FSHOW((stderr,
                            "/Wf2: %x %x %x\n",
                            pointer, start_addr, *start_addr));
+                }
                 return 0;
             }
             break;
         default:
-            if (gencgc_verbose)
+            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)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wl1: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         /* Is it plausible cons? */
@@ -2261,44 +2281,49 @@ looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
              is_lisp_immediate(start_addr[1])))
             break;
         else {
-            if (gencgc_verbose)
+            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)
+            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)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wi2: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         break;
     case OTHER_POINTER_LOWTAG:
         if ((unsigned long)pointer !=
             ((unsigned long)start_addr+OTHER_POINTER_LOWTAG)) {
-            if (gencgc_verbose)
+            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)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wo2: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         switch (widetag_of(start_addr[0])) {
@@ -2308,26 +2333,29 @@ looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
 #if N_WORD_BITS == 64
         case SINGLE_FLOAT_WIDETAG:
 #endif
-            if (gencgc_verbose)
+            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)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "*Wo4: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
 
         case INSTANCE_HEADER_WIDETAG:
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "*Wo5: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
 
             /* the valid other immediate pointer objects */
@@ -2430,18 +2458,20 @@ looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
             break;
 
         default:
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wo6: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         break;
     default:
-        if (gencgc_verbose)
+        if (gencgc_verbose) {
             FSHOW((stderr,
                    "*W?: %x %x %x\n",
                    pointer, start_addr, *start_addr));
+        }
         return 0;
     }
 
@@ -2710,7 +2740,7 @@ preserve_pointer(void *addr)
      * probability that random garbage will be bogusly interpreted as
      * a pointer which prevents a page from moving. */
     if (!(code_page_p(addr_page_index)
-          || (is_lisp_pointer(addr) &&
+          || (is_lisp_pointer((lispobj)addr) &&
               possibly_valid_dynamic_space_pointer(addr))))
         return;
 
@@ -3145,8 +3175,9 @@ scavenge_newspace_generation(generation_index_t generation)
             /* New areas of objects allocated have been lost so need to do a
              * full scan to be sure! If this becomes a problem try
              * increasing NUM_NEW_AREAS. */
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 SHOW("new_areas overflow, doing full scavenge");
+            }
 
             /* Don't need to record new areas that get scavenged
              * anyway during scavenge_newspace_generation_one_scan. */
@@ -4068,7 +4099,7 @@ garbage_collect_generation(generation_index_t generation, int raise)
         fprintf(stderr,
                 "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
                 num_dont_move_pages,
-                npage_bytes(num_dont_move_pages);
+                npage_bytes(num_dont_move_pages));
     }
 #endif
 
@@ -4205,8 +4236,9 @@ garbage_collect_generation(generation_index_t generation, int raise)
     generations[generation].alloc_large_unboxed_start_page = 0;
 
     if (generation >= verify_gens) {
-        if (gencgc_verbose)
+        if (gencgc_verbose) {
             SHOW("verifying");
+        }
         verify_gc();
         verify_dynamic_space();
     }
@@ -4434,8 +4466,9 @@ gc_free_heap(void)
 {
     page_index_t page;
 
-    if (gencgc_verbose > 1)
+    if (gencgc_verbose > 1) {
         SHOW("entering gc_free_heap");
+    }
 
     for (page = 0; page < page_table_pages; page++) {
         /* Skip free pages which should already be zero filled. */
@@ -4698,11 +4731,7 @@ general_alloc_internal(long nbytes, int page_type_flag, struct alloc_region *reg
     if ((alloc_signal & FIXNUM_TAG_MASK) == 0) {
         if ((signed long) alloc_signal <= 0) {
             SetSymbolValue(ALLOC_SIGNAL, T, thread);
-#ifdef LISP_FEATURE_SB_THREAD
-            kill_thread_safely(thread->os_thread, SIGPROF);
-#else
-            raise(SIGPROF);
-#endif
+            thread_kill(thread->os_thread, SIGPROF);
         } else {
             SetSymbolValue(ALLOC_SIGNAL,
                            alloc_signal - (1 << N_FIXNUM_TAG_BITS),