Import Upstream version 5b3upstream/5b3

1 files changed, 47 insertions, 23 deletions

diff --git a/sys.c b/sys.c
index 0a9615b..9767fe0 100644
--- a/sys.c
+++ b/sys.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 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
@@ -68,7 +68,7 @@ void	igc P((char *what, STACKITEM *stackbase));
 	char *mktemp P((char *template));
 #endif
 
-static void gc_sweep P((void));
+static void gc_sweep P((int contin_bad));
 
 char	s_nogrow[] = "could not grow", s_heap[] = "heap",
 	s_hplims[] = "hplims";
@@ -141,8 +141,8 @@ SCM open_file(filename, modes)
     SETSTREAM(port, f);
     if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes))))
       i_setbuf0(port);
-    ALLOW_INTS;
   }
+  ALLOW_INTS;
   return port;
 }
 
@@ -565,9 +565,9 @@ void add_final(final)
   return;
 }
 
-char s_obunhash[] = "object-unhash";
+char s_obunhash[] = "object-unhash", s_gc[] = "gc";
 static iproc subr0s[] = {
-	{"gc", gc},
+	{s_gc, gc},
 	{"tmpnam", ltmpnam},
 	{0, 0}};
 
@@ -883,7 +883,7 @@ void dowinds(to, delta)
   }
 }
 
-/* Remember that setjmp needs to be called after scm_make_cont */
+/* Remember that setjump needs to be called after scm_make_cont */
 
 SCM scm_make_cont()
 {
@@ -951,10 +951,13 @@ SCM obunhash(obj)
 #endif
   ASSERT(INUMP(obj), obj, ARG1, s_obunhash);
   obj = SRS(obj, 1) & ~1L;
- comm:
+comm:
   if IMP(obj) return obj;
   if NCELLP(obj) return BOOL_F;
-  {				/* code is adapted from mark_locations */
+  {
+    /* This code is adapted from mark_locations() in "sys.c" and
+       scm_cell_p() in "rope.c", which means that changes to these
+       routines must be coordinated. */
     register CELLPTR ptr = (CELLPTR)SCM2PTR(obj);
     register sizet i = 0, j = hplim_ind;
     do {
@@ -1295,7 +1298,7 @@ SCM gc_for_newcell()
 }
 
 static char	s_bad_type[] = "unknown type in ";
-jmp_buf save_regs_gc_mark;
+jump_buf save_regs_gc_mark;
 void mark_locations P((STACKITEM x[], sizet n));
 static void mark_syms P((SCM v));
 static void mark_sym_values P((SCM v));
@@ -1315,7 +1318,8 @@ void igc(what, stackbase)
   int j = num_protects;
   long oheap_size = heap_size;
   gc_start(what);
-  ++errjmp_bad;
+  if (++errjmp_bad > 1)
+    wta(MAKINUM(errjmp_bad), "gc called from within ", s_gc);
   /* By marking symhash first, we provide the best immunity from
      accidental references.  In order to accidentally protect a
      symbol, a pointer will have to point directly at the symbol (as
@@ -1329,8 +1333,8 @@ void igc(what, stackbase)
 #endif
   if (stackbase) {
     FLUSH_REGISTER_WINDOWS;
-    /* This assumes that all registers are saved into the jmp_buf */
-    setjmp(save_regs_gc_mark);
+    /* This assumes that all registers are saved into the jump_buf */
+    setjump(save_regs_gc_mark);
     mark_locations((STACKITEM *) save_regs_gc_mark,
 		   (sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) /
 		   sizeof(STACKITEM));
@@ -1354,9 +1358,10 @@ void igc(what, stackbase)
 #endif
     }
   }
-  while(j--) gc_mark(sys_protects[j]);
+  while(j--)
+    gc_mark(sys_protects[j]);
   sweep_symhash(symhash);
-  gc_sweep();
+  gc_sweep(!stackbase);
   --errjmp_bad;
   gc_end();
   if (oheap_size != heap_size) {
@@ -1376,7 +1381,7 @@ void free_storage()
   gc_mark(def_inp);		/* don't want to close stdin */
   gc_mark(def_outp);		/* don't want to close stdout */
   gc_mark(def_errp);		/* don't want to close stderr */
-  gc_sweep();
+  gc_sweep(0);
   rootcont = BOOL_F;
   while (hplim_ind) {		/* free heap segments */
     hplim_ind -= 2;
@@ -1507,6 +1512,12 @@ void gc_mark(p)
   }
 }
 
+/* mark_locations() marks a location pointed to by x[0:n] only if
+   `x[m]' is cell-aligned and points into a valid heap segment.  This
+   code is duplicated by obunhash() in "sys.c" and scm_cell_p() in
+   "rope.c", which means that changes to these routines must be
+   coordinated. */
+
 void mark_locations(x, n)
      STACKITEM x[];
      sizet n;
@@ -1532,7 +1543,8 @@ void mark_locations(x, n)
 
 #define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
 
-static void gc_sweep()
+static void gc_sweep(contin_bad)
+     int contin_bad;
 {
   register CELLPTR ptr;
 #ifdef POINTERS_MUNGED
@@ -1599,10 +1611,17 @@ static void gc_sweep()
 	m += LENGTH(scmptr)+1;
 	goto freechars;
       case tc7_contin:
-	if GC8MARKP(scmptr) goto c8mrkcontinue;
+	if GC8MARKP(scmptr) {
+	  if (contin_bad && CONT(scmptr)->length) {
+	    warn("uncollected ", (char *)0);
+	    iprin1(scmptr, cur_errp, 1);
+	    lputc('\n', cur_errp);
+	    lfflush(cur_errp);
+	  }
+	  goto c8mrkcontinue;
+	}
 	m += LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
-/*	free_continuation(CONT(scmptr)); */
-	goto freechars;
+	free_continuation(CONT(scmptr)); break; /* goto freechars; */
       case tc7_ssymbol:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
 	/* Do not free storage because tc7_ssymbol means scmptr's
@@ -1708,15 +1727,18 @@ static void mark_syms(v)
       /* If this bucket has already been marked, then something is wrong.  */
       ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
       x = CAR(al);
-      SETGCMARK(al);
+      SETGCMARK(al);		/* Do mark bucket list */
       ASSERT(!GCMARKP(x), x, s_bad_type, s_gc_sym);
       if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
 	goto used;		/* Don't mark symbol.  */
       SETGC8MARK(CAR(x));
     used:
-      SETGCMARK(x);		/* Do mark value cell.  */
+      /* SETGCMARK(x) */;	/* Don't mark value cell.  */
+      /* We used to mark the value cell, but value cells get returned
+	 by calls to intern().  This caused a rare GC leak which only
+	 showed up in large programs. */
     }
-  SETGC8MARK(v);		/* Mark bucket list.  */
+  SETGC8MARK(v);		/* Mark bucket vector.  */
 }
 
 /* mark_symhash marks the values of hash table V.  */
@@ -1744,8 +1766,10 @@ static void sweep_symhash(v)
     lloc = &(VELTS(v)[k]);
     while NIMP(al = (*lloc & ~1L)) {
       x = CAR(al);
-      if GC8MARKP(CAR(x))
+      if GC8MARKP(CAR(x)) {
 	lloc = &(CDR(al));
+	SETGCMARK(x);
+      }
       else {
 	*lloc = CDR(al);
 	CLRGCMARK(al);		/* bucket pair to be collected by gc_sweep */