From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 20 Jan 2016 16:38:03 +0000 (-0700)
Subject: src/microcode/debug.c: Improve verify_heap.  Add verify_stack.
X-Git-Tag: mit-scheme-pucked-9.2.12~371^2~13
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4c50487b271156f0688afc39b5bb7b80b93e7178;p=mit-scheme.git

src/microcode/debug.c: Improve verify_heap.  Add verify_stack.

Scan the stack and note if it is not "sealed" ("closed"?).  It should
have either a return code or a compiled entry at the top.  Also note
any extraordinarily large objects.
---

diff --git a/src/microcode/debug.c b/src/microcode/debug.c
index a1788142c..b47d93e45 100644
--- a/src/microcode/debug.c
+++ b/src/microcode/debug.c
@@ -800,7 +800,8 @@ dump_object (SCHEME_OBJECT * addr)
 {
   SCHEME_OBJECT object = *addr;
   outf_error ("%#lx: ", (unsigned long)addr);
-  print_object (object);
+  do_printing (ERROR_OUTPUT, object, true);
+  outf_error ("\n");
   {
     SCHEME_OBJECT * end = next_addr (addr);
     while (++addr < end)
@@ -895,10 +896,16 @@ verify_heap_area (const char * name, SCHEME_OBJECT * area, SCHEME_OBJECT * end)
 		  SCHEME_OBJECT * next = area + (1 + n_words);
 		  if (next > end)
 		    {
-		      outf_error ("; %#lx: Invalid linkage section size: %ld\n",
+		      outf_error ("%#lx: Invalid linkage section size: %ld\n",
 				  (unsigned long)area, n_words);
 		      return (false);
 		    }
+		  else if (n_words > 1000)
+		    {
+		      outf_error
+			("%#lx: Extraordinary linkage section size: %ld\n",
+			 (unsigned long)area, n_words);
+		    }
 		  area = next;
 		}
 		break;
@@ -907,7 +914,7 @@ verify_heap_area (const char * name, SCHEME_OBJECT * area, SCHEME_OBJECT * end)
 		area += 1;
 		break;
 	      default:
-		outf_error ("; %#lx: Invalid linkage section type: %d\n",
+		outf_error ("%#lx: Invalid linkage section type: %#x\n",
 			    (unsigned long)area, section_type);
 		complaints += 1;
 		area += 1;
@@ -924,18 +931,23 @@ verify_heap_area (const char * name, SCHEME_OBJECT * area, SCHEME_OBJECT * end)
 	    SCHEME_OBJECT * next = area + (1 + n_words);
 	    if (next > end)
 	      {
-		outf_error ("; %#lx: Invalid nm-vector size: %ld\n",
+		outf_error ("%#lx: Invalid nm-vector size: %ld\n",
 			    (unsigned long)area, n_words);
 		return (false);
 	      }
+	    else if (n_words > 1000000)
+	      {
+		outf_error ("%#lx: Extraordinary nm-vector size: %ld\n",
+			    (unsigned long)area, n_words);
+	      }
 	    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);
+	      outf_error ("%#lx: Invalid object type: %#x\n",
+			  (unsigned long)area, type);
 	      complaints += 1;
 	    }
 	  area += 1;
@@ -944,18 +956,63 @@ verify_heap_area (const char * name, SCHEME_OBJECT * area, SCHEME_OBJECT * end)
     }
   if (area != end)
     {
-      outf_error ("; %#lx: Invalid address\n", (unsigned long)area);
+      outf_error ("%#lx: Invalid end address\n", (unsigned long)area);
       return (false);
     }
   return (complaints == 0);
 }
 
+bool
+verify_stack (SCHEME_OBJECT * sp, SCHEME_OBJECT * bottom)
+{
+  /* Check that the stack is "sealed" -- the top is an interpreter
+     return code or a compiled entry point (return address). */
+
+  int complaints = 0;
+  unsigned long addr = (unsigned long)sp;
+  SCHEME_OBJECT object = STACK_LOCATIVE_POP (sp);
+  unsigned int type = OBJECT_TYPE (object);
+  if (! (type == TC_RETURN_CODE || type == TC_COMPILED_ENTRY))
+    {
+      outf_error ("%#lx: Invalid stack top: ", addr);
+      do_printing (ERROR_OUTPUT, object, true);
+      outf_error ("\n");
+      complaints += 1;
+    }
+  while (STACK_LOCATIVE_ABOVE_P (sp, bottom))
+    {
+      addr = (unsigned long)sp;
+      object = STACK_LOCATIVE_POP (sp);
+      type = OBJECT_TYPE (object);
+      if (type == TC_MANIFEST_NM_VECTOR)
+	{
+	  unsigned long n_words = (OBJECT_DATUM (object));
+	  if (n_words > 1000)
+	    outf_error ("%#lx: Extraordinary finger size: %ld\n",
+			addr, n_words);
+	  sp = STACK_LOCATIVE_OFFSET (sp, n_words);
+	}
+      else if (type == TC_MANIFEST_CLOSURE
+	       || type == TC_BROKEN_HEART
+	       || gc_type_code (type) == GC_UNDEFINED)
+	{
+	  outf_error ("%#lx: Invalid stack slot: ", addr);
+	  do_printing (ERROR_OUTPUT, object, true);
+	  outf_error ("\n");
+	  complaints += 1;
+	}
+    }
+  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);
+  bool s = verify_stack (stack_pointer, STACK_BOTTOM);
+  outf_flush_error ();
+  return (c && h && s);
 }
 
 #else  /* !ENABLE_DEBUGGING_TOOLS */