Call verify_heap before GC to scan for bogosities.

Trap recovery (on Unix) occasionally fails the assert in
linkage_section_type when its scan of the heap encounters non-marked
words that are not "hidden" by a non-marked vector header.

The new verify_heap function scans the heap in the same way, and
complains on stderr about any invalid linkage section types, object
types, etc.  If the GC_Debug flag is set, verify_heap is called by the
garbage-collect primitive to scan maximal heap.

The new dump_heap_at function can be used to inspect the heap around a
reported bogosity.

diff --git a/src/microcode/debug.c b/src/microcode/debug.c
index fa2fc681e9a96211d48cd4ddb9968bcfce881078..c5336cb9747bdd3b1d7716a71975fa451feb96ca 100644 (file)
--- a/src/microcode/debug.c
+++ b/src/microcode/debug.c
@@ -734,6 +734,237 @@ Print_Primitive (SCHEME_OBJECT primitive)
   }
 }
 \f
+#ifdef ENABLE_DEBUGGING_TOOLS
+
+static void
+dump_word (SCHEME_OBJECT *addr)
+{
+  int i = 0;
+  unsigned char * bytes = (unsigned char *)addr;
+  outf_error ("%#lx: ", (unsigned long)addr);
+  while (i < sizeof(SCHEME_OBJECT))
+    {
+      if (isgraph (bytes[i]))
+       outf_error (" %2c", bytes[i]);
+      else
+       outf_error (" %02x", bytes[i]);
+      i += 1;
+    }
+  outf_error ("\n");
+}
+
+static SCHEME_OBJECT *
+next_addr (SCHEME_OBJECT * addr)
+{
+  SCHEME_OBJECT object = *addr;
+  unsigned int type = OBJECT_TYPE (object);
+  switch (type)
+   {
+    case TC_LINKAGE_SECTION:
+      {
+       linkage_section_type_t section_type
+         = ((linkage_section_type_t)((OBJECT_DATUM (object)) >> 16));
+       switch (section_type)
+         {
+         case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+         case LINKAGE_SECTION_TYPE_OPERATOR:
+           {
+             unsigned long n_words = ((OBJECT_DATUM (object)) & 0xFFFFUL);
+             return (addr + (1 + n_words));
+           }
+         case LINKAGE_SECTION_TYPE_REFERENCE:
+         case LINKAGE_SECTION_TYPE_ASSIGNMENT:
+           return (addr + 1);
+         default:
+           outf_error ("Invalid linkage section type: %d\n", section_type);
+           return (addr + 1);
+         }
+      }
+    case TC_MANIFEST_CLOSURE:
+      return (compiled_closure_objects (addr + 1));
+    case TC_MANIFEST_NM_VECTOR:
+      {
+       unsigned long n_words = (OBJECT_DATUM (object));
+       return (addr + (1 + n_words));
+      }
+    default:
+      return (addr + 1);
+    }
+}
+
+static void
+dump_object (SCHEME_OBJECT * addr)
+{
+  SCHEME_OBJECT object = *addr;
+  outf_error ("%#lx: ", (unsigned long)addr);
+  print_object (object);
+  {
+    SCHEME_OBJECT * end = next_addr (addr);
+    while (++addr < end)
+      dump_word (addr);
+  }
+}
+
+#define SAVE_COUNT 16
+static SCHEME_OBJECT *saved_addrs[SAVE_COUNT];
+static int saved_index;
+
+static void
+dump_heap_area_at (SCHEME_OBJECT * addr,
+                  SCHEME_OBJECT * area, SCHEME_OBJECT * end)
+{
+  SCHEME_OBJECT * scan = area;
+  assert (area <= addr && addr < end);
+  saved_index = 0;
+  while (scan < addr)
+    {
+      saved_addrs[saved_index++] = scan;
+      if (saved_index == SAVE_COUNT) saved_index = 0;
+      scan = next_addr (scan);
+    }
+  {
+    int i = saved_index;
+    do
+      {
+       SCHEME_OBJECT * saved = saved_addrs[i++];
+       if (i == SAVE_COUNT) i = 0;
+       dump_object (saved);
+      }
+    while (i != saved_index);
+  }
+  outf_error ("=> ");
+  {
+    int i = 0;
+    while (i < SAVE_COUNT && scan < end)
+      {
+       dump_object (scan);
+       i += 1;
+       scan = next_addr (scan);
+      }
+  }
+}
+
+void
+dump_heap_at (SCHEME_OBJECT *addr)
+{
+  if (constant_start <= addr && addr < constant_alloc_next)
+    {
+      outf_error ("Scanning constant area (%#lx - %#lx):\n",
+                 (unsigned long)constant_start,
+                 (unsigned long)constant_alloc_next);
+      dump_heap_area_at (addr, constant_start, constant_alloc_next);
+    }
+  else if (heap_start <= addr && addr < Free)
+    {
+      outf_error ("Scanning heap area (%#lx - %#lx):\n",
+                 (unsigned long)heap_start,
+                 (unsigned long)Free);
+      dump_heap_area_at (addr, heap_start, Free);
+    }
+  else
+    {
+      outf_error ("%#lx: not a heap address\n", (unsigned long)addr);
+    }
+  outf_flush_error ();
+}
+
+static bool
+verify_heap_area (const char * name, SCHEME_OBJECT * area, SCHEME_OBJECT * end)
+{
+  int complaints = 0;
+
+  while (area < end)
+    {
+      SCHEME_OBJECT object = *area;
+      unsigned int type = OBJECT_TYPE (object);
+      switch (type)
+       {
+       case TC_LINKAGE_SECTION:
+         {
+           linkage_section_type_t section_type
+             = ((linkage_section_type_t)((OBJECT_DATUM (object)) >> 16));
+           switch (section_type)
+             {
+             case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
+             case LINKAGE_SECTION_TYPE_OPERATOR:
+               {
+                 unsigned long n_words = ((OBJECT_DATUM (object)) & 0xFFFFUL);
+                 SCHEME_OBJECT * next = area + (1 + n_words);
+                 if (next > end)
+                   {
+                     outf_error ("; %#lx: Invalid linkage section size: %ld\n",
+                                 (unsigned long)area, n_words);
+                     return (false);
+                   }
+                 area = next;
+               }
+               break;
+             case LINKAGE_SECTION_TYPE_REFERENCE:
+             case LINKAGE_SECTION_TYPE_ASSIGNMENT:
+               area += 1;
+               break;
+             default:
+               outf_error ("; %#lx: Invalid linkage section type: %d\n",
+                           (unsigned long)area, section_type);
+               complaints += 1;
+               area += 1;
+               break;
+             }
+         }
+         break;
+       case TC_MANIFEST_CLOSURE:
+         area = compiled_closure_objects (area + 1);
+         break;
+       case TC_MANIFEST_NM_VECTOR:
+         {
+           unsigned long n_words = (OBJECT_DATUM (object));
+           SCHEME_OBJECT * next = area + (1 + n_words);
+           if (next > end)
+             {
+               outf_error ("; %#lx: Invalid nm-vector size: %ld\n",
+                           (unsigned long)area, n_words);
+               return (false);
+             }
+           area = next;
+         }
+         break;
+       default:
+         if (gc_type_code (type) == GC_UNDEFINED)
+           {
+             outf_error ("; %#lx: Invalid type code: %d (0x%x)\n",
+                         (unsigned long)area, type, type);
+             complaints += 1;
+           }
+         area += 1;
+         break;
+       }
+    }
+  if (area != end)
+    {
+      outf_error ("; %#lx: Invalid address\n", (unsigned long)area);
+      return (false);
+    }
+  return (complaints == 0);
+}
+
+bool
+verify_heap (void)
+{
+  bool c = verify_heap_area ("constants", constant_start, constant_alloc_next);
+  bool h = verify_heap_area ("heap", heap_start, Free);
+  return (c && h);
+}
+
+DEFINE_PRIMITIVE ("VERIFY-HEAP", Prim_verify_heap, 0, 0,
+                 "Validate the heap.\n\
+Complains if a scan of the heap encounters anything unexpected.\n\
+Returns #T if the scan was successful and #F if there were any complaints.")
+{
+  PRIMITIVE_HEADER (0);
+  PRIMITIVE_RETURN (verify_heap () ? SHARP_T : SHARP_F);
+}
+#endif
+\f
 /* Code for interactively setting and clearing the interpreter
    debugging flags.  Invoked via the "D" command to the ^C
    handler or during each FASLOAD. */

diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index 92784051e98a8ccf1f5be6a0221a108b67d569fc..dacfea88a94e1ca6ad25d02d19c02904d1583e4e 100644 (file)
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -112,6 +112,7 @@ extern void set_ulong_register (unsigned int, unsigned long);
    extern bool Per_File;
    extern bool Bignum_Debug;
 
+   extern bool verify_heap (void);
    extern void Pop_Return_Break_Point (void);
    extern unsigned int debug_slotno;
    extern unsigned int debug_nslots;

diff --git a/src/microcode/memmag.c b/src/microcode/memmag.c
index bad61898583071f0052008c2eb491a342eaf62f5..72df8efbe28d91b1193e9d7c2874dba3c5e33cda 100644 (file)
--- a/src/microcode/memmag.c
+++ b/src/microcode/memmag.c
@@ -266,6 +266,10 @@ the primitive GC daemons before returning.")
 
   ENTER_CRITICAL_SECTION ("garbage collector");
 
+#ifdef ENABLE_DEBUGGING_TOOLS
+  if (GC_Debug == true) verify_heap ();
+#endif
+
   open_tospace (heap_start);
   initialize_weak_chain ();
   ephemeron_count = 0;