Add new primitive GC-TRACE-REFERENCES which will compute the set of

objects that point to a given object.  This primitive is implemented
only when the compile-time flag ENABLE_GC_DEBUGGING_TOOLS is set.

diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c
index d232e8ada0686bfa7e3dbeae052f67a7483e1c82..dc886959f81ed9ad42ecba792851c49007d562e1 100644 (file)
--- a/v7/src/microcode/fasdump.c
+++ b/v7/src/microcode/fasdump.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: fasdump.c,v 9.54 1993/02/11 02:18:59 adams Exp $
+$Id: fasdump.c,v 9.55 1993/03/10 17:19:29 cph Exp $
 
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -133,6 +133,9 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode)
 {
   fast SCHEME_OBJECT *To, *Old, Temp, New_Address, *Fixes;
   long result;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+  SCHEME_OBJECT object_referencing;
+#endif
 
   To = NewFree;
   Fixes = Fixup;
@@ -140,6 +143,9 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode)
   for ( ; Scan != To; Scan++)
   {
     Temp = *Scan;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+    object_referencing = Temp;
+#endif
 \f
     Switch_by_GC_Type (Temp)
     {

diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h
index d3751d9ffb3885751e0c202f6d4b7e8e93f58445..2e902d99427f6d0faa5db005859365159371ef22 100644 (file)
--- a/v7/src/microcode/gccode.h
+++ b/v7/src/microcode/gccode.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: gccode.h,v 9.46 1992/12/05 03:33:24 cph Exp $
+$Id: gccode.h,v 9.47 1993/03/10 17:19:44 cph Exp $
 
-Copyright (c) 1987-92 Massachusetts Institute of Technology
+Copyright (c) 1987-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -250,33 +250,82 @@ do                                                                        \
 \f
 /* GC Type handlers.  These do the actual work. */
 
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+
+extern SCHEME_OBJECT gc_object_referenced;
+extern SCHEME_OBJECT gc_objects_referencing;
+extern unsigned long gc_objects_referencing_count;
+extern SCHEME_OBJECT * gc_objects_referencing_scan;
+extern SCHEME_OBJECT * gc_objects_referencing_end;
+
+#define TRANSPORT_ONE_THING(transport_code)                            \
+{                                                                      \
+  if ((gc_object_referenced == (*Old))                                 \
+      && (gc_objects_referencing != SHARP_F))                          \
+    {                                                                  \
+      gc_objects_referencing_count += 1;                               \
+      if (gc_objects_referencing_scan != gc_objects_referencing_end)   \
+       {                                                               \
+         UPDATE_GC_OBJECTS_REFERENCING ();                             \
+         (*gc_objects_referencing_scan++) = object_referencing;        \
+       }                                                               \
+    }                                                                  \
+  transport_code;                                                      \
+}
+
+#define UPDATE_GC_OBJECTS_REFERENCING()                                        \
+{                                                                      \
+  if (BROKEN_HEART_P (MEMORY_REF (gc_objects_referencing, 0)))         \
+    {                                                                  \
+      SCHEME_OBJECT new =                                              \
+       (MAKE_OBJECT_FROM_OBJECTS                                       \
+        (gc_objects_referencing,                                       \
+         (MEMORY_REF (gc_objects_referencing, 0))));                   \
+      gc_objects_referencing_scan =                                    \
+       (VECTOR_LOC                                                     \
+        (new,                                                          \
+         (gc_objects_referencing_scan                                  \
+          - (VECTOR_LOC (gc_objects_referencing, 0)))));               \
+      gc_objects_referencing_end =                                     \
+       (VECTOR_LOC (new, (VECTOR_LENGTH (new))));                      \
+      gc_objects_referencing = new;                                    \
+    }                                                                  \
+}
+
+#else
+
+#define TRANSPORT_ONE_THING(transport_code) transport_code
+
+#endif
+
+
 #define Transport_Cell()                                               \
 {                                                                      \
-  (*To++) = (*Old);                                                    \
+  TRANSPORT_ONE_THING ((*To++) = (*Old));                              \
   Pointer_End ();                                                      \
 }
 
 #define Transport_Pair()                                               \
 {                                                                      \
-  (*To++) = (*Old++);                                                  \
-  (*To++) = (*Old);                                                    \
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));                            \
+  TRANSPORT_ONE_THING ((*To++) = (*Old));                              \
   Pointer_End ();                                                      \
 }
 
 #define Transport_Triple()                                             \
 {                                                                      \
-  (*To++) = (*Old++);                                                  \
-  (*To++) = (*Old++);                                                  \
-  (*To++) = (*Old);                                                    \
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));                            \
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));                            \
+  TRANSPORT_ONE_THING ((*To++) = (*Old));                              \
   Pointer_End ();                                                      \
 }
 
 #define Transport_Quadruple()                                          \
 {                                                                      \
-  (*To++) = (*Old++);                                                  \
-  (*To++) = (*Old++);                                                  \
-  (*To++) = (*Old++);                                                  \
-  (*To++) = (*Old);                                                    \
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));                            \
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));                            \
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));                            \
+  TRANSPORT_ONE_THING ((*To++) = (*Old));                              \
   Pointer_End ();                                                      \
 }
 \f
@@ -336,7 +385,7 @@ do                                                                  \
     }                                                                  \
   CHECK_TRANSPORT_VECTOR_TERMINATION ();                               \
   while (To != Scan)                                                   \
-    (*To++) = (*Old++);                                                        \
+    TRANSPORT_ONE_THING ((*To++) = (*Old++));                          \
   Scan = Saved_Scan;                                                   \
 }
 
@@ -356,7 +405,7 @@ do                                                                  \
       return (PRIM_INTERRUPT);                                         \
     }                                                                  \
   while (To != Scan)                                                   \
-    (*To++) = (*Old++);                                                        \
+    TRANSPORT_ONE_THING ((*To++) = (*Old++));                          \
   Scan = Saved_Scan;                                                   \
 }
 
@@ -422,7 +471,7 @@ extern SCHEME_OBJECT Weak_Chain;
   long Car_Type = (OBJECT_TYPE (*Old));                                        \
   (*To++) = (OBJECT_NEW_TYPE (TC_NULL, (*Old)));                       \
   Old += 1;                                                            \
-  (*To++) = (*Old);                                                    \
+  TRANSPORT_ONE_THING ((*To++) = (*Old));                              \
   *Old = (OBJECT_NEW_TYPE (Car_Type, Weak_Chain));                     \
   Weak_Chain = Temp;                                                   \
   Pointer_End ();                                                      \

diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c
index d429e80274c5602a2cb3f4d15f9dc16be4f56e54..62bee76686f5a9a6f253657785edb44ad1755d8a 100644 (file)
--- a/v7/src/microcode/gcloop.c
+++ b/v7/src/microcode/gcloop.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.39 1992/02/18 17:30:10 jinx Exp $
+$Id: gcloop.c,v 9.40 1993/03/10 17:19:52 cph Exp $
 
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -70,6 +70,12 @@ SCHEME_OBJECT
   * (gc_scan_history [GC_SCAN_HISTORY_SIZE]),
   * (gc_to_history [GC_SCAN_HISTORY_SIZE]);
 
+SCHEME_OBJECT gc_object_referenced = SHARP_F;
+SCHEME_OBJECT gc_objects_referencing = SHARP_F;
+unsigned long gc_objects_referencing_count;
+SCHEME_OBJECT * gc_objects_referencing_scan;
+SCHEME_OBJECT * gc_objects_referencing_end;
+
 static int gc_scan_history_index;
 
 #define INITIALIZE_GC_HISTORY()                                                \
@@ -118,6 +124,9 @@ DEFUN (GCLoop,
        AND SCHEME_OBJECT ** To_Pointer)
 {
   fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+  SCHEME_OBJECT object_referencing;
+#endif
 
   INITIALIZE_GC_HISTORY ();
   To = *To_Pointer;
@@ -125,6 +134,9 @@ DEFUN (GCLoop,
   for ( ; Scan != To; Scan++)
   {
     Temp = *Scan;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+    object_referencing = Temp;
+#endif
     HANDLE_GC_TRAP();
 
     Switch_by_GC_Type(Temp)

diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c
index 0949b75bbbde2c67933301f327d233a93d59c65b..56b5a27d898fd30fa49e98eed6ba4658eba8b9bd 100644 (file)
--- a/v7/src/microcode/memmag.c
+++ b/v7/src/microcode/memmag.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.47 1992/01/15 03:35:48 jinx Exp $
+$Id: memmag.c,v 9.48 1993/03/10 17:19:58 cph Exp $
 
-Copyright (c) 1987-92 Massachusetts Institute of Technology
+Copyright (c) 1987-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -338,6 +338,32 @@ DEFUN_VOID (GC)
   *Free++ = Current_State_Point;
   *Free++ = Fluid_Bindings;
 
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+  if (gc_objects_referencing != SHARP_F)
+    {
+      MEMORY_SET
+       (gc_objects_referencing, 0,
+        (MAKE_OBJECT
+         (TC_MANIFEST_NM_VECTOR,
+          (OBJECT_DATUM (MEMORY_REF (gc_objects_referencing, 0))))));
+      {
+       SCHEME_OBJECT * scan = (VECTOR_LOC (gc_objects_referencing, 0));
+       SCHEME_OBJECT * end =
+         (VECTOR_LOC (gc_objects_referencing,
+                      (VECTOR_LENGTH (gc_objects_referencing))));
+       while (scan < end)
+         (*scan++) = SHARP_F;
+      }
+      *Free++ = gc_objects_referencing;
+      gc_objects_referencing_count = 0;
+      gc_objects_referencing_scan =
+       (VECTOR_LOC (gc_objects_referencing, 1));
+      gc_objects_referencing_end =
+       (VECTOR_LOC (gc_objects_referencing,
+                    (VECTOR_LENGTH (gc_objects_referencing))));
+    }
+#endif
+
   /* The 4 step GC */
 
   Result = (GCLoop (Constant_Space, &Free));
@@ -363,6 +389,29 @@ DEFUN_VOID (GC)
     Microcode_Termination (TERM_BROKEN_HEART);
   }
 
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+  if (gc_objects_referencing != SHARP_F)
+    {
+      UPDATE_GC_OBJECTS_REFERENCING ();
+      MEMORY_SET
+       (gc_objects_referencing, 0,
+        (MAKE_OBJECT
+         (TC_MANIFEST_VECTOR,
+          (OBJECT_DATUM (MEMORY_REF (gc_objects_referencing, 0))))));
+      VECTOR_SET (gc_objects_referencing, 0,
+                 (LONG_TO_UNSIGNED_FIXNUM (gc_objects_referencing_count)));
+      {
+       SCHEME_OBJECT * end = gc_objects_referencing_scan;
+       Result = (GCLoop ((VECTOR_LOC (gc_objects_referencing, 1)), (&end)));
+       if ((end != Result) || (end != gc_objects_referencing_scan))
+         {
+           fprintf (stderr, "\nGC-3: Heap Scan ended too early.\n");
+           Microcode_Termination (TERM_BROKEN_HEART);
+         }
+      }
+    }
+#endif
+
   Fix_Weak_Chain ();
 
   /* Make the microcode registers point to the copies in new-space. */
@@ -455,3 +504,22 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
   /* The following comment is by courtesy of LINT, your friendly sponsor. */
   /*NOTREACHED*/
 }
+\f
+DEFINE_PRIMITIVE ("GC-TRACE-REFERENCES", Prim_gc_trace_references, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  {
+    SCHEME_OBJECT objects_referencing = (ARG_REF (2));
+    if (! ((objects_referencing == SHARP_F)
+          || ((VECTOR_P (objects_referencing))
+              && ((VECTOR_LENGTH (objects_referencing)) >= 1))))
+      error_wrong_type_arg (2);
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+    gc_object_referenced = (ARG_REF (1));
+    gc_objects_referencing = objects_referencing;
+#else /* not ENABLE_GC_DEBUGGING_TOOLS */
+    error_external_return ();
+#endif /* not ENABLE_GC_DEBUGGING_TOOLS */
+  }
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}

diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c
index 1eaed08f2900b2d833fe1bcdf71136b0407e4d04..fac805ce28a880eae215f9b30363039f95faffd5 100644 (file)
--- a/v7/src/microcode/purify.c
+++ b/v7/src/microcode/purify.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.47 1992/02/18 17:30:22 jinx Exp $
+$Id: purify.c,v 9.48 1993/03/10 17:20:04 cph Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -90,12 +90,18 @@ DEFUN (PurifyLoop,
        int GC_Mode)
 {
   fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+  SCHEME_OBJECT object_referencing;
+#endif
 
   To = *To_Pointer;
   Low_Constant = Constant_Space;
   for ( ; Scan != To; Scan++)
   {
     Temp = *Scan;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+    object_referencing = Temp;
+#endif
     Switch_by_GC_Type(Temp)
     {
       case TC_BROKEN_HEART: