HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* vectors.c, vectors.h (scm_make_vector): Removed third argument.
[bpt/guile.git] / libguile / gc.c
CommitLineData
b7f3516f 1/* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
0f2d19dd
JB		 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
82892bed
JB		 15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB		 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.
82892bed 40 * If you do not wish that, delete this exception notice. */
0f2d19dd
JB		 41\f
42#include <stdio.h>
43#include "_scm.h"
20e6290e
JB		 44#include "stime.h"
45#include "stackchk.h"
46#include "struct.h"
47#include "genio.h"
48#include "weaks.h"
49#include "smob.h"
50#include "unif.h"
51#include "async.h"
0f2d19dd 52
fce59c93
JB		 53#include "gc.h"
54
0f2d19dd 55#ifdef HAVE_MALLOC_H
95b88819 56#include <malloc.h>
0f2d19dd
JB		 57#endif
58
59#ifdef HAVE_UNISTD_H
95b88819 60#include <unistd.h>
0f2d19dd
JB		 61#endif
62
1cc91f1b
JB		 63#ifdef __STDC__
64#include <stdarg.h>
65#define var_start(x, y) va_start(x, y)
66#else
67#include <varargs.h>
68#define var_start(x, y) va_start(x)
69#endif
70
0f2d19dd
JB		 71\f
72/* {heap tuning parameters}
73 *
74 * These are parameters for controlling memory allocation. The heap
75 * is the area out of which scm_cons, and object headers are allocated.
76 *
77 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
78 * 64 bit machine. The units of the _SIZE parameters are bytes.
79 * Cons pairs and object headers occupy one heap cell.
80 *
81 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
82 * allocated initially the heap will grow by half its current size
83 * each subsequent time more heap is needed.
84 *
85 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
86 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
87 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
88 * is in scm_init_storage() and alloc_some_heap() in sys.c
89 *
90 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
91 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
92 *
93 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
94 * is needed.
95 *
96 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
97 * trigger a GC.
6064dcc6
MV		 98 *
99 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
100 * reclaimed by a GC triggered by must_malloc. If less than this is
101 * reclaimed, the trigger threshold is raised. [I don't know what a
102 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
103 * work around a oscillation that caused almost constant GC.]
0f2d19dd
JB		 104 */
105
106#define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
107#define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
108#ifdef _QC
109# define SCM_HEAP_SEG_SIZE 32768L
110#else
111# ifdef sequent
112# define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell))
113# else
114# define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
115# endif
116#endif
117#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
118#define SCM_INIT_MALLOC_LIMIT 100000
6064dcc6 119#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
0f2d19dd
JB		 120
121/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
122 bounds for allocated storage */
123
124#ifdef PROT386
125/*in 386 protected mode we must only adjust the offset */
126# define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
127# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
128#else
129# ifdef _UNICOS
130# define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
131# define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
132# else
133# define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
134# define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
135# endif /* UNICOS */
136#endif /* PROT386 */
137
138
139\f
140/* scm_freelist
141 * is the head of freelist of cons pairs.
142 */
143SCM scm_freelist = SCM_EOL;
144
145/* scm_mtrigger
146 * is the number of bytes of must_malloc allocation needed to trigger gc.
147 */
148long scm_mtrigger;
149
150
151/* scm_gc_heap_lock
152 * If set, don't expand the heap. Set only during gc, during which no allocation
153 * is supposed to take place anyway.
154 */
155int scm_gc_heap_lock = 0;
156
157/* GC Blocking
158 * Don't pause for collection if this is set -- just
159 * expand the heap.
160 */
161
162int scm_block_gc = 1;
163
164/* If fewer than MIN_GC_YIELD cells are recovered during a garbage
165 * collection (GC) more space is allocated for the heap.
166 */
167#define MIN_GC_YIELD (scm_heap_size/4)
168
169/* During collection, this accumulates objects holding
170 * weak references.
171 */
172SCM *scm_weak_vectors;
173int scm_weak_size;
174int scm_n_weak;
175
176/* GC Statistics Keeping
177 */
178unsigned long scm_cells_allocated = 0;
179unsigned long scm_mallocated = 0;
180unsigned long scm_gc_cells_collected;
181unsigned long scm_gc_malloc_collected;
182unsigned long scm_gc_ports_collected;
183unsigned long scm_gc_rt;
184unsigned long scm_gc_time_taken = 0;
185
186SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
187SCM_SYMBOL (sym_heap_size, "cell-heap-size");
188SCM_SYMBOL (sym_mallocated, "bytes-malloced");
189SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
190SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
191SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
192
193
194struct scm_heap_seg_data
195{
cf2d30f6
JB		 196 /* lower and upper bounds of the segment */
197 SCM_CELLPTR bounds[2];
198
199 /* address of the head-of-freelist pointer for this segment's cells.
200 All segments usually point to the same one, scm_freelist. */
201 SCM *freelistp;
202
203 /* number of SCM words per object in this segment */
204 int ncells;
205
206 /* If SEG_DATA->valid is non-zero, the conservative marking
207 functions will apply SEG_DATA->valid to the purported pointer and
208 SEG_DATA, and mark the object iff the function returns non-zero.
209 At the moment, I don't think anyone uses this. */
0f2d19dd
JB		 210 int (*valid) ();
211};
212
213
214
215
3e8a29f5
JB		 216static void scm_mark_weak_vector_spines SCM_P ((void));
217static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *));
218static void alloc_some_heap SCM_P ((int, SCM *));
0f2d19dd
JB		 219
220
221\f
cf2d30f6
JB		 222/* Debugging functions. */
223
224#ifdef DEBUG_FREELIST
225
226/* Return the number of the heap segment containing CELL. */
227static int
228which_seg (SCM cell)
229{
230 int i;
231
232 for (i = 0; i < scm_n_heap_segs; i++)
233 if (SCM_PTR_LE (scm_heap_table[i].bounds[0], (SCM_CELLPTR) cell)
234 && SCM_PTR_GT (scm_heap_table[i].bounds[1], (SCM_CELLPTR) cell))
235 return i;
236 fprintf (stderr, "which_seg: can't find segment containing cell %lx\n",
237 cell);
238 abort ();
239}
240
241
242SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list);
243SCM
244scm_map_free_list ()
245{
246 int last_seg = -1, count = 0;
247 SCM f;
248
249 fprintf (stderr, "%d segments total\n", scm_n_heap_segs);
250 for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f))
251 {
252 int this_seg = which_seg (f);
253
254 if (this_seg != last_seg)
255 {
256 if (last_seg != -1)
257 fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
258 last_seg = this_seg;
259 count = 0;
260 }
261 count++;
262 }
263 if (last_seg != -1)
264 fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
265
266 fflush (stderr);
267
268 return SCM_UNSPECIFIED;
269}
270
271
272/* Number of calls to SCM_NEWCELL since startup. */
273static unsigned long scm_newcell_count;
274
275/* Search freelist for anything that isn't marked as a free cell.
276 Abort if we find something. */
277static void
278scm_check_freelist ()
279{
280 SCM f;
281 int i = 0;
282
283 for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
284 if (SCM_CAR (f) != (SCM) scm_tc_free_cell)
285 {
286 fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n",
287 scm_newcell_count, i);
288 fflush (stderr);
289 abort ();
290 }
291}
292
293static int scm_debug_check_freelist = 0;
294void
295scm_debug_newcell (SCM *into)
296{
297 scm_newcell_count++;
298 if (scm_debug_check_freelist)
299 scm_check_freelist ();
300
301 /* The rest of this is supposed to be identical to the SCM_NEWCELL
302 macro. */
303 if (SCM_IMP (scm_freelist))
304 *into = scm_gc_for_newcell ();
305 else
306 {
307 *into = scm_freelist;
308 scm_freelist = SCM_CDR (scm_freelist);
309 ++scm_cells_allocated;
310 }
311}
312
313#endif /* DEBUG_FREELIST */
314
315\f
0f2d19dd
JB		 316
317/* {Scheme Interface to GC}
318 */
319
320SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats);
0f2d19dd
JB		 321SCM
322scm_gc_stats ()
0f2d19dd
JB		 323{
324 int i;
325 int n;
326 SCM heap_segs;
327 SCM local_scm_mtrigger;
328 SCM local_scm_mallocated;
329 SCM local_scm_heap_size;
330 SCM local_scm_cells_allocated;
331 SCM local_scm_gc_time_taken;
332 SCM answer;
333
334 SCM_DEFER_INTS;
335 scm_block_gc = 1;
336 retry:
337 heap_segs = SCM_EOL;
338 n = scm_n_heap_segs;
339 for (i = scm_n_heap_segs; i--; )
340 heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]),
341 scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])),
342 heap_segs);
343 if (scm_n_heap_segs != n)
344 goto retry;
345 scm_block_gc = 0;
346
347 local_scm_mtrigger = scm_mtrigger;
348 local_scm_mallocated = scm_mallocated;
349 local_scm_heap_size = scm_heap_size;
350 local_scm_cells_allocated = scm_cells_allocated;
351 local_scm_gc_time_taken = scm_gc_time_taken;
352
353 answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)),
354 scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)),
355 scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)),
356 scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)),
357 scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)),
358 scm_cons (sym_heap_segments, heap_segs),
359 SCM_UNDEFINED);
360 SCM_ALLOW_INTS;
361 return answer;
362}
363
364
0f2d19dd
JB		 365void
366scm_gc_start (what)
367 char *what;
0f2d19dd
JB		 368{
369 scm_gc_rt = SCM_INUM (scm_get_internal_run_time ());
370 scm_gc_cells_collected = 0;
371 scm_gc_malloc_collected = 0;
372 scm_gc_ports_collected = 0;
373}
374
0f2d19dd
JB		 375void
376scm_gc_end ()
0f2d19dd
JB		 377{
378 scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt;
379 scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
9ea54cc6 380 scm_system_async_mark (scm_gc_async);
0f2d19dd
JB		 381}
382
383
384SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr);
385SCM
386scm_object_addr (obj)
387 SCM obj;
388{
389 return scm_ulong2num ((unsigned long)obj);
390}
391
392
393SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc);
0f2d19dd
JB		 394SCM
395scm_gc ()
0f2d19dd
JB		 396{
397 SCM_DEFER_INTS;
398 scm_igc ("call");
399 SCM_ALLOW_INTS;
400 return SCM_UNSPECIFIED;
401}
402
403
404\f
405/* {C Interface For When GC is Triggered}
406 */
407
0f2d19dd
JB		 408void
409scm_gc_for_alloc (ncells, freelistp)
410 int ncells;
411 SCM * freelistp;
0f2d19dd
JB		 412{
413 SCM_REDEFER_INTS;
414 scm_igc ("cells");
415 if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp))
416 {
417 alloc_some_heap (ncells, freelistp);
418 }
419 SCM_REALLOW_INTS;
420}
421
422
0f2d19dd
JB		 423SCM
424scm_gc_for_newcell ()
0f2d19dd
JB		 425{
426 SCM fl;
427 scm_gc_for_alloc (1, &scm_freelist);
428 fl = scm_freelist;
429 scm_freelist = SCM_CDR (fl);
430 return fl;
431}
432
0f2d19dd
JB		 433void
434scm_igc (what)
435 char *what;
0f2d19dd
JB		 436{
437 int j;
438
42db06f0
MD		 439#ifdef USE_THREADS
440 /* During the critical section, only the current thread may run. */
441 SCM_THREAD_CRITICAL_SECTION_START;
442#endif
443
c68296f8
MV		 444 // fprintf (stderr, "gc: %s\n", what);
445
0f2d19dd
JB		 446 scm_gc_start (what);
447 if (!scm_stack_base || scm_block_gc)
448 {
449 scm_gc_end ();
450 return;
451 }
452
453 ++scm_gc_heap_lock;
454 scm_n_weak = 0;
455
456 /* unprotect any struct types with no instances */
457#if 0
458 {
459 SCM type_list;
460 SCM * pos;
461
462 pos = &scm_type_obj_list;
463 type_list = scm_type_obj_list;
464 while (type_list != SCM_EOL)
465 if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt])
466 {
24e68a57 467 pos = SCM_CDRLOC (type_list);
0f2d19dd
JB		 468 type_list = SCM_CDR (type_list);
469 }
470 else
471 {
472 *pos = SCM_CDR (type_list);
473 type_list = SCM_CDR (type_list);
474 }
475 }
476#endif
477
478 /* flush dead entries from the continuation stack */
479 {
480 int x;
481 int bound;
482 SCM * elts;
483 elts = SCM_VELTS (scm_continuation_stack);
484 bound = SCM_LENGTH (scm_continuation_stack);
485 x = SCM_INUM (scm_continuation_stack_ptr);
486 while (x < bound)
487 {
488 elts[x] = SCM_BOOL_F;
489 ++x;
490 }
491 }
492
42db06f0
MD		 493#ifndef USE_THREADS
494
0f2d19dd
JB		 495 /* Protect from the C stack. This must be the first marking
496 * done because it provides information about what objects
497 * are "in-use" by the C code. "in-use" objects are those
498 * for which the values from SCM_LENGTH and SCM_CHARS must remain
499 * usable. This requirement is stricter than a liveness
500 * requirement -- in particular, it constrains the implementation
501 * of scm_vector_set_length_x.
502 */
503 SCM_FLUSH_REGISTER_WINDOWS;
504 /* This assumes that all registers are saved into the jmp_buf */
505 setjmp (scm_save_regs_gc_mark);
506 scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
ce4a361d
JB		 507 ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 +
508 sizeof scm_save_regs_gc_mark)
509 / sizeof (SCM_STACKITEM)));
0f2d19dd
JB		 510
511 {
512 /* stack_len is long rather than scm_sizet in order to guarantee that
513 &stack_len is long aligned */
514#ifdef SCM_STACK_GROWS_UP
515#ifdef nosve
516 long stack_len = (SCM_STACKITEM *) (&stack_len) - scm_stack_base;
517#else
518 long stack_len = scm_stack_size (scm_stack_base);
519#endif
520 scm_mark_locations (scm_stack_base, (scm_sizet) stack_len);
521#else
522#ifdef nosve
523 long stack_len = scm_stack_base - (SCM_STACKITEM *) (&stack_len);
524#else
525 long stack_len = scm_stack_size (scm_stack_base);
526#endif
527 scm_mark_locations ((scm_stack_base - stack_len), (scm_sizet) stack_len);
528#endif
529 }
530
42db06f0
MD		 531#else /* USE_THREADS */
532
533 /* Mark every thread's stack and registers */
534 scm_threads_mark_stacks();
535
536#endif /* USE_THREADS */
0f2d19dd
JB		 537
538 /* FIXME: insert a phase to un-protect string-data preserved
539 * in scm_vector_set_length_x.
540 */
541
542 j = SCM_NUM_PROTECTS;
543 while (j--)
544 scm_gc_mark (scm_sys_protects[j]);
545
42db06f0
MD		 546#ifndef USE_THREADS
547 scm_gc_mark (scm_root->handle);
548#endif
0f2d19dd
JB		 549
550 scm_mark_weak_vector_spines ();
551
552 scm_gc_sweep ();
553
554 --scm_gc_heap_lock;
555 scm_gc_end ();
42db06f0
MD		 556
557#ifdef USE_THREADS
558 SCM_THREAD_CRITICAL_SECTION_END;
559#endif
0f2d19dd
JB		 560}
561
562\f
563/* {Mark/Sweep}
564 */
565
566
567
568/* Mark an object precisely.
569 */
0f2d19dd
JB		 570void
571scm_gc_mark (p)
572 SCM p;
0f2d19dd
JB		 573{
574 register long i;
575 register SCM ptr;
576
577 ptr = p;
578
579gc_mark_loop:
580 if (SCM_IMP (ptr))
581 return;
582
583gc_mark_nimp:
584 if (SCM_NCELLP (ptr))
f8392303 585 scm_wta (ptr, "rogue pointer in heap", NULL);
0f2d19dd
JB		 586
587 switch (SCM_TYP7 (ptr))
588 {
589 case scm_tcs_cons_nimcar:
590 if (SCM_GCMARKP (ptr))
591 break;
592 SCM_SETGCMARK (ptr);
593 if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */
594 {
595 ptr = SCM_CAR (ptr);
596 goto gc_mark_nimp;
597 }
598 scm_gc_mark (SCM_CAR (ptr));
599 ptr = SCM_GCCDR (ptr);
600 goto gc_mark_nimp;
601 case scm_tcs_cons_imcar:
602 if (SCM_GCMARKP (ptr))
603 break;
604 SCM_SETGCMARK (ptr);
605 ptr = SCM_GCCDR (ptr);
606 goto gc_mark_loop;
607 case scm_tcs_cons_gloc:
608 if (SCM_GCMARKP (ptr))
609 break;
610 SCM_SETGCMARK (ptr);
611 {
612 SCM vcell;
613 vcell = SCM_CAR (ptr) - 1L;
614 switch (SCM_CDR (vcell))
615 {
616 default:
617 scm_gc_mark (vcell);
618 ptr = SCM_GCCDR (ptr);
619 goto gc_mark_loop;
620 case 1: /* ! */
621 case 0: /* ! */
622 {
623 SCM layout;
624 SCM * vtable_data;
625 int len;
626 char * fields_desc;
ad75306c
MD		 627 register SCM * mem;
628 register int x;
0f2d19dd
JB		 629
630 vtable_data = (SCM *)vcell;
4bfdf158 631 layout = vtable_data[scm_vtable_index_layout];
0f2d19dd
JB		 632 len = SCM_LENGTH (layout);
633 fields_desc = SCM_CHARS (layout);
14d1400f
JB		 634 /* We're using SCM_GCCDR here like STRUCT_DATA, except
635 that it removes the mark */
636 mem = (SCM *)SCM_GCCDR (ptr);
0f2d19dd 637
ad75306c
MD		 638 if (len)
639 {
640 for (x = 0; x < len - 2; x += 2, ++mem)
641 if (fields_desc[x] == 'p')
642 scm_gc_mark (*mem);
643 if (fields_desc[x] == 'p')
644 {
645 if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
646 for (x = *mem; x; --x)
647 scm_gc_mark (*++mem);
648 else
649 scm_gc_mark (*mem);
650 }
651 }
0f2d19dd
JB		 652 if (!SCM_CDR (vcell))
653 {
654 SCM_SETGCMARK (vcell);
4bfdf158 655 ptr = vtable_data[scm_vtable_index_vtable];
0f2d19dd
JB		 656 goto gc_mark_loop;
657 }
658 }
659 }
660 }
661 break;
662 case scm_tcs_closures:
663 if (SCM_GCMARKP (ptr))
664 break;
665 SCM_SETGCMARK (ptr);
666 if (SCM_IMP (SCM_CDR (ptr)))
667 {
668 ptr = SCM_CLOSCAR (ptr);
669 goto gc_mark_nimp;
670 }
671 scm_gc_mark (SCM_CLOSCAR (ptr));
672 ptr = SCM_GCCDR (ptr);
673 goto gc_mark_nimp;
674 case scm_tc7_vector:
675 case scm_tc7_lvector:
676#ifdef CCLO
677 case scm_tc7_cclo:
678#endif
679 if (SCM_GC8MARKP (ptr))
680 break;
681 SCM_SETGC8MARK (ptr);
682 i = SCM_LENGTH (ptr);
683 if (i == 0)
684 break;
685 while (--i > 0)
686 if (SCM_NIMP (SCM_VELTS (ptr)[i]))
687 scm_gc_mark (SCM_VELTS (ptr)[i]);
688 ptr = SCM_VELTS (ptr)[0];
689 goto gc_mark_loop;
690 case scm_tc7_contin:
691 if SCM_GC8MARKP
692 (ptr) break;
693 SCM_SETGC8MARK (ptr);
c68296f8
MV		 694 if (SCM_VELTS (ptr))
695 scm_mark_locations (SCM_VELTS (ptr),
696 (scm_sizet)
697 (SCM_LENGTH (ptr) +
698 (sizeof (SCM_STACKITEM) + -1 +
699 sizeof (scm_contregs)) /
700 sizeof (SCM_STACKITEM)));
0f2d19dd
JB		 701 break;
702 case scm_tc7_bvect:
703 case scm_tc7_byvect:
704 case scm_tc7_ivect:
705 case scm_tc7_uvect:
706 case scm_tc7_fvect:
707 case scm_tc7_dvect:
708 case scm_tc7_cvect:
709 case scm_tc7_svect:
710#ifdef LONGLONGS
711 case scm_tc7_llvect:
712#endif
713
714 case scm_tc7_string:
0f2d19dd
JB		 715 SCM_SETGC8MARK (ptr);
716 break;
717
718 case scm_tc7_substring:
0f2d19dd
JB		 719 if (SCM_GC8MARKP(ptr))
720 break;
721 SCM_SETGC8MARK (ptr);
722 ptr = SCM_CDR (ptr);
723 goto gc_mark_loop;
724
725 case scm_tc7_wvect:
726 if (SCM_GC8MARKP(ptr))
727 break;
728 scm_weak_vectors[scm_n_weak++] = ptr;
729 if (scm_n_weak >= scm_weak_size)
730 {
731 SCM_SYSCALL (scm_weak_vectors =
732 (SCM *) realloc ((char *) scm_weak_vectors,
733 sizeof (SCM *) * (scm_weak_size *= 2)));
734 if (scm_weak_vectors == NULL)
735 {
b7f3516f
TT		 736 scm_puts ("weak vector table", scm_cur_errp);
737 scm_puts ("\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
738 scm_cur_errp);
0f2d19dd
JB		 739 exit(SCM_EXIT_FAILURE);
740 }
741 }
742 SCM_SETGC8MARK (ptr);
743 if (SCM_IS_WHVEC_ANY (ptr))
744 {
745 int x;
746 int len;
747 int weak_keys;
748 int weak_values;
749
750 len = SCM_LENGTH (ptr);
751 weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
752 weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr);
753
754 for (x = 0; x < len; ++x)
755 {
756 SCM alist;
757 alist = SCM_VELTS (ptr)[x];
758 /* mark everything on the alist
759 * except the keys or values, according to weak_values and weak_keys.
760 */
761 while ( SCM_NIMP (alist)
762 && SCM_CONSP (alist)
763 && !SCM_GCMARKP (alist)
764 && SCM_NIMP (SCM_CAR (alist))
765 && SCM_CONSP (SCM_CAR (alist)))
766 {
767 SCM kvpair;
768 SCM next_alist;
769
770 kvpair = SCM_CAR (alist);
771 next_alist = SCM_CDR (alist);
772 /*
773 * Do not do this:
774 * SCM_SETGCMARK (alist);
775 * SCM_SETGCMARK (kvpair);
776 *
777 * It may be that either the key or value is protected by
778 * an escaped reference to part of the spine of this alist.
779 * If we mark the spine here, and only mark one or neither of the
780 * key and value, they may never be properly marked.
781 * This leads to a horrible situation in which an alist containing
782 * freelist cells is exported.
783 *
784 * So only mark the spines of these arrays last of all marking.
785 * If somebody confuses us by constructing a weak vector
786 * with a circular alist then we are hosed, but at least we
787 * won't prematurely drop table entries.
788 */
789 if (!weak_keys)
790 scm_gc_mark (SCM_CAR (kvpair));
791 if (!weak_values)
792 scm_gc_mark (SCM_GCCDR (kvpair));
793 alist = next_alist;
794 }
795 if (SCM_NIMP (alist))
796 scm_gc_mark (alist);
797 }
798 }
799 break;
800
801 case scm_tc7_msymbol:
802 if (SCM_GC8MARKP(ptr))
803 break;
804 SCM_SETGC8MARK (ptr);
805 scm_gc_mark (SCM_SYMBOL_FUNC (ptr));
806 ptr = SCM_SYMBOL_PROPS (ptr);
807 goto gc_mark_loop;
808 case scm_tc7_ssymbol:
809 if (SCM_GC8MARKP(ptr))
810 break;
811 SCM_SETGC8MARK (ptr);
812 break;
813 case scm_tcs_subrs:
814 ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8));
815 goto gc_mark_loop;
816 case scm_tc7_port:
817 i = SCM_PTOBNUM (ptr);
818 if (!(i < scm_numptob))
819 goto def;
820 if (SCM_GC8MARKP (ptr))
821 break;
ebf7394e
GH		 822 if (SCM_PTAB_ENTRY(ptr))
823 scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name);
0f2d19dd
JB		 824 ptr = (scm_ptobs[i].mark) (ptr);
825 goto gc_mark_loop;
826 break;
827 case scm_tc7_smob:
828 if (SCM_GC8MARKP (ptr))
829 break;
830 switch SCM_TYP16 (ptr)
831 { /* should be faster than going through scm_smobs */
832 case scm_tc_free_cell:
833 /* printf("found free_cell %X ", ptr); fflush(stdout); */
834 SCM_SETGC8MARK (ptr);
24e68a57 835 SCM_SETCDR (ptr, SCM_EOL);
0f2d19dd
JB		 836 break;
837 case scm_tcs_bignums:
838 case scm_tc16_flo:
839 SCM_SETGC8MARK (ptr);
840 break;
841 default:
842 i = SCM_SMOBNUM (ptr);
843 if (!(i < scm_numsmob))
844 goto def;
845 ptr = (scm_smobs[i].mark) (ptr);
846 goto gc_mark_loop;
847 }
848 break;
849 default:
850 def:scm_wta (ptr, "unknown type in ", "gc_mark");
851 }
852}
853
854
855/* Mark a Region Conservatively
856 */
857
0f2d19dd
JB		 858void
859scm_mark_locations (x, n)
860 SCM_STACKITEM x[];
861 scm_sizet n;
0f2d19dd
JB		 862{
863 register long m = n;
864 register int i, j;
865 register SCM_CELLPTR ptr;
866
867 while (0 <= --m)
868 if SCM_CELLP (*(SCM **) & x[m])
869 {
870 ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
871 i = 0;
872 j = scm_n_heap_segs - 1;
873 if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
874 && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
875 {
876 while (i <= j)
877 {
878 int seg_id;
879 seg_id = -1;
880 if ( (i == j)
881 || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
882 seg_id = i;
883 else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
884 seg_id = j;
885 else
886 {
887 int k;
888 k = (i + j) / 2;
889 if (k == i)
890 break;
891 if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
892 {
893 j = k;
894 ++i;
895 if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
896 continue;
897 else
898 break;
899 }
900 else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
901 {
902 i = k;
903 --j;
904 if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
905 continue;
906 else
907 break;
908 }
909 }
910 if ( !scm_heap_table[seg_id].valid
911 || scm_heap_table[seg_id].valid (ptr,
912 &scm_heap_table[seg_id]))
913 scm_gc_mark (*(SCM *) & x[m]);
914 break;
915 }
916
917 }
918 }
919}
920
921
2e11a577
MD		 922/* The following is a C predicate which determines if an SCM value can be
923 regarded as a pointer to a cell on the heap. The code is duplicated
924 from scm_mark_locations. */
925
1cc91f1b 926
2e11a577
MD		 927int
928scm_cellp (value)
929 SCM value;
2e11a577
MD		 930{
931 register int i, j;
932 register SCM_CELLPTR ptr;
933
934 if SCM_CELLP (*(SCM **) & value)
935 {
936 ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
937 i = 0;
938 j = scm_n_heap_segs - 1;
939 if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
940 && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
941 {
942 while (i <= j)
943 {
944 int seg_id;
945 seg_id = -1;
946 if ( (i == j)
947 || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
948 seg_id = i;
949 else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
950 seg_id = j;
951 else
952 {
953 int k;
954 k = (i + j) / 2;
955 if (k == i)
956 break;
957 if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
958 {
959 j = k;
960 ++i;
961 if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
962 continue;
963 else
964 break;
965 }
966 else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
967 {
968 i = k;
969 --j;
970 if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
971 continue;
972 else
973 break;
974 }
975 }
976 if ( !scm_heap_table[seg_id].valid
977 || scm_heap_table[seg_id].valid (ptr,
978 &scm_heap_table[seg_id]))
979 return 1;
980 break;
981 }
982
983 }
984 }
985 return 0;
986}
987
988
3b2b8760 989static void
0f2d19dd 990scm_mark_weak_vector_spines ()
0f2d19dd
JB		 991{
992 int i;
993
994 for (i = 0; i < scm_n_weak; ++i)
995 {
996 if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
997 {
998 SCM *ptr;
999 SCM obj;
1000 int j;
1001 int n;
1002
1003 obj = scm_weak_vectors[i];
1004 ptr = SCM_VELTS (scm_weak_vectors[i]);
1005 n = SCM_LENGTH (scm_weak_vectors[i]);
1006 for (j = 0; j < n; ++j)
1007 {
1008 SCM alist;
1009
1010 alist = ptr[j];
1011 while ( SCM_NIMP (alist)
1012 && SCM_CONSP (alist)
1013 && !SCM_GCMARKP (alist)
1014 && SCM_NIMP (SCM_CAR (alist))
1015 && SCM_CONSP (SCM_CAR (alist)))
1016 {
1017 SCM_SETGCMARK (alist);
1018 SCM_SETGCMARK (SCM_CAR (alist));
1019 alist = SCM_GCCDR (alist);
1020 }
1021 }
1022 }
1023 }
1024}
1025
1026
1027
0f2d19dd
JB		 1028void
1029scm_gc_sweep ()
0f2d19dd
JB		 1030{
1031 register SCM_CELLPTR ptr;
1032#ifdef SCM_POINTERS_MUNGED
1033 register SCM scmptr;
1034#else
1035#undef scmptr
1036#define scmptr (SCM)ptr
1037#endif
1038 register SCM nfreelist;
1039 register SCM *hp_freelist;
1040 register long n;
1041 register long m;
1042 register scm_sizet j;
1043 register int span;
1044 scm_sizet i;
1045 scm_sizet seg_size;
1046
1047 n = 0;
1048 m = 0;
0f2d19dd 1049
cf2d30f6
JB		 1050 /* Reset all free list pointers. We'll reconstruct them completely
1051 while scanning. */
1052 for (i = 0; i < scm_n_heap_segs; i++)
1053 *scm_heap_table[i].freelistp = SCM_EOL;
1054
1055 for (i = 0; i < scm_n_heap_segs; i++)
0f2d19dd 1056 {
cf2d30f6
JB		 1057 /* Unmarked cells go onto the front of the freelist this heap
1058 segment points to. Rather than updating the real freelist
1059 pointer as we go along, we accumulate the new head in
1060 nfreelist. Then, if it turns out that the entire segment is
1061 free, we free (i.e., malloc's free) the whole segment, and
1062 simply don't assign nfreelist back into the real freelist. */
0f2d19dd 1063 hp_freelist = scm_heap_table[i].freelistp;
cf2d30f6
JB		 1064 nfreelist = *hp_freelist;
1065
0f2d19dd
JB		 1066 span = scm_heap_table[i].ncells;
1067 ptr = CELL_UP (scm_heap_table[i].bounds[0]);
1068 seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
0f2d19dd
JB		 1069 for (j = seg_size + span; j -= span; ptr += span)
1070 {
1071#ifdef SCM_POINTERS_MUNGED
1072 scmptr = PTR2SCM (ptr);
1073#endif
1074 switch SCM_TYP7 (scmptr)
1075 {
1076 case scm_tcs_cons_gloc:
1077 if (SCM_GCMARKP (scmptr))
1078 {
1079 if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1)
24e68a57 1080 SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0);
0f2d19dd
JB		 1081 goto cmrkcontinue;
1082 }
1083 {
1084 SCM vcell;
1085 vcell = SCM_CAR (scmptr) - 1L;
1086
1087 if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
1088 {
14d1400f
JB		 1089 SCM *p = (SCM *) SCM_GCCDR (scmptr);
1090 m += p[scm_struct_i_n_words] * sizeof (SCM);
1091 /* I feel like I'm programming in BCPL here... */
1092 free ((char *) p[scm_struct_i_ptr]);
0f2d19dd
JB		 1093 }
1094 }
1095 break;
1096 case scm_tcs_cons_imcar:
1097 case scm_tcs_cons_nimcar:
1098 case scm_tcs_closures:
1099 if (SCM_GCMARKP (scmptr))
1100 goto cmrkcontinue;
1101 break;
1102 case scm_tc7_wvect:
1103 if (SCM_GC8MARKP (scmptr))
1104 {
1105 goto c8mrkcontinue;
1106 }
1107 else
1108 {
1109 m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM);
1110 scm_must_free ((char *)(SCM_VELTS (scmptr) - 1));
1111 break;
1112 }
1113
1114 case scm_tc7_vector:
1115 case scm_tc7_lvector:
1116#ifdef CCLO
1117 case scm_tc7_cclo:
1118#endif
1119 if (SCM_GC8MARKP (scmptr))
1120 goto c8mrkcontinue;
1121
1122 m += (SCM_LENGTH (scmptr) * sizeof (SCM));
1123 freechars:
1124 scm_must_free (SCM_CHARS (scmptr));
1125 /* SCM_SETCHARS(scmptr, 0);*/
1126 break;
1127 case scm_tc7_bvect:
1128 if SCM_GC8MARKP (scmptr)
1129 goto c8mrkcontinue;
1130 m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
1131 goto freechars;
1132 case scm_tc7_byvect:
1133 if SCM_GC8MARKP (scmptr)
1134 goto c8mrkcontinue;
1135 m += SCM_HUGE_LENGTH (scmptr) * sizeof (char);
1136 goto freechars;
1137 case scm_tc7_ivect:
1138 case scm_tc7_uvect:
1139 if SCM_GC8MARKP (scmptr)
1140 goto c8mrkcontinue;
1141 m += SCM_HUGE_LENGTH (scmptr) * sizeof (long);
1142 goto freechars;
1143 case scm_tc7_svect:
1144 if SCM_GC8MARKP (scmptr)
1145 goto c8mrkcontinue;
1146 m += SCM_HUGE_LENGTH (scmptr) * sizeof (short);
1147 goto freechars;
1148#ifdef LONGLONGS
1149 case scm_tc7_llvect:
1150 if SCM_GC8MARKP (scmptr)
1151 goto c8mrkcontinue;
1152 m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long);
1153 goto freechars;
1154#endif
1155 case scm_tc7_fvect:
1156 if SCM_GC8MARKP (scmptr)
1157 goto c8mrkcontinue;
1158 m += SCM_HUGE_LENGTH (scmptr) * sizeof (float);
1159 goto freechars;
1160 case scm_tc7_dvect:
1161 if SCM_GC8MARKP (scmptr)
1162 goto c8mrkcontinue;
1163 m += SCM_HUGE_LENGTH (scmptr) * sizeof (double);
1164 goto freechars;
1165 case scm_tc7_cvect:
1166 if SCM_GC8MARKP (scmptr)
1167 goto c8mrkcontinue;
1168 m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
1169 goto freechars;
1170 case scm_tc7_substring:
0f2d19dd
JB		 1171 if (SCM_GC8MARKP (scmptr))
1172 goto c8mrkcontinue;
1173 break;
1174 case scm_tc7_string:
0f2d19dd
JB		 1175 if (SCM_GC8MARKP (scmptr))
1176 goto c8mrkcontinue;
1177 m += SCM_HUGE_LENGTH (scmptr) + 1;
1178 goto freechars;
1179 case scm_tc7_msymbol:
1180 if (SCM_GC8MARKP (scmptr))
1181 goto c8mrkcontinue;
1182 m += ( SCM_LENGTH (scmptr)
1183 + 1
1184 + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr)));
1185 scm_must_free ((char *)SCM_SLOTS (scmptr));
1186 break;
1187 case scm_tc7_contin:
1188 if SCM_GC8MARKP (scmptr)
1189 goto c8mrkcontinue;
0db18cf4 1190 m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
c68296f8
MV		 1191 if (SCM_VELTS (scmptr))
1192 goto freechars;
0f2d19dd
JB		 1193 case scm_tc7_ssymbol:
1194 if SCM_GC8MARKP(scmptr)
1195 goto c8mrkcontinue;
1196 break;
1197 case scm_tcs_subrs:
1198 continue;
1199 case scm_tc7_port:
1200 if SCM_GC8MARKP (scmptr)
1201 goto c8mrkcontinue;
1202 if SCM_OPENP (scmptr)
1203 {
1204 int k = SCM_PTOBNUM (scmptr);
1205 if (!(k < scm_numptob))
1206 goto sweeperr;
1207 /* Keep "revealed" ports alive. */
1208 if (scm_revealed_count(scmptr) > 0)
1209 continue;
1210 /* Yes, I really do mean scm_ptobs[k].free */
1211 /* rather than ftobs[k].close. .close */
1212 /* is for explicit CLOSE-PORT by user */
1213 (scm_ptobs[k].free) (SCM_STREAM (scmptr));
1214 SCM_SETSTREAM (scmptr, 0);
1215 scm_remove_from_port_table (scmptr);
1216 scm_gc_ports_collected++;
24e68a57 1217 SCM_SETAND_CAR (scmptr, ~SCM_OPN);
0f2d19dd
JB		 1218 }
1219 break;
1220 case scm_tc7_smob:
1221 switch SCM_GCTYP16 (scmptr)
1222 {
1223 case scm_tc_free_cell:
1224 if SCM_GC8MARKP (scmptr)
1225 goto c8mrkcontinue;
1226 break;
1227#ifdef SCM_BIGDIG
1228 case scm_tcs_bignums:
1229 if SCM_GC8MARKP (scmptr)
1230 goto c8mrkcontinue;
1231 m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT);
1232 goto freechars;
1233#endif /* def SCM_BIGDIG */
1234 case scm_tc16_flo:
1235 if SCM_GC8MARKP (scmptr)
1236 goto c8mrkcontinue;
1237 switch ((int) (SCM_CAR (scmptr) >> 16))
1238 {
1239 case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
1240 m += sizeof (double);
1241 case SCM_REAL_PART >> 16:
1242 case SCM_IMAG_PART >> 16:
1243 m += sizeof (double);
1244 goto freechars;
1245 case 0:
1246 break;
1247 default:
1248 goto sweeperr;
1249 }
1250 break;
1251 default:
1252 if SCM_GC8MARKP (scmptr)
1253 goto c8mrkcontinue;
1254
1255 {
1256 int k;
1257 k = SCM_SMOBNUM (scmptr);
1258 if (!(k < scm_numsmob))
1259 goto sweeperr;
1260 m += (scm_smobs[k].free) ((SCM) scmptr);
1261 break;
1262 }
1263 }
1264 break;
1265 default:
1266 sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep");
1267 }
1268 n += span;
1269#if 0
1270 if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
1271 exit (2);
1272#endif
e7c5fb37
JB		 1273 /* Stick the new cell on the front of nfreelist. It's
1274 critical that we mark this cell as freed; otherwise, the
1275 conservative collector might trace it as some other type
1276 of object. */
24e68a57
MD		 1277 SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
1278 SCM_SETCDR (scmptr, nfreelist);
0f2d19dd 1279 nfreelist = scmptr;
cf2d30f6 1280
0f2d19dd
JB		 1281 continue;
1282 c8mrkcontinue:
1283 SCM_CLRGC8MARK (scmptr);
1284 continue;
1285 cmrkcontinue:
1286 SCM_CLRGCMARK (scmptr);
1287 }
1288#ifdef GC_FREE_SEGMENTS
1289 if (n == seg_size)
1290 {
1291 scm_heap_size -= seg_size;
6f3067f1 1292 n = 0;
cf2d30f6
JB		 1293 free ((char *) scm_heap_table[i].bounds[0]);
1294 scm_heap_table[i].bounds[0] = 0;
1295 for (j = i + 1; j < scm_n_heap_segs; j++)
0f2d19dd
JB		 1296 scm_heap_table[j - 1] = scm_heap_table[j];
1297 scm_n_heap_segs -= 1;
cf2d30f6 1298 i--; /* We need to scan the segment just moved. */
0f2d19dd
JB		 1299 }
1300 else
1301#endif /* ifdef GC_FREE_SEGMENTS */
cf2d30f6
JB		 1302 /* Update the real freelist pointer to point to the head of
1303 the list of free cells we've built for this segment. */
0f2d19dd
JB		 1304 *hp_freelist = nfreelist;
1305
cf2d30f6
JB		 1306#ifdef DEBUG_FREELIST
1307 scm_check_freelist ();
1308 scm_map_free_list ();
1309#endif
1310
0f2d19dd
JB		 1311 scm_gc_cells_collected += n;
1312 n = 0;
1313 }
1314 /* Scan weak vectors. */
1315 {
1316 SCM *ptr;
1317 for (i = 0; i < scm_n_weak; ++i)
1318 {
1319 if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
1320 {
1321 ptr = SCM_VELTS (scm_weak_vectors[i]);
1322 n = SCM_LENGTH (scm_weak_vectors[i]);
1323 for (j = 0; j < n; ++j)
1324 if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j]))
1325 ptr[j] = SCM_BOOL_F;
1326 }
1327 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1328 {
1329 SCM obj;
1330 obj = scm_weak_vectors[i];
1331 ptr = SCM_VELTS (scm_weak_vectors[i]);
1332 n = SCM_LENGTH (scm_weak_vectors[i]);
1333 for (j = 0; j < n; ++j)
1334 {
1335 SCM * fixup;
1336 SCM alist;
1337 int weak_keys;
1338 int weak_values;
1339
1340 weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
1341 weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
1342
1343 fixup = ptr + j;
1344 alist = *fixup;
1345
1346 while (SCM_NIMP (alist)
1347 && SCM_CONSP (alist)
1348 && SCM_NIMP (SCM_CAR (alist))
1349 && SCM_CONSP (SCM_CAR (alist)))
1350 {
1351 SCM key;
1352 SCM value;
1353
1354 key = SCM_CAAR (alist);
1355 value = SCM_CDAR (alist);
1356 if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key))
1357 || (weak_values && SCM_NIMP (value) && SCM_FREEP (value)))
1358 {
1359 *fixup = SCM_CDR (alist);
1360 }
1361 else
24e68a57 1362 fixup = SCM_CDRLOC (alist);
0f2d19dd
JB		 1363 alist = SCM_CDR (alist);
1364 }
1365 }
1366 }
1367 }
1368 }
1369 scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected);
1370 scm_mallocated -= m;
1371 scm_gc_malloc_collected = m;
1372}
1373
1374
1375\f
1376
1377/* {Front end to malloc}
1378 *
c68296f8 1379 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
0f2d19dd
JB		 1380 *
1381 * These functions provide services comperable to malloc, realloc, and
1382 * free. They are for allocating malloced parts of scheme objects.
1383 * The primary purpose of the front end is to impose calls to gc.
1384 */
1385
1386/* scm_must_malloc
1387 * Return newly malloced storage or throw an error.
1388 *
1389 * The parameter WHAT is a string for error reporting.
1390 * If the threshold scm_mtrigger will be passed by this
1391 * allocation, or if the first call to malloc fails,
1392 * garbage collect -- on the presumption that some objects
1393 * using malloced storage may be collected.
1394 *
1395 * The limit scm_mtrigger may be raised by this allocation.
1396 */
0f2d19dd
JB		 1397char *
1398scm_must_malloc (len, what)
1399 long len;
1400 char *what;
0f2d19dd
JB		 1401{
1402 char *ptr;
1403 scm_sizet size = len;
1404 long nm = scm_mallocated + size;
1405 if (len != size)
1406 malerr:
1407 scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
1408 if ((nm <= scm_mtrigger))
1409 {
1410 SCM_SYSCALL (ptr = (char *) malloc (size));
1411 if (NULL != ptr)
1412 {
1413 scm_mallocated = nm;
1414 return ptr;
1415 }
1416 }
6064dcc6 1417
0f2d19dd
JB		 1418 scm_igc (what);
1419 nm = scm_mallocated + size;
1420 SCM_SYSCALL (ptr = (char *) malloc (size));
1421 if (NULL != ptr)
1422 {
1423 scm_mallocated = nm;
6064dcc6
MV		 1424 if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
1425 if (nm > scm_mtrigger)
1426 scm_mtrigger = nm + nm / 2;
1427 else
1428 scm_mtrigger += scm_mtrigger / 2;
1429 }
0f2d19dd
JB		 1430 return ptr;
1431 }
1432 goto malerr;
1433}
1434
1435
1436/* scm_must_realloc
1437 * is similar to scm_must_malloc.
1438 */
0f2d19dd
JB		 1439char *
1440scm_must_realloc (where, olen, len, what)
1441 char *where;
1442 long olen;
1443 long len;
1444 char *what;
0f2d19dd
JB		 1445{
1446 char *ptr;
1447 scm_sizet size = len;
1448 long nm = scm_mallocated + size - olen;
1449 if (len != size)
1450 ralerr:
1451 scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
1452 if ((nm <= scm_mtrigger))
1453 {
1454 SCM_SYSCALL (ptr = (char *) realloc (where, size));
1455 if (NULL != ptr)
1456 {
1457 scm_mallocated = nm;
1458 return ptr;
1459 }
1460 }
1461 scm_igc (what);
1462 nm = scm_mallocated + size - olen;
1463 SCM_SYSCALL (ptr = (char *) realloc (where, size));
1464 if (NULL != ptr)
1465 {
1466 scm_mallocated = nm;
6064dcc6
MV		 1467 if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
1468 if (nm > scm_mtrigger)
1469 scm_mtrigger = nm + nm / 2;
1470 else
1471 scm_mtrigger += scm_mtrigger / 2;
1472 }
0f2d19dd
JB		 1473 return ptr;
1474 }
1475 goto ralerr;
1476}
1477
0f2d19dd
JB		 1478void
1479scm_must_free (obj)
1480 char *obj;
0f2d19dd
JB		 1481{
1482 if (obj)
1483 free (obj);
1484 else
1485 scm_wta (SCM_INUM0, "already free", "");
1486}
0f2d19dd 1487
c68296f8
MV		 1488/* Announce that there has been some malloc done that will be freed
1489 * during gc. A typical use is for a smob that uses some malloced
1490 * memory but can not get it from scm_must_malloc (for whatever
1491 * reason). When a new object of this smob is created you call
1492 * scm_done_malloc with the size of the object. When your smob free
1493 * function is called, be sure to include this size in the return
1494 * value. */
0f2d19dd 1495
c68296f8
MV		 1496void
1497scm_done_malloc (size)
1498 long size;
1499{
1500 scm_mallocated += size;
1501
1502 if (scm_mallocated > scm_mtrigger)
1503 {
1504 scm_igc ("foreign mallocs");
1505 if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS)
1506 {
1507 if (scm_mallocated > scm_mtrigger)
1508 scm_mtrigger = scm_mallocated + scm_mallocated / 2;
1509 else
1510 scm_mtrigger += scm_mtrigger / 2;
1511 }
1512 }
1513}
1514
1515
1516\f
0f2d19dd
JB		 1517
1518/* {Heap Segments}
1519 *
1520 * Each heap segment is an array of objects of a particular size.
1521 * Every segment has an associated (possibly shared) freelist.
1522 * A table of segment records is kept that records the upper and
1523 * lower extents of the segment; this is used during the conservative
1524 * phase of gc to identify probably gc roots (because they point
c68296f8 1525 * into valid segments at reasonable offsets). */
0f2d19dd
JB		 1526
1527/* scm_expmem
1528 * is true if the first segment was smaller than INIT_HEAP_SEG.
1529 * If scm_expmem is set to one, subsequent segment allocations will
1530 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1531 */
1532int scm_expmem = 0;
1533
1534/* scm_heap_org
1535 * is the lowest base address of any heap segment.
1536 */
1537SCM_CELLPTR scm_heap_org;
1538
1539struct scm_heap_seg_data * scm_heap_table = 0;
1540int scm_n_heap_segs = 0;
1541
1542/* scm_heap_size
1543 * is the total number of cells in heap segments.
1544 */
1545long scm_heap_size = 0;
1546
1547/* init_heap_seg
1548 * initializes a new heap segment and return the number of objects it contains.
1549 *
1550 * The segment origin, segment size in bytes, and the span of objects
1551 * in cells are input parameters. The freelist is both input and output.
1552 *
1553 * This function presume that the scm_heap_table has already been expanded
1554 * to accomodate a new segment record.
1555 */
1556
1557
0f2d19dd
JB		 1558static scm_sizet
1559init_heap_seg (seg_org, size, ncells, freelistp)
1560 SCM_CELLPTR seg_org;
1561 scm_sizet size;
1562 int ncells;
1563 SCM *freelistp;
0f2d19dd
JB		 1564{
1565 register SCM_CELLPTR ptr;
1566#ifdef SCM_POINTERS_MUNGED
1567 register SCM scmptr;
1568#else
1569#undef scmptr
1570#define scmptr ptr
1571#endif
1572 SCM_CELLPTR seg_end;
1573 scm_sizet new_seg_index;
1574 scm_sizet n_new_objects;
1575
1576 if (seg_org == NULL)
1577 return 0;
1578
1579 ptr = seg_org;
1580
1581 /* Compute the ceiling on valid object pointers w/in this segment.
1582 */
1583 seg_end = CELL_DN ((char *) ptr + size);
1584
1585 /* Find the right place and insert the segment record.
1586 *
1587 */
1588 for (new_seg_index = 0;
1589 ( (new_seg_index < scm_n_heap_segs)
1590 && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
1591 new_seg_index++)
1592 ;
1593
1594 {
1595 int i;
1596 for (i = scm_n_heap_segs; i > new_seg_index; --i)
1597 scm_heap_table[i] = scm_heap_table[i - 1];
1598 }
1599
1600 ++scm_n_heap_segs;
1601
1602 scm_heap_table[new_seg_index].valid = 0;
1603 scm_heap_table[new_seg_index].ncells = ncells;
1604 scm_heap_table[new_seg_index].freelistp = freelistp;
1605 scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr;
1606 scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end;
1607
1608
1609 /* Compute the least valid object pointer w/in this segment
1610 */
1611 ptr = CELL_UP (ptr);
1612
1613
1614 n_new_objects = seg_end - ptr;
1615
1616 /* Prepend objects in this segment to the freelist.
1617 */
1618 while (ptr < seg_end)
1619 {
1620#ifdef SCM_POINTERS_MUNGED
1621 scmptr = PTR2SCM (ptr);
1622#endif
24e68a57
MD		 1623 SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
1624 SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells));
0f2d19dd
JB		 1625 ptr += ncells;
1626 }
1627
1628 ptr -= ncells;
1629
1630 /* Patch up the last freelist pointer in the segment
1631 * to join it to the input freelist.
1632 */
24e68a57 1633 SCM_SETCDR (PTR2SCM (ptr), *freelistp);
0f2d19dd
JB		 1634 *freelistp = PTR2SCM (CELL_UP (seg_org));
1635
1636 scm_heap_size += (ncells * n_new_objects);
1637 return size;
1638#ifdef scmptr
1639#undef scmptr
1640#endif
1641}
1642
1643
0f2d19dd
JB		 1644static void
1645alloc_some_heap (ncells, freelistp)
1646 int ncells;
1647 SCM * freelistp;
0f2d19dd
JB		 1648{
1649 struct scm_heap_seg_data * tmptable;
1650 SCM_CELLPTR ptr;
1651 scm_sizet len;
1652
1653 /* Critical code sections (such as the garbage collector)
1654 * aren't supposed to add heap segments.
1655 */
1656 if (scm_gc_heap_lock)
1657 scm_wta (SCM_UNDEFINED, "need larger initial", "heap");
1658
1659 /* Expand the heap tables to have room for the new segment.
1660 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1661 * only if the allocation of the segment itself succeeds.
1662 */
1663 len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data);
1664
1665 SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *)
1666 realloc ((char *)scm_heap_table, len)));
1667 if (!tmptable)
1668 scm_wta (SCM_UNDEFINED, "could not grow", "hplims");
1669 else
1670 scm_heap_table = tmptable;
1671
1672
1673 /* Pick a size for the new heap segment.
1674 * The rule for picking the size of a segment is explained in
1675 * gc.h
1676 */
1677 if (scm_expmem)
1678 {
1679 len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell));
1680 if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len)
1681 len = 0;
1682 }
1683 else
1684 len = SCM_HEAP_SEG_SIZE;
1685
1686 {
1687 scm_sizet smallest;
1688
1689 smallest = (ncells * sizeof (scm_cell));
1690 if (len < smallest)
1691 len = (ncells * sizeof (scm_cell));
1692
1693 /* Allocate with decaying ambition. */
1694 while ((len >= SCM_MIN_HEAP_SEG_SIZE)
1695 && (len >= smallest))
1696 {
1697 SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len));
1698 if (ptr)
1699 {
1700 init_heap_seg (ptr, len, ncells, freelistp);
1701 return;
1702 }
1703 len /= 2;
1704 }
1705 }
1706
1707 scm_wta (SCM_UNDEFINED, "could not grow", "heap");
1708}
1709
1710
1711
1712SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
0f2d19dd
JB		 1713SCM
1714scm_unhash_name (name)
1715 SCM name;
0f2d19dd
JB		 1716{
1717 int x;
1718 int bound;
1719 SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name);
1720 SCM_DEFER_INTS;
1721 bound = scm_n_heap_segs;
1722 for (x = 0; x < bound; ++x)
1723 {
1724 SCM_CELLPTR p;
1725 SCM_CELLPTR pbound;
1726 p = (SCM_CELLPTR)scm_heap_table[x].bounds[0];
1727 pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1];
1728 while (p < pbound)
1729 {
1730 SCM incar;
1731 incar = p->car;
1732 if (1 == (7 & (int)incar))
1733 {
1734 --incar;
1735 if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
1736 && (SCM_CDR (incar) != 0)
1737 && (SCM_CDR (incar) != 1))
1738 {
1739 p->car = name;
1740 }
1741 }
1742 ++p;
1743 }
1744 }
1745 SCM_ALLOW_INTS;
1746 return name;
1747}
1748
1749
1750\f
1751/* {GC Protection Helper Functions}
1752 */
1753
1754
0f2d19dd
JB		 1755void
1756scm_remember (ptr)
1757 SCM * ptr;
0f2d19dd
JB		 1758{}
1759
1cc91f1b 1760
0f2d19dd
JB		 1761#ifdef __STDC__
1762SCM
1763scm_return_first (SCM elt, ...)
1764#else
1765SCM
1766scm_return_first (elt, va_alist)
1767 SCM elt;
1768 va_dcl
1769#endif
1770{
1771 return elt;
1772}
1773
1774
0f2d19dd
JB		 1775SCM
1776scm_permanent_object (obj)
1777 SCM obj;
0f2d19dd
JB		 1778{
1779 SCM_REDEFER_INTS;
1780 scm_permobjs = scm_cons (obj, scm_permobjs);
1781 SCM_REALLOW_INTS;
1782 return obj;
1783}
1784
1785
ef290276
JB		 1786/* Protect OBJ from the garbage collector. OBJ will not be freed,
1787 even if all other references are dropped, until someone applies
1788 scm_unprotect_object to it. This function returns OBJ.
1789
1790 Note that calls to scm_protect_object do not nest. You can call
1791 scm_protect_object any number of times on a given object, and the
1792 next call to scm_unprotect_object will unprotect it completely.
1793
1794 Basically, scm_protect_object and scm_unprotect_object just
1795 maintain a list of references to things. Since the GC knows about
1796 this list, all objects it mentions stay alive. scm_protect_object
1797 adds its argument to the list; scm_unprotect_object remove its
1798 argument from the list. */
1799SCM
1800scm_protect_object (obj)
1801 SCM obj;
1802{
1803 /* This function really should use address hashing tables, but I
1804 don't know how to use them yet. For now we just use a list. */
1805 scm_protects = scm_cons (obj, scm_protects);
1806
1807 return obj;
1808}
1809
1810
1811/* Remove any protection for OBJ established by a prior call to
1812 scm_protect_obj. This function returns OBJ.
1813
1814 See scm_protect_obj for more information. */
1815SCM
1816scm_unprotect_object (obj)
1817 SCM obj;
1818{
1819 scm_protects = scm_delq_x (obj, scm_protects);
1820
1821 return obj;
1822}
1823
1824
0f2d19dd 1825\f
0f2d19dd
JB		 1826int
1827scm_init_storage (init_heap_size)
1828 long init_heap_size;
0f2d19dd
JB		 1829{
1830 scm_sizet j;
1831
1832 j = SCM_NUM_PROTECTS;
1833 while (j)
1834 scm_sys_protects[--j] = SCM_BOOL_F;
1835 scm_block_gc = 1;
1836 scm_freelist = SCM_EOL;
1837 scm_expmem = 0;
1838
1839 j = SCM_HEAP_SEG_SIZE;
1840 scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
1841 scm_heap_table = ((struct scm_heap_seg_data *)
1842 scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims"));
1843 if (0L == init_heap_size)
1844 init_heap_size = SCM_INIT_HEAP_SIZE;
1845 j = init_heap_size;
1846 if ((init_heap_size != j)
1847 || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
1848 {
1849 j = SCM_HEAP_SEG_SIZE;
1850 if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
1851 return 1;
1852 }
1853 else
1854 scm_expmem = 1;
1855 scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
1856 /* scm_hplims[0] can change. do not remove scm_heap_org */
1857 if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *))))
1858 return 1;
1859
1860 /* Initialise the list of ports. */
1861 scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table)
1862 * scm_port_table_room));
1863 if (!scm_port_table)
1864 return 1;
1865
1866
1867 scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
24e68a57 1868 SCM_SETCDR (scm_undefineds, scm_undefineds);
0f2d19dd
JB		 1869
1870 scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
1871 scm_nullstr = scm_makstr (0L, 0);
1872 scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED);
1873 scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
4037ac5f 1874 scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
0f2d19dd 1875 scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
8960e0a0 1876 scm_stand_in_procs = SCM_EOL;
0f2d19dd 1877 scm_permobjs = SCM_EOL;
ef290276 1878 scm_protects = SCM_EOL;
3b2b8760 1879 scm_asyncs = SCM_EOL;
0f2d19dd
JB		 1880 scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
1881 scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
1882#ifdef SCM_BIGDIG
1883 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD));
1884#endif
1885 return 0;
1886}
1887\f
1888
0f2d19dd
JB		 1889void
1890scm_init_gc ()
0f2d19dd
JB		 1891{
1892#include "gc.x"
1893}
Unnamed repository; edit this file 'description' to name the repository.