* __scm.h eq.c, eval.c, gc.c, hc.h, gh_data, hash.c, numbers.c,

numbers.h, objects.c, ramap.c, random.c, unif.c, unif.h: Extensive
rewrite of handling of real and complex numbers.
(SCM_FLOATS, SCM_SINGLES): These #ifdef conditionals have been
removed along with the support for floats.  (Float vectors are
still supported.)

* gc.c (scm_freelist2): multi-cell freelists.
(inner_map_free_list): map_free_list, parameterized on ncells.
"nn cells in segment mm" was misleading for ncells > 1; changed to
"objects".  still print cells too, though.
(scm_map_free_list): rewritten using inner_map_free_list.
(scm_check_freelist): get freelist as parameter, since now we have
more than one.
(scm_debug_newcell2): multi-cell variants of
scm_debug_newcell.
(scm_gc_for_newcell): take ncells and freelist pointer as
parameters.
(scm_gc_mark): add case for tc7_pws (procedures with setters are
now double cells).
(scm_gc_sweep): don't free the float data, since it's not malloced
anymore.
(init_heap_seg): didn't understand what n_new_objects stood for,
so changed to n_new_cells.
(make_initial_segment): new function, makes an initial segment
according to given ncells.
(scm_init_storage): call make_initial_segment, for ncells={1,2,3}.

libguile/gc.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000 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
@@ -147,6 +147,7 @@
  * is the head of freelist of cons pairs.
  */
 SCM scm_freelist = SCM_EOL;
+SCM scm_freelist2 = SCM_EOL;
 
 /* scm_mtrigger
  * is the number of bytes of must_malloc allocation needed to trigger gc.
@@ -243,32 +244,40 @@ which_seg (SCM cell)
 }
 
 
-SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, 
+static void
-            (),
+map_free_list (SCM freelist, int ncells)
-            "Print debugging information about the free-list.\n"
-            "`map-free-list' is only included in GUILE_DEBUG_FREELIST builds of Guile.")
-#define FUNC_NAME s_scm_map_free_list
 {
   int last_seg = -1, count = 0;
   SCM f;
   
-  fprintf (stderr, "%d segments total\n", scm_n_heap_segs);
+  for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f))
-  for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f))
     {
       int this_seg = which_seg (f);
 
       if (this_seg != last_seg)
 	{
 	  if (last_seg != -1)
-	    fprintf (stderr, "  %5d cells in segment %d\n", count, last_seg);
+	    fprintf (stderr, "  %5d %d-cells in segment %d\n",
+		     count, ncells, last_seg);
 	  last_seg = this_seg;
 	  count = 0;
 	}
       count++;
     }
   if (last_seg != -1)
-    fprintf (stderr, "  %5d cells in segment %d\n", count, last_seg);
+    fprintf (stderr, "  %5d %d-cells in segment %d\n",
+	     count, ncells, last_seg);
+}
 
+SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, 
+            (),
+            "Print debugging information about the free-list.\n"
+            "`map-free-list' is only included in GUILE_DEBUG_FREELIST builds of Guile.")
+#define FUNC_NAME s_scm_map_free_list
+{
+  fprintf (stderr, "%d segments total\n", scm_n_heap_segs);
+  map_free_list (scm_freelist, 1);
+  map_free_list (scm_freelist2, 2);
   fflush (stderr);
 
   return SCM_UNSPECIFIED;
@@ -278,16 +287,17 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
 
 /* Number of calls to SCM_NEWCELL since startup.  */
 static unsigned long scm_newcell_count;
+static unsigned long scm_newcell2_count;
 
 /* Search freelist for anything that isn't marked as a free cell.
    Abort if we find something.  */
 static void
-scm_check_freelist ()
+scm_check_freelist (SCM freelist)
 {
   SCM f;
   int i = 0;
 
-  for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
+  for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
     if (SCM_CAR (f) != (SCM) scm_tc_free_cell)
       {
 	fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n",
@@ -319,14 +329,14 @@ scm_debug_newcell (void)
 
   scm_newcell_count++;
   if (scm_debug_check_freelist) {
-    scm_check_freelist ();
+    scm_check_freelist (scm_freelist);
     scm_gc();
   }
 
   /* The rest of this is supposed to be identical to the SCM_NEWCELL
      macro.  */
   if (SCM_IMP (scm_freelist))
-    new = scm_gc_for_newcell ();
+    new = scm_gc_for_newcell (1, &scm_freelist);
   else
     {
       new = scm_freelist;
@@ -338,6 +348,32 @@ scm_debug_newcell (void)
   return new;
 }
 
+SCM
+scm_debug_newcell2 (void)
+{
+  SCM new;
+
+  scm_newcell2_count++;
+  if (scm_debug_check_freelist) {
+    scm_check_freelist (scm_freelist2);
+    scm_gc();
+  }
+
+  /* The rest of this is supposed to be identical to the SCM_NEWCELL2
+     macro.  */
+  if (SCM_IMP (scm_freelist2))
+    new = scm_gc_for_newcell (2, &scm_freelist2);
+  else
+    {
+      new = scm_freelist2;
+      scm_freelist2 = SCM_CDR (scm_freelist2);
+      SCM_SETCAR (new, scm_tc16_allocated);
+      scm_cells_allocated += 2;
+    }
+
+  return new;
+}
+
 #endif /* GUILE_DEBUG_FREELIST */
 
 
@@ -445,6 +481,10 @@ scm_gc_for_alloc (int ncells, SCM *freelistp)
 {
   SCM_REDEFER_INTS;
   scm_igc ("cells");
+#if 0
+  fprintf (stderr, "Collected: %d, min_yield: %d\n",
+	   scm_gc_cells_collected, MIN_GC_YIELD);
+#endif
   if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp))
     {
       alloc_some_heap (ncells, freelistp);
@@ -454,12 +494,12 @@ scm_gc_for_alloc (int ncells, SCM *freelistp)
 
 
 SCM 
-scm_gc_for_newcell ()
+scm_gc_for_newcell (int ncells, SCM *freelistp)
 {
   SCM fl;
-  scm_gc_for_alloc (1, &scm_freelist);
+  scm_gc_for_alloc (ncells, freelistp);
-  fl = scm_freelist;
+  fl = *freelistp;
-  scm_freelist = SCM_CDR (fl);
+  *freelistp = SCM_CDR (fl);
   SCM_SETCAR (fl, scm_tc16_allocated);
   return fl;
 }
@@ -655,10 +695,16 @@ gc_mark_nimp:
       ptr = SCM_GCCDR (ptr);
       goto gc_mark_nimp;
     case scm_tcs_cons_imcar:
+      if (SCM_GCMARKP (ptr))
+	break;
+      SCM_SETGCMARK (ptr);
+      ptr = SCM_GCCDR (ptr);
+      goto gc_mark_loop;
     case scm_tc7_pws:
       if (SCM_GCMARKP (ptr))
 	break;
       SCM_SETGCMARK (ptr);
+      scm_gc_mark (SCM_CELL_WORD (ptr, 2));
       ptr = SCM_GCCDR (ptr);
       goto gc_mark_loop;
     case scm_tcs_cons_gloc:
@@ -883,16 +929,14 @@ gc_mark_nimp:
       if (SCM_GC8MARKP (ptr))
 	break;
       SCM_SETGC8MARK (ptr);
-      switch SCM_GCTYP16 (ptr)
+      switch (SCM_GCTYP16 (ptr))
 	{ /* should be faster than going through scm_smobs */
 	case scm_tc_free_cell:
 	  /* printf("found free_cell %X ", ptr); fflush(stdout); */
-          break;
         case scm_tc16_allocated:
-	  SCM_SETGC8MARK (ptr);
+	case scm_tc16_big:
-	  break;
+	case scm_tc16_real:
-	case scm_tcs_bignums:
+	case scm_tc16_complex:
-	case scm_tc16_flo:
 	  break;
 	default:
 	  i = SCM_SMOBNUM (ptr);
@@ -1279,33 +1323,22 @@ scm_gc_sweep ()
 	      switch SCM_GCTYP16 (scmptr)
 		{
 		case scm_tc_free_cell:
+		case scm_tc16_real:
 		  if SCM_GC8MARKP (scmptr)
 		    goto c8mrkcontinue;
 		  break;
 #ifdef SCM_BIGDIG
-		case scm_tcs_bignums:
+		case scm_tc16_big:
 		  if SCM_GC8MARKP (scmptr)
 		    goto c8mrkcontinue;
 		  m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT);
 		  goto freechars;
 #endif /* def SCM_BIGDIG */
-		case scm_tc16_flo:
+		case scm_tc16_complex:
 		  if SCM_GC8MARKP (scmptr)
 		    goto c8mrkcontinue;
-		  switch ((int) (SCM_UNPACK_CAR (scmptr) >> 16))
+		  m += 2 * sizeof (double);
-		    {
-		    case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
-		      m += sizeof (double);
-		    case SCM_REAL_PART >> 16:
-		    case SCM_IMAG_PART >> 16:
-		      m += sizeof (double);
 		  goto freechars;
-		    case 0:
-		      break;
-		    default:
-		      goto sweeperr;
-		    }
-		  break;
 		default:
 		  if SCM_GC8MARKP (scmptr)
 		    goto c8mrkcontinue;
@@ -1363,7 +1396,7 @@ scm_gc_sweep ()
 	*hp_freelist = nfreelist;
 
 #ifdef GUILE_DEBUG_FREELIST
-      scm_check_freelist ();
+      scm_check_freelist (*hp_freelist);
       scm_map_free_list ();
 #endif
 
@@ -1623,13 +1656,15 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, int ncells, SCM *freelistp)
 #endif
   SCM_CELLPTR seg_end;
   int new_seg_index;
-  int n_new_objects;
+  int n_new_cells;
   
   if (seg_org == NULL)
     return 0;
 
   ptr = seg_org;
 
+  size = (size / sizeof(scm_cell) / ncells) * ncells * sizeof(scm_cell);
+
   /* Compute the ceiling on valid object pointers w/in this segment. 
    */
   seg_end = CELL_DN ((char *) ptr + size);
@@ -1663,7 +1698,8 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, int ncells, SCM *freelistp)
   ptr = CELL_UP (ptr);
 
 
-  n_new_objects = seg_end - ptr;
+  /*n_new_cells*/
+  n_new_cells = seg_end - ptr;
 
   /* Prepend objects in this segment to the freelist. 
    */
@@ -1685,7 +1721,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, int ncells, SCM *freelistp)
   SCM_SETCDR (PTR2SCM (ptr), *freelistp);
   *freelistp = PTR2SCM (CELL_UP (seg_org));
 
-  scm_heap_size += (ncells * n_new_objects);
+  scm_heap_size += n_new_cells;
   return size;
 #ifdef scmptr
 #undef scmptr
@@ -1906,9 +1942,35 @@ cleanup (int status, void *arg)
   scm_flush_all_ports ();
 }
 
+
+static int
+make_initial_segment(scm_sizet init_heap_size,
+                     int ncells,
+                     SCM *freelistp)
+{
+  if (0L == init_heap_size)
+    init_heap_size = SCM_INIT_HEAP_SIZE;
+  if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size),
+		      init_heap_size,
+		      ncells,
+		      freelistp))
+    {
+      init_heap_size = SCM_HEAP_SEG_SIZE;
+      if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size),
+			  init_heap_size,
+			  ncells,
+			  freelistp))
+	return 1;
+    }
+  else
+    scm_expmem = 1;
+
+  return 0;
+}
+
 
 int
-scm_init_storage (scm_sizet init_heap_size)
+scm_init_storage (scm_sizet init_heap_size, scm_sizet init_heap2_size)
 {
   scm_sizet j;
 
@@ -1917,25 +1979,20 @@ scm_init_storage (scm_sizet init_heap_size)
     scm_sys_protects[--j] = SCM_BOOL_F;
   scm_block_gc = 1;
   scm_freelist = SCM_EOL;
+  scm_freelist2 = SCM_EOL;
   scm_expmem = 0;
 
   j = SCM_HEAP_SEG_SIZE;
   scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
   scm_heap_table = ((struct scm_heap_seg_data *)
-		    scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims"));
+		    scm_must_malloc (sizeof (struct scm_heap_seg_data) * 2, "hplims"));
-  if (0L == init_heap_size)
+
-    init_heap_size = SCM_INIT_HEAP_SIZE;
+  if (make_initial_segment(init_heap_size, 1, &scm_freelist) ||
-  j = init_heap_size;
+      make_initial_segment(init_heap2_size, 2, &scm_freelist2))
-  if ((init_heap_size != j)
-      || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
-    {
-      j = SCM_HEAP_SEG_SIZE;
-      if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
     return 1;
-    }
+
-  else
-    scm_expmem = 1;
   scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
+
   /* scm_hplims[0] can change. do not remove scm_heap_org */
   scm_weak_vectors = SCM_EOL;