libguile/gc-card.c

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