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 int
  88 scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
  89 #define FUNC_NAME "sweep_card"
  90 {
  91   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  92   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  93   int span = seg->span;
  94   int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
  95   int free_count  = 0;
  96
  97   ++ scm_gc_running_p;
  98
  99   /*
 100     I tried something fancy with shifting by one bit every word from
 101     the bitvec in turn, but it wasn't any faster, but quite bit
 102     hairier.
 103    */
 104   for (p += offset; p < end; p += span, offset += span)
 105     {
 106       SCM scmptr = PTR2SCM(p);
 107       if (SCM_C_BVEC_GET (bitvec, offset))
 108         continue;
 109
 110       switch (SCM_TYP7 (scmptr))
 111         {
 112         case scm_tcs_struct:
 113           {
 114             /* Structs need to be freed in a special order.
 115              * This is handled by GC C hooks in struct.c.
 116              */
 117             SCM_SET_STRUCT_GC_CHAIN (p, scm_i_structs_to_free);
 118             scm_i_structs_to_free = scmptr;
 119           }
 120           continue;
 121
 122         case scm_tcs_cons_imcar:
 123         case scm_tcs_cons_nimcar:
 124         case scm_tcs_closures:
 125         case scm_tc7_pws:
 126           break;
 127         case scm_tc7_wvect:
 128         case scm_tc7_vector:
 129           {
 130             unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
 131             if (length > 0)
 132               {
 133                 scm_gc_free (SCM_VECTOR_BASE (scmptr),
 134                              length * sizeof (scm_t_bits),
 135                              "vector");
 136               }
 137             break;
 138           }
 139 #ifdef CCLO
 140         case scm_tc7_cclo:
 141           scm_gc_free (SCM_CCLO_BASE (scmptr),
 142                        SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
 143                        "compiled closure");
 144           break;
 145 #endif
 146 #ifdef HAVE_ARRAYS
 147         case scm_tc7_bvect:
 148           {
 149             unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
 150             if (length > 0)
 151               {
 152                 scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
 153                              (sizeof (long)
 154                               * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
 155                              "vector");
 156               }
 157           }
 158           break;
 159         case scm_tc7_byvect:
 160         case scm_tc7_ivect:
 161         case scm_tc7_uvect:
 162         case scm_tc7_svect:
 163 #ifdef HAVE_LONG_LONGS
 164         case scm_tc7_llvect:
 165 #endif
 166         case scm_tc7_fvect:
 167         case scm_tc7_dvect:
 168         case scm_tc7_cvect:
 169           scm_gc_free (SCM_UVECTOR_BASE (scmptr),
 170                        (SCM_UVECTOR_LENGTH (scmptr)
 171                         * scm_uniform_element_size (scmptr)),
 172                        "vector");
 173           break;
 174 #endif
 175         case scm_tc7_string:
 176           scm_gc_free (SCM_STRING_CHARS (scmptr),
 177                        SCM_STRING_LENGTH (scmptr) + 1, "string");
 178           break;
 179         case scm_tc7_symbol:
 180           scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
 181                        SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
 182           break;
 183         case scm_tc7_variable:
 184           break;
 185         case scm_tcs_subrs:
 186           /* the various "subrs" (primitives) are never freed */
 187           continue;
 188         case scm_tc7_port:
 189           if SCM_OPENP (scmptr)
 190             {
 191               int k = SCM_PTOBNUM (scmptr);
 192               size_t mm;
 193 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 194               if (!(k < scm_numptob))
 195                 {
 196                   fprintf (stderr, "undefined port type");
 197                   abort();
 198                 }
 199 #endif
 200               /* Keep "revealed" ports alive.  */
 201               if (scm_revealed_count (scmptr) > 0)
 202                 continue;
 203
 204               /* Yes, I really do mean scm_ptobs[k].free */
 205               /* rather than ftobs[k].close.  .close */
 206               /* is for explicit CLOSE-PORT by user */
 207               mm = scm_ptobs[k].free (scmptr);
 208
 209               if (mm != 0)
 210                 {
 211 #if SCM_ENABLE_DEPRECATED == 1
 212                   scm_c_issue_deprecation_warning
 213                     ("Returning non-0 from a port free function is "
 214                      "deprecated.  Use scm_gc_free et al instead.");
 215                   scm_c_issue_deprecation_warning_fmt
 216                     ("(You just returned non-0 while freeing a %s.)",
 217                      SCM_PTOBNAME (k));
 218                   scm_i_deprecated_memory_return += mm;
 219 #else
 220                   abort ();
 221 #endif
 222                 }
 223
 224               SCM_SETSTREAM (scmptr, 0);
 225               scm_remove_from_port_table (scmptr);
 226               scm_gc_ports_collected++;
 227               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 228             }
 229           break;
 230         case scm_tc7_smob:
 231           switch SCM_TYP16 (scmptr)
 232             {
 233             case scm_tc_free_cell:
 234             case scm_tc16_real:
 235               break;
 236 #ifdef SCM_BIGDIG
 237             case scm_tc16_big:
 238               scm_gc_free (SCM_BDIGITS (scmptr),
 239                            ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
 240                              / SCM_CHAR_BIT)), "bignum");
 241               break;
 242 #endif /* def SCM_BIGDIG */
 243             case scm_tc16_complex:
 244               scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
 245                            "complex");
 246               break;
 247             default:
 248               {
 249                 int k;
 250                 k = SCM_SMOBNUM (scmptr);
 251 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 252                 if (!(k < scm_numsmob))
 253                   {
 254                     fprintf (stderr, "undefined smob type");
 255                     abort();
 256                   }
 257 #endif
 258                 if (scm_smobs[k].free)
 259                   {
 260                     size_t mm;
 261                     mm = scm_smobs[k].free (scmptr);
 262                     if (mm != 0)
 263                       {
 264 #if SCM_ENABLE_DEPRECATED == 1
 265                         scm_c_issue_deprecation_warning
 266                           ("Returning non-0 from a smob free function is "
 267                            "deprecated.  Use scm_gc_free et al instead.");
 268                         scm_c_issue_deprecation_warning_fmt
 269                           ("(You just returned non-0 while freeing a %s.)",
 270                            SCM_SMOBNAME (k));
 271                         scm_i_deprecated_memory_return += mm;
 272 #else
 273                         abort();
 274 #endif
 275                       }
 276                   }
 277                 break;
 278               }
 279             }
 280           break;
 281         default:
 282           fprintf (stderr, "unknown type");
 283           abort();
 284         }
 285
 286
 287       SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
 288       SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
 289       *free_list = PTR2SCM (p);
 290       free_count ++;
 291     }
 292
 293   --scm_gc_running_p;
 294   return free_count;
 295 }
 296 #undef FUNC_NAME
 297
 298
 299 /*
 300   Like sweep, but no complicated logic to do the sweeping.
 301  */
 302 int
 303 scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
 304                         scm_t_heap_segment*seg)
 305 {
 306   int span = seg->span;
 307   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 308   scm_t_cell *p = end - span;
 309
 310   scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
 311   int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 312
 313   bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
 314   SCM_GC_CELL_BVEC (card) = bvec_ptr;
 315
 316   /*
 317      ASSUMPTION: n_header_cells <= 2.
 318    */
 319   for (; p > card;  p -= span)
 320     {
 321       SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
 322       SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
 323       *free_list = PTR2SCM (p);
 324     }
 325
 326   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 327 }
 328
 329
 330 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 331 int
 332 scm_gc_marked_p (SCM obj)
 333 {
 334   return SCM_GC_MARK_P(obj);
 335 }
 336 #endif
 337
 338 #if 0
 339 /*
 340   These functions are meant to be called from GDB as a debug aid.
 341
 342   I've left them as a convenience for future generations. --hwn.
 343  */
 344
 345
 346 int scm_gc_marked_p (SCM obj);
 347 scm_t_cell * scm_gc_get_card (SCM obj);
 348 long * scm_gc_get_bvec (SCM obj);
 349
 350 typedef struct scm_t_list_cell_struct {
 351   scm_t_bits car;
 352   struct scm_t_list_cell_struct * cdr;
 353 } scm_t_list_cell;
 354
 355
 356 typedef struct scm_t_double_cell
 357 {
 358   scm_t_bits word_0;
 359   scm_t_bits word_1;
 360   scm_t_bits word_2;
 361   scm_t_bits word_3;
 362 } scm_t_double_cell;
 363
 364
 365
 366 scm_t_cell *
 367 scm_gc_get_card (SCM obj)
 368 {
 369   return SCM_GC_CELL_CARD(obj);
 370 }
 371
 372 long *
 373 scm_gc_get_bvec (SCM obj)
 374 {
 375   return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj));
 376 }
 377 #endif