libguile/gc-card.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 #include <stdio.h>
  44
  45 #include "libguile/_scm.h"
  46 #include "libguile/eval.h"
  47 #include "libguile/stime.h"
  48 #include "libguile/stackchk.h"
  49 #include "libguile/struct.h"
  50 #include "libguile/smob.h"
  51 #include "libguile/unif.h"
  52 #include "libguile/async.h"
  53 #include "libguile/ports.h"
  54 #include "libguile/root.h"
  55 #include "libguile/strings.h"
  56 #include "libguile/vectors.h"
  57 #include "libguile/weaks.h"
  58 #include "libguile/hashtab.h"
  59 #include "libguile/tags.h"
  60 #include "libguile/private-gc.h"
  61 #include "libguile/validate.h"
  62 #include "libguile/deprecation.h"
  63 #include "libguile/gc.h"
  64
  65
  66 #include "libguile/private-gc.h"
  67
  68 long int scm_i_deprecated_memory_return;
  69
  70
  71 /* During collection, this accumulates structures which are to be freed.
  72  */
  73 SCM scm_i_structs_to_free;
  74
  75
  76 /*
  77   Init all the free cells in CARD, prepending to *FREE_LIST.
  78
  79   Return: number of free cells found in this card.
  80
  81   It would be cleaner to have a separate function sweep_value(), but
  82   that is too slow (functions with switch statements can't be
  83   inlined).
  84
  85
  86
  87
  88   NOTE:
  89
  90   This function is quite efficient. However, for many types of cells,
  91   allocation and a de-allocation involves calling malloc() and
  92   free().
  93
  94   This is costly for small objects (due to malloc/free overhead.)
  95   (should measure this).
  96
  97   It might also be bad for threads: if several threads are allocating
  98   strings concurrently, then mallocs for both threads may have to
  99   fiddle with locks.
 100
 101   It might be interesting to add a separate memory pool for small
 102   objects to each freelist.
 103
 104   --hwn.
 105  */
 106 int
 107 scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
 108 #define FUNC_NAME "sweep_card"
 109 {
 110   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
 111   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
 112   int span = seg->span;
 113   int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
 114   int free_count  = 0;
 115
 116   ++ scm_gc_running_p;
 117
 118   /*
 119     I tried something fancy with shifting by one bit every word from
 120     the bitvec in turn, but it wasn't any faster, but quite bit
 121     hairier.
 122    */
 123   for (p += offset; p < end; p += span, offset += span)
 124     {
 125       SCM scmptr = PTR2SCM(p);
 126       if (SCM_C_BVEC_GET (bitvec, offset))
 127         continue;
 128
 129       switch (SCM_TYP7 (scmptr))
 130         {
 131         case scm_tcs_struct:
 132           /* The card can be swept more than once.  Check that it's
 133            * the first time!
 134            */
 135           if (!SCM_STRUCT_GC_CHAIN (p))
 136             {
 137               /* Structs need to be freed in a special order.
 138                * This is handled by GC C hooks in struct.c.
 139                */
 140               SCM_SET_STRUCT_GC_CHAIN (p, scm_i_structs_to_free);
 141               scm_i_structs_to_free = scmptr;
 142             }
 143           continue;
 144
 145         case scm_tcs_cons_imcar:
 146         case scm_tcs_cons_nimcar:
 147         case scm_tcs_closures:
 148         case scm_tc7_pws:
 149           break;
 150         case scm_tc7_wvect:
 151         case scm_tc7_vector:
 152           {
 153             unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
 154             if (length > 0)
 155               {
 156                 scm_gc_free (SCM_VECTOR_BASE (scmptr),
 157                              length * sizeof (scm_t_bits),
 158                              "vector");
 159               }
 160             break;
 161           }
 162 #ifdef CCLO
 163         case scm_tc7_cclo:
 164           scm_gc_free (SCM_CCLO_BASE (scmptr),
 165                        SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
 166                        "compiled closure");
 167           break;
 168 #endif
 169 #if SCM_HAVE_ARRAYS
 170         case scm_tc7_bvect:
 171           {
 172             unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
 173             if (length > 0)
 174               {
 175                 scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
 176                              (sizeof (long)
 177                               * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
 178                              "vector");
 179               }
 180           }
 181           break;
 182         case scm_tc7_byvect:
 183         case scm_tc7_ivect:
 184         case scm_tc7_uvect:
 185         case scm_tc7_svect:
 186 #if SCM_SIZEOF_LONG_LONG != 0
 187         case scm_tc7_llvect:
 188 #endif
 189         case scm_tc7_fvect:
 190         case scm_tc7_dvect:
 191         case scm_tc7_cvect:
 192           scm_gc_free (SCM_UVECTOR_BASE (scmptr),
 193                        (SCM_UVECTOR_LENGTH (scmptr)
 194                         * scm_uniform_element_size (scmptr)),
 195                        "vector");
 196           break;
 197 #endif
 198         case scm_tc7_string:
 199           scm_gc_free (SCM_STRING_CHARS (scmptr),
 200                        SCM_STRING_LENGTH (scmptr) + 1, "string");
 201           break;
 202         case scm_tc7_symbol:
 203           scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
 204                        SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
 205           break;
 206         case scm_tc7_variable:
 207           break;
 208         case scm_tcs_subrs:
 209           /* the various "subrs" (primitives) are never freed */
 210           continue;
 211         case scm_tc7_port:
 212           if SCM_OPENP (scmptr)
 213             {
 214               int k = SCM_PTOBNUM (scmptr);
 215               size_t mm;
 216 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 217               if (!(k < scm_numptob))
 218                 {
 219                   fprintf (stderr, "undefined port type");
 220                   abort();
 221                 }
 222 #endif
 223               /* Keep "revealed" ports alive.  */
 224               if (scm_revealed_count (scmptr) > 0)
 225                 continue;
 226
 227               /* Yes, I really do mean scm_ptobs[k].free */
 228               /* rather than ftobs[k].close.  .close */
 229               /* is for explicit CLOSE-PORT by user */
 230               mm = scm_ptobs[k].free (scmptr);
 231
 232               if (mm != 0)
 233                 {
 234 #if SCM_ENABLE_DEPRECATED == 1
 235                   scm_c_issue_deprecation_warning
 236                     ("Returning non-0 from a port free function is "
 237                      "deprecated.  Use scm_gc_free et al instead.");
 238                   scm_c_issue_deprecation_warning_fmt
 239                     ("(You just returned non-0 while freeing a %s.)",
 240                      SCM_PTOBNAME (k));
 241                   scm_i_deprecated_memory_return += mm;
 242 #else
 243                   abort ();
 244 #endif
 245                 }
 246
 247               SCM_SETSTREAM (scmptr, 0);
 248               scm_remove_from_port_table (scmptr);
 249               scm_gc_ports_collected++;
 250               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 251             }
 252           break;
 253         case scm_tc7_smob:
 254           switch SCM_TYP16 (scmptr)
 255             {
 256             case scm_tc_free_cell:
 257             case scm_tc16_real:
 258               break;
 259 #ifdef SCM_BIGDIG
 260             case scm_tc16_big:
 261               scm_gc_free (SCM_BDIGITS (scmptr),
 262                            ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
 263                              / SCM_CHAR_BIT)), "bignum");
 264               break;
 265 #endif /* def SCM_BIGDIG */
 266             case scm_tc16_complex:
 267               scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
 268                            "complex");
 269               break;
 270             default:
 271               {
 272                 int k;
 273                 k = SCM_SMOBNUM (scmptr);
 274 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 275                 if (!(k < scm_numsmob))
 276                   {
 277                     fprintf (stderr, "undefined smob type");
 278                     abort();
 279                   }
 280 #endif
 281                 if (scm_smobs[k].free)
 282                   {
 283                     size_t mm;
 284                     mm = scm_smobs[k].free (scmptr);
 285                     if (mm != 0)
 286                       {
 287 #if SCM_ENABLE_DEPRECATED == 1
 288                         scm_c_issue_deprecation_warning
 289                           ("Returning non-0 from a smob free function is "
 290                            "deprecated.  Use scm_gc_free et al instead.");
 291                         scm_c_issue_deprecation_warning_fmt
 292                           ("(You just returned non-0 while freeing a %s.)",
 293                            SCM_SMOBNAME (k));
 294                         scm_i_deprecated_memory_return += mm;
 295 #else
 296                         abort();
 297 #endif
 298                       }
 299                   }
 300                 break;
 301               }
 302             }
 303           break;
 304         default:
 305           fprintf (stderr, "unknown type");
 306           abort();
 307         }
 308
 309
 310       SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
 311       SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
 312       *free_list = PTR2SCM (p);
 313       free_count ++;
 314     }
 315
 316   --scm_gc_running_p;
 317   return free_count;
 318 }
 319 #undef FUNC_NAME
 320
 321
 322 /*
 323   Like sweep, but no complicated logic to do the sweeping.
 324  */
 325 int
 326 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 327                         scm_t_heap_segment*seg)
 328 {
 329   int span = seg->span;
 330   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 331   scm_t_cell *p = end - span;
 332
 333   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 334   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 335
 336   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 337   SCM_GC_CELL_BVEC (card) = bvec_ptr;
 338
 339   /*
 340      ASSUMPTION: n_header_cells <= 2.
 341    */
 342   for (; p > card;  p -= span)
 343     {
 344       SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
 345       SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
 346       *free_list = PTR2SCM (p);
 347     }
 348
 349   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 350 }
 351
 352
 353 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 354 int
 355 scm_gc_marked_p (SCM obj)
 356 {
 357   return SCM_GC_MARK_P(obj);
 358 }
 359 #endif
 360
 361 #if 0
 362 /*
 363   These functions are meant to be called from GDB as a debug aid.
 364
 365   I've left them as a convenience for future generations. --hwn.
 366  */
 367
 368
 369 int scm_gc_marked_p (SCM obj);
 370 scm_t_cell * scm_gc_get_card (SCM obj);
 371 long * scm_gc_get_bvec (SCM obj);
 372
 373 typedef struct scm_t_list_cell_struct {
 374   scm_t_bits car;
 375   struct scm_t_list_cell_struct * cdr;
 376 } scm_t_list_cell;
 377
 378
 379 typedef struct scm_t_double_cell
 380 {
 381   scm_t_bits word_0;
 382   scm_t_bits word_1;
 383   scm_t_bits word_2;
 384   scm_t_bits word_3;
 385 } scm_t_double_cell;
 386
 387
 388
 389 scm_t_cell *
 390 scm_gc_get_card (SCM obj)
 391 {
 392   return SCM_GC_CELL_CARD(obj);
 393 }
 394
 395 long *
 396 scm_gc_get_bvec (SCM obj)
 397 {
 398   return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj));
 399 }
 400 #endif