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   ++ scm_gc_running_p;
  95
  96   /*
  97     I tried something fancy with shifting by one bit every word from
  98     the bitvec in turn, but it wasn't any faster, but quite a bit
  99     hairier.
 100    */
 101   for (p += offset; p < end; p += span, offset += span)
 102     {
 103       SCM scmptr = PTR2SCM (p);
 104       if (SCM_C_BVEC_GET (bitvec, offset))
 105         continue;
 106
 107       switch (SCM_TYP7 (scmptr))
 108         {
 109         case scm_tcs_struct:
 110           /* The card can be swept more than once.  Check that it's
 111            * the first time!
 112            */
 113           if (!SCM_STRUCT_GC_CHAIN (scmptr))
 114             {
 115               /* Structs need to be freed in a special order.
 116                * This is handled by GC C hooks in struct.c.
 117                */
 118               SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
 119               scm_i_structs_to_free = scmptr;
 120             }
 121           continue;
 122
 123         case scm_tcs_cons_imcar:
 124         case scm_tcs_cons_nimcar:
 125         case scm_tcs_closures:
 126         case scm_tc7_pws:
 127           break;
 128         case scm_tc7_wvect:
 129         case scm_tc7_vector:
 130           scm_i_vector_free (scmptr);
 131           break;
 132
 133 #ifdef CCLO
 134         case scm_tc7_cclo:
 135           scm_gc_free (SCM_CCLO_BASE (scmptr),
 136                        SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
 137                        "compiled closure");
 138           break;
 139 #endif
 140
 141         case scm_tc7_number:
 142           switch SCM_TYP16 (scmptr)
 143             {
 144             case scm_tc16_real:
 145               break;
 146             case scm_tc16_big:
 147               mpz_clear (SCM_I_BIG_MPZ (scmptr));
 148               /* nothing else to do here since the mpz is in a double cell */
 149               break;
 150             case scm_tc16_complex:
 151               scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
 152                            "complex");
 153               break;
 154             case scm_tc16_fraction:
 155               /* nothing to do here since the num/denum of a fraction
 156                  are proper SCM objects themselves. */
 157               break;
 158             }
 159           break;
 160         case scm_tc7_string:
 161           scm_i_string_free (scmptr);
 162           break;
 163         case scm_tc7_stringbuf:
 164           scm_i_stringbuf_free (scmptr);
 165           break;
 166         case scm_tc7_symbol:
 167           scm_i_symbol_free (scmptr);
 168           break;
 169         case scm_tc7_variable:
 170           break;
 171         case scm_tcs_subrs:
 172           /* the various "subrs" (primitives) are never freed */
 173           continue;
 174         case scm_tc7_port:
 175           if SCM_OPENP (scmptr)
 176             {
 177               int k = SCM_PTOBNUM (scmptr);
 178               size_t mm;
 179 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 180               if (!(k < scm_numptob))
 181                 {
 182                   fprintf (stderr, "undefined port type");
 183                   abort();
 184                 }
 185 #endif
 186               /* Keep "revealed" ports alive.  */
 187               if (scm_revealed_count (scmptr) > 0)
 188                 continue;
 189
 190               /* Yes, I really do mean scm_ptobs[k].free */
 191               /* rather than ftobs[k].close.  .close */
 192               /* is for explicit CLOSE-PORT by user */
 193               mm = scm_ptobs[k].free (scmptr);
 194
 195               if (mm != 0)
 196                 {
 197 #if SCM_ENABLE_DEPRECATED == 1
 198                   scm_c_issue_deprecation_warning
 199                     ("Returning non-0 from a port free function is "
 200                      "deprecated.  Use scm_gc_free et al instead.");
 201                   scm_c_issue_deprecation_warning_fmt
 202                     ("(You just returned non-0 while freeing a %s.)",
 203                      SCM_PTOBNAME (k));
 204                   scm_i_deprecated_memory_return += mm;
 205 #else
 206                   abort ();
 207 #endif
 208                 }
 209
 210               SCM_SETSTREAM (scmptr, 0);
 211               scm_remove_from_port_table (scmptr);
 212               scm_gc_ports_collected++;
 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       free_count ++;
 264     }
 265
 266   --scm_gc_running_p;
 267   return free_count;
 268 }
 269 #undef FUNC_NAME
 270
 271
 272 /*
 273   Like sweep, but no complicated logic to do the sweeping.
 274  */
 275 int
 276 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 277                         scm_t_heap_segment*seg)
 278 {
 279   int span = seg->span;
 280   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 281   scm_t_cell *p = end - span;
 282
 283   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 284   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 285
 286   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 287   SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
 288
 289   /*
 290      ASSUMPTION: n_header_cells <= 2.
 291    */
 292   for (; p > card;  p -= span)
 293     {
 294       const SCM scmptr = PTR2SCM (p);
 295       SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
 296       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 297       *free_list = scmptr;
 298     }
 299
 300   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 301 }
 302
 303
 304 void
 305 scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
 306 {
 307   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
 308   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
 309   int span = seg->span;
 310   int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
 311
 312   for (p += offset; p < end; p += span, offset += span)
 313     {
 314       SCM scmptr = PTR2SCM (p);
 315       if (!SCM_C_BVEC_GET (bitvec, offset))
 316         continue;
 317
 318       scm_t_bits tag = SCM_TYP7 (scmptr);
 319       if (tag  == scm_tc7_smob)
 320         {
 321           tag = SCM_TYP16(scmptr);
 322         }
 323       else
 324         switch (tag)
 325         {
 326         case scm_tcs_cons_imcar:
 327           tag = scm_tc2_int;
 328           break;
 329         case scm_tcs_cons_nimcar:
 330           tag = scm_tc3_cons;
 331           break;
 332         }
 333
 334       SCM tag_as_scm = scm_from_int (tag);
 335       SCM current = scm_hashq_ref (hashtab, tag_as_scm, SCM_I_MAKINUM (0));
 336
 337       scm_hashq_set_x (hashtab, tag_as_scm,
 338                        scm_from_int (scm_to_int (current) + 1));
 339     }
 340 }
 341
 342
 343 char const *
 344 scm_i_tag_name (scm_t_bits tag)
 345 {
 346   if (tag >= 255)
 347     {
 348       if (tag == scm_tc_free_cell)
 349         return "free cell";
 350
 351       {
 352         int k = 0xff & (tag >> 8);
 353         return (scm_smobs[k].name);
 354       }
 355     }
 356
 357   switch (tag) /* 7 bits */
 358     {
 359     case scm_tcs_struct:
 360       return "struct";
 361     case scm_tcs_cons_imcar:
 362       return "cons (immediate car)";
 363     case scm_tcs_cons_nimcar:
 364       return "cons (non-immediate car)";
 365     case scm_tcs_closures:
 366       return "closures";
 367     case scm_tc7_pws:
 368       return "pws";
 369     case scm_tc7_wvect:
 370       return "weak vector";
 371     case scm_tc7_vector:
 372       return "vector";
 373 #ifdef CCLO
 374     case scm_tc7_cclo:
 375       return "compiled closure";
 376 #endif
 377     case scm_tc7_number:
 378       switch (tag)
 379         {
 380         case scm_tc16_real:
 381           return "real";
 382           break;
 383         case scm_tc16_big:
 384           return "bignum";
 385           break;
 386         case scm_tc16_complex:
 387           return "complex number";
 388           break;
 389         case scm_tc16_fraction:
 390           return "fraction";
 391           break;
 392         }
 393       break;
 394     case scm_tc7_string:
 395       return "string";
 396       break;
 397     case scm_tc7_stringbuf:
 398       return "string buffer";
 399       break;
 400     case scm_tc7_symbol:
 401       return "symbol";
 402       break;
 403     case scm_tc7_variable:
 404       return "variable";
 405       break;
 406     case scm_tcs_subrs:
 407       return "subrs";
 408       break;
 409     case scm_tc7_port:
 410       return "port";
 411       break;
 412     case scm_tc7_smob:
 413       return "smob";            /* should not occur. */
 414       break;
 415     }
 416
 417   return NULL;
 418 }
 419
 420
 421 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 422
 423 typedef struct scm_dbg_t_list_cell {
 424   scm_t_bits car;
 425   struct scm_dbg_t_list_cell * cdr;
 426 } scm_dbg_t_list_cell;
 427
 428
 429 typedef struct scm_dbg_t_double_cell {
 430   scm_t_bits word_0;
 431   scm_t_bits word_1;
 432   scm_t_bits word_2;
 433   scm_t_bits word_3;
 434 } scm_dbg_t_double_cell;
 435
 436
 437 int scm_dbg_gc_marked_p (SCM obj);
 438 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 439 long * scm_dbg_gc_get_bvec (SCM obj);
 440
 441
 442 int
 443 scm_dbg_gc_marked_p (SCM obj)
 444 {
 445   if (!SCM_IMP (obj))
 446     return SCM_GC_MARK_P(obj);
 447   else
 448     return 0;
 449 }
 450
 451 scm_t_cell *
 452 scm_dbg_gc_get_card (SCM obj)
 453 {
 454   if (!SCM_IMP (obj))
 455     return SCM_GC_CELL_CARD(obj);
 456   else
 457     return NULL;
 458 }
 459
 460 long *
 461 scm_dbg_gc_get_bvec (SCM obj)
 462 {
 463   if (!SCM_IMP (obj))
 464     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 465   else
 466     return NULL;
 467 }
 468
 469 #endif