elk/src/heap-sc.c

/* Stop-and-copy garbage collector
 */

extern void *sbrk();

#define Recursive_Visit(p) {\
    register Object *pp = p;\
    if (Stack_Size () > Max_Stack)\
	Fatal_Error("stack overflow during GC (increase stack limit)");\
    if (Types[TYPE(*pp)].haspointer) Visit (pp);\
}

char *Heap_Start,
     *Hp,                     /* First free byte */
     *Heap_End,               /* Points behind free bytes */
     *Free_Start,             /* Start of free area */
     *Free_End;               /* Points behind free area */

static char *To;

Make_Heap (size) {
    register unsigned k = 1024 * size;
    register unsigned s = 2 * k;

    if ((Hp = Heap_Start = (char *)sbrk (s)) == (char *)-1)
	Fatal_Error ("cannot allocate heap (%u KBytes)", 2*size);
    Heap_End = Heap_Start + k;
    Free_Start = Heap_End;
    Free_End = Free_Start + k;
}

Object Alloc_Object (size, type, konst) {
    register char *p = Hp;
    Object ret;

    if (GC_Debug) {
	(void)P_Collect ();
	p = Hp;
    }
    ALIGN(p);
    if (p + size > Heap_End) {
	(void)P_Collect ();
	p = Hp;
	ALIGN(p);
	if (p + size > Heap_End - HEAP_MARGIN)
	    Uncatchable_Error ("Out of heap space");
    }
    Hp = p + size;
    *(Object *)p = Null;
    SET(ret, type, p);
    if (konst)
	SETCONST(ret);
    return ret;
}

Object P_Collect () {
    register char *tmp;
    register msg = 0;
    Object a[2];

    if (!Interpreter_Initialized)
	Fatal_Error ("heap too small (increase heap size)");
    if (GC_In_Progress)
	Fatal_Error ("GC while GC in progress");
    Disable_Interrupts;
    GC_In_Progress = 1;
    Call_Before_GC ();
    if (GC_Debug) {
	printf ("."); (void)fflush (stdout);
    } else if (Var_Is_True (V_Garbage_Collect_Notifyp)) {
	msg++;
	Format (Standard_Output_Port, "[Garbage collecting... ", 23, 0,
	    (Object *)0);
	(void)fflush (stdout);
    }
    To = Free_Start;
    Visit_GC_List (Global_GC_Obj, 0);
    Visit_GC_List (GC_List, 0);
    Visit_Wind (First_Wind, 0);
    Hp = To;
    tmp = Heap_Start; Heap_Start = Free_Start; Free_Start = tmp;
    tmp = Heap_End; Heap_End = Free_End; Free_End = tmp;
    if (!GC_Debug) {
	if (msg) {
	    a[0] = Make_Integer ((Hp-Heap_Start) / 1024);
	    a[1] = Make_Integer ((Heap_End-Heap_Start) / 1024);
	    Format (Standard_Output_Port, "~sK of ~sK]~%", 13, 2, a);
	}
    }
    Call_After_GC ();
    GC_In_Progress = 0;
    Enable_Interrupts;
    return Void;
}

Visit (p) register Object *p; {
    register Object *tag;
    register t, size, reloc;

again:
    t = TYPE(*p);
    if (!Types[t].haspointer)
	return;
    tag = (Object *)POINTER(*p);
    if ((char *)tag >= Free_Start && (char *)tag < Free_End)
	return;
    if (TYPE(*tag) == T_Broken_Heart) {
	SETPOINTER(*p, POINTER(*tag));
	return;
    }
    ALIGN(To);
    switch (t) {
    case T_Bignum:
	size = sizeof (struct S_Bignum) - sizeof (gran_t)
	       + BIGNUM(*p)->size * sizeof (gran_t);
	bcopy ((char *)tag, To, size);
	break;
    case T_Flonum:
	size = sizeof (struct S_Flonum);
	*(struct S_Flonum *)To = *(struct S_Flonum *)tag;
	break;
    case T_Symbol:
	size = sizeof (struct S_Symbol);
	*(struct S_Symbol *)To = *(struct S_Symbol *)tag;
	break;
    case T_Pair:
    case T_Environment:
	size = sizeof (struct S_Pair);
	*(struct S_Pair *)To = *(struct S_Pair *)tag;
	break;
    case T_String:
	size = sizeof (struct S_String) + STRING(*p)->size - 1;
	bcopy ((char *)tag, To, size);
	break;
    case T_Vector:
	size = sizeof (struct S_Vector) + (VECTOR(*p)->size - 1) *
	    sizeof (Object);
	bcopy ((char *)tag, To, size);
	break;
    case T_Primitive:
	size = sizeof (struct S_Primitive);
	*(struct S_Primitive *)To = *(struct S_Primitive *)tag;
	break;
    case T_Compound:
	size = sizeof (struct S_Compound);
	*(struct S_Compound *)To = *(struct S_Compound *)tag;
	break;
    case T_Control_Point:
	size = sizeof (struct S_Control) + CONTROL(*p)->size - 1;
	reloc = To - (char *)tag;
	bcopy ((char *)tag, To, size);
	break;
    case T_Promise:
	size = sizeof (struct S_Promise);
	*(struct S_Promise *)To = *(struct S_Promise *)tag;
	break;
    case T_Port:
	size = sizeof (struct S_Port);
	*(struct S_Port *)To = *(struct S_Port *)tag;
	break;
    case T_Autoload:
	size = sizeof (struct S_Autoload);
	*(struct S_Autoload *)To = *(struct S_Autoload *)tag;
	break;
    case T_Macro:
	size = sizeof (struct S_Macro);
	*(struct S_Macro *)To = *(struct S_Macro *)tag;
	break;
    case T_Broken_Heart:
	Panic ("broken heart in GC");
    default:
	if (t < 0 || t >= Num_Types)
	    Panic ("bad type in GC");
	if (Types[t].size == NOFUNC)
	    size = Types[t].const_size;
	else
	    size = (Types[t].size)(*p);
	bcopy ((char *)tag, To, size);
    }
    SETPOINTER(*p, To);
    SET(*tag, T_Broken_Heart, To);
    To += size;
    if (To > Free_End)
	Panic ("free exhausted in GC");
    switch (t) {
    case T_Symbol:
	Recursive_Visit (&SYMBOL(*p)->next);
	Recursive_Visit (&SYMBOL(*p)->name);
	Recursive_Visit (&SYMBOL(*p)->value);
	p = &SYMBOL(*p)->plist;
	goto again;
    case T_Pair:
    case T_Environment:
	Recursive_Visit (&PAIR(*p)->car);
	p = &PAIR(*p)->cdr;
	goto again;
    case T_Vector: {
	    register i, n;
	    for (i = 0, n = VECTOR(*p)->size; i < n; i++)
		Recursive_Visit (&VECTOR(*p)->data[i]);
	    break;
	}
    case T_Compound:
	Recursive_Visit (&COMPOUND(*p)->closure);
	Recursive_Visit (&COMPOUND(*p)->env);
	p = &COMPOUND(*p)->name;
	goto again;
    case T_Control_Point:
	Recursive_Visit (&CONTROL(*p)->memsave);
	CONTROL(*p)->delta += reloc;
#ifdef USE_ALLOCA
	Visit_GC_List (CONTROL(*p)->gclist, CONTROL(*p)->delta);
#else
	Recursive_Visit (&CONTROL(*p)->gcsave);
#endif
	Visit_Wind (CONTROL(*p)->firstwind, CONTROL(*p)->delta);
	p = &CONTROL(*p)->env;
	goto again;
    case T_Promise:
	Recursive_Visit (&PROMISE(*p)->env);
	p = &PROMISE(*p)->thunk;
	goto again;
    case T_Port:
	p = &PORT(*p)->name;
	goto again;
    case T_Autoload:
	Recursive_Visit (&AUTOLOAD(*p)->files);
	p = &AUTOLOAD(*p)->env;
	goto again;
    case T_Macro:
	Recursive_Visit (&MACRO(*p)->body);
	p = &MACRO(*p)->name;
	goto again;
    default:
	if (Types[t].visit)
	    (Types[t].visit)(p, Visit);
    }
}

Object Internal_GC_Status (strat, flags) {
    return (Cons (Sym_Stop_And_Copy_GC, Null));
}