HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Simplify smob and port marking; set the mark bit in the generic
[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
e242dfd2 444 /* fprintf (stderr, "gc: %s\n", what); */
c68296f8 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;
dc53f026 822 SCM_SETGC8MARK (ptr);
ebf7394e
GH		 823 if (SCM_PTAB_ENTRY(ptr))
824 scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name);
dc53f026
JB		 825 if (scm_ptobs[i].mark)
826 {
827 ptr = (scm_ptobs[i].mark) (ptr);
828 goto gc_mark_loop;
829 }
830 else
831 return;
0f2d19dd
JB		 832 break;
833 case scm_tc7_smob:
834 if (SCM_GC8MARKP (ptr))
835 break;
dc53f026
JB		 836 SCM_SETGC8MARK (ptr);
837 switch SCM_GCTYP16 (ptr)
0f2d19dd
JB		 838 { /* should be faster than going through scm_smobs */
839 case scm_tc_free_cell:
840 /* printf("found free_cell %X ", ptr); fflush(stdout); */
24e68a57 841 SCM_SETCDR (ptr, SCM_EOL);
0f2d19dd
JB		 842 break;
843 case scm_tcs_bignums:
844 case scm_tc16_flo:
0f2d19dd
JB		 845 break;
846 default:
847 i = SCM_SMOBNUM (ptr);
848 if (!(i < scm_numsmob))
849 goto def;
dc53f026
JB		 850 if (scm_smobs[i].mark)
851 {
852 ptr = (scm_smobs[i].mark) (ptr);
853 goto gc_mark_loop;
854 }
855 else
856 return;
0f2d19dd
JB		 857 }
858 break;
859 default:
860 def:scm_wta (ptr, "unknown type in ", "gc_mark");
861 }
862}
863
864
865/* Mark a Region Conservatively
866 */
867
0f2d19dd
JB		 868void
869scm_mark_locations (x, n)
870 SCM_STACKITEM x[];
871 scm_sizet n;
0f2d19dd
JB		 872{
873 register long m = n;
874 register int i, j;
875 register SCM_CELLPTR ptr;
876
877 while (0 <= --m)
878 if SCM_CELLP (*(SCM **) & x[m])
879 {
880 ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
881 i = 0;
882 j = scm_n_heap_segs - 1;
883 if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
884 && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
885 {
886 while (i <= j)
887 {
888 int seg_id;
889 seg_id = -1;
890 if ( (i == j)
891 || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
892 seg_id = i;
893 else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
894 seg_id = j;
895 else
896 {
897 int k;
898 k = (i + j) / 2;
899 if (k == i)
900 break;
901 if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
902 {
903 j = k;
904 ++i;
905 if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
906 continue;
907 else
908 break;
909 }
910 else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
911 {
912 i = k;
913 --j;
914 if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
915 continue;
916 else
917 break;
918 }
919 }
920 if ( !scm_heap_table[seg_id].valid
921 || scm_heap_table[seg_id].valid (ptr,
922 &scm_heap_table[seg_id]))
923 scm_gc_mark (*(SCM *) & x[m]);
924 break;
925 }
926
927 }
928 }
929}
930
931
2e11a577
MD		 932/* The following is a C predicate which determines if an SCM value can be
933 regarded as a pointer to a cell on the heap. The code is duplicated
934 from scm_mark_locations. */
935
1cc91f1b 936
2e11a577
MD		 937int
938scm_cellp (value)
939 SCM value;
2e11a577
MD		 940{
941 register int i, j;
942 register SCM_CELLPTR ptr;
943
944 if SCM_CELLP (*(SCM **) & value)
945 {
946 ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
947 i = 0;
948 j = scm_n_heap_segs - 1;
949 if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
950 && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
951 {
952 while (i <= j)
953 {
954 int seg_id;
955 seg_id = -1;
956 if ( (i == j)
957 || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
958 seg_id = i;
959 else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
960 seg_id = j;
961 else
962 {
963 int k;
964 k = (i + j) / 2;
965 if (k == i)
966 break;
967 if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
968 {
969 j = k;
970 ++i;
971 if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
972 continue;
973 else
974 break;
975 }
976 else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
977 {
978 i = k;
979 --j;
980 if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
981 continue;
982 else
983 break;
984 }
985 }
986 if ( !scm_heap_table[seg_id].valid
987 || scm_heap_table[seg_id].valid (ptr,
988 &scm_heap_table[seg_id]))
989 return 1;
990 break;
991 }
992
993 }
994 }
995 return 0;
996}
997
998
3b2b8760 999static void
0f2d19dd 1000scm_mark_weak_vector_spines ()
0f2d19dd
JB		 1001{
1002 int i;
1003
1004 for (i = 0; i < scm_n_weak; ++i)
1005 {
1006 if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
1007 {
1008 SCM *ptr;
1009 SCM obj;
1010 int j;
1011 int n;
1012
1013 obj = scm_weak_vectors[i];
1014 ptr = SCM_VELTS (scm_weak_vectors[i]);
1015 n = SCM_LENGTH (scm_weak_vectors[i]);
1016 for (j = 0; j < n; ++j)
1017 {
1018 SCM alist;
1019
1020 alist = ptr[j];
1021 while ( SCM_NIMP (alist)
1022 && SCM_CONSP (alist)
1023 && !SCM_GCMARKP (alist)
1024 && SCM_NIMP (SCM_CAR (alist))
1025 && SCM_CONSP (SCM_CAR (alist)))
1026 {
1027 SCM_SETGCMARK (alist);
1028 SCM_SETGCMARK (SCM_CAR (alist));
1029 alist = SCM_GCCDR (alist);
1030 }
1031 }
1032 }
1033 }
1034}
1035
1036
1037
0f2d19dd
JB		 1038void
1039scm_gc_sweep ()
0f2d19dd
JB		 1040{
1041 register SCM_CELLPTR ptr;
1042#ifdef SCM_POINTERS_MUNGED
1043 register SCM scmptr;
1044#else
1045#undef scmptr
1046#define scmptr (SCM)ptr
1047#endif
1048 register SCM nfreelist;
1049 register SCM *hp_freelist;
1050 register long n;
1051 register long m;
1052 register scm_sizet j;
1053 register int span;
1054 scm_sizet i;
1055 scm_sizet seg_size;
1056
1057 n = 0;
1058 m = 0;
0f2d19dd 1059
cf2d30f6
JB		 1060 /* Reset all free list pointers. We'll reconstruct them completely
1061 while scanning. */
1062 for (i = 0; i < scm_n_heap_segs; i++)
1063 *scm_heap_table[i].freelistp = SCM_EOL;
1064
1065 for (i = 0; i < scm_n_heap_segs; i++)
0f2d19dd 1066 {
cf2d30f6
JB		 1067 /* Unmarked cells go onto the front of the freelist this heap
1068 segment points to. Rather than updating the real freelist
1069 pointer as we go along, we accumulate the new head in
1070 nfreelist. Then, if it turns out that the entire segment is
1071 free, we free (i.e., malloc's free) the whole segment, and
1072 simply don't assign nfreelist back into the real freelist. */
0f2d19dd 1073 hp_freelist = scm_heap_table[i].freelistp;
cf2d30f6
JB		 1074 nfreelist = *hp_freelist;
1075
0f2d19dd
JB		 1076 span = scm_heap_table[i].ncells;
1077 ptr = CELL_UP (scm_heap_table[i].bounds[0]);
1078 seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
0f2d19dd
JB		 1079 for (j = seg_size + span; j -= span; ptr += span)
1080 {
1081#ifdef SCM_POINTERS_MUNGED
1082 scmptr = PTR2SCM (ptr);
1083#endif
1084 switch SCM_TYP7 (scmptr)
1085 {
1086 case scm_tcs_cons_gloc:
1087 if (SCM_GCMARKP (scmptr))
1088 {
1089 if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1)
24e68a57 1090 SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0);
0f2d19dd
JB		 1091 goto cmrkcontinue;
1092 }
1093 {
1094 SCM vcell;
1095 vcell = SCM_CAR (scmptr) - 1L;
1096
1097 if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
1098 {
14d1400f
JB		 1099 SCM *p = (SCM *) SCM_GCCDR (scmptr);
1100 m += p[scm_struct_i_n_words] * sizeof (SCM);
1101 /* I feel like I'm programming in BCPL here... */
1102 free ((char *) p[scm_struct_i_ptr]);
0f2d19dd
JB		 1103 }
1104 }
1105 break;
1106 case scm_tcs_cons_imcar:
1107 case scm_tcs_cons_nimcar:
1108 case scm_tcs_closures:
1109 if (SCM_GCMARKP (scmptr))
1110 goto cmrkcontinue;
1111 break;
1112 case scm_tc7_wvect:
1113 if (SCM_GC8MARKP (scmptr))
1114 {
1115 goto c8mrkcontinue;
1116 }
1117 else
1118 {
1119 m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM);
1120 scm_must_free ((char *)(SCM_VELTS (scmptr) - 1));
1121 break;
1122 }
1123
1124 case scm_tc7_vector:
1125 case scm_tc7_lvector:
1126#ifdef CCLO
1127 case scm_tc7_cclo:
1128#endif
1129 if (SCM_GC8MARKP (scmptr))
1130 goto c8mrkcontinue;
1131
1132 m += (SCM_LENGTH (scmptr) * sizeof (SCM));
1133 freechars:
1134 scm_must_free (SCM_CHARS (scmptr));
1135 /* SCM_SETCHARS(scmptr, 0);*/
1136 break;
1137 case scm_tc7_bvect:
1138 if SCM_GC8MARKP (scmptr)
1139 goto c8mrkcontinue;
1140 m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
1141 goto freechars;
1142 case scm_tc7_byvect:
1143 if SCM_GC8MARKP (scmptr)
1144 goto c8mrkcontinue;
1145 m += SCM_HUGE_LENGTH (scmptr) * sizeof (char);
1146 goto freechars;
1147 case scm_tc7_ivect:
1148 case scm_tc7_uvect:
1149 if SCM_GC8MARKP (scmptr)
1150 goto c8mrkcontinue;
1151 m += SCM_HUGE_LENGTH (scmptr) * sizeof (long);
1152 goto freechars;
1153 case scm_tc7_svect:
1154 if SCM_GC8MARKP (scmptr)
1155 goto c8mrkcontinue;
1156 m += SCM_HUGE_LENGTH (scmptr) * sizeof (short);
1157 goto freechars;
1158#ifdef LONGLONGS
1159 case scm_tc7_llvect:
1160 if SCM_GC8MARKP (scmptr)
1161 goto c8mrkcontinue;
1162 m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long);
1163 goto freechars;
1164#endif
1165 case scm_tc7_fvect:
1166 if SCM_GC8MARKP (scmptr)
1167 goto c8mrkcontinue;
1168 m += SCM_HUGE_LENGTH (scmptr) * sizeof (float);
1169 goto freechars;
1170 case scm_tc7_dvect:
1171 if SCM_GC8MARKP (scmptr)
1172 goto c8mrkcontinue;
1173 m += SCM_HUGE_LENGTH (scmptr) * sizeof (double);
1174 goto freechars;
1175 case scm_tc7_cvect:
1176 if SCM_GC8MARKP (scmptr)
1177 goto c8mrkcontinue;
1178 m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
1179 goto freechars;
1180 case scm_tc7_substring:
0f2d19dd
JB		 1181 if (SCM_GC8MARKP (scmptr))
1182 goto c8mrkcontinue;
1183 break;
1184 case scm_tc7_string:
0f2d19dd
JB		 1185 if (SCM_GC8MARKP (scmptr))
1186 goto c8mrkcontinue;
1187 m += SCM_HUGE_LENGTH (scmptr) + 1;
1188 goto freechars;
1189 case scm_tc7_msymbol:
1190 if (SCM_GC8MARKP (scmptr))
1191 goto c8mrkcontinue;
1192 m += ( SCM_LENGTH (scmptr)
1193 + 1
1194 + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr)));
1195 scm_must_free ((char *)SCM_SLOTS (scmptr));
1196 break;
1197 case scm_tc7_contin:
1198 if SCM_GC8MARKP (scmptr)
1199 goto c8mrkcontinue;
0db18cf4 1200 m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
c68296f8
MV		 1201 if (SCM_VELTS (scmptr))
1202 goto freechars;
0f2d19dd
JB		 1203 case scm_tc7_ssymbol:
1204 if SCM_GC8MARKP(scmptr)
1205 goto c8mrkcontinue;
1206 break;
1207 case scm_tcs_subrs:
1208 continue;
1209 case scm_tc7_port:
1210 if SCM_GC8MARKP (scmptr)
1211 goto c8mrkcontinue;
1212 if SCM_OPENP (scmptr)
1213 {
1214 int k = SCM_PTOBNUM (scmptr);
1215 if (!(k < scm_numptob))
1216 goto sweeperr;
1217 /* Keep "revealed" ports alive. */
1218 if (scm_revealed_count(scmptr) > 0)
1219 continue;
1220 /* Yes, I really do mean scm_ptobs[k].free */
1221 /* rather than ftobs[k].close. .close */
1222 /* is for explicit CLOSE-PORT by user */
1223 (scm_ptobs[k].free) (SCM_STREAM (scmptr));
1224 SCM_SETSTREAM (scmptr, 0);
1225 scm_remove_from_port_table (scmptr);
1226 scm_gc_ports_collected++;
24e68a57 1227 SCM_SETAND_CAR (scmptr, ~SCM_OPN);
0f2d19dd
JB		 1228 }
1229 break;
1230 case scm_tc7_smob:
1231 switch SCM_GCTYP16 (scmptr)
1232 {
1233 case scm_tc_free_cell:
1234 if SCM_GC8MARKP (scmptr)
1235 goto c8mrkcontinue;
1236 break;
1237#ifdef SCM_BIGDIG
1238 case scm_tcs_bignums:
1239 if SCM_GC8MARKP (scmptr)
1240 goto c8mrkcontinue;
1241 m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT);
1242 goto freechars;
1243#endif /* def SCM_BIGDIG */
1244 case scm_tc16_flo:
1245 if SCM_GC8MARKP (scmptr)
1246 goto c8mrkcontinue;
1247 switch ((int) (SCM_CAR (scmptr) >> 16))
1248 {
1249 case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
1250 m += sizeof (double);
1251 case SCM_REAL_PART >> 16:
1252 case SCM_IMAG_PART >> 16:
1253 m += sizeof (double);
1254 goto freechars;
1255 case 0:
1256 break;
1257 default:
1258 goto sweeperr;
1259 }
1260 break;
1261 default:
1262 if SCM_GC8MARKP (scmptr)
1263 goto c8mrkcontinue;
1264
1265 {
1266 int k;
1267 k = SCM_SMOBNUM (scmptr);
1268 if (!(k < scm_numsmob))
1269 goto sweeperr;
1270 m += (scm_smobs[k].free) ((SCM) scmptr);
1271 break;
1272 }
1273 }
1274 break;
1275 default:
1276 sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep");
1277 }
1278 n += span;
1279#if 0
1280 if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
1281 exit (2);
1282#endif
e7c5fb37
JB		 1283 /* Stick the new cell on the front of nfreelist. It's
1284 critical that we mark this cell as freed; otherwise, the
1285 conservative collector might trace it as some other type
1286 of object. */
24e68a57
MD		 1287 SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
1288 SCM_SETCDR (scmptr, nfreelist);
0f2d19dd 1289 nfreelist = scmptr;
cf2d30f6 1290
0f2d19dd
JB		 1291 continue;
1292 c8mrkcontinue:
1293 SCM_CLRGC8MARK (scmptr);
1294 continue;
1295 cmrkcontinue:
1296 SCM_CLRGCMARK (scmptr);
1297 }
1298#ifdef GC_FREE_SEGMENTS
1299 if (n == seg_size)
1300 {
1301 scm_heap_size -= seg_size;
6f3067f1 1302 n = 0;
cf2d30f6
JB		 1303 free ((char *) scm_heap_table[i].bounds[0]);
1304 scm_heap_table[i].bounds[0] = 0;
1305 for (j = i + 1; j < scm_n_heap_segs; j++)
0f2d19dd
JB		 1306 scm_heap_table[j - 1] = scm_heap_table[j];
1307 scm_n_heap_segs -= 1;
cf2d30f6 1308 i--; /* We need to scan the segment just moved. */
0f2d19dd
JB		 1309 }
1310 else
1311#endif /* ifdef GC_FREE_SEGMENTS */
cf2d30f6
JB		 1312 /* Update the real freelist pointer to point to the head of
1313 the list of free cells we've built for this segment. */
0f2d19dd
JB		 1314 *hp_freelist = nfreelist;
1315
cf2d30f6
JB		 1316#ifdef DEBUG_FREELIST
1317 scm_check_freelist ();
1318 scm_map_free_list ();
1319#endif
1320
0f2d19dd
JB		 1321 scm_gc_cells_collected += n;
1322 n = 0;
1323 }
1324 /* Scan weak vectors. */
1325 {
1326 SCM *ptr;
1327 for (i = 0; i < scm_n_weak; ++i)
1328 {
1329 if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
1330 {
1331 ptr = SCM_VELTS (scm_weak_vectors[i]);
1332 n = SCM_LENGTH (scm_weak_vectors[i]);
1333 for (j = 0; j < n; ++j)
1334 if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j]))
1335 ptr[j] = SCM_BOOL_F;
1336 }
1337 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1338 {
1339 SCM obj;
1340 obj = scm_weak_vectors[i];
1341 ptr = SCM_VELTS (scm_weak_vectors[i]);
1342 n = SCM_LENGTH (scm_weak_vectors[i]);
1343 for (j = 0; j < n; ++j)
1344 {
1345 SCM * fixup;
1346 SCM alist;
1347 int weak_keys;
1348 int weak_values;
1349
1350 weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
1351 weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
1352
1353 fixup = ptr + j;
1354 alist = *fixup;
1355
1356 while (SCM_NIMP (alist)
1357 && SCM_CONSP (alist)
1358 && SCM_NIMP (SCM_CAR (alist))
1359 && SCM_CONSP (SCM_CAR (alist)))
1360 {
1361 SCM key;
1362 SCM value;
1363
1364 key = SCM_CAAR (alist);
1365 value = SCM_CDAR (alist);
1366 if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key))
1367 || (weak_values && SCM_NIMP (value) && SCM_FREEP (value)))
1368 {
1369 *fixup = SCM_CDR (alist);
1370 }
1371 else
24e68a57 1372 fixup = SCM_CDRLOC (alist);
0f2d19dd
JB		 1373 alist = SCM_CDR (alist);
1374 }
1375 }
1376 }
1377 }
1378 }
1379 scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected);
1380 scm_mallocated -= m;
1381 scm_gc_malloc_collected = m;
1382}
1383
1384
1385\f
1386
1387/* {Front end to malloc}
1388 *
c68296f8 1389 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
0f2d19dd
JB		 1390 *
1391 * These functions provide services comperable to malloc, realloc, and
1392 * free. They are for allocating malloced parts of scheme objects.
1393 * The primary purpose of the front end is to impose calls to gc.
1394 */
1395
1396/* scm_must_malloc
1397 * Return newly malloced storage or throw an error.
1398 *
1399 * The parameter WHAT is a string for error reporting.
1400 * If the threshold scm_mtrigger will be passed by this
1401 * allocation, or if the first call to malloc fails,
1402 * garbage collect -- on the presumption that some objects
1403 * using malloced storage may be collected.
1404 *
1405 * The limit scm_mtrigger may be raised by this allocation.
1406 */
0f2d19dd
JB		 1407char *
1408scm_must_malloc (len, what)
1409 long len;
1410 char *what;
0f2d19dd
JB		 1411{
1412 char *ptr;
1413 scm_sizet size = len;
1414 long nm = scm_mallocated + size;
1415 if (len != size)
1416 malerr:
1417 scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
1418 if ((nm <= scm_mtrigger))
1419 {
1420 SCM_SYSCALL (ptr = (char *) malloc (size));
1421 if (NULL != ptr)
1422 {
1423 scm_mallocated = nm;
1424 return ptr;
1425 }
1426 }
6064dcc6 1427
0f2d19dd
JB		 1428 scm_igc (what);
1429 nm = scm_mallocated + size;
1430 SCM_SYSCALL (ptr = (char *) malloc (size));
1431 if (NULL != ptr)
1432 {
1433 scm_mallocated = nm;
6064dcc6
MV		 1434 if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
1435 if (nm > scm_mtrigger)
1436 scm_mtrigger = nm + nm / 2;
1437 else
1438 scm_mtrigger += scm_mtrigger / 2;
1439 }
0f2d19dd
JB		 1440 return ptr;
1441 }
1442 goto malerr;
1443}
1444
1445
1446/* scm_must_realloc
1447 * is similar to scm_must_malloc.
1448 */
0f2d19dd
JB		 1449char *
1450scm_must_realloc (where, olen, len, what)
1451 char *where;
1452 long olen;
1453 long len;
1454 char *what;
0f2d19dd
JB		 1455{
1456 char *ptr;
1457 scm_sizet size = len;
1458 long nm = scm_mallocated + size - olen;
1459 if (len != size)
1460 ralerr:
1461 scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
1462 if ((nm <= scm_mtrigger))
1463 {
1464 SCM_SYSCALL (ptr = (char *) realloc (where, size));
1465 if (NULL != ptr)
1466 {
1467 scm_mallocated = nm;
1468 return ptr;
1469 }
1470 }
1471 scm_igc (what);
1472 nm = scm_mallocated + size - olen;
1473 SCM_SYSCALL (ptr = (char *) realloc (where, size));
1474 if (NULL != ptr)
1475 {
1476 scm_mallocated = nm;
6064dcc6
MV		 1477 if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
1478 if (nm > scm_mtrigger)
1479 scm_mtrigger = nm + nm / 2;
1480 else
1481 scm_mtrigger += scm_mtrigger / 2;
1482 }
0f2d19dd
JB		 1483 return ptr;
1484 }
1485 goto ralerr;
1486}
1487
0f2d19dd
JB		 1488void
1489scm_must_free (obj)
1490 char *obj;
0f2d19dd
JB		 1491{
1492 if (obj)
1493 free (obj);
1494 else
1495 scm_wta (SCM_INUM0, "already free", "");
1496}
0f2d19dd 1497
c68296f8
MV		 1498/* Announce that there has been some malloc done that will be freed
1499 * during gc. A typical use is for a smob that uses some malloced
1500 * memory but can not get it from scm_must_malloc (for whatever
1501 * reason). When a new object of this smob is created you call
1502 * scm_done_malloc with the size of the object. When your smob free
1503 * function is called, be sure to include this size in the return
1504 * value. */
0f2d19dd 1505
c68296f8
MV		 1506void
1507scm_done_malloc (size)
1508 long size;
1509{
1510 scm_mallocated += size;
1511
1512 if (scm_mallocated > scm_mtrigger)
1513 {
1514 scm_igc ("foreign mallocs");
1515 if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS)
1516 {
1517 if (scm_mallocated > scm_mtrigger)
1518 scm_mtrigger = scm_mallocated + scm_mallocated / 2;
1519 else
1520 scm_mtrigger += scm_mtrigger / 2;
1521 }
1522 }
1523}
1524
1525
1526\f
0f2d19dd
JB		 1527
1528/* {Heap Segments}
1529 *
1530 * Each heap segment is an array of objects of a particular size.
1531 * Every segment has an associated (possibly shared) freelist.
1532 * A table of segment records is kept that records the upper and
1533 * lower extents of the segment; this is used during the conservative
1534 * phase of gc to identify probably gc roots (because they point
c68296f8 1535 * into valid segments at reasonable offsets). */
0f2d19dd
JB		 1536
1537/* scm_expmem
1538 * is true if the first segment was smaller than INIT_HEAP_SEG.
1539 * If scm_expmem is set to one, subsequent segment allocations will
1540 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1541 */
1542int scm_expmem = 0;
1543
1544/* scm_heap_org
1545 * is the lowest base address of any heap segment.
1546 */
1547SCM_CELLPTR scm_heap_org;
1548
1549struct scm_heap_seg_data * scm_heap_table = 0;
1550int scm_n_heap_segs = 0;
1551
1552/* scm_heap_size
1553 * is the total number of cells in heap segments.
1554 */
1555long scm_heap_size = 0;
1556
1557/* init_heap_seg
1558 * initializes a new heap segment and return the number of objects it contains.
1559 *
1560 * The segment origin, segment size in bytes, and the span of objects
1561 * in cells are input parameters. The freelist is both input and output.
1562 *
1563 * This function presume that the scm_heap_table has already been expanded
1564 * to accomodate a new segment record.
1565 */
1566
1567
0f2d19dd
JB		 1568static scm_sizet
1569init_heap_seg (seg_org, size, ncells, freelistp)
1570 SCM_CELLPTR seg_org;
1571 scm_sizet size;
1572 int ncells;
1573 SCM *freelistp;
0f2d19dd
JB		 1574{
1575 register SCM_CELLPTR ptr;
1576#ifdef SCM_POINTERS_MUNGED
1577 register SCM scmptr;
1578#else
1579#undef scmptr
1580#define scmptr ptr
1581#endif
1582 SCM_CELLPTR seg_end;
1583 scm_sizet new_seg_index;
1584 scm_sizet n_new_objects;
1585
1586 if (seg_org == NULL)
1587 return 0;
1588
1589 ptr = seg_org;
1590
1591 /* Compute the ceiling on valid object pointers w/in this segment.
1592 */
1593 seg_end = CELL_DN ((char *) ptr + size);
1594
1595 /* Find the right place and insert the segment record.
1596 *
1597 */
1598 for (new_seg_index = 0;
1599 ( (new_seg_index < scm_n_heap_segs)
1600 && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
1601 new_seg_index++)
1602 ;
1603
1604 {
1605 int i;
1606 for (i = scm_n_heap_segs; i > new_seg_index; --i)
1607 scm_heap_table[i] = scm_heap_table[i - 1];
1608 }
1609
1610 ++scm_n_heap_segs;
1611
1612 scm_heap_table[new_seg_index].valid = 0;
1613 scm_heap_table[new_seg_index].ncells = ncells;
1614 scm_heap_table[new_seg_index].freelistp = freelistp;
1615 scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr;
1616 scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end;
1617
1618
1619 /* Compute the least valid object pointer w/in this segment
1620 */
1621 ptr = CELL_UP (ptr);
1622
1623
1624 n_new_objects = seg_end - ptr;
1625
1626 /* Prepend objects in this segment to the freelist.
1627 */
1628 while (ptr < seg_end)
1629 {
1630#ifdef SCM_POINTERS_MUNGED
1631 scmptr = PTR2SCM (ptr);
1632#endif
24e68a57
MD		 1633 SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
1634 SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells));
0f2d19dd
JB		 1635 ptr += ncells;
1636 }
1637
1638 ptr -= ncells;
1639
1640 /* Patch up the last freelist pointer in the segment
1641 * to join it to the input freelist.
1642 */
24e68a57 1643 SCM_SETCDR (PTR2SCM (ptr), *freelistp);
0f2d19dd
JB		 1644 *freelistp = PTR2SCM (CELL_UP (seg_org));
1645
1646 scm_heap_size += (ncells * n_new_objects);
1647 return size;
1648#ifdef scmptr
1649#undef scmptr
1650#endif
1651}
1652
1653
0f2d19dd
JB		 1654static void
1655alloc_some_heap (ncells, freelistp)
1656 int ncells;
1657 SCM * freelistp;
0f2d19dd
JB		 1658{
1659 struct scm_heap_seg_data * tmptable;
1660 SCM_CELLPTR ptr;
1661 scm_sizet len;
1662
1663 /* Critical code sections (such as the garbage collector)
1664 * aren't supposed to add heap segments.
1665 */
1666 if (scm_gc_heap_lock)
1667 scm_wta (SCM_UNDEFINED, "need larger initial", "heap");
1668
1669 /* Expand the heap tables to have room for the new segment.
1670 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1671 * only if the allocation of the segment itself succeeds.
1672 */
1673 len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data);
1674
1675 SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *)
1676 realloc ((char *)scm_heap_table, len)));
1677 if (!tmptable)
1678 scm_wta (SCM_UNDEFINED, "could not grow", "hplims");
1679 else
1680 scm_heap_table = tmptable;
1681
1682
1683 /* Pick a size for the new heap segment.
1684 * The rule for picking the size of a segment is explained in
1685 * gc.h
1686 */
1687 if (scm_expmem)
1688 {
1689 len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell));
1690 if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len)
1691 len = 0;
1692 }
1693 else
1694 len = SCM_HEAP_SEG_SIZE;
1695
1696 {
1697 scm_sizet smallest;
1698
1699 smallest = (ncells * sizeof (scm_cell));
1700 if (len < smallest)
1701 len = (ncells * sizeof (scm_cell));
1702
1703 /* Allocate with decaying ambition. */
1704 while ((len >= SCM_MIN_HEAP_SEG_SIZE)
1705 && (len >= smallest))
1706 {
1707 SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len));
1708 if (ptr)
1709 {
1710 init_heap_seg (ptr, len, ncells, freelistp);
1711 return;
1712 }
1713 len /= 2;
1714 }
1715 }
1716
1717 scm_wta (SCM_UNDEFINED, "could not grow", "heap");
1718}
1719
1720
1721
1722SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
0f2d19dd
JB		 1723SCM
1724scm_unhash_name (name)
1725 SCM name;
0f2d19dd
JB		 1726{
1727 int x;
1728 int bound;
1729 SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name);
1730 SCM_DEFER_INTS;
1731 bound = scm_n_heap_segs;
1732 for (x = 0; x < bound; ++x)
1733 {
1734 SCM_CELLPTR p;
1735 SCM_CELLPTR pbound;
1736 p = (SCM_CELLPTR)scm_heap_table[x].bounds[0];
1737 pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1];
1738 while (p < pbound)
1739 {
1740 SCM incar;
1741 incar = p->car;
1742 if (1 == (7 & (int)incar))
1743 {
1744 --incar;
1745 if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
1746 && (SCM_CDR (incar) != 0)
1747 && (SCM_CDR (incar) != 1))
1748 {
1749 p->car = name;
1750 }
1751 }
1752 ++p;
1753 }
1754 }
1755 SCM_ALLOW_INTS;
1756 return name;
1757}
1758
1759
1760\f
1761/* {GC Protection Helper Functions}
1762 */
1763
1764
0f2d19dd
JB		 1765void
1766scm_remember (ptr)
1767 SCM * ptr;
0f2d19dd
JB		 1768{}
1769
1cc91f1b 1770
0f2d19dd
JB		 1771#ifdef __STDC__
1772SCM
1773scm_return_first (SCM elt, ...)
1774#else
1775SCM
1776scm_return_first (elt, va_alist)
1777 SCM elt;
1778 va_dcl
1779#endif
1780{
1781 return elt;
1782}
1783
1784
0f2d19dd
JB		 1785SCM
1786scm_permanent_object (obj)
1787 SCM obj;
0f2d19dd
JB		 1788{
1789 SCM_REDEFER_INTS;
1790 scm_permobjs = scm_cons (obj, scm_permobjs);
1791 SCM_REALLOW_INTS;
1792 return obj;
1793}
1794
1795
ef290276
JB		 1796/* Protect OBJ from the garbage collector. OBJ will not be freed,
1797 even if all other references are dropped, until someone applies
1798 scm_unprotect_object to it. This function returns OBJ.
1799
1800 Note that calls to scm_protect_object do not nest. You can call
1801 scm_protect_object any number of times on a given object, and the
1802 next call to scm_unprotect_object will unprotect it completely.
1803
1804 Basically, scm_protect_object and scm_unprotect_object just
1805 maintain a list of references to things. Since the GC knows about
1806 this list, all objects it mentions stay alive. scm_protect_object
1807 adds its argument to the list; scm_unprotect_object remove its
1808 argument from the list. */
1809SCM
1810scm_protect_object (obj)
1811 SCM obj;
1812{
1813 /* This function really should use address hashing tables, but I
1814 don't know how to use them yet. For now we just use a list. */
1815 scm_protects = scm_cons (obj, scm_protects);
1816
1817 return obj;
1818}
1819
1820
1821/* Remove any protection for OBJ established by a prior call to
1822 scm_protect_obj. This function returns OBJ.
1823
1824 See scm_protect_obj for more information. */
1825SCM
1826scm_unprotect_object (obj)
1827 SCM obj;
1828{
1829 scm_protects = scm_delq_x (obj, scm_protects);
1830
1831 return obj;
1832}
1833
1834
0f2d19dd 1835\f
0f2d19dd
JB		 1836int
1837scm_init_storage (init_heap_size)
1838 long init_heap_size;
0f2d19dd
JB		 1839{
1840 scm_sizet j;
1841
1842 j = SCM_NUM_PROTECTS;
1843 while (j)
1844 scm_sys_protects[--j] = SCM_BOOL_F;
1845 scm_block_gc = 1;
1846 scm_freelist = SCM_EOL;
1847 scm_expmem = 0;
1848
1849 j = SCM_HEAP_SEG_SIZE;
1850 scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
1851 scm_heap_table = ((struct scm_heap_seg_data *)
1852 scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims"));
1853 if (0L == init_heap_size)
1854 init_heap_size = SCM_INIT_HEAP_SIZE;
1855 j = init_heap_size;
1856 if ((init_heap_size != j)
1857 || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
1858 {
1859 j = SCM_HEAP_SEG_SIZE;
1860 if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
1861 return 1;
1862 }
1863 else
1864 scm_expmem = 1;
1865 scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
1866 /* scm_hplims[0] can change. do not remove scm_heap_org */
1867 if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *))))
1868 return 1;
1869
1870 /* Initialise the list of ports. */
1871 scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table)
1872 * scm_port_table_room));
1873 if (!scm_port_table)
1874 return 1;
1875
1876
1877 scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
24e68a57 1878 SCM_SETCDR (scm_undefineds, scm_undefineds);
0f2d19dd
JB		 1879
1880 scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
1881 scm_nullstr = scm_makstr (0L, 0);
a8741caa
MD		 1882 scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED);
1883 scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL);
4037ac5f 1884 scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
a8741caa 1885 scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL);
8960e0a0 1886 scm_stand_in_procs = SCM_EOL;
0f2d19dd 1887 scm_permobjs = SCM_EOL;
ef290276 1888 scm_protects = SCM_EOL;
3b2b8760 1889 scm_asyncs = SCM_EOL;
0f2d19dd
JB		 1890 scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
1891 scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
1892#ifdef SCM_BIGDIG
1893 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD));
1894#endif
1895 return 0;
1896}
1897\f
1898
0f2d19dd
JB		 1899void
1900scm_init_gc ()
0f2d19dd
JB		 1901{
1902#include "gc.x"
1903}
Unnamed repository; edit this file 'description' to name the repository.