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