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