libguile/gc-card.c

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