* coop.c, iselect.c: Since thread switches are now performed with

[bpt/guile.git] / libguile / gc.c

diff --git a/libguile/gc.c b/libguile/gc.c
index dfe5732..14a1190 100644 (file)
--- 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)
     {
@@ -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", "");
 }
-\f
 
+/* 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;
+       }
+    }
+}
+
+
+\f
 
 /* {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.