guile18/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 <stdio.h>
  23 #include <gmp.h>
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/eval.h"
  27 #include "libguile/numbers.h"
  28 #include "libguile/stime.h"
  29 #include "libguile/stackchk.h"
  30 #include "libguile/struct.h"
  31 #include "libguile/smob.h"
  32 #include "libguile/unif.h"
  33 #include "libguile/async.h"
  34 #include "libguile/ports.h"
  35 #include "libguile/root.h"
  36 #include "libguile/strings.h"
  37 #include "libguile/vectors.h"
  38 #include "libguile/weaks.h"
  39 #include "libguile/hashtab.h"
  40 #include "libguile/tags.h"
  41 #include "libguile/private-gc.h"
  42 #include "libguile/validate.h"
  43 #include "libguile/deprecation.h"
  44 #include "libguile/gc.h"
  45 #include "libguile/srfi-4.h"
  46
  47 #include "libguile/private-gc.h"
  48
  49 long int scm_i_deprecated_memory_return;
  50
  51
  52 /* During collection, this accumulates structures which are to be freed.
  53  */
  54 SCM scm_i_structs_to_free;
  55
  56
  57 /*
  58   Init all the free cells in CARD, prepending to *FREE_LIST.
  59
  60   Return: number of free cells found in this card.
  61
  62   It would be cleaner to have a separate function sweep_value(), but
  63   that is too slow (functions with switch statements can't be
  64   inlined).
  65
  66
  67
  68
  69   NOTE:
  70
  71   This function is quite efficient. However, for many types of cells,
  72   allocation and a de-allocation involves calling malloc() and
  73   free().
  74
  75   This is costly for small objects (due to malloc/free overhead.)
  76   (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 *  p, 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(p);
  92   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  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
 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_remove_from_port_table (scmptr);
 213               scm_gc_ports_collected++;
 214               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 215             }
 216           break;
 217         case scm_tc7_smob:
 218           switch SCM_TYP16 (scmptr)
 219             {
 220             case scm_tc_free_cell:
 221               free_count --;
 222               break;
 223             default:
 224               {
 225                 int k;
 226                 k = SCM_SMOBNUM (scmptr);
 227 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 228                 if (!(k < scm_numsmob))
 229                   {
 230                     fprintf (stderr, "undefined smob type");
 231                     abort();
 232                   }
 233 #endif
 234                 if (scm_smobs[k].free)
 235                   {
 236                     size_t mm;
 237                     mm = scm_smobs[k].free (scmptr);
 238                     if (mm != 0)
 239                       {
 240 #if SCM_ENABLE_DEPRECATED == 1
 241                         scm_c_issue_deprecation_warning
 242                           ("Returning non-0 from a smob free function is "
 243                            "deprecated.  Use scm_gc_free et al instead.");
 244                         scm_c_issue_deprecation_warning_fmt
 245                           ("(You just returned non-0 while freeing a %s.)",
 246                            SCM_SMOBNAME (k));
 247                         scm_i_deprecated_memory_return += mm;
 248 #else
 249                         abort();
 250 #endif
 251                       }
 252                   }
 253                 break;
 254               }
 255             }
 256           break;
 257         default:
 258           fprintf (stderr, "unknown type");
 259           abort();
 260         }
 261
 262       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 263       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 264       *free_list = scmptr;
 265       free_count ++;
 266     }
 267
 268   return free_count;
 269 }
 270 #undef FUNC_NAME
 271
 272
 273 /*
 274   Like sweep, but no complicated logic to do the sweeping.
 275  */
 276 int
 277 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 278                         scm_t_heap_segment*seg)
 279 {
 280   int span = seg->span;
 281   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 282   scm_t_cell *p = end - span;
 283
 284   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 285   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 286
 287   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 288   SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
 289
 290   /*
 291      ASSUMPTION: n_header_cells <= 2.
 292    */
 293   for (; p > card;  p -= span)
 294     {
 295       const SCM scmptr = PTR2SCM (p);
 296       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 297       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 298       *free_list = scmptr;
 299     }
 300
 301   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 302 }
 303
 304
 305 void
 306 scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
 307 {
 308   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
 309   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
 310   int span = seg->span;
 311   int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
 312
 313   if (!bitvec)
 314     /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
 315     return;
 316
 317   for (p += offset; p < end; p += span, offset += span)
 318     {
 319       scm_t_bits tag = -1;
 320       SCM scmptr = PTR2SCM (p);
 321
 322       if (!SCM_C_BVEC_GET (bitvec, offset))
 323         continue;
 324
 325       tag = SCM_TYP7 (scmptr);
 326       if (tag == scm_tc7_smob || tag == scm_tc7_number)
 327         {
 328           /* Record smobs and numbers under 16 bits of the tag, so the
 329              different smob objects are distinguished, and likewise the
 330              different numbers big, real, complex and fraction. */
 331           tag = SCM_TYP16(scmptr);
 332         }
 333       else
 334         switch (tag)
 335         {
 336         case scm_tcs_cons_imcar:
 337           tag = scm_tc2_int;
 338           break;
 339         case scm_tcs_cons_nimcar:
 340           tag = scm_tc3_cons;
 341           break;
 342
 343         case scm_tcs_struct:
 344           tag = scm_tc3_struct;
 345           break;
 346         case scm_tcs_closures:
 347           tag = scm_tc3_closure;
 348           break;
 349         case scm_tcs_subrs:
 350           tag = scm_tc7_asubr;
 351           break;
 352         }
 353
 354       {
 355         SCM handle = scm_hashq_create_handle_x (hashtab,
 356                                                 scm_from_int (tag), SCM_INUM0);
 357         SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
 358       }
 359     }
 360 }
 361
 362 /* TAG is the tag word of a cell, return a string which is its name, or NULL
 363    if unknown.  Currently this is only used by gc-live-object-stats and the
 364    distinctions between types are oriented towards what that code records
 365    while scanning what's alive.  */
 366 char const *
 367 scm_i_tag_name (scm_t_bits tag)
 368 {
 369   switch (tag & 0x7F) /* 7 bits */
 370     {
 371     case scm_tcs_struct:
 372       return "struct";
 373     case scm_tcs_cons_imcar:
 374       return "cons (immediate car)";
 375     case scm_tcs_cons_nimcar:
 376       return "cons (non-immediate car)";
 377     case scm_tcs_closures:
 378       return "closures";
 379     case scm_tc7_pws:
 380       return "pws";
 381     case scm_tc7_wvect:
 382       return "weak vector";
 383     case scm_tc7_vector:
 384       return "vector";
 385 #ifdef CCLO
 386     case scm_tc7_cclo:
 387       return "compiled closure";
 388 #endif
 389     case scm_tc7_number:
 390       switch (tag)
 391         {
 392         case scm_tc16_real:
 393           return "real";
 394         case scm_tc16_big:
 395           return "bignum";
 396         case scm_tc16_complex:
 397           return "complex number";
 398         case scm_tc16_fraction:
 399           return "fraction";
 400         }
 401       /* shouldn't reach here unless there's a new class of numbers */
 402       return "number";
 403     case scm_tc7_string:
 404       return "string";
 405     case scm_tc7_stringbuf:
 406       return "string buffer";
 407     case scm_tc7_symbol:
 408       return "symbol";
 409     case scm_tc7_variable:
 410       return "variable";
 411     case scm_tcs_subrs:
 412       return "subrs";
 413     case scm_tc7_port:
 414       return "port";
 415     case scm_tc7_smob:
 416       /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
 417          entry should be ok for our return here */
 418       return scm_smobs[SCM_TC2SMOBNUM(tag)].name;
 419     }
 420
 421   return NULL;
 422 }
 423
 424
 425 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 426
 427 typedef struct scm_dbg_t_list_cell {
 428   scm_t_bits car;
 429   struct scm_dbg_t_list_cell * cdr;
 430 } scm_dbg_t_list_cell;
 431
 432
 433 typedef struct scm_dbg_t_double_cell {
 434   scm_t_bits word_0;
 435   scm_t_bits word_1;
 436   scm_t_bits word_2;
 437   scm_t_bits word_3;
 438 } scm_dbg_t_double_cell;
 439
 440
 441 int scm_dbg_gc_marked_p (SCM obj);
 442 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 443 scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
 444
 445
 446 int
 447 scm_dbg_gc_marked_p (SCM obj)
 448 {
 449   if (!SCM_IMP (obj))
 450     return SCM_GC_MARK_P(obj);
 451   else
 452     return 0;
 453 }
 454
 455 scm_t_cell *
 456 scm_dbg_gc_get_card (SCM obj)
 457 {
 458   if (!SCM_IMP (obj))
 459     return SCM_GC_CELL_CARD(obj);
 460   else
 461     return NULL;
 462 }
 463
 464 scm_t_c_bvec_long *
 465 scm_dbg_gc_get_bvec (SCM obj)
 466 {
 467   if (!SCM_IMP (obj))
 468     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 469   else
 470     return NULL;
 471 }
 472
 473 #endif