Revert "(scm_shell_usage): Note need for subscription to bug-guile@gnu.org."
[bpt/guile.git] / libguile / gc-card.c
index c2a316a..1948aff 100644 (file)
@@ -1,67 +1,51 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008 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
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
  *
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
  * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- * GNU General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
  *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING.  If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE.  If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way.  To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.  */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
 
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
 
+#include <assert.h>
 #include <stdio.h>
+#include <count-one-bits.h>
+
+#include <gmp.h>
 
 #include "libguile/_scm.h"
-#include "libguile/eval.h"
-#include "libguile/stime.h"
-#include "libguile/stackchk.h"
-#include "libguile/struct.h"
-#include "libguile/smob.h"
-#include "libguile/unif.h"
 #include "libguile/async.h"
+#include "libguile/deprecation.h"
+#include "libguile/eval.h"
+#include "libguile/gc.h"
+#include "libguile/hashtab.h"
+#include "libguile/numbers.h"
 #include "libguile/ports.h"
+#include "libguile/private-gc.h"
 #include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/srfi-4.h"
+#include "libguile/stackchk.h"
+#include "libguile/stime.h"
 #include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/weaks.h"
-#include "libguile/hashtab.h"
+#include "libguile/struct.h"
 #include "libguile/tags.h"
-#include "libguile/private-gc.h"
+#include "libguile/unif.h"
 #include "libguile/validate.h"
-#include "libguile/deprecation.h"
-#include "libguile/gc.h"
-
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
 
 #include "libguile/private-gc.h"
 
@@ -72,27 +56,23 @@ long int scm_i_deprecated_memory_return;
  */
 SCM scm_i_structs_to_free;
 
-
 /*
   Init all the free cells in CARD, prepending to *FREE_LIST.
 
-  Return: number of free cells found in this card.
+  Return: FREE_COUNT, the number of cells collected.  This is
+  typically the length of the *FREE_LIST, but for some special cases,
+  we do not actually free the cell. To make the numbers match up, we
+  do increase the FREE_COUNT.
 
-  It would be cleaner to have a separate function sweep_value(), but
+  It would be cleaner to have a separate function sweep_value (), but
   that is too slow (functions with switch statements can't be
   inlined).
 
-
-
-  
   NOTE:
 
-  This function is quite efficient. However, for many types of cells,
-  allocation and a de-allocation involves calling malloc() and
-  free().
-
-  This is costly for small objects (due to malloc/free overhead.)
-  (should measure this).
+  For many types of cells, allocation and a de-allocation involves
+  calling malloc () and free ().  This is costly for small objects (due
+  to malloc/free overhead.)  (should measure this).
 
   It might also be bad for threads: if several threads are allocating
   strings concurrently, then mallocs for both threads may have to
@@ -104,40 +84,39 @@ SCM scm_i_structs_to_free;
   --hwn.
  */
 int
-scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
+scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg)
 #define FUNC_NAME "sweep_card"
 {
-  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
-  scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
+  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (card);
+  scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
+  scm_t_cell *p = card;
   int span = seg->span;
-  int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
-  int free_count  = 0;
-
-  ++ scm_gc_running_p;
-
+  int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
+  int free_count = 0;
+  
   /*
     I tried something fancy with shifting by one bit every word from
-    the bitvec in turn, but it wasn't any faster, but quite bit
+    the bitvec in turn, but it wasn't any faster, but quite bit
     hairier.
    */
   for (p += offset; p < end; p += span, offset += span)
     {
-      SCM scmptr = PTR2SCM(p);
+      SCM scmptr = PTR2SCM (p);
       if (SCM_C_BVEC_GET (bitvec, offset))
         continue;
-
+      free_count++;
       switch (SCM_TYP7 (scmptr))
        {
        case scm_tcs_struct:
          /* The card can be swept more than once.  Check that it's
           * the first time!
           */
-         if (!SCM_STRUCT_GC_CHAIN (p))
+         if (!SCM_STRUCT_GC_CHAIN (scmptr))
            {
              /* Structs need to be freed in a special order.
               * This is handled by GC C hooks in struct.c.
               */
-             SCM_SET_STRUCT_GC_CHAIN (p, scm_i_structs_to_free);
+             SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
              scm_i_structs_to_free = scmptr;
            }
          continue;
@@ -149,16 +128,9 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
          break;
        case scm_tc7_wvect:
        case scm_tc7_vector:
-         {
-           unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
-           if (length > 0)
-             {
-               scm_gc_free (SCM_VECTOR_BASE (scmptr),
-                            length * sizeof (scm_t_bits),
-                            "vector");
-             }
-           break;
-         }
+         scm_i_vector_free (scmptr);
+         break;
+
 #ifdef CCLO
        case scm_tc7_cclo:
          scm_gc_free (SCM_CCLO_BASE (scmptr), 
@@ -166,42 +138,34 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
                       "compiled closure");
          break;
 #endif
-#ifdef SCM_HAVE_ARRAYS
-       case scm_tc7_bvect:
-         {
-           unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
-           if (length > 0)
-             {
-               scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
-                            (sizeof (long)
-                             * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
-                            "vector");
-             }
-         }
-         break;
-       case scm_tc7_byvect:
-       case scm_tc7_ivect:
-       case scm_tc7_uvect:
-       case scm_tc7_svect:
-#if SCM_SIZEOF_LONG_LONG != 0
-       case scm_tc7_llvect:
-#endif
-       case scm_tc7_fvect:
-       case scm_tc7_dvect:
-       case scm_tc7_cvect:
-         scm_gc_free (SCM_UVECTOR_BASE (scmptr), 
-                      (SCM_UVECTOR_LENGTH (scmptr)
-                       * scm_uniform_element_size (scmptr)),
-                      "vector");
-         break;
-#endif
+
+       case scm_tc7_number:
+         switch SCM_TYP16 (scmptr)
+            {
+            case scm_tc16_real:
+              break;
+            case scm_tc16_big:
+              mpz_clear (SCM_I_BIG_MPZ (scmptr));
+              /* nothing else to do here since the mpz is in a double cell */
+              break;
+           case scm_tc16_complex:
+             scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
+                          "complex");
+             break;
+           case scm_tc16_fraction:
+             /* nothing to do here since the num/denum of a fraction
+                are proper SCM objects themselves. */
+             break;
+            }
+          break;
        case scm_tc7_string:
-         scm_gc_free (SCM_STRING_CHARS (scmptr), 
-                      SCM_STRING_LENGTH (scmptr) + 1, "string");
+         scm_i_string_free (scmptr);
+         break;
+       case scm_tc7_stringbuf:
+         scm_i_stringbuf_free (scmptr);
          break;
        case scm_tc7_symbol:
-         scm_gc_free (SCM_SYMBOL_CHARS (scmptr), 
-                      SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
+         scm_i_symbol_free (scmptr); 
          break;
        case scm_tc7_variable:
          break;
@@ -217,13 +181,13 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
              if (!(k < scm_numptob))
                {
                  fprintf (stderr, "undefined port type");
-                 abort();
+                 abort ();
                }
 #endif
              /* Keep "revealed" ports alive.  */
              if (scm_revealed_count (scmptr) > 0)
                continue;
-         
+             
              /* Yes, I really do mean scm_ptobs[k].free */
              /* rather than ftobs[k].close.  .close */
              /* is for explicit CLOSE-PORT by user */
@@ -245,8 +209,7 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
                }
 
              SCM_SETSTREAM (scmptr, 0);
-             scm_remove_from_port_table (scmptr);
-             scm_gc_ports_collected++;
+             scm_i_remove_port (scmptr);
              SCM_CLR_PORT_OPEN_FLAG (scmptr);
            }
          break;
@@ -254,18 +217,6 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
          switch SCM_TYP16 (scmptr)
            {
            case scm_tc_free_cell:
-           case scm_tc16_real:
-             break;
-#ifdef SCM_BIGDIG
-           case scm_tc16_big:
-             scm_gc_free (SCM_BDIGITS (scmptr),
-                          ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
-                            / SCM_CHAR_BIT)), "bignum");
-             break;
-#endif /* def SCM_BIGDIG */
-           case scm_tc16_complex:
-             scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
-                          "complex");
              break;
            default:
              {
@@ -275,7 +226,7 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
                if (!(k < scm_numsmob))
                  {
                    fprintf (stderr, "undefined smob type");
-                   abort();
+                   abort ();
                  }
 #endif
                if (scm_smobs[k].free)
@@ -293,7 +244,7 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
                           SCM_SMOBNAME (k));
                        scm_i_deprecated_memory_return += mm;
 #else
-                       abort();
+                       abort ();
 #endif
                      }
                  }
@@ -303,17 +254,14 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
          break;
        default:
          fprintf (stderr, "unknown type");
-         abort();
+         abort ();
        }
 
-         
-      SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
-      SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
-      *free_list = PTR2SCM (p);
-      free_count ++;
+      SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);        
+      SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
+      *free_list = scmptr;
     }
-
-  --scm_gc_running_p;
+  
   return free_count;
 }
 #undef FUNC_NAME
@@ -323,78 +271,218 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
   Like sweep, but no complicated logic to do the sweeping.
  */
 int
-scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
-                       scm_t_heap_segment*seg)
+scm_i_init_card_freelist (scm_t_cell *card, SCM *free_list,
+                         scm_t_heap_segment *seg)
 {
   int span = seg->span;
   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
   scm_t_cell *p = end - span;
-
-  scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
+  int collected = 0;
+  scm_t_c_bvec_long *bvec_ptr = (scm_t_c_bvec_long*) seg->bounds[1];
   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; 
 
-  bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
-  SCM_GC_CELL_BVEC (card) = bvec_ptr;
+  bvec_ptr += idx * SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
+  SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
   
   /*
      ASSUMPTION: n_header_cells <= 2. 
    */
   for (; p > card;  p -= span)
     {
-      SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
-      SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
-      *free_list = PTR2SCM (p);
+      const SCM scmptr = PTR2SCM (p);
+      SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
+      SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
+      *free_list = scmptr;
+      collected ++;
     }
 
-  return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
+  return collected;
 }
 
-
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
+/*
+  Amount of cells marked in this cell, measured in 1-cells.
+ */
 int
-scm_gc_marked_p (SCM obj)
+scm_i_card_marked_count (scm_t_cell *card, int span)
 {
-  return SCM_GC_MARK_P(obj);
+  scm_t_c_bvec_long* bvec = SCM_GC_CARD_BVEC (card);
+  scm_t_c_bvec_long* bvec_end = (bvec + SCM_GC_CARD_BVEC_SIZE_IN_LONGS);
+  
+  int count = 0;
+  while (bvec < bvec_end)
+    {
+      count += count_one_bits_l (*bvec);
+      bvec ++;
+    }
+  return count * span;
 }
-#endif
 
-#if 0
-/*
-  These functions are meant to be called from GDB as a debug aid.
+void
+scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
+{
+  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (p);
+  scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
+  int span = seg->span;
+  int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
 
-  I've left them as a convenience for future generations. --hwn.
- */
+  if (!bitvec)
+    /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
+    return;
 
+  for (p += offset; p < end; p += span, offset += span)
+    {
+      scm_t_bits tag = -1;
+      SCM scmptr = PTR2SCM (p);
 
-int scm_gc_marked_p (SCM obj);
-scm_t_cell * scm_gc_get_card (SCM obj);
-long * scm_gc_get_bvec (SCM obj);
+      if (!SCM_C_BVEC_GET (bitvec, offset))
+        continue;
 
-typedef struct scm_t_list_cell_struct {
-  scm_t_bits car;  
-  struct scm_t_list_cell_struct * cdr;
-} scm_t_list_cell;
+      tag = SCM_TYP7 (scmptr);
+      if (tag == scm_tc7_smob || tag == scm_tc7_number)
+       {
+          /* Record smobs and numbers under 16 bits of the tag, so the
+             different smob objects are distinguished, and likewise the
+             different numbers big, real, complex and fraction. */
+         tag = SCM_TYP16(scmptr);
+       }
+      else
+       switch (tag) 
+       {
+       case scm_tcs_cons_imcar:
+         tag = scm_tc2_int;
+         break;
+       case scm_tcs_cons_nimcar:
+         tag = scm_tc3_cons;
+         break;
 
+       case scm_tcs_struct:
+         tag = scm_tc3_struct;
+         break;
+       case scm_tcs_closures:
+         tag = scm_tc3_closure;
+         break;
+       case scm_tcs_subrs:
+         tag = scm_tc7_asubr;
+         break;
+       }
 
-typedef struct scm_t_double_cell
+      {      
+        SCM handle = scm_hashq_create_handle_x (hashtab,
+                                                scm_from_int (tag), SCM_INUM0);
+        SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
+      }
+    }
+}
+
+/* TAG is the tag word of a cell, return a string which is its name, or NULL
+   if unknown.  Currently this is only used by gc-live-object-stats and the
+   distinctions between types are oriented towards what that code records
+   while scanning what's alive.  */
+char const *
+scm_i_tag_name (scm_t_bits tag)
 {
+  switch (tag & 0x7F) /* 7 bits */
+    {
+    case scm_tcs_struct:
+      return "struct";
+    case scm_tcs_cons_imcar:
+      return "cons (immediate car)";
+    case scm_tcs_cons_nimcar:
+      return "cons (non-immediate car)";
+    case scm_tcs_closures:
+      return "closures";
+    case scm_tc7_pws:
+      return "pws";
+    case scm_tc7_wvect:
+      return "weak vector";
+    case scm_tc7_vector:
+      return "vector";
+#ifdef CCLO
+    case scm_tc7_cclo:
+      return "compiled closure";
+#endif
+    case scm_tc7_number:
+      switch (tag)
+       {
+       case scm_tc16_real:
+         return "real";
+       case scm_tc16_big:
+         return "bignum";
+       case scm_tc16_complex:
+         return "complex number";
+       case scm_tc16_fraction:
+         return "fraction";
+       }
+      /* shouldn't reach here unless there's a new class of numbers */
+      return "number";
+    case scm_tc7_string:
+      return "string";
+    case scm_tc7_stringbuf:
+      return "string buffer";
+    case scm_tc7_symbol:
+      return "symbol";
+    case scm_tc7_variable:
+      return "variable";
+    case scm_tcs_subrs:
+      return "subrs";
+    case scm_tc7_port:
+      return "port";
+    case scm_tc7_smob:
+      /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
+         entry should be ok for our return here */
+      return scm_smobs[SCM_TC2SMOBNUM (tag)].name;
+    }
+
+  return NULL;
+}
+
+
+#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
+
+typedef struct scm_dbg_t_list_cell {
+  scm_t_bits car;  
+  struct scm_dbg_t_list_cell * cdr;
+} scm_dbg_t_list_cell;
+
+
+typedef struct scm_dbg_t_double_cell {
   scm_t_bits word_0;
   scm_t_bits word_1;
   scm_t_bits word_2;
   scm_t_bits word_3;
-} scm_t_double_cell;
+} scm_dbg_t_double_cell;
+
 
+int scm_dbg_gc_marked_p (SCM obj);
+scm_t_cell * scm_dbg_gc_get_card (SCM obj);
+scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
 
 
+int
+scm_dbg_gc_marked_p (SCM obj)
+{
+  if (!SCM_IMP (obj))
+    return SCM_GC_MARK_P (obj);
+  else
+    return 0;
+}
+
 scm_t_cell *
-scm_gc_get_card (SCM obj)
+scm_dbg_gc_get_card (SCM obj)
 {
-  return SCM_GC_CELL_CARD(obj);
+  if (!SCM_IMP (obj))
+    return SCM_GC_CELL_CARD (obj);
+  else
+    return NULL;
 }
 
-long *
-scm_gc_get_bvec (SCM obj)
+scm_t_c_bvec_long *
+scm_dbg_gc_get_bvec (SCM obj)
 {
-  return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj));
+  if (!SCM_IMP (obj))
+    return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
+  else
+    return NULL;
 }
+
 #endif