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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 scmptr = PTR2SCM (p);
 312       if (!SCM_C_BVEC_GET (bitvec, offset))
 313         continue;
 314
 315       scm_t_bits tag = SCM_TYP7 (scmptr);
 316       if (tag  == scm_tc7_smob)
 317         {
 318           tag = SCM_TYP16(scmptr);
 319         }
 320       else
 321         switch (tag)
 322         {
 323         case scm_tcs_cons_imcar:
 324           tag = scm_tc2_int;
 325           break;
 326         case scm_tcs_cons_nimcar:
 327           tag = scm_tc3_cons;
 328           break;
 329
 330         case scm_tcs_struct:
 331           tag = scm_tc3_struct;
 332           break;
 333         case scm_tcs_closures:
 334           tag = scm_tc3_closure;
 335           break;
 336         case scm_tcs_subrs:
 337           tag = scm_tc7_asubr;
 338           break;
 339         }
 340
 341       SCM tag_as_scm = scm_from_int (tag);
 342       SCM current = scm_hashq_ref (hashtab, tag_as_scm, SCM_I_MAKINUM (0));
 343
 344       scm_hashq_set_x (hashtab, tag_as_scm,
 345                        scm_from_int (scm_to_int (current) + 1));
 346     }
 347 }
 348
 349
 350 char const *
 351 scm_i_tag_name (scm_t_bits tag)
 352 {
 353   if (tag >= 255)
 354     {
 355       if (tag == scm_tc_free_cell)
 356         return "free cell";
 357
 358       {
 359         int k = 0xff & (tag >> 8);
 360         return (scm_smobs[k].name);
 361       }
 362     }
 363
 364   switch (tag) /* 7 bits */
 365     {
 366     case scm_tcs_struct:
 367       return "struct";
 368     case scm_tcs_cons_imcar:
 369       return "cons (immediate car)";
 370     case scm_tcs_cons_nimcar:
 371       return "cons (non-immediate car)";
 372     case scm_tcs_closures:
 373       return "closures";
 374     case scm_tc7_pws:
 375       return "pws";
 376     case scm_tc7_wvect:
 377       return "weak vector";
 378     case scm_tc7_vector:
 379       return "vector";
 380 #ifdef CCLO
 381     case scm_tc7_cclo:
 382       return "compiled closure";
 383 #endif
 384     case scm_tc7_number:
 385       switch (tag)
 386         {
 387         case scm_tc16_real:
 388           return "real";
 389           break;
 390         case scm_tc16_big:
 391           return "bignum";
 392           break;
 393         case scm_tc16_complex:
 394           return "complex number";
 395           break;
 396         case scm_tc16_fraction:
 397           return "fraction";
 398           break;
 399         }
 400       break;
 401     case scm_tc7_string:
 402       return "string";
 403       break;
 404     case scm_tc7_stringbuf:
 405       return "string buffer";
 406       break;
 407     case scm_tc7_symbol:
 408       return "symbol";
 409       break;
 410     case scm_tc7_variable:
 411       return "variable";
 412       break;
 413     case scm_tcs_subrs:
 414       return "subrs";
 415       break;
 416     case scm_tc7_port:
 417       return "port";
 418       break;
 419     case scm_tc7_smob:
 420       return "smob";            /* should not occur. */
 421       break;
 422     }
 423
 424   return NULL;
 425 }
 426
 427
 428 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 429
 430 typedef struct scm_dbg_t_list_cell {
 431   scm_t_bits car;
 432   struct scm_dbg_t_list_cell * cdr;
 433 } scm_dbg_t_list_cell;
 434
 435
 436 typedef struct scm_dbg_t_double_cell {
 437   scm_t_bits word_0;
 438   scm_t_bits word_1;
 439   scm_t_bits word_2;
 440   scm_t_bits word_3;
 441 } scm_dbg_t_double_cell;
 442
 443
 444 int scm_dbg_gc_marked_p (SCM obj);
 445 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 446 long * scm_dbg_gc_get_bvec (SCM obj);
 447
 448
 449 int
 450 scm_dbg_gc_marked_p (SCM obj)
 451 {
 452   if (!SCM_IMP (obj))
 453     return SCM_GC_MARK_P(obj);
 454   else
 455     return 0;
 456 }
 457
 458 scm_t_cell *
 459 scm_dbg_gc_get_card (SCM obj)
 460 {
 461   if (!SCM_IMP (obj))
 462     return SCM_GC_CELL_CARD(obj);
 463   else
 464     return NULL;
 465 }
 466
 467 long *
 468 scm_dbg_gc_get_bvec (SCM obj)
 469 {
 470   if (!SCM_IMP (obj))
 471     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 472   else
 473     return NULL;
 474 }
 475
 476 #endif