1 /* heap-sc.c: Stop-and-copy garbage collector.
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include <string.h>
32
33 extern void Uncatchable_Error (char *);
34 extern unsigned int Stack_Size ();
35 extern void *sbrk();
36
37 #define Recursive_Visit(p) {\
38 register Object *pp = p;\
39 if (Stack_Size () > Max_Stack)\
40 Fatal_Error("stack overflow during GC (increase stack limit)");\
41 if (Types[TYPE(*pp)].haspointer) Visit (pp);\
42 }
43
44 char *Heap_Start,
45 *Hp, /* First free byte */
46 *Heap_End, /* Points behind free bytes */
47 *Free_Start, /* Start of free area */
48 *Free_End; /* Points behind free area */
49
50 static char *To;
51
Make_Heap(int size)52 void Make_Heap (int size) {
53 register unsigned int k = 1024 * size;
54 register unsigned int s = 2 * k;
55
56 if ((Hp = Heap_Start = (char *)sbrk (s)) == (char *)-1)
57 Fatal_Error ("cannot allocate heap (%u KBytes)", 2*size);
58 Heap_End = Heap_Start + k;
59 Free_Start = Heap_End;
60 Free_End = Free_Start + k;
61 }
62
Free_Heap()63 void Free_Heap () {
64 /* Do nothing. */
65 }
66
Alloc_Object(int size,int type,int konst)67 Object Alloc_Object (int size, int type, int konst) {
68 register char *p = Hp;
69 Object ret;
70
71 if (GC_Debug) {
72 (void)P_Collect ();
73 p = Hp;
74 }
75 ELK_ALIGN(p);
76 if (p + size > Heap_End) {
77 (void)P_Collect ();
78 p = Hp;
79 ELK_ALIGN(p);
80 if (p + size > Heap_End - HEAP_MARGIN)
81 Uncatchable_Error ("Out of heap space");
82 }
83 Hp = p + size;
84 *(Object *)p = Null;
85 SET(ret, type, p);
86 if (konst)
87 SETCONST(ret);
88 return ret;
89 }
90
P_Collect()91 Object P_Collect () {
92 register char *tmp;
93 register int msg = 0;
94 Object a[2];
95
96 if (!Interpreter_Initialized)
97 Fatal_Error ("heap too small (increase heap size)");
98 if (GC_In_Progress)
99 Fatal_Error ("GC while GC in progress");
100 Disable_Interrupts;
101 GC_In_Progress = 1;
102 Call_Before_GC ();
103 if (GC_Debug) {
104 printf ("."); (void)fflush (stdout);
105 } else if (Var_Is_True (V_Garbage_Collect_Notifyp)) {
106 msg++;
107 Format (Standard_Output_Port, "[Garbage collecting... ", 23, 0,
108 (Object *)0);
109 (void)fflush (stdout);
110 }
111 To = Free_Start;
112 Visit_GC_List (Global_GC_Obj, 0);
113 Visit_GC_List (GC_List, 0);
114 Visit_Wind (First_Wind, 0);
115 Hp = To;
116 tmp = Heap_Start; Heap_Start = Free_Start; Free_Start = tmp;
117 tmp = Heap_End; Heap_End = Free_End; Free_End = tmp;
118 if (!GC_Debug) {
119 if (msg) {
120 a[0] = Make_Integer ((Hp-Heap_Start) / 1024);
121 a[1] = Make_Integer ((Heap_End-Heap_Start) / 1024);
122 Format (Standard_Output_Port, "~sK of ~sK]~%", 13, 2, a);
123 }
124 }
125 Call_After_GC ();
126 GC_In_Progress = 0;
127 Enable_Interrupts;
128 return Void;
129 }
130
Visit(register Object * p)131 int Visit (register Object *p) {
132 register Object *tag;
133 register int t, size, reloc = 0;
134
135 again:
136 t = TYPE(*p);
137 if (!Types[t].haspointer)
138 return 0;
139 tag = (Object *)POINTER(*p);
140 if ((char *)tag >= Free_Start && (char *)tag < Free_End)
141 return 0;
142 if (TYPE(*tag) == T_Broken_Heart) {
143 SETPOINTER(*p, POINTER(*tag));
144 return 0;
145 }
146 ELK_ALIGN(To);
147 switch (t) {
148 case T_Bignum:
149 size = sizeof (struct S_Bignum) - sizeof (gran_t)
150 + BIGNUM(*p)->size * sizeof (gran_t);
151 memcpy (To, tag, size);
152 break;
153 case T_Flonum:
154 size = sizeof (struct S_Flonum);
155 *(struct S_Flonum *)To = *(struct S_Flonum *)tag;
156 break;
157 case T_Symbol:
158 size = sizeof (struct S_Symbol);
159 *(struct S_Symbol *)To = *(struct S_Symbol *)tag;
160 break;
161 case T_Pair:
162 case T_Environment:
163 size = sizeof (struct S_Pair);
164 *(struct S_Pair *)To = *(struct S_Pair *)tag;
165 break;
166 case T_String:
167 size = sizeof (struct S_String) + STRING(*p)->size - 1;
168 memcpy (To, tag, size);
169 break;
170 case T_Vector:
171 size = sizeof (struct S_Vector) + (VECTOR(*p)->size - 1) *
172 sizeof (Object);
173 memcpy (To, tag, size);
174 break;
175 case T_Primitive:
176 size = sizeof (struct S_Primitive);
177 *(struct S_Primitive *)To = *(struct S_Primitive *)tag;
178 break;
179 case T_Compound:
180 size = sizeof (struct S_Compound);
181 *(struct S_Compound *)To = *(struct S_Compound *)tag;
182 break;
183 case T_Control_Point:
184 size = sizeof (struct S_Control) + CONTROL(*p)->size - 1;
185 reloc = To - (char *)tag;
186 memcpy (To, tag, size);
187 break;
188 case T_Promise:
189 size = sizeof (struct S_Promise);
190 *(struct S_Promise *)To = *(struct S_Promise *)tag;
191 break;
192 case T_Port:
193 size = sizeof (struct S_Port);
194 *(struct S_Port *)To = *(struct S_Port *)tag;
195 break;
196 case T_Autoload:
197 size = sizeof (struct S_Autoload);
198 *(struct S_Autoload *)To = *(struct S_Autoload *)tag;
199 break;
200 case T_Macro:
201 size = sizeof (struct S_Macro);
202 *(struct S_Macro *)To = *(struct S_Macro *)tag;
203 break;
204 case T_Broken_Heart:
205 Panic ("broken heart in GC");
206 default:
207 if (t < 0 || t >= Num_Types)
208 Panic ("bad type in GC");
209 if (Types[t].size == NOFUNC)
210 size = Types[t].const_size;
211 else
212 size = (Types[t].size)(*p);
213 memcpy (To, tag, size);
214 }
215 SETPOINTER(*p, To);
216 SET(*tag, T_Broken_Heart, To);
217 To += size;
218 if (To > Free_End)
219 Panic ("free exhausted in GC");
220 switch (t) {
221 case T_Symbol:
222 Recursive_Visit (&SYMBOL(*p)->next);
223 Recursive_Visit (&SYMBOL(*p)->name);
224 Recursive_Visit (&SYMBOL(*p)->value);
225 p = &SYMBOL(*p)->plist;
226 goto again;
227 case T_Pair:
228 case T_Environment:
229 Recursive_Visit (&PAIR(*p)->car);
230 p = &PAIR(*p)->cdr;
231 goto again;
232 case T_Vector: {
233 register int i, n;
234 for (i = 0, n = VECTOR(*p)->size; i < n; i++)
235 Recursive_Visit (&VECTOR(*p)->data[i]);
236 break;
237 }
238 case T_Compound:
239 Recursive_Visit (&COMPOUND(*p)->closure);
240 Recursive_Visit (&COMPOUND(*p)->env);
241 p = &COMPOUND(*p)->name;
242 goto again;
243 case T_Control_Point:
244 Recursive_Visit (&CONTROL(*p)->memsave);
245 CONTROL(*p)->delta += reloc;
246 #ifdef HAVE_ALLOCA
247 Visit_GC_List (CONTROL(*p)->gclist, CONTROL(*p)->delta);
248 #else
249 Recursive_Visit (&CONTROL(*p)->gcsave);
250 #endif
251 Visit_Wind (CONTROL(*p)->firstwind, CONTROL(*p)->delta);
252 p = &CONTROL(*p)->env;
253 goto again;
254 case T_Promise:
255 Recursive_Visit (&PROMISE(*p)->env);
256 p = &PROMISE(*p)->thunk;
257 goto again;
258 case T_Port:
259 p = &PORT(*p)->name;
260 goto again;
261 case T_Autoload:
262 Recursive_Visit (&AUTOLOAD(*p)->files);
263 p = &AUTOLOAD(*p)->env;
264 goto again;
265 case T_Macro:
266 Recursive_Visit (&MACRO(*p)->body);
267 p = &MACRO(*p)->name;
268 goto again;
269 default:
270 if (Types[t].visit)
271 (Types[t].visit)(p, Visit);
272 }
273
274 return 0;
275 }
276
Internal_GC_Status(strat,flags)277 Object Internal_GC_Status (strat, flags) {
278 return (Cons (Sym_Stop_And_Copy_GC, Null));
279 }
280