libguile/gc-card.c

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