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