libguile/gc-card.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004 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               break;
 219             default:
 220               {
 221                 int k;
 222                 k = SCM_SMOBNUM (scmptr);
 223 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 224                 if (!(k < scm_numsmob))
 225                   {
 226                     fprintf (stderr, "undefined smob type");
 227                     abort();
 228                   }
 229 #endif
 230                 if (scm_smobs[k].free)
 231                   {
 232                     size_t mm;
 233                     mm = scm_smobs[k].free (scmptr);
 234                     if (mm != 0)
 235                       {
 236 #if SCM_ENABLE_DEPRECATED == 1
 237                         scm_c_issue_deprecation_warning
 238                           ("Returning non-0 from a smob free function is "
 239                            "deprecated.  Use scm_gc_free et al instead.");
 240                         scm_c_issue_deprecation_warning_fmt
 241                           ("(You just returned non-0 while freeing a %s.)",
 242                            SCM_SMOBNAME (k));
 243                         scm_i_deprecated_memory_return += mm;
 244 #else
 245                         abort();
 246 #endif
 247                       }
 248                   }
 249                 break;
 250               }
 251             }
 252           break;
 253         default:
 254           fprintf (stderr, "unknown type");
 255           abort();
 256         }
 257
 258       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 259       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 260       *free_list = scmptr;
 261       free_count ++;
 262     }
 263
 264   return free_count;
 265 }
 266 #undef FUNC_NAME
 267
 268
 269 /*
 270   Like sweep, but no complicated logic to do the sweeping.
 271  */
 272 int
 273 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 274                         scm_t_heap_segment*seg)
 275 {
 276   int span = seg->span;
 277   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 278   scm_t_cell *p = end - span;
 279
 280   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 281   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 282
 283   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 284   SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
 285
 286   /*
 287      ASSUMPTION: n_header_cells <= 2.
 288    */
 289   for (; p > card;  p -= span)
 290     {
 291       const SCM scmptr = PTR2SCM (p);
 292       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 293       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 294       *free_list = scmptr;
 295     }
 296
 297   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 298 }
 299
 300
 301 void
 302 scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
 303 {
 304   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
 305   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
 306   int span = seg->span;
 307   int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
 308
 309   for (p += offset; p < end; p += span, offset += span)
 310     {
 311       scm_t_bits tag;
 312       SCM scmptr = PTR2SCM (p);
 313
 314       if (!SCM_C_BVEC_GET (bitvec, offset))
 315         continue;
 316
 317       tag = SCM_TYP7 (scmptr);
 318       if (tag  == scm_tc7_smob)
 319         {
 320           tag = SCM_TYP16(scmptr);
 321         }
 322       else
 323         switch (tag)
 324         {
 325         case scm_tcs_cons_imcar:
 326           tag = scm_tc2_int;
 327           break;
 328         case scm_tcs_cons_nimcar:
 329           tag = scm_tc3_cons;
 330           break;
 331
 332         case scm_tcs_struct:
 333           tag = scm_tc3_struct;
 334           break;
 335         case scm_tcs_closures:
 336           tag = scm_tc3_closure;
 337           break;
 338         case scm_tcs_subrs:
 339           tag = scm_tc7_asubr;
 340           break;
 341         }
 342
 343       {
 344         SCM tag_as_scm = scm_from_int (tag);
 345         SCM current = scm_hashq_ref (hashtab, tag_as_scm, SCM_I_MAKINUM (0));
 346
 347         scm_hashq_set_x (hashtab, tag_as_scm,
 348                          scm_from_int (scm_to_int (current) + 1));
 349       }
 350     }
 351 }
 352
 353
 354 char const *
 355 scm_i_tag_name (scm_t_bits tag)
 356 {
 357   if (tag >= 255)
 358     {
 359       if (tag == scm_tc_free_cell)
 360         return "free cell";
 361
 362       {
 363         int k = 0xff & (tag >> 8);
 364         return (scm_smobs[k].name);
 365       }
 366     }
 367
 368   switch (tag) /* 7 bits */
 369     {
 370     case scm_tcs_struct:
 371       return "struct";
 372     case scm_tcs_cons_imcar:
 373       return "cons (immediate car)";
 374     case scm_tcs_cons_nimcar:
 375       return "cons (non-immediate car)";
 376     case scm_tcs_closures:
 377       return "closures";
 378     case scm_tc7_pws:
 379       return "pws";
 380     case scm_tc7_wvect:
 381       return "weak vector";
 382     case scm_tc7_vector:
 383       return "vector";
 384 #ifdef CCLO
 385     case scm_tc7_cclo:
 386       return "compiled closure";
 387 #endif
 388     case scm_tc7_number:
 389       switch (tag)
 390         {
 391         case scm_tc16_real:
 392           return "real";
 393           break;
 394         case scm_tc16_big:
 395           return "bignum";
 396           break;
 397         case scm_tc16_complex:
 398           return "complex number";
 399           break;
 400         case scm_tc16_fraction:
 401           return "fraction";
 402           break;
 403         }
 404       break;
 405     case scm_tc7_string:
 406       return "string";
 407       break;
 408     case scm_tc7_stringbuf:
 409       return "string buffer";
 410       break;
 411     case scm_tc7_symbol:
 412       return "symbol";
 413       break;
 414     case scm_tc7_variable:
 415       return "variable";
 416       break;
 417     case scm_tcs_subrs:
 418       return "subrs";
 419       break;
 420     case scm_tc7_port:
 421       return "port";
 422       break;
 423     case scm_tc7_smob:
 424       return "smob";            /* should not occur. */
 425       break;
 426     }
 427
 428   return NULL;
 429 }
 430
 431
 432 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 433
 434 typedef struct scm_dbg_t_list_cell {
 435   scm_t_bits car;
 436   struct scm_dbg_t_list_cell * cdr;
 437 } scm_dbg_t_list_cell;
 438
 439
 440 typedef struct scm_dbg_t_double_cell {
 441   scm_t_bits word_0;
 442   scm_t_bits word_1;
 443   scm_t_bits word_2;
 444   scm_t_bits word_3;
 445 } scm_dbg_t_double_cell;
 446
 447
 448 int scm_dbg_gc_marked_p (SCM obj);
 449 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 450 long * scm_dbg_gc_get_bvec (SCM obj);
 451
 452
 453 int
 454 scm_dbg_gc_marked_p (SCM obj)
 455 {
 456   if (!SCM_IMP (obj))
 457     return SCM_GC_MARK_P(obj);
 458   else
 459     return 0;
 460 }
 461
 462 scm_t_cell *
 463 scm_dbg_gc_get_card (SCM obj)
 464 {
 465   if (!SCM_IMP (obj))
 466     return SCM_GC_CELL_CARD(obj);
 467   else
 468     return NULL;
 469 }
 470
 471 long *
 472 scm_dbg_gc_get_bvec (SCM obj)
 473 {
 474   if (!SCM_IMP (obj))
 475     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 476   else
 477     return NULL;
 478 }
 479
 480 #endif