libguile/gc-card.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 #include <stdio.h>
  20 #include <gmp.h>
  21
  22 #include "libguile/_scm.h"
  23 #include "libguile/eval.h"
  24 #include "libguile/stime.h"
  25 #include "libguile/stackchk.h"
  26 #include "libguile/struct.h"
  27 #include "libguile/smob.h"
  28 #include "libguile/unif.h"
  29 #include "libguile/async.h"
  30 #include "libguile/ports.h"
  31 #include "libguile/root.h"
  32 #include "libguile/strings.h"
  33 #include "libguile/vectors.h"
  34 #include "libguile/weaks.h"
  35 #include "libguile/hashtab.h"
  36 #include "libguile/tags.h"
  37 #include "libguile/private-gc.h"
  38 #include "libguile/validate.h"
  39 #include "libguile/deprecation.h"
  40 #include "libguile/gc.h"
  41
  42
  43 #include "libguile/private-gc.h"
  44
  45 long int scm_i_deprecated_memory_return;
  46
  47
  48 /* During collection, this accumulates structures which are to be freed.
  49  */
  50 SCM scm_i_structs_to_free;
  51
  52
  53 /*
  54   Init all the free cells in CARD, prepending to *FREE_LIST.
  55
  56   Return: number of free cells found in this card.
  57
  58   It would be cleaner to have a separate function sweep_value(), but
  59   that is too slow (functions with switch statements can't be
  60   inlined).
  61
  62
  63
  64
  65   NOTE:
  66
  67   This function is quite efficient. However, for many types of cells,
  68   allocation and a de-allocation involves calling malloc() and
  69   free().
  70
  71   This is costly for small objects (due to malloc/free overhead.)
  72   (should measure this).
  73
  74   It might also be bad for threads: if several threads are allocating
  75   strings concurrently, then mallocs for both threads may have to
  76   fiddle with locks.
  77
  78   It might be interesting to add a separate memory pool for small
  79   objects to each freelist.
  80
  81   --hwn.
  82  */
  83 int
  84 scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
  85 #define FUNC_NAME "sweep_card"
  86 {
  87   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  88   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  89   int span = seg->span;
  90   int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
  91   int free_count  = 0;
  92
  93   ++ scm_gc_running_p;
  94
  95   /*
  96     I tried something fancy with shifting by one bit every word from
  97     the bitvec in turn, but it wasn't any faster, but quite a bit
  98     hairier.
  99    */
 100   for (p += offset; p < end; p += span, offset += span)
 101     {
 102       SCM scmptr = PTR2SCM (p);
 103       if (SCM_C_BVEC_GET (bitvec, offset))
 104         continue;
 105
 106       switch (SCM_TYP7 (scmptr))
 107         {
 108         case scm_tcs_struct:
 109           /* The card can be swept more than once.  Check that it's
 110            * the first time!
 111            */
 112           if (!SCM_STRUCT_GC_CHAIN (scmptr))
 113             {
 114               /* Structs need to be freed in a special order.
 115                * This is handled by GC C hooks in struct.c.
 116                */
 117               SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
 118               scm_i_structs_to_free = scmptr;
 119             }
 120           continue;
 121
 122         case scm_tcs_cons_imcar:
 123         case scm_tcs_cons_nimcar:
 124         case scm_tcs_closures:
 125         case scm_tc7_pws:
 126           break;
 127         case scm_tc7_wvect:
 128         case scm_tc7_vector:
 129           {
 130             unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
 131             if (length > 0)
 132               {
 133                 scm_gc_free (SCM_VECTOR_BASE (scmptr),
 134                              length * sizeof (scm_t_bits),
 135                              "vector");
 136               }
 137             break;
 138           }
 139 #ifdef CCLO
 140         case scm_tc7_cclo:
 141           scm_gc_free (SCM_CCLO_BASE (scmptr),
 142                        SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
 143                        "compiled closure");
 144           break;
 145 #endif
 146 #if SCM_HAVE_ARRAYS
 147         case scm_tc7_bvect:
 148           {
 149             unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
 150             if (length > 0)
 151               {
 152                 scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
 153                              (sizeof (long)
 154                               * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
 155                              "vector");
 156               }
 157           }
 158           break;
 159         case scm_tc7_byvect:
 160         case scm_tc7_ivect:
 161         case scm_tc7_uvect:
 162         case scm_tc7_svect:
 163 #if SCM_SIZEOF_LONG_LONG != 0
 164         case scm_tc7_llvect:
 165 #endif
 166         case scm_tc7_fvect:
 167         case scm_tc7_dvect:
 168         case scm_tc7_cvect:
 169           scm_gc_free (SCM_UVECTOR_BASE (scmptr),
 170                        (SCM_UVECTOR_LENGTH (scmptr)
 171                         * scm_uniform_element_size (scmptr)),
 172                        "vector");
 173           break;
 174 #endif
 175         case scm_tc7_string:
 176           scm_gc_free (SCM_STRING_CHARS (scmptr),
 177                        SCM_STRING_LENGTH (scmptr) + 1, "string");
 178           break;
 179         case scm_tc7_symbol:
 180           scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
 181                        SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
 182           break;
 183         case scm_tc7_variable:
 184           break;
 185         case scm_tcs_subrs:
 186           /* the various "subrs" (primitives) are never freed */
 187           continue;
 188         case scm_tc7_port:
 189           if SCM_OPENP (scmptr)
 190             {
 191               int k = SCM_PTOBNUM (scmptr);
 192               size_t mm;
 193 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 194               if (!(k < scm_numptob))
 195                 {
 196                   fprintf (stderr, "undefined port type");
 197                   abort();
 198                 }
 199 #endif
 200               /* Keep "revealed" ports alive.  */
 201               if (scm_revealed_count (scmptr) > 0)
 202                 continue;
 203
 204               /* Yes, I really do mean scm_ptobs[k].free */
 205               /* rather than ftobs[k].close.  .close */
 206               /* is for explicit CLOSE-PORT by user */
 207               mm = scm_ptobs[k].free (scmptr);
 208
 209               if (mm != 0)
 210                 {
 211 #if SCM_ENABLE_DEPRECATED == 1
 212                   scm_c_issue_deprecation_warning
 213                     ("Returning non-0 from a port free function is "
 214                      "deprecated.  Use scm_gc_free et al instead.");
 215                   scm_c_issue_deprecation_warning_fmt
 216                     ("(You just returned non-0 while freeing a %s.)",
 217                      SCM_PTOBNAME (k));
 218                   scm_i_deprecated_memory_return += mm;
 219 #else
 220                   abort ();
 221 #endif
 222                 }
 223
 224               SCM_SETSTREAM (scmptr, 0);
 225               scm_remove_from_port_table (scmptr);
 226               scm_gc_ports_collected++;
 227               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 228             }
 229           break;
 230         case scm_tc7_smob:
 231           switch SCM_TYP16 (scmptr)
 232             {
 233             case scm_tc_free_cell:
 234             case scm_tc16_real:
 235               break;
 236             case scm_tc16_big:
 237               mpz_clear (SCM_I_BIG_MPZ (scmptr));
 238               /* nothing else to do here since the mpz is in a double cell */
 239               break;
 240             case scm_tc16_complex:
 241               scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
 242                            "complex");
 243               break;
 244             default:
 245               {
 246                 int k;
 247                 k = SCM_SMOBNUM (scmptr);
 248 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 249                 if (!(k < scm_numsmob))
 250                   {
 251                     fprintf (stderr, "undefined smob type");
 252                     abort();
 253                   }
 254 #endif
 255                 if (scm_smobs[k].free)
 256                   {
 257                     size_t mm;
 258                     mm = scm_smobs[k].free (scmptr);
 259                     if (mm != 0)
 260                       {
 261 #if SCM_ENABLE_DEPRECATED == 1
 262                         scm_c_issue_deprecation_warning
 263                           ("Returning non-0 from a smob free function is "
 264                            "deprecated.  Use scm_gc_free et al instead.");
 265                         scm_c_issue_deprecation_warning_fmt
 266                           ("(You just returned non-0 while freeing a %s.)",
 267                            SCM_SMOBNAME (k));
 268                         scm_i_deprecated_memory_return += mm;
 269 #else
 270                         abort();
 271 #endif
 272                       }
 273                   }
 274                 break;
 275               }
 276             }
 277           break;
 278         default:
 279           fprintf (stderr, "unknown type");
 280           abort();
 281         }
 282
 283
 284       SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
 285       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 286       *free_list = scmptr;
 287       free_count ++;
 288     }
 289
 290   --scm_gc_running_p;
 291   return free_count;
 292 }
 293 #undef FUNC_NAME
 294
 295
 296 /*
 297   Like sweep, but no complicated logic to do the sweeping.
 298  */
 299 int
 300 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 301                         scm_t_heap_segment*seg)
 302 {
 303   int span = seg->span;
 304   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 305   scm_t_cell *p = end - span;
 306
 307   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 308   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 309
 310   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 311   SCM_GC_CELL_BVEC (card) = bvec_ptr;
 312
 313   /*
 314      ASSUMPTION: n_header_cells <= 2.
 315    */
 316   for (; p > card;  p -= span)
 317     {
 318       const SCM scmptr = PTR2SCM (p);
 319       SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
 320       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 321       *free_list = scmptr;
 322     }
 323
 324   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 325 }
 326
 327
 328 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 329
 330 typedef struct scm_dbg_t_list_cell {
 331   scm_t_bits car;
 332   struct scm_dbg_t_list_cell * cdr;
 333 } scm_dbg_t_list_cell;
 334
 335
 336 typedef struct scm_dbg_t_double_cell {
 337   scm_t_bits word_0;
 338   scm_t_bits word_1;
 339   scm_t_bits word_2;
 340   scm_t_bits word_3;
 341 } scm_dbg_t_double_cell;
 342
 343
 344 int scm_dbg_gc_marked_p (SCM obj);
 345 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 346 long * scm_dbg_gc_get_bvec (SCM obj);
 347
 348
 349 int
 350 scm_dbg_gc_marked_p (SCM obj)
 351 {
 352   if (!SCM_IMP (obj))
 353     return SCM_GC_MARK_P(obj);
 354   else
 355     return 0;
 356 }
 357
 358 scm_t_cell *
 359 scm_dbg_gc_get_card (SCM obj)
 360 {
 361   if (!SCM_IMP (obj))
 362     return SCM_GC_CELL_CARD(obj);
 363   else
 364     return NULL;
 365 }
 366
 367 long *
 368 scm_dbg_gc_get_bvec (SCM obj)
 369 {
 370   if (!SCM_IMP (obj))
 371     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 372   else
 373     return NULL;
 374 }
 375
 376 #endif