1 /* -*- tab-width:4; -*- */
2 /*
3 * Heap allocation and garbage collection
4 *
5 * $Id: heap.c 1.33 Mon, 20 Mar 2000 00:26:37 +0100 crad $
6 */
7 #include "s.h"
8 /* #include "gc.h" */
9 #include <string.h>
10
11 /* #define DEBUG_GC_PHASE */
12 /* #define SUPER_SAFE_GC */
13
14 int scm_gc_verbose = FALSE;
15 int scm_in_gc = 0; /* true during gc */
16
17 struct gc_protected {
18 SOBJ *location; /* location to protect */
19 struct gc_protected *next;
20 };
21
22 static struct gc_protected *protected_cells; /* list of protected cell */
23
24 /* This is the heap block descriptor.
25 *
26 * A heap block is a memory block where we store Sobject structure.
27 *
28 * Note: The mblock pointer points to the block allocated with
29 * malloc. Because of odd alignement, the base pointer may point to a
30 * different address.
31 * */
32
33 typedef struct _SCM_HEAP_BLOCK {
34 struct _SCM_HEAP_BLOCK *next; /* next heap block */
35 int size; /* size of this block */
36 void *mblock; /* memory block obtained with alloc */
37 SOBJ base; /* points to base of heap */
38 SOBJ limit; /* points to limit of heap */
39 SOBJ ptr; /* points to next cell to be allocated */
40 } SCM_HEAP_BLOCK;
41
42 /* List of heap block descriptor. The newest heap block are first in
43 * list.
44 */
45
46 static SCM_HEAP_BLOCK *scm_heap_list;
47
48 /* List of free cells contained between base and ptr of all heap
49 * blocks. after gc(), free nodes from the older heap are on top of
50 * the free list, so we try to reuse space from old heap first.
51 */
52
53 static SOBJ scm_hfree;
54
55 /*-- heap variables */
56 #ifdef OLD
57 SOBJ scm_hbase, scm_hptr, scm_hlimit, scm_hfree, scm_hwater;
58 long scm_hsize;
59 #endif
60
61 /* This variable holds statistic of gc run */
62 int gcmarked, gcfree;
63
64 /* This keeps track of successive calls to scm_must_alloc / scm_free
65 */
66 long scm_cells_allocated;
67 long scm_malloc_allocated;
68 long scm_global_heap_size; /* size of all heap block */
69
70 /****************************************************************
71 * Malloc utilities
72 ****************************************************************/
73
74 /* Alloc a memory block or exit with an error message.
75 */
scm_must_alloc(long size)76 void *scm_must_alloc(long size)
77 {
78 void *p = malloc(size);
79 #ifdef DEBUG
80 fprintf(stderr, "scm_must_alloc: %ld bytes\n", size);
81 #endif
82 if (p == NULL) {
83 fprintf(stderr, "out of memory\n");
84 exit(1);
85 }
86 memset(p, 0, size);
87 scm_malloc_allocated++;
88 return(p);
89 }
90
91 /* Alloc a fresh block and copy data from the old one.
92 */
scm_must_realloc(void * mem,long size)93 void *scm_must_realloc(void *mem, long size)
94 {
95 void *p = realloc(mem, size);
96 if (p == NULL) {
97 fprintf(stderr, "out of memory\n");
98 exit(1);
99 }
100 return(p);
101 }
102
103 /* Alloc a new block and copy a string into it.
104 */
scm_must_strdup(char * str)105 char *scm_must_strdup(char *str)
106 {
107 char *p = scm_must_alloc(strlen(str) + 1);
108 strcpy(p, str);
109 return(p);
110 }
111
112 /* Clear a memory block
113 */
scm_mem_clear(void * mem,long size)114 void scm_mem_clear(void *mem, long size)
115 {
116 memset(mem, 0, size);
117 }
118
119 /* Release a memory block. Decrements the scm_malloc_allocated counter
120 */
scm_free(void * mem)121 void scm_free(void *mem)
122 {
123 if (mem) { scm_malloc_allocated--; free(mem); }
124 }
125
126 /****************************************************************
127 * Heap blocks utilities
128 ****************************************************************/
129
130 /* Add a new heap block in front of the heap list
131 */
scm_add_heap_block(int size)132 static void scm_add_heap_block(int size)
133 {
134 SCM_HEAP_BLOCK *hb = scm_must_alloc(sizeof(SCM_HEAP_BLOCK));
135
136 /* 2 more byte for alignement purpose */
137 hb->mblock = scm_must_alloc((size * sizeof(Sobject)) + 2);
138
139 hb->size = size;
140 hb->base = hb->mblock + ((long)hb->mblock & 1);
141 hb->limit = hb->base + size;
142 hb->ptr = hb->base;
143 hb->next = scm_heap_list;
144 scm_heap_list = hb;
145 scm_global_heap_size += size;
146 }
147
148 /* Display some statistics about usage of a block heap
149 */
scm_heap_block_stats(SCM_HEAP_BLOCK * h)150 static void scm_heap_block_stats(SCM_HEAP_BLOCK *h)
151 {
152 scm_puts("; heap block @"); scm_putx(h);
153 scm_puts(" size="); scm_putn(h->size);
154 scm_puts(" used="); scm_putn(h->ptr - h->base);
155 scm_puts(" free="); scm_putn(h->limit - h->ptr);
156 scm_puts("\n");
157 }
158
159 /* Display stat about all heap block */
scm_heap_stat()160 void scm_heap_stat()
161 {
162 SCM_HEAP_BLOCK *h;
163 for (h = scm_heap_list; h; h = h->next) {
164 scm_heap_block_stats(h);
165 }
166 scm_puts("; malloced "); scm_putn(scm_malloc_allocated);
167 scm_puts("\n; gc: marked "); scm_putn(gcmarked);
168 scm_puts(", free "); scm_putn(gcfree);
169 scm_puts("\n");
170 }
171
172 /* Test if a pointer is a valid member of any heap block of the heap
173 * block list.
174 *
175 * The pointer is tested against the heap block limit and also if it
176 * points to a valid object. An valid pointer object is correctly
177 * aligned and points to a valid Sobject structure.
178 */
scm_is_pointer_to_heap(void * p)179 int scm_is_pointer_to_heap(void *p)
180 {
181 SCM_HEAP_BLOCK *h;
182
183 if ( (long)p & 1) /* ignore odd pointers */
184 return(FALSE);
185
186 for (h = scm_heap_list; h; h = h->next) {
187 if ((SOBJ)p >= h->base && (SOBJ)p < h->ptr &&
188 ((p - (void*)h->base) % sizeof(Sobject)) == 0)
189 return(TRUE);
190 }
191 return(FALSE);
192 }
193
194 /****************************************************************
195 * Garbage collection
196 ****************************************************************/
197
198 /* Keep track of pointer to objects which are not stored in the heap.
199 * Note: reference are not stored twice.
200 */
scm_gc_protect(SOBJ * location)201 void scm_gc_protect(SOBJ *location)
202 {
203 struct gc_protected *p;
204
205 for (p = protected_cells; p; p = p->next) {
206 if (p->location == location) {
207 #ifdef DEBUG
208 fprintf(stderr, "gc_protect: location %p already registered\n",
209 p->location);
210 #endif
211 return;
212 }
213 }
214
215 p = (struct gc_protected *) scm_must_alloc(sizeof(struct gc_protected));
216
217 p->location = location;
218 p->next = protected_cells;
219 protected_cells = p;
220 }
221
222 #ifdef SUPER_SAFE_GC
scm_is_protected(SOBJ obj)223 static int scm_is_protected(SOBJ obj)
224 {
225 struct gc_protected *p;
226 printf("scm_is_protected: %p\n", obj);
227 for (p = protected_cells; p; p = p->next) {
228 if (*(p->location) == obj)
229 return(TRUE);
230 }
231 return(FALSE);
232 }
233 #endif
234
235 /*-- mark a cell as used */
236
scm_gc_mark(SOBJ obj)237 void scm_gc_mark(SOBJ obj)
238 {
239 int t;
240
241 if (obj == NULL || SCM_INUMP(obj) || SCM_GCBIT(obj))
242 return;
243
244 t = SCM_OBJTYPE(obj);
245 SCM_GCBIT_SET(obj);
246 gcmarked++;
247 switch(t) {
248 case SOBJ_T_PAIR: scm_gc_mark(SCM_CAR(obj)); scm_gc_mark(SCM_CDR(obj));
249 return;
250 case SOBJ_T_BNUM: return;
251 case SOBJ_T_FNUM: return;
252 case SOBJ_T_LSYMBOL:
253
254 /* Do we really need to mark atoms that are anyway referenced by
255 * the atom_hash ? :)
256 */
257 /* scm_gc_mark(SCM_LSYM_SYM(obj)); */
258 return;
259 case SOBJ_T_CPRIM: return;
260
261 default:
262 #ifdef SUPER_SAFE_GC
263 if (!scm_is_pointer_to_heap(obj) &&
264 !((obj >= (SOBJ)scm_sp) && (obj < (SOBJ)scm_stack_limit)) &&
265 !scm_is_protected(obj)) {
266 fprintf(stderr, "OOPS: object %p (type=%d) does not point to heap\n",
267 obj, obj->type & 0x3fff);
268 }
269 #endif
270 if (t < SOBJ_T_MAX && scm_type_hook[t].mark != NULL)
271 (*scm_type_hook[t].mark)(obj);
272 }
273 }
274
275 /* Mark location from protected object list
276 */
scm_gc_mark_protected()277 static void scm_gc_mark_protected()
278 {
279 struct gc_protected *p;
280
281 p = protected_cells;
282 while(p) {
283 scm_gc_mark(*(p->location));
284 p = p->next;
285 }
286 }
287
288 /* Mark pointers that are stored on the VM stack.
289 */
scm_gc_mark_stacks()290 static void scm_gc_mark_stacks()
291 {
292 SOBJ p, *pp;
293 SCM_VMD *v = scm_vmd();
294
295 pp = v->reg.sp;
296 while(pp < v->stack_limit) {
297 p = *pp++;
298 if (scm_is_pointer_to_heap(p)) scm_gc_mark(p);
299 }
300 }
301
302 /* Try to mark pointers that are stored on the system stack and in the
303 * CPU registers.
304 */
scm_gc_mark_cstack()305 static void scm_gc_mark_cstack()
306 {
307 #ifdef SCM_WITH_THREADS
308 SOBJ *pp;
309 SOBJ node;
310 SCM_VMD *v;
311
312 for (node = scm_thread_list; node; node = SCM_CDR(node)) {
313 v = SCM_AUX(SCM_CAR(node));
314 if ((v->tflags & SCM_THREAD_FINISHED) != 0) continue;
315 #ifdef DEBUG
316 fprintf(stderr, "scm_gc_mark_cstack: tid=%d stackrange=[%p %p]\n",
317 v->tid, v->cstack_ptr, v->cstack_limit);
318 #endif
319
320 pp = v->cstack_ptr;
321 while(pp < (SOBJ*)v->cstack_limit) {
322 if (scm_is_pointer_to_heap(*pp)) {
323 #ifdef DEBUG
324 fprintf(stderr, "scm_gc_mark_cstack: marking %p\n", *pp);
325 #endif
326 scm_gc_mark(*pp);
327 }
328 pp++;
329 }
330 }
331
332 #else /* ! SCM_WITH_THREADS */
333 SOBJ *pp;
334 jmp_buf regs;
335
336 /* save the registers on the stack and mark registers */
337 setjmp(regs);
338 pp = (SOBJ*)®s;
339 #ifdef DEBUG
340 fprintf(scm_stdout, "; marking the registers\n");
341 #endif
342 while((void*)pp < ((void*)regs) + sizeof(regs)) {
343 if (scm_is_pointer_to_heap(*pp)) {
344 #ifdef DEBUG
345 fprintf(stderr, "; found plausible reg=%p\n", *pp);
346 #endif
347 scm_gc_mark(*pp);
348 }
349 pp++;
350 }
351
352 pp = (SOBJ*)&pp;
353 #ifdef DEBUG
354 fprintf(stderr, "; marking the cstack beween %p and %p\n", pp, scm_cstack_start);
355 #endif
356 while((void*)pp < (void*)scm_cstack_limit) {
357 if (scm_is_pointer_to_heap(*pp)) {
358 #ifdef DEBUG
359 fprintf(stderr, "; found plausible ptr: (%p)=%p\n", pp, *pp);
360 #endif
361 scm_gc_mark(*pp);
362 }
363 pp++;
364 }
365 #endif /* SCM_WITH_THREADS */
366 }
367
368 /* Prepare mark by clearing the mark bit of each cells.
369 *
370 * Note: the mark bit shoud never be set and normaly does not need to
371 * be cleared. This routine is more a sanity check than something
372 * really needed.
373 */
scm_gc_clear_gcmark()374 static void scm_gc_clear_gcmark()
375 {
376 SCM_HEAP_BLOCK *h;
377 SOBJ p;
378
379 #ifdef DEBUG_GC_PHASE
380 fprintf(stderr, " clearing gcmark\n");
381 #endif
382 for (h = scm_heap_list; h; h = h->next) {
383 p = h->base;
384 while(p < h->ptr) {
385 if (SCM_GCBIT(p)) {
386 SCM_GCBIT_CLR(p);
387 scm_puts("; gc: cell at "); scm_putx(p);
388 scm_puts(" had gcmark != 0, obj=");
389 scm_cprint(p);
390 }
391 p++;
392 }
393 }
394 }
395
396
397 /* Add free cells to scm_hfree list.
398 * Make some efforts to lower the ptr of the heap block when possible.
399 */
scm_gc_sweep_block(SCM_HEAP_BLOCK * h)400 static void scm_gc_sweep_block(SCM_HEAP_BLOCK *h)
401 {
402 SOBJ p;
403 int t;
404
405 #ifdef DEBUG_GC_PHASE
406 fprintf(stderr, " compressing heap\n");
407 #endif
408 p = h->ptr - 1;
409 while(p >= h->base) {
410 if (SCM_GCBIT(p)) break;
411 #ifdef DEBUG
412 fprintf(stdout, "; gc : removing node at %p: ", p); scm_print(p);
413 #endif
414 t = SCM_OBJTYPE(p);
415 if (t < SOBJ_T_MAX) {
416 if (scm_type_hook[t].sweep != NULL)
417 (*scm_type_hook[t].sweep)(p);
418
419 if (scm_type_hook[t].finalize != NULL) {
420 printf("; gc : calling finalizer for type '%s'\n",
421 scm_type_hook[t].name);
422 scm_apply1(scm_type_hook[t].finalize, p);
423 }
424 }
425
426 h->ptr = p;
427 p--;
428 }
429
430 while(p >= h->base) {
431 if (SCM_GCBIT(p) == 0) {
432 #ifdef DEBUG
433 fprintf(scm_stdout, "; gc : removing node at %p: ", p); scm_print(p);
434 #endif
435 t = p->type;
436 if (t < SOBJ_T_MAX) {
437 if (scm_type_hook[t].sweep != NULL)
438 (*scm_type_hook[t].sweep)(p);
439
440 if (scm_type_hook[t].finalize != NULL) {
441 printf("; gc : calling finalizer for type '%s'\n",
442 scm_type_hook[t].name);
443 scm_apply1(scm_type_hook[t].finalize, p);
444 }
445 }
446 p->type = SOBJ_T_FREE;
447 p->data.pair.car = scm_hfree;
448 scm_hfree = p;
449 gcfree++;
450 }
451 SCM_GCBIT_CLR(p); /* clear gcmark */
452 p--;
453 }
454 }
455
456 /*-- add free cells to scm_hfree list : try to lower scm_hptr */
scm_gc_sweep()457 static void scm_gc_sweep()
458 {
459 SCM_HEAP_BLOCK *h;
460 gcfree = 0;
461 scm_hfree = NULL;
462 for (h = scm_heap_list; h; h = h->next) {
463 scm_gc_sweep_block(h);
464 }
465 }
466
467 /*-- garbage collect:
468 * ASSUMES THAT HEAP IS LOCKED
469 */
scm_gc()470 void scm_gc()
471 {
472 if (scm_in_gc) {
473 fprintf(stderr, "OOPS: recursive gc not allowed\n");
474 return;
475 }
476 scm_in_gc = 1;
477
478 #ifdef SCM_WITH_THREADS
479 scm_thread_suspend_other();
480 #endif /* SCM_WITH_THREADS */
481
482 if (scm_gc_verbose > 0 && scm_interractive) {
483 scm_puts("; gc ("); scm_putn(scm_cells_allocated);
484 scm_puts(" new cells)\n");
485 }
486 scm_cells_allocated = 0;
487 scm_gc_clear_gcmark();
488
489 gcmarked = 0;
490 scm_gc_mark_protected();
491 scm_gc_mark_chars();
492 scm_gc_mark_stacks();
493 scm_gc_mark_cstack();
494 scm_gc_sweep_chars();
495 scm_gc_sweep();
496
497 #ifdef SCM_WITH_THREADS
498 scm_thread_resume_other();
499 #endif /* SCM_WITH_THREADS */
500 scm_in_gc = 0;
501
502 if (scm_gc_verbose > 1 && scm_interractive)
503 scm_heap_stat();
504
505 }
506
507 #define scm_clearcell(o) { SCM_CAR(o) = SCM_CDR(o) = 0;}
508
509 /* Allocate a new cell to hold an object.
510 *
511 * If scm_free list is not empty, use one of this cells. Otherwise try
512 * to allocate from current heap.
513 *
514 * If current heap is full, examine older heap and try to allocate
515 * there.
516 *
517 * If all of this fail, make a gc. After gc, free nodes are collected
518 * to the scm_free list. So if scm_free list is not empty use one of
519 * this node.
520 *
521 * If scm_free is empty, this means that gc has not collected any
522 * cells. Allocate a new heap block an return a cell from this heap
523 * block.
524 *
525 */
scm_newcell(int type)526 SOBJ scm_newcell(int type)
527 {
528 SOBJ obj;
529 SCM_HEAP_BLOCK *h;
530 int try_gc;
531
532 SCM_HEAP_LOCK();
533
534 try_gc = TRUE;
535
536 restart_after_gc:
537
538 if (scm_hfree) { /* have some avail cells */
539 obj = scm_hfree; /* take the first one */
540 scm_hfree = SCM_OBJREF(SCM_CAR(obj));
541 gcfree--; /* and decrement counter of free nodes */
542
543 } else {
544
545 restart_after_new_heap:
546 h = scm_heap_list;
547
548 /* try to allocate in current block. */
549 if ((h->ptr+1) >= h->limit) {
550
551 /* oops not enough space in current block. may be we can find
552 * one with some more free space */
553 h = h->next;
554 while(h && (h->ptr+1) >= h->limit) h = h->next;
555
556 if (h == NULL) {
557 /* Seems to be desesparate. If we have not try a gc(), try it
558 * and start again all the processus
559 */
560 if (try_gc &&
561 scm_cells_allocated >= (scm_global_heap_size/5) ) {
562 try_gc = FALSE;
563 scm_gc();
564 goto restart_after_gc;
565 }
566
567 /* Bad news, gc was not sucessfull. Last chance is to allocate
568 * a new heap block and to take a cell there.
569 */
570 scm_add_heap_block(scm_heap_list->size);
571 goto restart_after_new_heap;
572 }
573 }
574
575 /* YEAH. We got a heap block with some free cells inside. Eat one
576 * and continue to work. */
577 obj = h->ptr++;
578 }
579
580 SCM_HEAP_UNLOCK();
581 scm_cells_allocated++;
582 scm_clearcell(obj); obj->type = type;
583 return(obj);
584 }
585
586 /* Return a cell to free list
587 *
588 * Usefull to really remove cell now (file closing etc...)
589 */
scm_freecell(SOBJ obj)590 void scm_freecell(SOBJ obj)
591 {
592 int t;
593
594 SCM_HEAP_LOCK();
595
596 t = obj->type;
597 if (scm_type_hook[t].sweep != NULL) {
598 (*scm_type_hook[t].sweep)(obj);
599 }
600 if (scm_type_hook[t].finalize != NULL) {
601 fprintf(stderr, "scm_freecell: calling finalizer for type '%s'\n",
602 scm_type_hook[t].name);
603 scm_apply1(scm_type_hook[t].finalize, obj);
604 }
605 obj->type = SOBJ_T_FREE;
606 SCM_CAR(obj) = scm_hfree;
607 scm_hfree = obj;
608 gcfree++;
609 SCM_HEAP_UNLOCK();
610 }
611
612
scm_clone(SOBJ obj)613 SOBJ scm_clone(SOBJ obj)
614 {
615 SOBJ new;
616 if (SCM_INUMP(obj)) return(obj);
617 new = scm_newcell(obj->type);
618 *new = *obj;
619 return(new);
620 }
621
622
623 /*-- initialize */
624
scm_heap_init(long size)625 void scm_heap_init(long size)
626 {
627 scm_add_heap_block(size);
628 }
629
630 #ifdef OLD
scm_pre_gc()631 static void scm_pre_gc()
632 {
633 int est_free;
634 return;
635 est_free = (scm_hlimit - scm_hptr) + gcfree;
636 if (est_free < 10240) {
637 scm_puts("; pre gc\n");
638 scm_gc();
639 }
640 }
641 #endif
642