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 "libguile/_scm.h"
  44 #include "libguile/eval.h"
  45 #include "libguile/stime.h"
  46 #include "libguile/stackchk.h"
  47 #include "libguile/struct.h"
  48 #include "libguile/smob.h"
  49 #include "libguile/unif.h"
  50 #include "libguile/async.h"
  51 #include "libguile/ports.h"
  52 #include "libguile/root.h"
  53 #include "libguile/strings.h"
  54 #include "libguile/vectors.h"
  55 #include "libguile/weaks.h"
  56 #include "libguile/hashtab.h"
  57 #include "libguile/tags.h"
  58 #include "libguile/private-gc.h"
  59 #include "libguile/validate.h"
  60 #include "libguile/deprecation.h"
  61 #include "libguile/gc.h"
  62
  63
  64 #include "libguile/private-gc.h"
  65
  66 long int scm_i_deprecated_memory_return;
  67
  68
  69 /*
  70   Init all the free cells in CARD, prepending to *FREE_LIST.
  71
  72   Return: number of free cells found in this card.
  73
  74   It would be cleaner to have a separate function sweep_value(), but
  75   that is too slow (functions with switch statements can't be
  76   inlined).
  77
  78  */
  79
  80 int
  81 scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, int span)
  82 #define FUNC_NAME "sweep_card"
  83 {
  84   scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  85   scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  86   int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
  87   int free_count  = 0;
  88
  89   ++ scm_gc_running_p;
  90
  91   /*
  92     I tried something fancy with shifting by one bit every word from
  93     the bitvec in turn, but it wasn't any faster, but quite bit
  94     hairier.
  95    */
  96   for (p += offset; p < end; p += span, offset += span)
  97     {
  98       SCM scmptr = PTR2SCM(p);
  99       if (SCM_C_BVEC_GET (bitvec, offset))
 100         continue;
 101
 102       switch (SCM_TYP7 (scmptr))
 103         {
 104         case scm_tcs_struct:
 105           {
 106             /* Structs need to be freed in a special order.
 107              * This is handled by GC C hooks in struct.c.
 108              */
 109             SCM_SET_STRUCT_GC_CHAIN (p, scm_structs_to_free);
 110             scm_structs_to_free = scmptr;
 111           }
 112           continue;
 113
 114         case scm_tcs_cons_imcar:
 115         case scm_tcs_cons_nimcar:
 116         case scm_tcs_closures:
 117         case scm_tc7_pws:
 118           break;
 119         case scm_tc7_wvect:
 120         case scm_tc7_vector:
 121           {
 122             unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
 123             if (length > 0)
 124               {
 125                 scm_gc_free (SCM_VECTOR_BASE (scmptr),
 126                              length * sizeof (scm_t_bits),
 127                              "vector");
 128               }
 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 #ifdef HAVE_ARRAYS
 139         case scm_tc7_bvect:
 140           {
 141             unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
 142             if (length > 0)
 143               {
 144                 scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
 145                              (sizeof (long)
 146                               * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
 147                              "vector");
 148               }
 149           }
 150           break;
 151         case scm_tc7_byvect:
 152         case scm_tc7_ivect:
 153         case scm_tc7_uvect:
 154         case scm_tc7_svect:
 155 #ifdef HAVE_LONG_LONGS
 156         case scm_tc7_llvect:
 157 #endif
 158         case scm_tc7_fvect:
 159         case scm_tc7_dvect:
 160         case scm_tc7_cvect:
 161           scm_gc_free (SCM_UVECTOR_BASE (scmptr),
 162                        (SCM_UVECTOR_LENGTH (scmptr)
 163                         * scm_uniform_element_size (scmptr)),
 164                        "vector");
 165           break;
 166 #endif
 167         case scm_tc7_string:
 168           scm_gc_free (SCM_STRING_CHARS (scmptr),
 169                        SCM_STRING_LENGTH (scmptr) + 1, "string");
 170           break;
 171         case scm_tc7_symbol:
 172           scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
 173                        SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
 174           break;
 175         case scm_tc7_variable:
 176           break;
 177         case scm_tcs_subrs:
 178           /* the various "subrs" (primitives) are never freed */
 179           continue;
 180         case scm_tc7_port:
 181           if SCM_OPENP (scmptr)
 182             {
 183               int k = SCM_PTOBNUM (scmptr);
 184               size_t mm;
 185 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 186               if (!(k < scm_numptob))
 187                 SCM_MISC_ERROR ("undefined port type", SCM_EOL);
 188 #endif
 189               /* Keep "revealed" ports alive.  */
 190               if (scm_revealed_count (scmptr) > 0)
 191                 continue;
 192
 193               /* Yes, I really do mean scm_ptobs[k].free */
 194               /* rather than ftobs[k].close.  .close */
 195               /* is for explicit CLOSE-PORT by user */
 196               mm = scm_ptobs[k].free (scmptr);
 197
 198               if (mm != 0)
 199                 {
 200 #if SCM_ENABLE_DEPRECATED == 1
 201                   scm_c_issue_deprecation_warning
 202                     ("Returning non-0 from a port free function is "
 203                      "deprecated.  Use scm_gc_free et al instead.");
 204                   scm_c_issue_deprecation_warning_fmt
 205                     ("(You just returned non-0 while freeing a %s.)",
 206                      SCM_PTOBNAME (k));
 207                   scm_i_deprecated_memory_return += mm;
 208 #else
 209                   abort ();
 210 #endif
 211                 }
 212
 213               SCM_SETSTREAM (scmptr, 0);
 214               scm_remove_from_port_table (scmptr);
 215               scm_gc_ports_collected++;
 216               SCM_CLR_PORT_OPEN_FLAG (scmptr);
 217             }
 218           break;
 219         case scm_tc7_smob:
 220           switch SCM_TYP16 (scmptr)
 221             {
 222             case scm_tc_free_cell:
 223             case scm_tc16_real:
 224               break;
 225 #ifdef SCM_BIGDIG
 226             case scm_tc16_big:
 227               scm_gc_free (SCM_BDIGITS (scmptr),
 228                            ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
 229                              / SCM_CHAR_BIT)), "bignum");
 230               break;
 231 #endif /* def SCM_BIGDIG */
 232             case scm_tc16_complex:
 233               scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
 234                            "complex");
 235               break;
 236             default:
 237               {
 238                 int k;
 239                 k = SCM_SMOBNUM (scmptr);
 240 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 241                 if (!(k < scm_numsmob))
 242                   SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
 243 #endif
 244                 if (scm_smobs[k].free)
 245                   {
 246                     size_t mm;
 247                     mm = scm_smobs[k].free (scmptr);
 248                     if (mm != 0)
 249                       {
 250 #if SCM_ENABLE_DEPRECATED == 1
 251                         scm_c_issue_deprecation_warning
 252                           ("Returning non-0 from a smob free function is "
 253                            "deprecated.  Use scm_gc_free et al instead.");
 254                         scm_c_issue_deprecation_warning_fmt
 255                           ("(You just returned non-0 while freeing a %s.)",
 256                            SCM_SMOBNAME (k));
 257                         scm_i_deprecated_memory_return += mm;
 258 #else
 259                         abort();
 260 #endif
 261                       }
 262                   }
 263                 break;
 264               }
 265             }
 266           break;
 267         default:
 268           SCM_MISC_ERROR ("unknown type", SCM_EOL);
 269         }
 270
 271
 272       SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
 273       SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
 274       *free_list = PTR2SCM (p);
 275       free_count ++;
 276     }
 277
 278   --scm_gc_running_p;
 279   return free_count;
 280 }
 281 #undef FUNC_NAME
 282
 283
 284 /*
 285   Like sweep, but no complicated logic to do the sweeping.
 286  */
 287 int
 288 scm_init_card_freelist (scm_t_cell *  card, SCM *free_list, int span)
 289 {
 290   scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
 291   scm_t_cell *p = end - span;
 292
 293   /*
 294      ASSUMPTION: n_header_cells <= 2.
 295    */
 296   for (; p > card;  p -= span)
 297     {
 298       SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
 299       SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
 300       *free_list = PTR2SCM (p);
 301     }
 302
 303   return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
 304 }
 305
 306
 307
 308 #if 0
 309 /*
 310   These functions are meant to be called from GDB as a debug aid.
 311
 312   I've left them as a convenience for future generations.
 313  */
 314
 315
 316 int scm_gc_marked_p (SCM obj);
 317 scm_t_cell * scm_gc_get_card (SCM obj);
 318 long * scm_gc_get_bvec (SCM obj);
 319
 320 typedef struct scm_t_list_cell_struct {
 321   scm_t_bits car;
 322   struct scm_t_list_cell_struct * cdr;
 323 } scm_t_list_cell;
 324
 325
 326 typedef struct scm_t_double_cell
 327 {
 328   scm_t_bits word_0;
 329   scm_t_bits word_1;
 330   scm_t_bits word_2;
 331   scm_t_bits word_3;
 332 } scm_t_double_cell;
 333
 334
 335 int
 336 scm_gc_marked_p (SCM obj)
 337 {
 338   return SCM_GC_MARK_P(obj);
 339 }
 340
 341 scm_t_cell *
 342 scm_gc_get_card (SCM obj)
 343 {
 344   return SCM_GC_CELL_CARD(obj);
 345 }
 346
 347 long *
 348 scm_gc_get_bvec (SCM obj)
 349 {
 350   return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj));
 351 }
 352 #endif