libguile/gc-card.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * 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., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #ifdef HAVE_CONFIG_H
  20 # include <config.h>
  21 #endif
  22
  23 #include <assert.h>
  24 #include <stdio.h>
  25 #include <count-one-bits.h>
  26
  27 #include <gmp.h>
  28
  29 #include "libguile/_scm.h"
  30 #include "libguile/async.h"
  31 #include "libguile/deprecation.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/gc.h"
  34 #include "libguile/hashtab.h"
  35 #include "libguile/numbers.h"
  36 #include "libguile/ports.h"
  37 #include "libguile/private-gc.h"
  38 #include "libguile/root.h"
  39 #include "libguile/smob.h"
  40 #include "libguile/srfi-4.h"
  41 #include "libguile/stackchk.h"
  42 #include "libguile/stime.h"
  43 #include "libguile/strings.h"
  44 #include "libguile/struct.h"
  45 #include "libguile/tags.h"
  46 #include "libguile/unif.h"
  47 #include "libguile/validate.h"
  48 #include "libguile/vectors.h"
  49 #include "libguile/weaks.h"
  50
  51 #include "libguile/private-gc.h"
  52
  53 long int scm_i_deprecated_memory_return;
  54
  55
  56 /* During collection, this accumulates structures which are to be freed.
  57  */
  58 SCM scm_i_structs_to_free;
  59
  60 /*
  61   Init all the free cells in CARD, prepending to *FREE_LIST.
  62
  63   Return: FREE_COUNT, the number of cells collected.  This is
  64   typically the length of the *FREE_LIST, but for some special cases,
  65   we do not actually free the cell. To make the numbers match up, we
  66   do increase the FREE_COUNT.
  67
  68   It would be cleaner to have a separate function sweep_value (), but
  69   that is too slow (functions with switch statements can't be
  70   inlined).
  71
  72   NOTE:
  73
  74   For many types of cells, allocation and a de-allocation involves
  75   calling malloc () and free ().  This is costly for small objects (due
  76   to malloc/free overhead.)  (should measure this).
  77
  78   It might also be bad for threads: if several threads are allocating
  79   strings concurrently, then mallocs for both threads may have to
  80   fiddle with locks.
  81
  82   It might be interesting to add a separate memory pool for small
  83   objects to each freelist.
  84
  85   --hwn.
  86  */
  87 int
  88 scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg)
  89 #define FUNC_NAME "sweep_card"
  90 {
  91   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (card);
  92   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
  93   scm_t_cell *p = card;
  94   int span = seg->span;
  95   int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
  96   int free_count = 0;
  97
  98   /*
  99     I tried something fancy with shifting by one bit every word from
 100     the bitvec in turn, but it wasn't any faster, but quite a bit
 101     hairier.
 102    */
 103   for (p += offset; p < end; p += span, offset += span)
 104     {
 105       SCM scmptr = PTR2SCM (p);
 106       if (SCM_C_BVEC_GET (bitvec, offset))
 107         continue;
 108       free_count++;
 109       switch (SCM_TYP7 (scmptr))
 110         {
 111         case scm_tcs_struct:
 112           /* The card can be swept more than once.  Check that it's
 113            * the first time!
 114            */
 115           if (!SCM_STRUCT_GC_CHAIN (scmptr))
 116             {
 117               /* Structs need to be freed in a special order.
 118                * This is handled by GC C hooks in struct.c.
 119                */
 120               SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
 121               scm_i_structs_to_free = scmptr;
 122             }
 123           continue;
 124
 125         case scm_tcs_cons_imcar:
 126         case scm_tcs_cons_nimcar:
 127         case scm_tcs_closures:
 128         case scm_tc7_pws:
 129           break;
 130         case scm_tc7_wvect:
 131         case scm_tc7_vector:
 132           scm_i_vector_free (scmptr);
 133           break;
 134
 135         case scm_tc7_number:
 136           switch SCM_TYP16 (scmptr)
 137             {
 138             case scm_tc16_real:
 139               break;
 140             case scm_tc16_big:
 141               mpz_clear (SCM_I_BIG_MPZ (scmptr));
 142               /* nothing else to do here since the mpz is in a double cell */
 143               break;
 144             case scm_tc16_complex:
 145               scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
 146                            "complex");
 147               break;
 148             case scm_tc16_fraction:
 149               /* nothing to do here since the num/denum of a fraction
 150                  are proper SCM objects themselves. */
 151               break;
 152             }
 153           break;
 154         case scm_tc7_string:
 155           scm_i_string_free (scmptr);
 156           break;
 157         case scm_tc7_stringbuf:
 158           scm_i_stringbuf_free (scmptr);
 159           break;
 160         case scm_tc7_symbol:
 161           scm_i_symbol_free (scmptr);
 162           break;
 163         case scm_tc7_variable:
 164           break;
 165         case scm_tc7_program:
 166           break;
 167         case scm_tcs_subrs:
 168           /* the various "subrs" (primitives) are never freed */
 169           continue;
 170         case scm_tc7_port:
 171           if SCM_OPENP (scmptr)
 172             {
 173               int k = SCM_PTOBNUM (scmptr);
 174               size_t mm;
 175 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 176               if (!(k < scm_numptob))
 177                 {
 178                   fprintf (stderr, "undefined port type");
 179                   abort ();
 180                 }
 181 #endif
 182               /* Keep "revealed" ports alive.  */
 183               if (scm_revealed_count (scmptr) > 0)
 184                 continue;
 185
 186               /* Yes, I really do mean scm_ptobs[k].free */
 187               /* rather than ftobs[k].close.  .close */
 188               /* is for explicit CLOSE-PORT by user */
 189               mm = scm_ptobs[k].free (scmptr);
 190
 191               if (mm != 0)
 192                 {
 193 #if SCM_ENABLE_DEPRECATED == 1
 194                   scm_c_issue_deprecation_warning
 195                     ("Returning non-0 from a port free function is "
 196                      "deprecated.  Use scm_gc_free et al instead.");
 197                   scm_c_issue_deprecation_warning_fmt
 198                     ("(You just returned non-0 while freeing a %s.)",
 199                      SCM_PTOBNAME (k));
 200                   scm_i_deprecated_memory_return += mm;
 201 #else
 202                   abort ();
 203 #endif
 204                 }
 205
 206               SCM_SETSTREAM (scmptr, 0);
 207               scm_i_remove_port (scmptr);
 208               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 209             }
 210           break;
 211         case scm_tc7_smob:
 212           switch SCM_TYP16 (scmptr)
 213             {
 214             case scm_tc_free_cell:
 215               break;
 216             default:
 217               {
 218                 int k;
 219                 k = SCM_SMOBNUM (scmptr);
 220 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 221                 if (!(k < scm_numsmob))
 222                   {
 223                     fprintf (stderr, "undefined smob type");
 224                     abort ();
 225                   }
 226 #endif
 227                 if (scm_smobs[k].free)
 228                   {
 229                     size_t mm;
 230                     mm = scm_smobs[k].free (scmptr);
 231                     if (mm != 0)
 232                       {
 233 #if SCM_ENABLE_DEPRECATED == 1
 234                         scm_c_issue_deprecation_warning
 235                           ("Returning non-0 from a smob free function is "
 236                            "deprecated.  Use scm_gc_free et al instead.");
 237                         scm_c_issue_deprecation_warning_fmt
 238                           ("(You just returned non-0 while freeing a %s.)",
 239                            SCM_SMOBNAME (k));
 240                         scm_i_deprecated_memory_return += mm;
 241 #else
 242                         abort ();
 243 #endif
 244                       }
 245                   }
 246                 break;
 247               }
 248             }
 249           break;
 250         default:
 251           fprintf (stderr, "unknown type");
 252           abort ();
 253         }
 254
 255       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 256       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 257       *free_list = scmptr;
 258     }
 259
 260   return free_count;
 261 }
 262 #undef FUNC_NAME
 263
 264
 265 /*
 266   Like sweep, but no complicated logic to do the sweeping.
 267  */
 268 int
 269 scm_i_init_card_freelist (scm_t_cell *card, SCM *free_list,
 270                           scm_t_heap_segment *seg)
 271 {
 272   int span = seg->span;
 273   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 274   scm_t_cell *p = end - span;
 275   int collected = 0;
 276   scm_t_c_bvec_long *bvec_ptr = (scm_t_c_bvec_long*) seg->bounds[1];
 277   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 278
 279   bvec_ptr += idx * SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 280   SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
 281
 282   /*
 283      ASSUMPTION: n_header_cells <= 2.
 284    */
 285   for (; p > card;  p -= span)
 286     {
 287       const SCM scmptr = PTR2SCM (p);
 288       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 289       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 290       *free_list = scmptr;
 291       collected ++;
 292     }
 293
 294   return collected;
 295 }
 296
 297 /*
 298   Amount of cells marked in this cell, measured in 1-cells.
 299  */
 300 int
 301 scm_i_card_marked_count (scm_t_cell *card, int span)
 302 {
 303   scm_t_c_bvec_long* bvec = SCM_GC_CARD_BVEC (card);
 304   scm_t_c_bvec_long* bvec_end = (bvec + SCM_GC_CARD_BVEC_SIZE_IN_LONGS);
 305
 306   int count = 0;
 307   while (bvec < bvec_end)
 308     {
 309       count += count_one_bits_l (*bvec);
 310       bvec ++;
 311     }
 312   return count * span;
 313 }
 314
 315 void
 316 scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
 317 {
 318   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (p);
 319   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
 320   int span = seg->span;
 321   int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
 322
 323   if (!bitvec)
 324     /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
 325     return;
 326
 327   for (p += offset; p < end; p += span, offset += span)
 328     {
 329       scm_t_bits tag = -1;
 330       SCM scmptr = PTR2SCM (p);
 331
 332       if (!SCM_C_BVEC_GET (bitvec, offset))
 333         continue;
 334
 335       tag = SCM_TYP7 (scmptr);
 336       if (tag == scm_tc7_smob || tag == scm_tc7_number)
 337         {
 338           /* Record smobs and numbers under 16 bits of the tag, so the
 339              different smob objects are distinguished, and likewise the
 340              different numbers big, real, complex and fraction. */
 341           tag = SCM_TYP16(scmptr);
 342         }
 343       else
 344         switch (tag)
 345         {
 346         case scm_tcs_cons_imcar:
 347           tag = scm_tc2_int;
 348           break;
 349         case scm_tcs_cons_nimcar:
 350           tag = scm_tc3_cons;
 351           break;
 352
 353         case scm_tcs_struct:
 354           tag = scm_tc3_struct;
 355           break;
 356         case scm_tcs_closures:
 357           tag = scm_tc3_closure;
 358           break;
 359         case scm_tcs_subrs:
 360           tag = scm_tc7_asubr;
 361           break;
 362         }
 363
 364       {
 365         SCM handle = scm_hashq_create_handle_x (hashtab,
 366                                                 scm_from_int (tag), SCM_INUM0);
 367         SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
 368       }
 369     }
 370 }
 371
 372 /* TAG is the tag word of a cell, return a string which is its name, or NULL
 373    if unknown.  Currently this is only used by gc-live-object-stats and the
 374    distinctions between types are oriented towards what that code records
 375    while scanning what's alive.  */
 376 char const *
 377 scm_i_tag_name (scm_t_bits tag)
 378 {
 379   switch (tag & 0x7F) /* 7 bits */
 380     {
 381     case scm_tcs_struct:
 382       return "struct";
 383     case scm_tcs_cons_imcar:
 384       return "cons (immediate car)";
 385     case scm_tcs_cons_nimcar:
 386       return "cons (non-immediate car)";
 387     case scm_tcs_closures:
 388       return "closures";
 389     case scm_tc7_pws:
 390       return "pws";
 391     case scm_tc7_program:
 392       return "program";
 393     case scm_tc7_wvect:
 394       return "weak vector";
 395     case scm_tc7_vector:
 396       return "vector";
 397     case scm_tc7_number:
 398       switch (tag)
 399         {
 400         case scm_tc16_real:
 401           return "real";
 402         case scm_tc16_big:
 403           return "bignum";
 404         case scm_tc16_complex:
 405           return "complex number";
 406         case scm_tc16_fraction:
 407           return "fraction";
 408         }
 409       /* shouldn't reach here unless there's a new class of numbers */
 410       return "number";
 411     case scm_tc7_string:
 412       return "string";
 413     case scm_tc7_stringbuf:
 414       return "string buffer";
 415     case scm_tc7_symbol:
 416       return "symbol";
 417     case scm_tc7_variable:
 418       return "variable";
 419     case scm_tcs_subrs:
 420       return "subrs";
 421     case scm_tc7_port:
 422       return "port";
 423     case scm_tc7_smob:
 424       /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
 425          entry should be ok for our return here */
 426       return scm_smobs[SCM_TC2SMOBNUM (tag)].name;
 427     }
 428
 429   return NULL;
 430 }
 431
 432
 433 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 434
 435 typedef struct scm_dbg_t_list_cell {
 436   scm_t_bits car;
 437   struct scm_dbg_t_list_cell * cdr;
 438 } scm_dbg_t_list_cell;
 439
 440
 441 typedef struct scm_dbg_t_double_cell {
 442   scm_t_bits word_0;
 443   scm_t_bits word_1;
 444   scm_t_bits word_2;
 445   scm_t_bits word_3;
 446 } scm_dbg_t_double_cell;
 447
 448
 449 int scm_dbg_gc_marked_p (SCM obj);
 450 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 451 scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
 452
 453
 454 int
 455 scm_dbg_gc_marked_p (SCM obj)
 456 {
 457   if (!SCM_IMP (obj))
 458     return SCM_GC_MARK_P (obj);
 459   else
 460     return 0;
 461 }
 462
 463 scm_t_cell *
 464 scm_dbg_gc_get_card (SCM obj)
 465 {
 466   if (!SCM_IMP (obj))
 467     return SCM_GC_CELL_CARD (obj);
 468   else
 469     return NULL;
 470 }
 471
 472 scm_t_c_bvec_long *
 473 scm_dbg_gc_get_bvec (SCM obj)
 474 {
 475   if (!SCM_IMP (obj))
 476     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 477   else
 478     return NULL;
 479 }
 480
 481 #endif