libguile/gc-card.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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
  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           {
 131             unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
 132             if (length > 0)
 133               {
 134                 scm_gc_free (SCM_VECTOR_BASE (scmptr),
 135                              length * sizeof (scm_t_bits),
 136                              "vector");
 137               }
 138             break;
 139           }
 140 #ifdef CCLO
 141         case scm_tc7_cclo:
 142           scm_gc_free (SCM_CCLO_BASE (scmptr),
 143                        SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
 144                        "compiled closure");
 145           break;
 146 #endif
 147 #if SCM_HAVE_ARRAYS
 148         case scm_tc7_bvect:
 149           {
 150             unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
 151             if (length > 0)
 152               {
 153                 scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
 154                              (sizeof (long)
 155                               * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
 156                              "vector");
 157               }
 158           }
 159           break;
 160         case scm_tc7_byvect:
 161         case scm_tc7_ivect:
 162         case scm_tc7_uvect:
 163         case scm_tc7_svect:
 164 #if SCM_SIZEOF_LONG_LONG != 0
 165         case scm_tc7_llvect:
 166 #endif
 167         case scm_tc7_fvect:
 168         case scm_tc7_dvect:
 169         case scm_tc7_cvect:
 170           scm_gc_free (SCM_UVECTOR_BASE (scmptr),
 171                        (SCM_UVECTOR_LENGTH (scmptr)
 172                         * scm_uniform_element_size (scmptr)),
 173                        "vector");
 174           break;
 175 #endif
 176         case scm_tc7_number:
 177           switch SCM_TYP16 (scmptr)
 178             {
 179             case scm_tc16_real:
 180               break;
 181             case scm_tc16_big:
 182               mpz_clear (SCM_I_BIG_MPZ (scmptr));
 183               /* nothing else to do here since the mpz is in a double cell */
 184               break;
 185             case scm_tc16_complex:
 186               scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
 187                            "complex");
 188               break;
 189             case scm_tc16_fraction:
 190               /* nothing to do here since the num/denum of a fraction
 191                  are proper SCM objects themselves. */
 192               break;
 193             }
 194           break;
 195         case scm_tc7_string:
 196           scm_gc_free (SCM_STRING_CHARS (scmptr),
 197                        SCM_STRING_LENGTH (scmptr) + 1, "string");
 198           break;
 199         case scm_tc7_symbol:
 200           scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
 201                        SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
 202           break;
 203         case scm_tc7_variable:
 204           break;
 205         case scm_tcs_subrs:
 206           /* the various "subrs" (primitives) are never freed */
 207           continue;
 208         case scm_tc7_port:
 209           if SCM_OPENP (scmptr)
 210             {
 211               int k = SCM_PTOBNUM (scmptr);
 212               size_t mm;
 213 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 214               if (!(k < scm_numptob))
 215                 {
 216                   fprintf (stderr, "undefined port type");
 217                   abort();
 218                 }
 219 #endif
 220               /* Keep "revealed" ports alive.  */
 221               if (scm_revealed_count (scmptr) > 0)
 222                 continue;
 223
 224               /* Yes, I really do mean scm_ptobs[k].free */
 225               /* rather than ftobs[k].close.  .close */
 226               /* is for explicit CLOSE-PORT by user */
 227               mm = scm_ptobs[k].free (scmptr);
 228
 229               if (mm != 0)
 230                 {
 231 #if SCM_ENABLE_DEPRECATED == 1
 232                   scm_c_issue_deprecation_warning
 233                     ("Returning non-0 from a port free function is "
 234                      "deprecated.  Use scm_gc_free et al instead.");
 235                   scm_c_issue_deprecation_warning_fmt
 236                     ("(You just returned non-0 while freeing a %s.)",
 237                      SCM_PTOBNAME (k));
 238                   scm_i_deprecated_memory_return += mm;
 239 #else
 240                   abort ();
 241 #endif
 242                 }
 243
 244               SCM_SETSTREAM (scmptr, 0);
 245               scm_remove_from_port_table (scmptr);
 246               scm_gc_ports_collected++;
 247               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 248             }
 249           break;
 250         case scm_tc7_smob:
 251           switch SCM_TYP16 (scmptr)
 252             {
 253             case scm_tc_free_cell:
 254               break;
 255             default:
 256               {
 257                 int k;
 258                 k = SCM_SMOBNUM (scmptr);
 259 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 260                 if (!(k < scm_numsmob))
 261                   {
 262                     fprintf (stderr, "undefined smob type");
 263                     abort();
 264                   }
 265 #endif
 266                 if (scm_smobs[k].free)
 267                   {
 268                     size_t mm;
 269                     mm = scm_smobs[k].free (scmptr);
 270                     if (mm != 0)
 271                       {
 272 #if SCM_ENABLE_DEPRECATED == 1
 273                         scm_c_issue_deprecation_warning
 274                           ("Returning non-0 from a smob free function is "
 275                            "deprecated.  Use scm_gc_free et al instead.");
 276                         scm_c_issue_deprecation_warning_fmt
 277                           ("(You just returned non-0 while freeing a %s.)",
 278                            SCM_SMOBNAME (k));
 279                         scm_i_deprecated_memory_return += mm;
 280 #else
 281                         abort();
 282 #endif
 283                       }
 284                   }
 285                 break;
 286               }
 287             }
 288           break;
 289         default:
 290           fprintf (stderr, "unknown type");
 291           abort();
 292         }
 293
 294
 295       SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
 296       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 297       *free_list = scmptr;
 298       free_count ++;
 299     }
 300
 301   --scm_gc_running_p;
 302   return free_count;
 303 }
 304 #undef FUNC_NAME
 305
 306
 307 /*
 308   Like sweep, but no complicated logic to do the sweeping.
 309  */
 310 int
 311 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 312                         scm_t_heap_segment*seg)
 313 {
 314   int span = seg->span;
 315   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 316   scm_t_cell *p = end - span;
 317
 318   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 319   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 320
 321   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 322   SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
 323
 324   /*
 325      ASSUMPTION: n_header_cells <= 2.
 326    */
 327   for (; p > card;  p -= span)
 328     {
 329       const SCM scmptr = PTR2SCM (p);
 330       SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
 331       SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
 332       *free_list = scmptr;
 333     }
 334
 335   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 336 }
 337
 338
 339 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
 340
 341 typedef struct scm_dbg_t_list_cell {
 342   scm_t_bits car;
 343   struct scm_dbg_t_list_cell * cdr;
 344 } scm_dbg_t_list_cell;
 345
 346
 347 typedef struct scm_dbg_t_double_cell {
 348   scm_t_bits word_0;
 349   scm_t_bits word_1;
 350   scm_t_bits word_2;
 351   scm_t_bits word_3;
 352 } scm_dbg_t_double_cell;
 353
 354
 355 int scm_dbg_gc_marked_p (SCM obj);
 356 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
 357 long * scm_dbg_gc_get_bvec (SCM obj);
 358
 359
 360 int
 361 scm_dbg_gc_marked_p (SCM obj)
 362 {
 363   if (!SCM_IMP (obj))
 364     return SCM_GC_MARK_P(obj);
 365   else
 366     return 0;
 367 }
 368
 369 scm_t_cell *
 370 scm_dbg_gc_get_card (SCM obj)
 371 {
 372   if (!SCM_IMP (obj))
 373     return SCM_GC_CELL_CARD(obj);
 374   else
 375     return NULL;
 376 }
 377
 378 long *
 379 scm_dbg_gc_get_bvec (SCM obj)
 380 {
 381   if (!SCM_IMP (obj))
 382     return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
 383   else
 384     return NULL;
 385 }
 386
 387 #endif