X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/0869cca6113678a35876194a3a26cd01b813a61e..c69dfa6575e6de1063f91a1a9a94808e404f06d0:/libguile/gc.c

diff --git a/libguile/gc.c b/libguile/gc.c
index ef75f342d..14a1190bf 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/*	Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -441,6 +441,8 @@ scm_igc (what)
   SCM_THREAD_CRITICAL_SECTION_START;
 #endif
 
+  // fprintf (stderr, "gc: %s\n", what);
+
   scm_gc_start (what);
   if (!scm_stack_base || scm_block_gc)
     {
@@ -580,7 +582,7 @@ gc_mark_loop:
 
 gc_mark_nimp:
   if (SCM_NCELLP (ptr))
-    scm_wta (ptr, "rogue pointer in heap", SCM_BOOL_F);
+    scm_wta (ptr, "rogue pointer in heap", NULL);
 
   switch (SCM_TYP7 (ptr))
     {
@@ -626,7 +628,7 @@ gc_mark_nimp:
 	      register int x;
 
 	      vtable_data = (SCM *)vcell;
-	      layout = vtable_data[scm_struct_i_layout];
+	      layout = vtable_data[scm_vtable_index_layout];
 	      len = SCM_LENGTH (layout);
 	      fields_desc = SCM_CHARS (layout);
 	      /* We're using SCM_GCCDR here like STRUCT_DATA, except
@@ -650,7 +652,7 @@ gc_mark_nimp:
 	      if (!SCM_CDR (vcell))
 		{
 		  SCM_SETGCMARK (vcell);
-		  ptr = vtable_data[scm_struct_i_vtable];
+		  ptr = vtable_data[scm_vtable_index_vtable];
 		  goto gc_mark_loop;
 		}
 	    }
@@ -689,11 +691,13 @@ gc_mark_nimp:
       if SCM_GC8MARKP
 	(ptr) break;
       SCM_SETGC8MARK (ptr);
-      scm_mark_locations (SCM_VELTS (ptr),
-	       (scm_sizet)
-	       (SCM_LENGTH (ptr) +
-		(sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) /
-		sizeof (SCM_STACKITEM)));
+      if (SCM_VELTS (ptr))
+	scm_mark_locations (SCM_VELTS (ptr),
+			    (scm_sizet)
+			    (SCM_LENGTH (ptr) +
+			     (sizeof (SCM_STACKITEM) + -1 +
+			      sizeof (scm_contregs)) /
+			     sizeof (SCM_STACKITEM)));
       break;
     case scm_tc7_bvect:
     case scm_tc7_byvect:
@@ -708,12 +712,10 @@ gc_mark_nimp:
 #endif
 
     case scm_tc7_string:
-    case scm_tc7_mb_string:
       SCM_SETGC8MARK (ptr);
       break;
 
     case scm_tc7_substring:
-    case scm_tc7_mb_substring:
       if (SCM_GC8MARKP(ptr))
 	break;
       SCM_SETGC8MARK (ptr);
@@ -731,12 +733,9 @@ gc_mark_nimp:
 					sizeof (SCM *) * (scm_weak_size *= 2)));
 	  if (scm_weak_vectors == NULL)
 	    {
-	      scm_gen_puts (scm_regular_string,
-			    "weak vector table",
-			    scm_cur_errp);
-	      scm_gen_puts (scm_regular_string,
-			    "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
-			    scm_cur_errp);
+	      scm_puts ("weak vector table", scm_cur_errp);
+	      scm_puts ("\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
+			scm_cur_errp);
 	      exit(SCM_EXIT_FAILURE);
 	    }
 	}
@@ -1169,12 +1168,10 @@ scm_gc_sweep ()
 	      m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
 	      goto freechars;
 	    case scm_tc7_substring:
-	    case scm_tc7_mb_substring:
 	      if (SCM_GC8MARKP (scmptr))
 		goto c8mrkcontinue;
 	      break;
 	    case scm_tc7_string:
-	    case scm_tc7_mb_string:
 	      if (SCM_GC8MARKP (scmptr))
 		goto c8mrkcontinue;
 	      m += SCM_HUGE_LENGTH (scmptr) + 1;
@@ -1191,7 +1188,8 @@ scm_gc_sweep ()
 	      if SCM_GC8MARKP (scmptr)
 		goto c8mrkcontinue;
 	      m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
-	      goto freechars;
+	      if (SCM_VELTS (scmptr))
+		goto freechars;
 	    case scm_tc7_ssymbol:
 	      if SCM_GC8MARKP(scmptr)
 		goto c8mrkcontinue;
@@ -1272,7 +1270,10 @@ scm_gc_sweep ()
 	  if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
 	    exit (2);
 #endif
-	  /* Stick the new cell on the front of nfreelist.  */
+	  /* Stick the new cell on the front of nfreelist.  It's
+	     critical that we mark this cell as freed; otherwise, the
+	     conservative collector might trace it as some other type
+	     of object.  */
 	  SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
 	  SCM_SETCDR (scmptr, nfreelist);
 	  nfreelist = scmptr;
@@ -1374,7 +1375,7 @@ scm_gc_sweep ()
 
 /* {Front end to malloc}
  *
- * scm_must_malloc, scm_must_realloc, scm_must_free
+ * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
  *
  * These functions provide services comperable to malloc, realloc, and
  * free.  They are for allocating malloced parts of scheme objects.
@@ -1482,9 +1483,36 @@ scm_must_free (obj)
   else
     scm_wta (SCM_INUM0, "already free", "");
 }
-
 
+/* Announce that there has been some malloc done that will be freed
+ * during gc.  A typical use is for a smob that uses some malloced
+ * memory but can not get it from scm_must_malloc (for whatever
+ * reason).  When a new object of this smob is created you call
+ * scm_done_malloc with the size of the object.  When your smob free
+ * function is called, be sure to include this size in the return
+ * value. */
 
+void
+scm_done_malloc (size)
+     long size;
+{
+  scm_mallocated += size;
+
+  if (scm_mallocated > scm_mtrigger)
+    {
+      scm_igc ("foreign mallocs");
+      if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS)
+	{
+	  if (scm_mallocated > scm_mtrigger)
+	    scm_mtrigger = scm_mallocated + scm_mallocated / 2;
+	  else
+	    scm_mtrigger += scm_mtrigger / 2;
+	}
+    }
+}
+
+
+
 
 /* {Heap Segments}
  *
@@ -1493,8 +1521,7 @@ scm_must_free (obj)
  * A table of segment records is kept that records the upper and
  * lower extents of the segment;  this is used during the conservative
  * phase of gc to identify probably gc roots (because they point
- * into valid segments at reasonable offsets).
- */
+ * into valid segments at reasonable offsets).  */
 
 /* scm_expmem
  * is true if the first segment was smaller than INIT_HEAP_SEG.