1 |
/* |
/* |
2 |
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
3 |
|
|
4 |
This file is part of GNU Common Lisp, herein referred to as GCL |
This file is part of GNU Common Lisp, herein referred to as GCL |
5 |
|
|
6 |
GCL is free software; you can redistribute it and/or modify it under |
GCL is free software; you can redistribute it and/or modify it under |
7 |
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
8 |
the Free Software Foundation; either version 2, or (at your option) |
the Free Software Foundation; either version 2, or (at your option) |
9 |
any later version. |
any later version. |
10 |
|
|
11 |
GCL is distributed in the hope that it will be useful, but WITHOUT |
GCL is distributed in the hope that it will be useful, but WITHOUT |
12 |
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
13 |
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
14 |
License for more details. |
License for more details. |
15 |
|
|
16 |
You should have received a copy of the GNU Library General Public License |
You should have received a copy of the GNU Library General Public License |
17 |
along with GCL; see the file COPYING. If not, write to the Free Software |
along with GCL; see the file COPYING. If not, write to the Free Software |
18 |
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
19 |
|
|
20 |
*/ |
*/ |
21 |
|
|
22 |
/* |
/* |
23 |
GBC.c |
GBC.c |
24 |
IMPLEMENTATION-DEPENDENT |
IMPLEMENTATION-DEPENDENT |
25 |
*/ |
*/ |
26 |
|
|
27 |
#define DEBUG |
#define DEBUG |
31 |
#include "include.h" |
#include "include.h" |
32 |
|
|
33 |
/* the following in line definitions seem to be twice as fast (at |
/* the following in line definitions seem to be twice as fast (at |
34 |
least on mc68020) as going to the assembly function calls in bitop.c so |
least on mc68020) as going to the assembly function calls in bitop.c so |
35 |
since this is more portable and faster lets use them --W. Schelter |
since this is more portable and faster lets use them --W. Schelter |
36 |
These assume that DBEGIN is divisible by 32, or else we should have |
These assume that DBEGIN is divisible by 32, or else we should have |
37 |
#define Shamt(x) (((((int) x -DBEGIN) >> 2) & ~(~0 << 5))) |
#define Shamt(x) (((((int) x -DBEGIN) >> 2) & ~(~0 << 5))) |
38 |
*/ |
*/ |
39 |
#define BBITS_CHAR 3 |
#define BBITS_CHAR 3 |
40 |
|
|
68 |
bool saving_system; |
bool saving_system; |
69 |
static int gc_time = -1; |
static int gc_time = -1; |
70 |
static int gc_start = 0; |
static int gc_start = 0; |
71 |
int runtime(); |
int runtime(void); |
72 |
int sgc_enabled=0; |
int sgc_enabled=0; |
73 |
int first_protectable_page =0; |
int first_protectable_page =0; |
74 |
|
|
75 |
|
|
76 |
|
|
77 |
char *copy_relblock(); |
char *copy_relblock(char *p, int s); |
78 |
|
|
79 |
#include "page.h" |
#include "page.h" |
80 |
|
|
92 |
(real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32) |
(real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32) |
93 |
|
|
94 |
struct apage { |
struct apage { |
95 |
char apage_self[PAGESIZE]; |
char apage_self[PAGESIZE]; |
96 |
}; |
}; |
97 |
|
|
98 |
int maxpage; |
int maxpage; |
109 |
|
|
110 |
#ifdef AV |
#ifdef AV |
111 |
/* |
/* |
112 |
See bitop.c. |
See bitop.c. |
113 |
*/ |
*/ |
114 |
#endif |
#endif |
115 |
#ifdef MV |
#ifdef MV |
135 |
int mark_origin_max; |
int mark_origin_max; |
136 |
|
|
137 |
struct { |
struct { |
138 |
object *mob_addr; /* mark origin block address */ |
object *mob_addr; /* mark origin block address */ |
139 |
int mob_size; /* mark origin block size */ |
int mob_size; /* mark origin block size */ |
140 |
} mark_origin_block[MARK_ORIGIN_BLOCK_MAX]; |
} mark_origin_block[MARK_ORIGIN_BLOCK_MAX]; |
141 |
int mark_origin_block_max; |
int mark_origin_block_max; |
142 |
|
|
147 |
|
|
148 |
|
|
149 |
void |
void |
150 |
enter_mark_origin(p) |
enter_mark_origin(object *p) |
|
object *p; |
|
151 |
{ |
{ |
152 |
if (mark_origin_max >= MARK_ORIGIN_MAX) |
if (mark_origin_max >= MARK_ORIGIN_MAX) |
153 |
error("too many mark origins"); |
error("too many mark origins"); |
154 |
#ifdef SGC |
#ifdef SGC |
155 |
sgc_type_map[page(p)] |= SGC_PERM_WRITABLE ; |
sgc_type_map[page(p)] |= SGC_PERM_WRITABLE ; |
156 |
#endif |
#endif |
157 |
mark_origin[mark_origin_max++] = p; |
mark_origin[mark_origin_max++] = p; |
158 |
} |
} |
159 |
|
|
160 |
enter_mark_origin_block(p, n) |
void |
161 |
object *p; |
enter_mark_origin_block(object *p, int n) { |
162 |
int n; |
if (mark_origin_block_max >= MARK_ORIGIN_BLOCK_MAX) |
163 |
{ |
error("too many mark origin blocks"); |
164 |
if (mark_origin_block_max >= MARK_ORIGIN_BLOCK_MAX) |
mark_origin_block[mark_origin_block_max].mob_addr = p; |
165 |
error("too many mark origin blocks"); |
mark_origin_block[mark_origin_block_max++].mob_size = n; |
|
mark_origin_block[mark_origin_block_max].mob_addr = p; |
|
|
mark_origin_block[mark_origin_block_max++].mob_size = n; |
|
166 |
} |
} |
167 |
|
|
168 |
mark_cons(x) |
void |
169 |
object x; |
mark_cons(object x) { |
170 |
{ |
|
171 |
cs_check(x); |
cs_check(x); |
172 |
|
|
173 |
/* x is already marked. */ |
/* x is already marked. */ |
174 |
|
|
175 |
BEGIN: |
BEGIN: |
176 |
if (NULL_OR_ON_C_STACK(x->c.c_car)) goto MARK_CDR; |
if (NULL_OR_ON_C_STACK(x->c.c_car)) goto MARK_CDR; |
177 |
if (type_of(x->c.c_car) == t_cons) { |
if (type_of(x->c.c_car) == t_cons) { |
178 |
if (x->c.c_car->c.m) |
if (x->c.c_car->c.m) |
179 |
; |
; |
180 |
else { |
else { |
181 |
x->c.c_car->c.m = TRUE; |
x->c.c_car->c.m = TRUE; |
182 |
mark_cons(x->c.c_car); |
mark_cons(x->c.c_car); |
183 |
} |
} |
184 |
} else |
} else |
185 |
mark_object(x->c.c_car); |
mark_object(x->c.c_car); |
186 |
MARK_CDR: |
MARK_CDR: |
187 |
x = x->c.c_cdr; |
x = x->c.c_cdr; |
188 |
if (NULL_OR_ON_C_STACK(x)) |
if (NULL_OR_ON_C_STACK(x)) |
189 |
return; |
return; |
190 |
if (type_of(x) == t_cons) { |
if (type_of(x) == t_cons) { |
191 |
if (x->c.m) |
if (x->c.m) |
192 |
return; |
return; |
193 |
x->c.m = TRUE; |
x->c.m = TRUE; |
194 |
goto BEGIN; |
goto BEGIN; |
195 |
} |
} |
196 |
if (x == Cnil) |
if (x == Cnil) |
197 |
return; |
return; |
198 |
mark_object(x); |
mark_object(x); |
199 |
} |
} |
200 |
|
|
201 |
/* Whenever two arrays are linked together by displacement, |
/* Whenever two arrays are linked together by displacement, |
202 |
if one is live, the other will be made live */ |
if one is live, the other will be made live */ |
203 |
#define mark_displaced_field(ar) mark_object(ar->a.a_displaced) |
#define mark_displaced_field(ar) mark_object(ar->a.a_displaced) |
204 |
|
|
205 |
mark_object(x) |
void |
206 |
object x; |
mark_object(object x) { |
207 |
{ |
|
208 |
long i; |
long i; |
209 |
int j; |
int j; |
210 |
object *p; |
object *p; |
211 |
char *cp; |
char *cp; |
212 |
object y; |
|
213 |
|
cs_check(x); |
214 |
cs_check(x); |
BEGIN: |
215 |
BEGIN: |
/* if the body of x is in the c stack, its elements |
216 |
/* if the body of x is in the c stack, its elements |
are marked anyway by the c stack mark carefully, and |
217 |
are marked anyway by the c stack mark carefully, and |
if this x is somehow hanging around in a cons that |
218 |
if this x is somehow hanging around in a cons that |
should be dead, we dont want to mark it. -wfs |
219 |
should be dead, we dont want to mark it. -wfs |
*/ |
220 |
*/ |
|
221 |
|
if (NULL_OR_ON_C_STACK(x)) |
222 |
if (NULL_OR_ON_C_STACK(x)) |
return; |
223 |
return; |
if (x->d.m) |
224 |
if (x->d.m) |
return; |
225 |
return; |
x->d.m = TRUE; |
226 |
x->d.m = TRUE; |
switch (type_of(x)) { |
227 |
switch (type_of(x)) { |
case t_fixnum: |
228 |
case t_fixnum: |
break; |
229 |
break; |
|
230 |
|
case t_ratio: |
231 |
case t_ratio: |
mark_object(x->rat.rat_num); |
232 |
mark_object(x->rat.rat_num); |
x = x->rat.rat_den; |
233 |
x = x->rat.rat_den; |
goto BEGIN; |
234 |
goto BEGIN; |
|
235 |
|
case t_shortfloat: |
236 |
case t_shortfloat: |
break; |
237 |
break; |
|
238 |
|
case t_longfloat: |
239 |
case t_longfloat: |
break; |
240 |
break; |
|
241 |
|
case t_complex: |
242 |
case t_complex: |
mark_object(x->cmp.cmp_imag); |
243 |
mark_object(x->cmp.cmp_imag); |
x = x->cmp.cmp_real; |
244 |
x = x->cmp.cmp_real; |
goto BEGIN; |
245 |
goto BEGIN; |
|
246 |
|
case t_character: |
247 |
case t_character: |
break; |
248 |
break; |
|
249 |
|
case t_symbol: |
250 |
case t_symbol: |
mark_object(x->s.s_plist); |
251 |
mark_object(x->s.s_plist); |
mark_object(x->s.s_gfdef); |
252 |
mark_object(x->s.s_gfdef); |
mark_object(x->s.s_dbind); |
253 |
mark_object(x->s.s_dbind); |
if (x->s.s_self == NULL) |
254 |
if (x->s.s_self == NULL) |
break; |
255 |
break; |
if ((int)what_to_collect >= (int)t_contiguous) { |
256 |
if ((int)what_to_collect >= (int)t_contiguous) { |
if (inheap(x->s.s_self)) { |
257 |
if (inheap(x->s.s_self)) { |
if (what_to_collect == t_contiguous) |
258 |
if (what_to_collect == t_contiguous) |
mark_contblock(x->s.s_self, |
259 |
mark_contblock(x->s.s_self, |
x->s.s_fillp); |
260 |
x->s.s_fillp); |
} else |
261 |
} else |
x->s.s_self = |
262 |
x->s.s_self = |
copy_relblock(x->s.s_self, x->s.s_fillp); |
263 |
copy_relblock(x->s.s_self, x->s.s_fillp); |
} |
264 |
} |
break; |
265 |
break; |
|
266 |
|
case t_package: |
267 |
case t_package: |
mark_object(x->p.p_name); |
268 |
mark_object(x->p.p_name); |
mark_object(x->p.p_nicknames); |
269 |
mark_object(x->p.p_nicknames); |
mark_object(x->p.p_shadowings); |
270 |
mark_object(x->p.p_shadowings); |
mark_object(x->p.p_uselist); |
271 |
mark_object(x->p.p_uselist); |
mark_object(x->p.p_usedbylist); |
272 |
mark_object(x->p.p_usedbylist); |
if (what_to_collect != t_contiguous) |
273 |
if (what_to_collect != t_contiguous) |
break; |
274 |
break; |
if (x->p.p_internal != NULL) |
275 |
if (x->p.p_internal != NULL) |
mark_contblock((char *)(x->p.p_internal), |
276 |
mark_contblock((char *)(x->p.p_internal), |
x->p.p_internal_size*sizeof(object)); |
277 |
x->p.p_internal_size*sizeof(object)); |
if (x->p.p_external != NULL) |
278 |
if (x->p.p_external != NULL) |
mark_contblock((char *)(x->p.p_external), |
279 |
mark_contblock((char *)(x->p.p_external), |
x->p.p_external_size*sizeof(object)); |
280 |
x->p.p_external_size*sizeof(object)); |
break; |
281 |
break; |
|
282 |
|
case t_cons: |
283 |
case t_cons: |
/* |
284 |
/* |
mark_object(x->c.c_car); |
285 |
mark_object(x->c.c_car); |
x = x->c.c_cdr; |
286 |
x = x->c.c_cdr; |
goto BEGIN; |
287 |
goto BEGIN; |
*/ |
288 |
*/ |
mark_cons(x); |
289 |
mark_cons(x); |
break; |
290 |
break; |
|
291 |
|
case t_hashtable: |
292 |
case t_hashtable: |
mark_object(x->ht.ht_rhsize); |
293 |
mark_object(x->ht.ht_rhsize); |
mark_object(x->ht.ht_rhthresh); |
294 |
mark_object(x->ht.ht_rhthresh); |
if (x->ht.ht_self == NULL) |
295 |
if (x->ht.ht_self == NULL) |
break; |
296 |
break; |
for (i = 0, j = x->ht.ht_size; i < j; i++) { |
297 |
for (i = 0, j = x->ht.ht_size; i < j; i++) { |
mark_object(x->ht.ht_self[i].hte_key); |
298 |
mark_object(x->ht.ht_self[i].hte_key); |
mark_object(x->ht.ht_self[i].hte_value); |
299 |
mark_object(x->ht.ht_self[i].hte_value); |
} |
300 |
} |
if ((short)what_to_collect >= (short)t_contiguous) { |
301 |
if ((short)what_to_collect >= (short)t_contiguous) { |
if (inheap(x->ht.ht_self)) { |
302 |
if (inheap(x->ht.ht_self)) { |
if (what_to_collect == t_contiguous) |
303 |
if (what_to_collect == t_contiguous) |
mark_contblock((char *)(x->ht.ht_self), |
304 |
mark_contblock((char *)(x->ht.ht_self), |
j * sizeof(struct htent)); |
305 |
j * sizeof(struct htent)); |
} else |
306 |
} else |
x->ht.ht_self = (struct htent *) |
307 |
x->ht.ht_self = (struct htent *) |
copy_relblock((char *)(x->ht.ht_self), |
308 |
copy_relblock((char *)(x->ht.ht_self), |
j * sizeof(struct htent)); |
309 |
j * sizeof(struct htent)); |
} |
310 |
} |
break; |
311 |
break; |
|
312 |
|
case t_array: |
313 |
case t_array: |
if ((x->a.a_displaced) != Cnil) |
314 |
if ((x->a.a_displaced) != Cnil) |
mark_displaced_field(x); |
315 |
mark_displaced_field(x); |
if ((int)what_to_collect >= (int)t_contiguous && |
316 |
if ((int)what_to_collect >= (int)t_contiguous && |
x->a.a_dims != NULL) { |
317 |
x->a.a_dims != NULL) { |
if (inheap(x->a.a_dims)) { |
318 |
if (inheap(x->a.a_dims)) { |
if (what_to_collect == t_contiguous) |
319 |
if (what_to_collect == t_contiguous) |
mark_contblock((char *)(x->a.a_dims), |
320 |
mark_contblock((char *)(x->a.a_dims), |
sizeof(int)*x->a.a_rank); |
321 |
sizeof(int)*x->a.a_rank); |
} else |
322 |
} else |
x->a.a_dims = (int *) |
323 |
x->a.a_dims = (int *) |
copy_relblock((char *)(x->a.a_dims), |
324 |
copy_relblock((char *)(x->a.a_dims), |
sizeof(int)*x->a.a_rank); |
325 |
sizeof(int)*x->a.a_rank); |
} |
326 |
} |
if ((enum aelttype)x->a.a_elttype == aet_ch) |
327 |
if ((enum aelttype)x->a.a_elttype == aet_ch) |
goto CASE_STRING; |
328 |
goto CASE_STRING; |
if ((enum aelttype)x->a.a_elttype == aet_bit) |
329 |
if ((enum aelttype)x->a.a_elttype == aet_bit) |
goto CASE_BITVECTOR; |
330 |
goto CASE_BITVECTOR; |
if ((enum aelttype)x->a.a_elttype == aet_object) |
331 |
if ((enum aelttype)x->a.a_elttype == aet_object) |
goto CASE_GENERAL; |
332 |
goto CASE_GENERAL; |
|
333 |
|
CASE_SPECIAL: |
334 |
CASE_SPECIAL: |
cp = (char *)(x->fixa.fixa_self); |
335 |
cp = (char *)(x->fixa.fixa_self); |
if (cp == NULL) |
336 |
if (cp == NULL) |
break; |
337 |
break; |
/* set j to the size in char of the body of the array */ |
338 |
/* set j to the size in char of the body of the array */ |
|
339 |
|
switch((enum aelttype)x->a.a_elttype){ |
|
switch((enum aelttype)x->a.a_elttype){ |
|
340 |
#define ROUND_RB_POINTERS_DOUBLE \ |
#define ROUND_RB_POINTERS_DOUBLE \ |
341 |
{int tem = ((long)rb_pointer1) & (sizeof(double)-1); \ |
{int tem = ((long)rb_pointer1) & (sizeof(double)-1); \ |
342 |
if (tem) \ |
if (tem) \ |
343 |
{ rb_pointer += (sizeof(double) - tem); \ |
{ rb_pointer += (sizeof(double) - tem); \ |
344 |
rb_pointer1 += (sizeof(double) - tem); \ |
rb_pointer1 += (sizeof(double) - tem); \ |
345 |
}} |
}} |
346 |
case aet_lf: |
case aet_lf: |
347 |
j= sizeof(longfloat)*x->lfa.lfa_dim; |
j= sizeof(longfloat)*x->lfa.lfa_dim; |
348 |
if (((int)what_to_collect >= (int)t_contiguous) && |
if (((int)what_to_collect >= (int)t_contiguous) && |
349 |
!(inheap(cp))) ROUND_RB_POINTERS_DOUBLE; |
!(inheap(cp))) ROUND_RB_POINTERS_DOUBLE; |
350 |
break; |
break; |
351 |
case aet_char: |
case aet_char: |
352 |
case aet_uchar: |
case aet_uchar: |
353 |
j=sizeof(char)*x->a.a_dim; |
j=sizeof(char)*x->a.a_dim; |
354 |
break; |
break; |
355 |
case aet_short: |
case aet_short: |
356 |
case aet_ushort: |
case aet_ushort: |
357 |
j=sizeof(short)*x->a.a_dim; |
j=sizeof(short)*x->a.a_dim; |
358 |
break; |
break; |
359 |
default: |
default: |
360 |
j=sizeof(fixnum)*x->fixa.fixa_dim;} |
j=sizeof(fixnum)*x->fixa.fixa_dim;} |
361 |
|
|
362 |
goto COPY; |
goto COPY; |
363 |
|
|
364 |
CASE_GENERAL: |
CASE_GENERAL: |
365 |
p = x->a.a_self; |
p = x->a.a_self; |
366 |
if (p == NULL |
if (p == NULL |
367 |
#ifdef HAVE_ALLOCA |
#ifdef HAVE_ALLOCA |
368 |
|| (char *)p >= core_end |
|| (char *)p >= core_end |
369 |
#endif |
#endif |
370 |
) |
) |
371 |
break; |
break; |
372 |
if (x->a.a_displaced->c.c_car == Cnil) |
j=0; |
373 |
for (i = 0, j = x->a.a_dim; i < j; i++) |
if (x->a.a_displaced->c.c_car == Cnil) |
374 |
mark_object(p[i]); |
for (i = 0, j = x->a.a_dim; i < j; i++) |
375 |
cp = (char *)p; |
mark_object(p[i]); |
376 |
j *= sizeof(object); |
cp = (char *)p; |
377 |
COPY: |
j *= sizeof(object); |
378 |
if ((int)what_to_collect >= (int)t_contiguous) { |
COPY: |
379 |
if (inheap(cp)) { |
if ((int)what_to_collect >= (int)t_contiguous) { |
380 |
if (what_to_collect == t_contiguous) |
if (inheap(cp)) { |
381 |
mark_contblock(cp, j); |
if (what_to_collect == t_contiguous) |
382 |
} else if (x->a.a_displaced == Cnil) { |
mark_contblock(cp, j); |
383 |
|
} else if (x->a.a_displaced == Cnil) { |
384 |
#ifdef HAVE_ALLOCA |
#ifdef HAVE_ALLOCA |
385 |
if (cp <= core_end) /* only if body of array not on C stack */ |
if (cp <= core_end) /* only if body of array not on C stack */ |
386 |
#endif |
#endif |
387 |
x->a.a_self = (object *)copy_relblock(cp, j);} |
x->a.a_self = (object *)copy_relblock(cp, j);} |
388 |
else if (x->a.a_displaced->c.c_car == Cnil) { |
else if (x->a.a_displaced->c.c_car == Cnil) { |
389 |
i = (long)(object *)copy_relblock(cp, j) |
i = (long)(object *)copy_relblock(cp, j) |
390 |
- (long)(x->a.a_self); |
- (long)(x->a.a_self); |
391 |
adjust_displaced(x, i); |
adjust_displaced(x, i); |
392 |
} |
} |
393 |
} |
} |
394 |
break; |
break; |
395 |
|
|
396 |
case t_vector: |
case t_vector: |
397 |
if ((x->v.v_displaced) != Cnil) |
if ((x->v.v_displaced) != Cnil) |
398 |
mark_displaced_field(x); |
mark_displaced_field(x); |
399 |
if ((enum aelttype)x->v.v_elttype == aet_object) |
if ((enum aelttype)x->v.v_elttype == aet_object) |
400 |
goto CASE_GENERAL; |
goto CASE_GENERAL; |
401 |
else |
else |
402 |
goto CASE_SPECIAL; |
goto CASE_SPECIAL; |
403 |
|
|
404 |
case t_bignum: |
case t_bignum: |
405 |
#ifdef SDEBUG |
#ifdef SDEBUG |
406 |
if (type_map[page(x->big.big_self)] < t_contiguous) |
if (type_map[page(x->big.big_self)] < t_contiguous) |
407 |
{ |
{ |
408 |
printf("bad body for %x (%x)\n",x,cp); |
printf("bad body for %x (%x)\n",x,cp); |
409 |
|
|
410 |
} |
} |
411 |
#endif |
#endif |
412 |
#ifndef GMP_USE_MALLOC |
#ifndef GMP_USE_MALLOC |
413 |
if ((int)what_to_collect >= (int)t_contiguous) { |
if ((int)what_to_collect >= (int)t_contiguous) { |
414 |
j = MP_ALLOCATED(x); |
j = MP_ALLOCATED(x); |
415 |
cp = (char *)MP_SELF(x); |
cp = (char *)MP_SELF(x); |
416 |
if (cp == 0) |
if (cp == 0) |
417 |
break; |
break; |
418 |
#ifdef PARI |
#ifdef PARI |
419 |
if (j != lg(MP(x)) && |
if (j != lg(MP(x)) && |
420 |
/* we don't bother to zero this register, |
/* we don't bother to zero this register, |
421 |
and its contents may get over written */ |
and its contents may get over written */ |
422 |
! (x == big_register_1 && |
! (x == big_register_1 && |
423 |
(int)(cp) <= top && |
(int)(cp) <= top && |
424 |
(int) cp >= bot)) |
(int) cp >= bot)) |
425 |
printf("bad length 0x%x ",x); |
printf("bad length 0x%x ",x); |
426 |
#endif |
#endif |
427 |
j = j * MP_LIMB_SIZE; |
j = j * MP_LIMB_SIZE; |
428 |
if (inheap(cp)) { |
if (inheap(cp)) { |
429 |
if (what_to_collect == t_contiguous) |
if (what_to_collect == t_contiguous) |
430 |
mark_contblock(cp, j); |
mark_contblock(cp, j); |
431 |
} else{ |
} else{ |
432 |
MP_SELF(x) = (void *) copy_relblock(cp, j);}} |
MP_SELF(x) = (void *) copy_relblock(cp, j);}} |
433 |
#endif /* not GMP_USE_MALLOC */ |
#endif /* not GMP_USE_MALLOC */ |
434 |
break; |
break; |
435 |
|
|
436 |
CASE_STRING: |
CASE_STRING: |
437 |
case t_string: |
case t_string: |
438 |
if ((x->st.st_displaced) != Cnil) |
if ((x->st.st_displaced) != Cnil) |
439 |
mark_displaced_field(x); |
mark_displaced_field(x); |
440 |
j = x->st.st_dim; |
j = x->st.st_dim; |
441 |
cp = x->st.st_self; |
cp = x->st.st_self; |
442 |
if (cp == NULL) |
if (cp == NULL) |
443 |
break; |
break; |
444 |
COPY_STRING: |
COPY_STRING: |
445 |
if ((int)what_to_collect >= (int)t_contiguous) { |
if ((int)what_to_collect >= (int)t_contiguous) { |
446 |
if (inheap(cp)) { |
if (inheap(cp)) { |
447 |
if (what_to_collect == t_contiguous) |
if (what_to_collect == t_contiguous) |
448 |
mark_contblock(cp, j); |
mark_contblock(cp, j); |
449 |
} else if (x->st.st_displaced == Cnil) |
} else if (x->st.st_displaced == Cnil) |
450 |
x->st.st_self = copy_relblock(cp, j); |
x->st.st_self = copy_relblock(cp, j); |
451 |
else if (x->st.st_displaced->c.c_car == Cnil) { |
else if (x->st.st_displaced->c.c_car == Cnil) { |
452 |
i = copy_relblock(cp, j) - cp; |
i = copy_relblock(cp, j) - cp; |
453 |
adjust_displaced(x, i); |
adjust_displaced(x, i); |
454 |
} |
} |
455 |
} |
} |
456 |
break; |
break; |
457 |
|
|
458 |
CASE_BITVECTOR: |
CASE_BITVECTOR: |
459 |
case t_bitvector: |
case t_bitvector: |
460 |
if ((x->bv.bv_displaced) != Cnil) |
if ((x->bv.bv_displaced) != Cnil) |
461 |
mark_displaced_field(x); |
mark_displaced_field(x); |
462 |
/* We make bitvectors multiple of sizeof(int) in size allocated |
/* We make bitvectors multiple of sizeof(int) in size allocated |
463 |
Assume 8 = number of bits in char */ |
Assume 8 = number of bits in char */ |
464 |
|
|
465 |
#define W_SIZE (8*sizeof(int)) |
#define W_SIZE (8*sizeof(int)) |
466 |
j= sizeof(int) * |
j= sizeof(int) * |
467 |
((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); |
((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); |
468 |
cp = x->bv.bv_self; |
cp = x->bv.bv_self; |
469 |
if (cp == NULL) |
if (cp == NULL) |
470 |
break; |
break; |
471 |
goto COPY_STRING; |
goto COPY_STRING; |
472 |
|
|
473 |
case t_structure: |
case t_structure: |
474 |
mark_object(x->str.str_def); |
mark_object(x->str.str_def); |
475 |
p = x->str.str_self; |
p = x->str.str_self; |
476 |
if (p == NULL) |
if (p == NULL) |
477 |
break; |
break; |
478 |
{object def=x->str.str_def; |
{object def=x->str.str_def; |
479 |
unsigned char * s_type = &SLOT_TYPE(def,0); |
unsigned char * s_type = &SLOT_TYPE(def,0); |
480 |
unsigned short *s_pos= & SLOT_POS(def,0); |
unsigned short *s_pos= & SLOT_POS(def,0); |
481 |
for (i = 0, j = S_DATA(def)->length; i < j; i++) |
for (i = 0, j = S_DATA(def)->length; i < j; i++) |
482 |
if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); |
if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); |
483 |
if ((int)what_to_collect >= (int)t_contiguous) { |
if ((int)what_to_collect >= (int)t_contiguous) { |
484 |
if (inheap(x->str.str_self)) { |
if (inheap(x->str.str_self)) { |
485 |
if (what_to_collect == t_contiguous) |
if (what_to_collect == t_contiguous) |
486 |
mark_contblock((char *)p, |
mark_contblock((char *)p, |
487 |
S_DATA(def)->size); |
S_DATA(def)->size); |
488 |
|
|
489 |
} else |
} else |
490 |
x->str.str_self = (object *) |
x->str.str_self = (object *) |
491 |
copy_relblock((char *)p, S_DATA(def)->size); |
copy_relblock((char *)p, S_DATA(def)->size); |
492 |
}} |
}} |
493 |
break; |
break; |
494 |
|
|
495 |
case t_stream: |
case t_stream: |
496 |
switch (x->sm.sm_mode) { |
switch (x->sm.sm_mode) { |
497 |
case smm_input: |
case smm_input: |
498 |
case smm_output: |
case smm_output: |
499 |
case smm_io: |
case smm_io: |
500 |
case smm_socket: |
case smm_socket: |
501 |
case smm_probe: |
case smm_probe: |
502 |
mark_object(x->sm.sm_object0); |
mark_object(x->sm.sm_object0); |
503 |
mark_object(x->sm.sm_object1); |
mark_object(x->sm.sm_object1); |
504 |
if (saving_system) |
if (saving_system) |
505 |
{FILE *fp = x->sm.sm_fp; |
{FILE *fp = x->sm.sm_fp; |
506 |
if (fp != 0 && fp != stdin && fp !=stdout |
if (fp != 0 && fp != stdin && fp !=stdout |
507 |
) |
) |
508 |
{fclose(fp); |
{fclose(fp); |
509 |
x->sm.sm_fp=0; |
x->sm.sm_fp=0; |
510 |
}} |
}} |
511 |
else |
else |
512 |
if (what_to_collect == t_contiguous && |
if (what_to_collect == t_contiguous && |
513 |
x->sm.sm_fp && |
x->sm.sm_fp && |
514 |
x->sm.sm_buffer) |
x->sm.sm_buffer) |
515 |
mark_contblock(x->sm.sm_buffer, BUFSIZ); |
mark_contblock(x->sm.sm_buffer, BUFSIZ); |
516 |
break; |
break; |
517 |
|
|
518 |
case smm_synonym: |
case smm_synonym: |
519 |
mark_object(x->sm.sm_object0); |
mark_object(x->sm.sm_object0); |
520 |
break; |
break; |
521 |
|
|
522 |
case smm_broadcast: |
case smm_broadcast: |
523 |
case smm_concatenated: |
case smm_concatenated: |
524 |
mark_object(x->sm.sm_object0); |
mark_object(x->sm.sm_object0); |
525 |
break; |
break; |
526 |
|
|
527 |
case smm_two_way: |
case smm_two_way: |
528 |
case smm_echo: |
case smm_echo: |
529 |
mark_object(x->sm.sm_object0); |
mark_object(x->sm.sm_object0); |
530 |
mark_object(x->sm.sm_object1); |
mark_object(x->sm.sm_object1); |
531 |
break; |
break; |
532 |
|
|
533 |
case smm_string_input: |
case smm_string_input: |
534 |
case smm_string_output: |
case smm_string_output: |
535 |
mark_object(x->sm.sm_object0); |
mark_object(x->sm.sm_object0); |
536 |
break; |
break; |
537 |
#ifdef USER_DEFINED_STREAMS |
#ifdef USER_DEFINED_STREAMS |
538 |
case smm_user_defined: |
case smm_user_defined: |
539 |
mark_object(x->sm.sm_object0); |
mark_object(x->sm.sm_object0); |
540 |
mark_object(x->sm.sm_object1); |
mark_object(x->sm.sm_object1); |
541 |
break; |
break; |
542 |
#endif |
#endif |
543 |
default: |
default: |
544 |
error("mark stream botch"); |
error("mark stream botch"); |
545 |
} |
} |
546 |
break; |
break; |
547 |
|
|
548 |
case t_random: |
case t_random: |
549 |
break; |
break; |
550 |
|
|
551 |
case t_readtable: |
case t_readtable: |
552 |
if (x->rt.rt_self == NULL) |
if (x->rt.rt_self == NULL) |
553 |
break; |
break; |
554 |
if (what_to_collect == t_contiguous) |
if (what_to_collect == t_contiguous) |
555 |
mark_contblock((char *)(x->rt.rt_self), |
mark_contblock((char *)(x->rt.rt_self), |
556 |
RTABSIZE*sizeof(struct rtent)); |
RTABSIZE*sizeof(struct rtent)); |
557 |
for (i = 0; i < RTABSIZE; i++) { |
for (i = 0; i < RTABSIZE; i++) { |
558 |
mark_object(x->rt.rt_self[i].rte_macro); |
mark_object(x->rt.rt_self[i].rte_macro); |
559 |
if (x->rt.rt_self[i].rte_dtab != NULL) { |
if (x->rt.rt_self[i].rte_dtab != NULL) { |
560 |
/**/ |
/**/ |
561 |
if (what_to_collect == t_contiguous) |
if (what_to_collect == t_contiguous) |
562 |
mark_contblock((char *)(x->rt.rt_self[i].rte_dtab), |
mark_contblock((char *)(x->rt.rt_self[i].rte_dtab), |
563 |
RTABSIZE*sizeof(object)); |
RTABSIZE*sizeof(object)); |
564 |
for (j = 0; j < RTABSIZE; j++) |
for (j = 0; j < RTABSIZE; j++) |
565 |
mark_object(x->rt.rt_self[i].rte_dtab[j]); |
mark_object(x->rt.rt_self[i].rte_dtab[j]); |
566 |
/**/ |
/**/ |
567 |
} |
} |
568 |
} |
} |
569 |
break; |
break; |
570 |
|
|
571 |
case t_pathname: |
case t_pathname: |
572 |
mark_object(x->pn.pn_host); |
mark_object(x->pn.pn_host); |
573 |
mark_object(x->pn.pn_device); |
mark_object(x->pn.pn_device); |
574 |
mark_object(x->pn.pn_directory); |
mark_object(x->pn.pn_directory); |
575 |
mark_object(x->pn.pn_name); |
mark_object(x->pn.pn_name); |
576 |
mark_object(x->pn.pn_type); |
mark_object(x->pn.pn_type); |
577 |
mark_object(x->pn.pn_version); |
mark_object(x->pn.pn_version); |
578 |
break; |
break; |
579 |
|
|
580 |
case t_closure: |
case t_closure: |
581 |
{ int i ; |
{ int i ; |
582 |
if (what_to_collect == t_contiguous) |
if (what_to_collect == t_contiguous) |
583 |
mark_contblock(x->cc.cc_turbo,x->cc.cc_envdim); |
mark_contblock(x->cc.cc_turbo,x->cc.cc_envdim); |
584 |
for (i= 0 ; i < x->cc.cc_envdim ; i++) { |
for (i= 0 ; i < x->cc.cc_envdim ; i++) { |
585 |
mark_object(x->cc.cc_turbo[i]);}} |
mark_object(x->cc.cc_turbo[i]);}} |
586 |
|
|
587 |
case t_cfun: |
case t_cfun: |
588 |
case t_sfun: |
case t_sfun: |
589 |
case t_vfun: |
case t_vfun: |
590 |
case t_afun: |
case t_afun: |
591 |
case t_gfun: |
case t_gfun: |
592 |
mark_object(x->cf.cf_name); |
mark_object(x->cf.cf_name); |
593 |
mark_object(x->cf.cf_data); |
mark_object(x->cf.cf_data); |
594 |
break; |
break; |
595 |
|
|
596 |
case t_cfdata: |
case t_cfdata: |
597 |
|
|
598 |
if (x->cfd.cfd_self != NULL) |
if (x->cfd.cfd_self != NULL) |
599 |
{int i=x->cfd.cfd_fillp; |
{int i=x->cfd.cfd_fillp; |
600 |
while(i-- > 0) |
while(i-- > 0) |
601 |
mark_object(x->cfd.cfd_self[i]);} |
mark_object(x->cfd.cfd_self[i]);} |
602 |
if (x->cfd.cfd_start == NULL) |
if (x->cfd.cfd_start == NULL) |
603 |
break; |
break; |
604 |
if (what_to_collect == t_contiguous) { |
if (what_to_collect == t_contiguous) { |
605 |
if (!MAYBE_DATA_P((x->cfd.cfd_start)) || |
if (!MAYBE_DATA_P((x->cfd.cfd_start)) || |
606 |
get_mark_bit((long *)(x->cfd.cfd_start))) |
get_mark_bit((long *)(x->cfd.cfd_start))) |
607 |
break; |
break; |
608 |
mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size);} |
mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size);} |
609 |
break; |
break; |
610 |
case t_cclosure: |
case t_cclosure: |
611 |
mark_object(x->cc.cc_name); |
mark_object(x->cc.cc_name); |
612 |
mark_object(x->cc.cc_env); |
mark_object(x->cc.cc_env); |
613 |
mark_object(x->cc.cc_data); |
mark_object(x->cc.cc_data); |
614 |
if (what_to_collect == t_contiguous) { |
if (what_to_collect == t_contiguous) { |
615 |
if (x->cc.cc_turbo != NULL) |
if (x->cc.cc_turbo != NULL) |
616 |
mark_contblock((char *)(x->cc.cc_turbo-1), |
mark_contblock((char *)(x->cc.cc_turbo-1), |
617 |
(1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); |
(1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); |
618 |
} |
} |
619 |
break; |
break; |
620 |
|
|
621 |
case t_spice: |
case t_spice: |
622 |
break; |
break; |
623 |
default: |
default: |
624 |
#ifdef DEBUG |
#ifdef DEBUG |
625 |
if (debug) |
if (debug) |
626 |
printf("\ttype = %d\n", type_of(x)); |
printf("\ttype = %d\n", type_of(x)); |
627 |
#endif |
#endif |
628 |
error("mark botch"); |
error("mark botch"); |
629 |
} |
} |
630 |
} |
} |
631 |
|
|
632 |
static long *c_stack_where; |
static long *c_stack_where; |
633 |
|
|
634 |
mark_stack_carefully(top,bottom,offset) |
void |
635 |
long *bottom,*top; |
mark_stack_carefully(void *topv, void *bottomv, int offset) { |
|
{int p,m,pageoffset; |
|
|
object x; |
|
|
struct typemanager *tm; |
|
|
register long *j; |
|
|
|
|
|
/* if either of these happens we are marking the C stack |
|
|
and need to use a local */ |
|
|
|
|
|
if (top==0) top = c_stack_where; |
|
|
if (bottom==0) bottom= c_stack_where; |
|
|
|
|
|
/* On machines which align local pointers on multiple of 2 rather |
|
|
than 4 we need to mark twice |
|
|
*/ |
|
|
|
|
|
if (offset) {mark_stack_carefully((((char *) top) +offset),bottom,0);} |
|
|
for (j=top ; j >= bottom ; j--) |
|
|
{if (VALID_DATA_ADDRESS_P(*j) |
|
|
&& type_map[(p=page(*j))]< (char)t_end) |
|
|
{pageoffset=((char *)*j - pagetochar(p)); |
|
|
tm=tm_of((enum type) type_map[p]); |
|
|
x= (object) |
|
|
((char *)(*j) - |
|
|
((pageoffset=((char *)*j - pagetochar(p))) % |
|
|
tm->tm_size)); |
|
|
if ((pageoffset < (tm->tm_size * tm->tm_nppage)) |
|
|
&& (m=x->d.m) != FREE) |
|
|
{if (m==TRUE) continue; |
|
|
if (m!=0) |
|
|
{fprintf(stdout, |
|
|
"**bad value %d of d.m in gbc page %d skipping mark**" |
|
|
,m,p);fflush(stdout); |
|
|
continue; |
|
|
}; |
|
|
mark_object(x);}}}} |
|
|
|
|
636 |
|
|
637 |
mark_phase() |
int p,m,pageoffset; |
638 |
{ |
object x; |
639 |
STATIC object *p; |
struct typemanager *tm; |
640 |
STATIC int i, j, k, n; |
register long *j; |
641 |
STATIC struct package *pp; |
long *top=topv,*bottom=bottomv; |
642 |
STATIC object s, l, *lp; |
|
643 |
STATIC bds_ptr bdp; |
/* if either of these happens we are marking the C stack |
644 |
STATIC frame_ptr frp; |
and need to use a local */ |
645 |
STATIC ihs_ptr ihsp; |
|
646 |
STATIC char *cp; |
if (top==0) top = c_stack_where; |
647 |
|
if (bottom==0) bottom= c_stack_where; |
648 |
mark_object(Cnil); |
|
649 |
mark_object(Ct); |
/* On machines which align local pointers on multiple of 2 rather |
650 |
|
than 4 we need to mark twice |
651 |
mark_stack_carefully(vs_top-1,vs_org,0); |
*/ |
652 |
clear_stack(vs_top,vs_limit); |
|
653 |
mark_stack_carefully(MVloc+(sizeof(MVloc)/sizeof(object)),MVloc,0); |
if (offset) |
654 |
/* |
mark_stack_carefully((((char *) top) +offset),bottom,0); |
|
for (p = vs_org; p < vs_top; p++) { |
|
|
if (p && (inheap(*p))) |
|
|
mark_object(*p); |
|
|
} |
|
|
*/ |
|
|
#ifdef DEBUG |
|
|
if (debug) { |
|
|
printf("value stack marked\n"); |
|
|
fflush(stdout); |
|
|
} |
|
|
#endif |
|
655 |
|
|
656 |
for (bdp = bds_org; bdp<=bds_top; bdp++) { |
for (j=top ; j >= bottom ; j--) { |
657 |
mark_object(bdp->bds_sym); |
if (VALID_DATA_ADDRESS_P(*j) |
658 |
mark_object(bdp->bds_val); |
&& type_map[(p=page(*j))]< (char)t_end) { |
659 |
|
pageoffset=((char *)*j - pagetochar(p)); |
660 |
|
tm=tm_of((enum type) type_map[p]); |
661 |
|
x= (object) |
662 |
|
((char *)(*j) - |
663 |
|
((pageoffset=((char *)*j - pagetochar(p))) % |
664 |
|
tm->tm_size)); |
665 |
|
if ((pageoffset < (tm->tm_size * tm->tm_nppage)) |
666 |
|
&& (m=x->d.m) != FREE) { |
667 |
|
if (m==TRUE) continue; |
668 |
|
if (m!=0) { |
669 |
|
fprintf(stdout, |
670 |
|
"**bad value %d of d.m in gbc page %d skipping mark**" |
671 |
|
,m,p);fflush(stdout); |
672 |
|
continue; |
673 |
} |
} |
674 |
|
mark_object(x); |
675 |
|
} |
676 |
|
} |
677 |
|
} |
678 |
|
} |
679 |
|
|
|
for (frp = frs_org; frp <= frs_top; frp++) |
|
|
mark_object(frp->frs_val); |
|
|
|
|
|
for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) |
|
|
mark_object(ihsp->ihs_function); |
|
680 |
|
|
681 |
for (i = 0; i < mark_origin_max; i++) |
void |
682 |
mark_object(*mark_origin[i]); |
mark_phase(void) { |
|
for (i = 0; i < mark_origin_block_max; i++) |
|
|
for (j = 0; j < mark_origin_block[i].mob_size; j++) |
|
|
mark_object(mark_origin_block[i].mob_addr[j]); |
|
683 |
|
|
684 |
for (pp = pack_pointer; pp != NULL; pp = pp->p_link) |
STATIC int i, j; |
685 |
mark_object(pp); |
STATIC struct package *pp; |
686 |
|
STATIC bds_ptr bdp; |
687 |
|
STATIC frame_ptr frp; |
688 |
|
STATIC ihs_ptr ihsp; |
689 |
|
|
690 |
|
mark_object(Cnil); |
691 |
|
mark_object(Ct); |
692 |
|
|
693 |
|
mark_stack_carefully(vs_top-1,vs_org,0); |
694 |
|
clear_stack(vs_top,vs_limit); |
695 |
|
mark_stack_carefully(MVloc+(sizeof(MVloc)/sizeof(object)),MVloc,0); |
696 |
|
/* |
697 |
|
for (p = vs_org; p < vs_top; p++) { |
698 |
|
if (p && (inheap(*p))) |
699 |
|
mark_object(*p); |
700 |
|
} |
701 |
|
*/ |
702 |
|
#ifdef DEBUG |
703 |
|
if (debug) { |
704 |
|
printf("value stack marked\n"); |
705 |
|
fflush(stdout); |
706 |
|
} |
707 |
|
#endif |
708 |
|
|
709 |
|
for (bdp = bds_org; bdp<=bds_top; bdp++) { |
710 |
|
mark_object(bdp->bds_sym); |
711 |
|
mark_object(bdp->bds_val); |
712 |
|
} |
713 |
|
|
714 |
|
for (frp = frs_org; frp <= frs_top; frp++) |
715 |
|
mark_object(frp->frs_val); |
716 |
|
|
717 |
|
for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) |
718 |
|
mark_object(ihsp->ihs_function); |
719 |
|
|
720 |
|
for (i = 0; i < mark_origin_max; i++) |
721 |
|
mark_object(*mark_origin[i]); |
722 |
|
for (i = 0; i < mark_origin_block_max; i++) |
723 |
|
for (j = 0; j < mark_origin_block[i].mob_size; j++) |
724 |
|
mark_object(mark_origin_block[i].mob_addr[j]); |
725 |
|
|
726 |
|
for (pp = pack_pointer; pp != NULL; pp = pp->p_link) |
727 |
|
mark_object((object)pp); |
728 |
#ifdef KCLOVM |
#ifdef KCLOVM |
729 |
if (ovm_process_created) |
if (ovm_process_created) |
730 |
mark_all_stacks(); |
mark_all_stacks(); |
731 |
#endif |
#endif |
732 |
|
|
733 |
#ifdef DEBUG |
#ifdef DEBUG |
734 |
if (debug) { |
if (debug) { |
735 |
printf("symbol navigation\n"); |
printf("symbol navigation\n"); |
736 |
fflush(stdout); |
fflush(stdout); |
737 |
} |
} |
738 |
#endif |
#endif |
739 |
|
|
740 |
/* |
/* |
741 |
if (what_to_collect != t_symbol && |
if (what_to_collect != t_symbol && |
742 |
(int)what_to_collect < (int)t_contiguous) { |
(int)what_to_collect < (int)t_contiguous) { |
743 |
*/ |
*/ |
744 |
|
|
745 |
{int size; |
{int size; |
746 |
|
|
747 |
for (pp = pack_pointer; pp != NULL; pp = pp->p_link) { |
for (pp = pack_pointer; pp != NULL; pp = pp->p_link) { |
748 |
size = pp->p_internal_size; |
size = pp->p_internal_size; |
749 |
if (pp->p_internal != NULL) |
if (pp->p_internal != NULL) |
750 |
for (i = 0; i < size; i++) |
for (i = 0; i < size; i++) |
751 |
mark_object(pp->p_internal[i]); |
mark_object(pp->p_internal[i]); |
752 |
size = pp->p_external_size; |
size = pp->p_external_size; |
753 |
if (pp->p_external != NULL) |
if (pp->p_external != NULL) |
754 |
for (i = 0; i < size; i++) |
for (i = 0; i < size; i++) |
755 |
mark_object(pp->p_external[i]); |
mark_object(pp->p_external[i]); |
756 |
}} |
}} |
757 |
|
|
758 |
/* mark the c stack */ |
/* mark the c stack */ |
759 |
#ifndef N_RECURSION_REQD |
#ifndef N_RECURSION_REQD |
760 |
#define N_RECURSION_REQD 2 |
#define N_RECURSION_REQD 2 |
761 |
#endif |
#endif |
762 |
mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully); |
mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully); |
763 |
|
|
764 |
} |
} |
765 |
|
|
766 |
mark_c_stack(env1,n,fn) |
void |
767 |
jmp_buf *env1; |
mark_c_stack(jmp_buf env1, int n, void (*fn)(void *,void *,int)) { |
768 |
int n; |
|
769 |
int (*fn)(); |
jmp_buf env; |
770 |
{jmp_buf env; |
int where; |
771 |
int where; |
if (n== N_RECURSION_REQD) |
772 |
if (n== N_RECURSION_REQD) |
c_stack_where = (long *) (void *) &env; |
773 |
{ c_stack_where = (long *) (void *) &env;} |
if (n > 0 ) { |
774 |
if (n > 0 ) |
setjmp(env); |
775 |
{ setjmp(env); |
mark_c_stack(env,n - 1,fn); |
776 |
mark_c_stack(env,n - 1,fn);} |
} else { |
777 |
else |
|
778 |
{ |
/* If the locals of type object in a C function could be |
779 |
|
aligned other than on multiples of sizeof (char *) |
780 |
/* If the locals of type object in a C function could be |
then define this. At the moment 2 is the only other |
781 |
aligned other than on multiples of sizeof (char *) |
legitimate value besides 0 */ |
782 |
then define this. At the moment 2 is the only other |
|
|
legitimate value besides 0 */ |
|
|
|
|
783 |
#ifndef C_GC_OFFSET |
#ifndef C_GC_OFFSET |
784 |
#define C_GC_OFFSET 0 |
#define C_GC_OFFSET 0 |
785 |
#endif |
#endif |
786 |
if (&where > cs_org) |
if (&where > cs_org) |
787 |
(*fn)(0,cs_org,C_GC_OFFSET); |
(*fn)(0,cs_org,C_GC_OFFSET); |
788 |
else |
else |
789 |
(*fn)(cs_org,0,C_GC_OFFSET);} |
(*fn)(cs_org,0,C_GC_OFFSET);} |
790 |
|
|
791 |
} |
} |
792 |
|
|
793 |
|
void |
794 |
|
sweep_phase(void) { |
|
|
|
|
sweep_phase() |
|
|
{ |
|
|
STATIC int i, j, k; |
|
|
STATIC object x; |
|
|
STATIC char *p; |
|
|
STATIC int *ip; |
|
|
STATIC struct typemanager *tm; |
|
|
STATIC object f; |
|
|
|
|
|
Cnil->s.m = FALSE; |
|
|
Ct->s.m = FALSE; |
|
795 |
|
|
796 |
|
STATIC int i, j, k; |
797 |
|
STATIC object x; |
798 |
|
STATIC char *p; |
799 |
|
STATIC struct typemanager *tm; |
800 |
|
STATIC object f; |
801 |
|
|
802 |
|
Cnil->s.m = FALSE; |
803 |
|
Ct->s.m = FALSE; |
804 |
|
|
805 |
#ifdef DEBUG |
#ifdef DEBUG |
806 |
if (debug) |
if (debug) |
807 |
printf("type map\n"); |
printf("type map\n"); |
808 |
#endif |
#endif |
809 |
for (i = 0; i < maxpage; i++) { |
for (i = 0; i < maxpage; i++) { |
810 |
if (type_map[i] == (int)t_contiguous) { |
if (type_map[i] == (int)t_contiguous) { |
811 |
if (debug) { |
if (debug) { |
812 |
printf("-"); |
printf("-"); |
|
/* |
|
|
fflush(stdout); |
|
|
*/ |
|
|
continue; |
|
|
} |
|
|
} |
|
|
if (type_map[i] >= (int)t_end) |
|
|
continue; |
|
|
|
|
|
tm = tm_of((enum type)type_map[i]); |
|
|
|
|
813 |
/* |
/* |
814 |
general sweeper |
fflush(stdout); |
815 |
*/ |
*/ |
816 |
|
continue; |
817 |
|
} |
818 |
|
} |
819 |
|
if (type_map[i] >= (int)t_end) |
820 |
|
continue; |
821 |
|
|
822 |
|
tm = tm_of((enum type)type_map[i]); |
823 |
|
|
824 |
|
/* |
825 |
|
general sweeper |
826 |
|
*/ |
827 |
|
|
828 |
#ifdef DEBUG |
#ifdef DEBUG |
829 |
if (debug) { |
if (debug) { |
830 |
printf("%c", tm->tm_name[0]); |
printf("%c", tm->tm_name[0]); |
831 |
/* |
/* |
832 |
fflush(stdout); |
fflush(stdout); |
833 |
*/ |
*/ |
834 |
} |
} |
835 |
#endif |
#endif |
836 |
p = pagetochar(i); |
p = pagetochar(i); |
837 |
f = tm->tm_free; |
f = tm->tm_free; |
838 |
k = 0; |
k = 0; |
839 |
for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { |
for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { |
840 |
x = (object)p; |
x = (object)p; |
841 |
if (x->d.m == FREE) |
if (x->d.m == FREE) |
842 |
continue; |
continue; |
843 |
else if (x->d.m) { |
else if (x->d.m) { |
844 |
x->d.m = FALSE; |
x->d.m = FALSE; |
845 |
continue; |
continue; |
846 |
} |
} |
847 |
/* Since we now mark forwards and backwards on displaced |
/* Since we now mark forwards and backwards on displaced |
848 |
arrays, this is not necessary. |
arrays, this is not necessary. |
849 |
switch (x->d.t) { |
switch (x->d.t) { |
850 |
case t_array: |
case t_array: |
851 |
case t_vector: |
case t_vector: |
852 |
case t_string: |
case t_string: |
853 |
case t_bitvector: |
case t_bitvector: |
854 |
if (x->a.a_displaced->c.c_car != Cnil) |
if (x->a.a_displaced->c.c_car != Cnil) |
855 |
{undisplace(x); |
{undisplace(x); |
856 |
} |
} |
857 |
} |
} |
858 |
*/ |
*/ |
859 |
/* ((struct freelist *)x)->f_link = f; */ |
/* ((struct freelist *)x)->f_link = f; */ |
860 |
|
|
861 |
#ifdef GMP_USE_MALLOC |
#ifdef GMP_USE_MALLOC |
862 |
if (x->d.t == t_bignum) { |
if (x->d.t == t_bignum) { |
863 |
mpz_clear(MP(x)); |
mpz_clear(MP(x)); |
864 |
} |
} |
865 |
#endif |
#endif |
866 |
SET_LINK(x,f); |
SET_LINK(x,f); |
867 |
x->d.m = FREE; |
x->d.m = FREE; |
868 |
f = x; |
f = x; |
869 |
k++; |
k++; |
870 |
} |
} |
871 |
tm->tm_free = f; |
tm->tm_free = f; |
872 |
tm->tm_nfree += k; |
tm->tm_nfree += k; |
873 |
|
|
874 |
NEXT_PAGE: |
} |
|
; |
|
|
} |
|
875 |
#ifdef DEBUG |
#ifdef DEBUG |
876 |
if (debug) { |
if (debug) { |
877 |
putchar('\n'); |
putchar('\n'); |
878 |
fflush(stdout); |
fflush(stdout); |
879 |
} |
} |
880 |
#endif |
#endif |
881 |
} |
} |
882 |
|
|
883 |
contblock_sweep_phase() |
void |
884 |
{ |
contblock_sweep_phase(void) { |
885 |
STATIC int i, j; |
|
886 |
STATIC char *s, *e, *p, *q; |
STATIC int i, j; |
887 |
STATIC struct contblock *cbp; |
STATIC char *s, *e, *p, *q; |
888 |
|
STATIC struct contblock *cbp; |
889 |
cb_pointer = NULL; |
|
890 |
ncb = 0; |
cb_pointer = NULL; |
891 |
for (i = 0; i < maxpage;) { |
ncb = 0; |
892 |
if (type_map[i] != (int)t_contiguous) { |
for (i = 0; i < maxpage;) { |
893 |
i++; |
if (type_map[i] != (int)t_contiguous) { |
894 |
continue; |
i++; |
895 |
} |
continue; |
896 |
for (j = i+1; |
} |
897 |
j < maxpage && type_map[j] == (int)t_contiguous; |
for (j = i+1; |
898 |
j++) |
j < maxpage && type_map[j] == (int)t_contiguous; |
899 |
; |
j++) |
900 |
s = pagetochar(i); |
; |
901 |
e = pagetochar(j); |
s = pagetochar(i); |
902 |
for (p = s; p < e;) { |
e = pagetochar(j); |
903 |
if (get_mark_bit((int *)p)) { |
for (p = s; p < e;) { |
904 |
p += PTR_ALIGN; |
if (get_mark_bit((int *)p)) { |
905 |
continue; |
p += PTR_ALIGN; |
906 |
} |
continue; |
907 |
q = p + PTR_ALIGN; |
} |
908 |
while (q < e) { |
q = p + PTR_ALIGN; |
909 |
if (!get_mark_bit((int *)q)) { |
while (q < e) { |
910 |
q += PTR_ALIGN; |
if (!get_mark_bit((int *)q)) { |
911 |
continue; |
q += PTR_ALIGN; |
912 |
} |
continue; |
913 |
break; |
} |
914 |
} |
break; |
915 |
insert_contblock(p, q - p); |
} |
916 |
p = q + PTR_ALIGN; |
insert_contblock(p, q - p); |
917 |
} |
p = q + PTR_ALIGN; |
918 |
i = j + 1; |
} |
919 |
} |
i = j + 1; |
920 |
|
} |
921 |
#ifdef DEBUG |
#ifdef DEBUG |
922 |
if (debug) { |
if (debug) { |
923 |
for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) |
for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) |
924 |
printf("%d-byte contblock\n", cbp->cb_size); |
printf("%d-byte contblock\n", cbp->cb_size); |
925 |
fflush(stdout); |
fflush(stdout); |
926 |
} |
} |
927 |
#endif |
#endif |
928 |
} |
} |
929 |
|
|
931 |
int (*GBC_enter_hook)() = NULL; |
int (*GBC_enter_hook)() = NULL; |
932 |
int (*GBC_exit_hook)() = NULL; |
int (*GBC_exit_hook)() = NULL; |
933 |
char *old_rb_start; |
char *old_rb_start; |
934 |
GBC(t) |
void |
935 |
enum type t; |
GBC(enum type t) { |
936 |
{ |
|
937 |
int i, j; |
int i, j; |
938 |
struct apage *pp, *qq; |
struct apage *pp, *qq; |
939 |
int in_sgc = sgc_enabled; |
int in_sgc = sgc_enabled; |
|
int where ; |
|
940 |
#ifdef DEBUG |
#ifdef DEBUG |
941 |
int tm; |
int tm=0; |
942 |
#endif |
#endif |
943 |
|
|
944 |
if (in_signal_handler && t == t_relocatable) |
if (in_signal_handler && t == t_relocatable) |
945 |
error("cant gc relocatable in signal handler"); |
error("cant gc relocatable in signal handler"); |
946 |
|
|
947 |
if (GBC_enter_hook != NULL) |
if (GBC_enter_hook != NULL) |
948 |
(*GBC_enter_hook)(); |
(*GBC_enter_hook)(); |
949 |
|
|
950 |
if (!GBC_enable) |
if (!GBC_enable) |
951 |
error("GBC is not enabled"); |
error("GBC is not enabled"); |
952 |
interrupt_enable = FALSE; |
interrupt_enable = FALSE; |
953 |
|
|
954 |
if (saving_system) |
if (saving_system) |
955 |
{t = t_contiguous; gc_time = -1; |
{t = t_contiguous; gc_time = -1; |
956 |
if(sgc_enabled) sgc_quit(); |
if(sgc_enabled) sgc_quit(); |
957 |
|
|
958 |
} |
} |
959 |
|
|
960 |
|
|
961 |
#ifdef DEBUG |
#ifdef DEBUG |
962 |
debug = symbol_value(sSAgbc_messageA) != Cnil; |
debug = symbol_value(sSAgbc_messageA) != Cnil; |
963 |
#endif |
#endif |
964 |
|
|
965 |
what_to_collect = t; |
what_to_collect = t; |
966 |
|
|
967 |
tm_table[(int)t].tm_gbccount++; |
tm_table[(int)t].tm_gbccount++; |
968 |
|
|
969 |
#ifdef DEBUG |
#ifdef DEBUG |
970 |
if (debug || (sSAnotify_gbcA->s.s_dbind != Cnil)) { |
if (debug || (sSAnotify_gbcA->s.s_dbind != Cnil)) { |
971 |
|
|
972 |
if (gc_time < 0) gc_time=0; |
if (gc_time < 0) gc_time=0; |
973 |
printf("[%s for %d %s pages..", |
printf("[%s for %d %s pages..", |
974 |
(sgc_enabled ? "SGC" : "GC"), |
(sgc_enabled ? "SGC" : "GC"), |
975 |
(sgc_enabled ? sgc_count_type(t) : tm_of(t)->tm_npage), |
(sgc_enabled ? sgc_count_type(t) : tm_of(t)->tm_npage), |
976 |
(tm_table[(int)t].tm_name)+1); |
(tm_table[(int)t].tm_name)+1); |
977 |
#ifdef SGC |
#ifdef SGC |
978 |
if(sgc_enabled) |
if(sgc_enabled) |
979 |
printf("(%d writable)..",sgc_count_writable(page(core_end))); |
printf("(%d writable)..",sgc_count_writable(page(core_end))); |
980 |
#endif |
#endif |
981 |
fflush(stdout); |
fflush(stdout); |
982 |
} |
} |
983 |
#endif |
#endif |
984 |
if (gc_time >=0) {gc_start=runtime();} |
if (gc_time >=0) {gc_start=runtime();} |
985 |
|
|
986 |
maxpage = page(heap_end); |
maxpage = page(heap_end); |
987 |
|
|
988 |
if ((int)t >= (int)t_contiguous) { |
if ((int)t >= (int)t_contiguous) { |
989 |
j = maxpage*(PAGESIZE/(sizeof(int)*sizeof(int)*CHAR_SIZE)) ; |
j = maxpage*(PAGESIZE/(sizeof(int)*sizeof(int)*CHAR_SIZE)) ; |
990 |
/* |
/* |
991 |
(PAGESIZE / sizeof(int)) = x * (sizeof(int)*CHAR_SIZE) |
(PAGESIZE / sizeof(int)) = x * (sizeof(int)*CHAR_SIZE) |
992 |
eg if PAGESIZE = 2048 x=16 |
eg if PAGESIZE = 2048 x=16 |
993 |
1 page = 512 long word |
1 page = 512 long word |
994 |
512 bit = 16 long word |
512 bit = 16 long word |
995 |
*/ |
*/ |
996 |
|
|
997 |
if (t == t_relocatable) |
if (t == t_relocatable) |
998 |
j = 0; |
j = 0; |
999 |
/* if in sgc we don't need more pages below hole |
/* if in sgc we don't need more pages below hole |
1000 |
just more relocatable or cleaning it */ |
just more relocatable or cleaning it */ |
1001 |
if (sgc_enabled ==0 && holepage < new_holepage) |
if (sgc_enabled ==0 && holepage < new_holepage) |
1002 |
holepage = new_holepage; |
holepage = new_holepage; |
1003 |
|
|
1004 |
i = rb_pointer - (sgc_enabled ? old_rb_start : rb_start); |
i = rb_pointer - (sgc_enabled ? old_rb_start : rb_start); |
1005 |
|
|
1006 |
if (nrbpage > (real_maxpage-page(heap_end) |
if (nrbpage > (real_maxpage-page(heap_end) |
1007 |
-holepage-real_maxpage/32)/2) { |
-holepage-real_maxpage/32)/2) { |
1008 |
if (i > nrbpage*PAGESIZE) |
if (i > nrbpage*PAGESIZE) |
1009 |
error("Can't allocate. Good-bye!."); |
error("Can't allocate. Good-bye!."); |
1010 |
else |
else |
1011 |
nrbpage = |
nrbpage = |
1012 |
(real_maxpage-page(heap_end) |
(real_maxpage-page(heap_end) |
1013 |
-holepage-real_maxpage/32)/2; |
-holepage-real_maxpage/32)/2; |
1014 |
} |
} |
1015 |
|
|
1016 |
if (saving_system) |
if (saving_system) |
1017 |
rb_start = heap_end; |
rb_start = heap_end; |
1018 |
else |
else |
1019 |
if (sgc_enabled==0) |
if (sgc_enabled==0) |
1020 |
{rb_start = heap_end + PAGESIZE*holepage;} |
{rb_start = heap_end + PAGESIZE*holepage;} |
1021 |
|
|
1022 |
rb_end = heap_end + (holepage + nrbpage) *PAGESIZE; |
rb_end = heap_end + (holepage + nrbpage) *PAGESIZE; |
1023 |
|
|
1024 |
if (rb_start < rb_pointer) |
if (rb_start < rb_pointer) |
1025 |
rb_start1 = (char *) |
rb_start1 = (char *) |
1026 |
((long)(rb_pointer + PAGESIZE-1) & -(unsigned long)PAGESIZE); |
((long)(rb_pointer + PAGESIZE-1) & -(unsigned long)PAGESIZE); |
1027 |
else |
else |
1028 |
rb_start1 = rb_start; |
rb_start1 = rb_start; |
1029 |
|
|
1030 |
/* as we walk through marking data, we replace the |
/* as we walk through marking data, we replace the |
1031 |
relocatable pointers |
relocatable pointers |
1032 |
in objects by the rb_pointer, advance that |
in objects by the rb_pointer, advance that |
1033 |
by the size, and copy the actual |
by the size, and copy the actual |
1034 |
data there to rb_pointer1, and advance it by the size |
data there to rb_pointer1, and advance it by the size |
1035 |
at the end [rb_start1,rb_pointer1] is copied |
at the end [rb_start1,rb_pointer1] is copied |
1036 |
to [rb_start,rb_pointer] |
to [rb_start,rb_pointer] |
1037 |
*/ |
*/ |
1038 |
rb_pointer = rb_start; /* where the new relblock will start */ |
rb_pointer = rb_start; /* where the new relblock will start */ |
1039 |
rb_pointer1 = rb_start1;/* where we will copy it to during gc*/ |
rb_pointer1 = rb_start1;/* where we will copy it to during gc*/ |
1040 |
|
|
1041 |
mark_table = (long *)(rb_start1 + i); |
mark_table = (long *)(rb_start1 + i); |
1042 |
|
|
1043 |
if (rb_end < (char *)&mark_table[j]) |
if (rb_end < (char *)&mark_table[j]) |
1044 |
i = (char *)&mark_table[j] - heap_end; |
i = (char *)&mark_table[j] - heap_end; |
1045 |
else |
else |
1046 |
i = rb_end - heap_end; |
i = rb_end - heap_end; |
1047 |
alloc_page(-(i + PAGESIZE - 1)/PAGESIZE); |
alloc_page(-(i + PAGESIZE - 1)/PAGESIZE); |
1048 |
|
|
1049 |
for (i = 0; i < j; i++) |
for (i = 0; i < j; i++) |
1050 |
mark_table[i] = 0; |
mark_table[i] = 0; |
1051 |
} |
} |
1052 |
|
|
1053 |
#ifdef DEBUG |
#ifdef DEBUG |
1054 |
if (debug) { |
if (debug) { |
1055 |
printf("mark phase\n"); |
printf("mark phase\n"); |
1056 |
fflush(stdout); |
fflush(stdout); |
1057 |
tm = runtime(); |
tm = runtime(); |
1058 |
} |
} |
1059 |
#endif |
#endif |
1060 |
#ifdef SGC |
#ifdef SGC |
1061 |
if(sgc_enabled) |
if(sgc_enabled) |
1062 |
{ if (t < t_end && tm_of(t)->tm_sgc == 0) |
{ if (t < t_end && tm_of(t)->tm_sgc == 0) |
1063 |
{sgc_quit(); |
{sgc_quit(); |
1064 |
if (sSAnotify_gbcA->s.s_dbind != Cnil) |
if (sSAnotify_gbcA->s.s_dbind != Cnil) |
1065 |
{fprintf(stdout, " (doing full gc)"); |
{fprintf(stdout, " (doing full gc)"); |
1066 |
fflush(stdout);} |
fflush(stdout);} |
1067 |
mark_phase();} |
mark_phase();} |
1068 |
else |
else |
1069 |
sgc_mark_phase();} |
sgc_mark_phase();} |
1070 |
else |
else |
1071 |
#endif |
#endif |
1072 |
mark_phase(); |
mark_phase(); |
1073 |
#ifdef DEBUG |
#ifdef DEBUG |
1074 |
if (debug) { |
if (debug) { |
1075 |
printf("mark ended (%d)\n", runtime() - tm); |
printf("mark ended (%d)\n", runtime() - tm); |
1076 |
fflush(stdout); |
fflush(stdout); |
1077 |
} |
} |
1078 |
#endif |
#endif |
1079 |
|
|
1080 |
#ifdef DEBUG |
#ifdef DEBUG |
1081 |
if (debug) { |
if (debug) { |
1082 |
printf("sweep phase\n"); |
printf("sweep phase\n"); |
1083 |
fflush(stdout); |
fflush(stdout); |
1084 |
tm = runtime(); |
tm = runtime(); |
1085 |
} |
} |
1086 |
#endif |
#endif |
1087 |
#ifdef SGC |
#ifdef SGC |
1088 |
if(sgc_enabled) |
if(sgc_enabled) |
1089 |
sgc_sweep_phase(); |
sgc_sweep_phase(); |
1090 |
else |
else |
1091 |
#endif |
#endif |
1092 |
sweep_phase(); |
sweep_phase(); |
1093 |
#ifdef DEBUG |
#ifdef DEBUG |
1094 |
if (debug) { |
if (debug) { |
1095 |
printf("sweep ended (%d)\n", runtime() - tm); |
printf("sweep ended (%d)\n", runtime() - tm); |
1096 |
fflush(stdout); |
fflush(stdout); |
1097 |
} |
} |
1098 |
#endif |
#endif |
1099 |
|
|
1100 |
if (t == t_contiguous) { |
if (t == t_contiguous) { |
1101 |
#ifdef DEBUG |
#ifdef DEBUG |
1102 |
if (debug) { |
if (debug) { |
1103 |
printf("contblock sweep phase\n"); |
printf("contblock sweep phase\n"); |
1104 |
fflush(stdout); |
fflush(stdout); |
1105 |
tm = runtime(); |
tm = runtime(); |
1106 |
} |
} |
1107 |
#endif |
#endif |
1108 |
|
|
1109 |
#ifdef SGC |
#ifdef SGC |
1110 |
if (sgc_enabled) |
if (sgc_enabled) |
1111 |
sgc_contblock_sweep_phase(); |
sgc_contblock_sweep_phase(); |
1112 |
else |
else |
1113 |
#endif |
#endif |
1114 |
contblock_sweep_phase(); |
contblock_sweep_phase(); |
1115 |
#ifdef DEBUG |
#ifdef DEBUG |
1116 |
if (debug) |
if (debug) |
1117 |
printf("contblock sweep ended (%d)\n", |
printf("contblock sweep ended (%d)\n", |
1118 |
runtime() - tm); |
runtime() - tm); |
1119 |
#endif |
#endif |
1120 |
} |
} |
1121 |
|
|
1122 |
if ((int)t >= (int)t_contiguous) { |
if ((int)t >= (int)t_contiguous) { |
1123 |
|
|
1124 |
if (rb_start < rb_start1) { |
if (rb_start < rb_start1) { |
1125 |
j = (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE; |
j = (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE; |
1126 |
pp = (struct apage *)rb_start; |
pp = (struct apage *)rb_start; |
1127 |
qq = (struct apage *)rb_start1; |
qq = (struct apage *)rb_start1; |
1128 |
for (i = 0; i < j; i++) |
for (i = 0; i < j; i++) |
1129 |
*pp++ = *qq++; |
*pp++ = *qq++; |
1130 |
} |
} |
1131 |
|
|
1132 |
#ifdef SGC |
#ifdef SGC |
1133 |
/* we don't know which pages have relblock on them */ |
/* we don't know which pages have relblock on them */ |
1134 |
if(sgc_enabled) |
if(sgc_enabled) |
1135 |
make_writable(page(rb_start), |
make_writable(page(rb_start), |
1136 |
(rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE); |
(rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE); |
1137 |
|
|
1138 |
#endif |
#endif |
1139 |
rb_limit = rb_end - 2*RB_GETA; |
rb_limit = rb_end - 2*RB_GETA; |
1140 |
|
|
1141 |
} |
} |
1142 |
|
|
1143 |
#ifdef DEBUG |
#ifdef DEBUG |
1144 |
if (debug) { |
if (debug) { |
1145 |
for (i = 0, j = 0; i < (int)t_end; i++) { |
for (i = 0, j = 0; i < (int)t_end; i++) { |
1146 |
if (tm_table[i].tm_type == (enum type)i) { |
if (tm_table[i].tm_type == (enum type)i) { |
1147 |
printf("%13s: %8d used %8d free %4d/%d pages\n", |
printf("%13s: %8d used %8d free %4d/%d pages\n", |
1148 |
tm_table[i].tm_name, |
tm_table[i].tm_name, |
1149 |
TM_NUSED(tm_table[i]), |
TM_NUSED(tm_table[i]), |
1150 |
tm_table[i].tm_nfree, |
tm_table[i].tm_nfree, |
1151 |
tm_table[i].tm_npage, |
tm_table[i].tm_npage, |
1152 |
tm_table[i].tm_maxpage); |
tm_table[i].tm_maxpage); |
1153 |
j += tm_table[i].tm_npage; |
j += tm_table[i].tm_npage; |
1154 |
} else |
} else |
1155 |
printf("%13s: linked to %s\n", |
printf("%13s: linked to %s\n", |
1156 |
tm_table[i].tm_name, |
tm_table[i].tm_name, |
1157 |
tm_table[(int)tm_table[i].tm_type].tm_name); |
tm_table[(int)tm_table[i].tm_type].tm_name); |
1158 |
} |
} |
1159 |
printf("contblock: %d blocks %d pages\n", ncb, ncbpage); |
printf("contblock: %d blocks %d pages\n", ncb, ncbpage); |
1160 |
printf("hole: %d pages\n", holepage); |
printf("hole: %d pages\n", holepage); |
1161 |
printf("relblock: %d bytes used %d bytes free %d pages\n", |
printf("relblock: %d bytes used %d bytes free %d pages\n", |
1162 |
rb_pointer - rb_start, rb_end - rb_pointer, nrbpage); |
rb_pointer - rb_start, rb_end - rb_pointer, nrbpage); |
1163 |
printf("GBC ended\n"); |
printf("GBC ended\n"); |
1164 |
fflush(stdout); |
fflush(stdout); |
1165 |
} |
} |
1166 |
#endif |
#endif |
1167 |
|
|
1168 |
interrupt_enable = TRUE; |
interrupt_enable = TRUE; |
1169 |
|
|
1170 |
if (saving_system) { |
if (saving_system) { |
1171 |
j = (rb_pointer-rb_start+PAGESIZE-1) / PAGESIZE; |
j = (rb_pointer-rb_start+PAGESIZE-1) / PAGESIZE; |
1172 |
|
|
1173 |
heap_end += PAGESIZE*j; |
heap_end += PAGESIZE*j; |
1174 |
|
|
1175 |
/* When the program is re-loaded, the system initialization |
/* When the program is re-loaded, the system initialization |
1176 |
code may use malloc() before main() begins. This |
code may use malloc() before main() begins. This |
1177 |
happens in Linux. We need to allow some heap expansion |
happens in Linux. We need to allow some heap expansion |
1178 |
space for this. One page is enough for Linux. |
space for this. One page is enough for Linux. |
1179 |
Bill Metzenthen May95. |
Bill Metzenthen May95. |
1180 |
*/ |
*/ |
1181 |
if ( core_end < heap_end + PAGESIZE ) |
if ( core_end < heap_end + PAGESIZE ) |
1182 |
{ |
{ |
1183 |
fprintf(stderr, |
fprintf(stderr, |
1184 |
"Not enough memory available for saved image\n"); |
"Not enough memory available for saved image\n"); |
1185 |
exit(1); |
exit(1); |
1186 |
} |
} |
1187 |
core_end = heap_end + PAGESIZE; |
core_end = heap_end + PAGESIZE; |
1188 |
|
|
1189 |
for (i = 0; i < maxpage; i++) |
for (i = 0; i < maxpage; i++) |
1190 |
if ((enum type)type_map[i] == t_contiguous) |
if ((enum type)type_map[i] == t_contiguous) |
1191 |
type_map[i] = (char)t_other; |
type_map[i] = (char)t_other; |
1192 |
cb_pointer = NULL; |
cb_pointer = NULL; |
1193 |
maxcbpage -= ncbpage; |
maxcbpage -= ncbpage; |
1194 |
if (maxcbpage < 100) |
if (maxcbpage < 100) |
1195 |
maxcbpage = 100; |
maxcbpage = 100; |
1196 |
ncbpage = 0; |
ncbpage = 0; |
1197 |
ncb = 0; |
ncb = 0; |
1198 |
|
|
1199 |
/* hmm.... why is this test necessary.*/ |
/* hmm.... why is this test necessary.*/ |
1200 |
if (sgc_enabled==0) {holepage = new_holepage; |
if (sgc_enabled==0) {holepage = new_holepage; |
1201 |
nrbpage = INIT_NRBPAGE;} |
nrbpage = INIT_NRBPAGE;} |
1202 |
|
|
1203 |
if (nrbpage < 0) |
if (nrbpage < 0) |
1204 |
error("no relocatable pages left"); |
error("no relocatable pages left"); |
1205 |
|
|
1206 |
rb_start = heap_end + PAGESIZE*holepage; |
rb_start = heap_end + PAGESIZE*holepage; |
1207 |
rb_end = rb_start + PAGESIZE*nrbpage; |
rb_end = rb_start + PAGESIZE*nrbpage; |
1208 |
rb_limit = rb_end - 2*RB_GETA; |
rb_limit = rb_end - 2*RB_GETA; |
1209 |
rb_pointer = rb_start; |
rb_pointer = rb_start; |
1210 |
} |
} |
1211 |
|
|
1212 |
if (GBC_exit_hook != NULL) |
if (GBC_exit_hook != NULL) |
1213 |
(*GBC_exit_hook)(); |
(*GBC_exit_hook)(); |
1214 |
|
|
1215 |
|
|
1216 |
if (in_sgc && sgc_enabled==0) |
if (in_sgc && sgc_enabled==0) |
1217 |
sgc_start(); |
sgc_start(); |
1218 |
|
|
1219 |
if(gc_time>=0) {gc_time=gc_time+(gc_start=(runtime()-gc_start));} |
if(gc_time>=0) {gc_time=gc_time+(gc_start=(runtime()-gc_start));} |
1220 |
|
|
1221 |
if (sSAnotify_gbcA->s.s_dbind != Cnil) { |
if (sSAnotify_gbcA->s.s_dbind != Cnil) { |
1222 |
|
|
1223 |
fprintf(stdout, "(T=%d).GC finished]\n", |
fprintf(stdout, "(T=%d).GC finished]\n", |
1224 |
gc_start |
gc_start |
1225 |
); |
); |
1226 |
fflush(stdout); |
fflush(stdout); |
1227 |
} |
} |
1228 |
|
|
1229 |
|
|
1230 |
CHECK_INTERRUPT; |
CHECK_INTERRUPT; |
1231 |
} |
} |
1232 |
|
|
1233 |
siLroom_report() |
void |
1234 |
{ |
siLroom_report(void) { |
|
int i; |
|
|
|
|
|
check_arg(0); |
|
|
|
|
|
/* |
|
|
GBC(t_contiguous); |
|
|
*/ |
|
1235 |
|
|
1236 |
vs_check_push(make_fixnum(real_maxpage)); |
int i; |
1237 |
vs_push(make_fixnum(available_pages)); |
|
1238 |
vs_push(make_fixnum(ncbpage)); |
check_arg(0); |
1239 |
vs_push(make_fixnum(maxcbpage)); |
|
1240 |
vs_push(make_fixnum(ncb)); |
/* |
1241 |
vs_push(make_fixnum(cbgbccount)); |
GBC(t_contiguous); |
1242 |
vs_push(make_fixnum(holepage)); |
*/ |
1243 |
vs_push(make_fixnum(rb_pointer - rb_start)); |
|
1244 |
vs_push(make_fixnum(rb_end - rb_pointer)); |
vs_check_push(make_fixnum(real_maxpage)); |
1245 |
vs_push(make_fixnum(nrbpage)); |
vs_push(make_fixnum(available_pages)); |
1246 |
vs_push(make_fixnum(rbgbccount)); |
vs_push(make_fixnum(ncbpage)); |
1247 |
for (i = 0; i < (int)t_end; i++) { |
vs_push(make_fixnum(maxcbpage)); |
1248 |
if (tm_table[i].tm_type == (enum type)i) { |
vs_push(make_fixnum(ncb)); |
1249 |
vs_check_push(make_fixnum(TM_NUSED(tm_table[i]))); |
vs_push(make_fixnum(cbgbccount)); |
1250 |
vs_push(make_fixnum(tm_table[i].tm_nfree)); |
vs_push(make_fixnum(holepage)); |
1251 |
vs_push(make_fixnum(tm_table[i].tm_npage)); |
vs_push(make_fixnum(rb_pointer - rb_start)); |
1252 |
vs_push(make_fixnum(tm_table[i].tm_maxpage)); |
vs_push(make_fixnum(rb_end - rb_pointer)); |
1253 |
vs_push(make_fixnum(tm_table[i].tm_gbccount)); |
vs_push(make_fixnum(nrbpage)); |
1254 |
} else { |
vs_push(make_fixnum(rbgbccount)); |
1255 |
vs_check_push(Cnil); |
for (i = 0; i < (int)t_end; i++) { |
1256 |
vs_push(make_fixnum(tm_table[i].tm_type)); |
if (tm_table[i].tm_type == (enum type)i) { |
1257 |
vs_push(Cnil); |
vs_check_push(make_fixnum(TM_NUSED(tm_table[i]))); |
1258 |
vs_push(Cnil); |
vs_push(make_fixnum(tm_table[i].tm_nfree)); |
1259 |
vs_push(Cnil); |
vs_push(make_fixnum(tm_table[i].tm_npage)); |
1260 |
} |
vs_push(make_fixnum(tm_table[i].tm_maxpage)); |
1261 |
} |
vs_push(make_fixnum(tm_table[i].tm_gbccount)); |
1262 |
|
} else { |
1263 |
|
vs_check_push(Cnil); |
1264 |
|
vs_push(make_fixnum(tm_table[i].tm_type)); |
1265 |
|
vs_push(Cnil); |
1266 |
|
vs_push(Cnil); |
1267 |
|
vs_push(Cnil); |
1268 |
|
} |
1269 |
|
} |
1270 |
} |
} |
1271 |
|
|
1272 |
siLreset_gbc_count() |
void |
1273 |
{ |
siLreset_gbc_count(void) { |
|
int i; |
|
|
|
|
|
check_arg(0); |
|
1274 |
|
|
1275 |
for (i = 0; i < (int)t_other; i++) |
int i; |
1276 |
tm_table[i].tm_gbccount = 0; |
|
1277 |
|
check_arg(0); |
1278 |
|
|
1279 |
|
for (i = 0; i < (int)t_other; i++) |
1280 |
|
tm_table[i].tm_gbccount = 0; |
1281 |
} |
} |
1282 |
|
|
1283 |
/* copy S bytes starting at P to beyond rb_pointer1 (temporarily) |
/* copy S bytes starting at P to beyond rb_pointer1 (temporarily) |
1284 |
but return a pointer to where this will be copied back to, |
but return a pointer to where this will be copied back to, |
1285 |
when gc is done. alignment of rb_pointer is kept at a multiple |
when gc is done. alignment of rb_pointer is kept at a multiple |
1286 |
of sizeof(char *); |
of sizeof(char *); |
1287 |
*/ |
*/ |
1288 |
|
|
1289 |
char * |
char * |
1290 |
copy_relblock(p, s) |
copy_relblock(char *p, int s) |
|
char *p; |
|
|
int s; |
|
1291 |
{ char *res = rb_pointer; |
{ char *res = rb_pointer; |
1292 |
char *q = rb_pointer1; |
char *q = rb_pointer1; |
1293 |
s = ROUND_UP_PTR(s); |
s = ROUND_UP_PTR(s); |
1294 |
rb_pointer += s; |
rb_pointer += s; |
1295 |
rb_pointer1 += s; |
rb_pointer1 += s; |
1296 |
|
|
1297 |
while (--s >= 0) |
while (--s >= 0) |
1298 |
{ *q++ = *p++;} |
{ *q++ = *p++;} |
1299 |
|
|
1300 |
return res; |
return res; |
1301 |
} |
} |
1302 |
|
|
|
|
|
|
mark_contblock(p, s) |
|
|
char *p; |
|
|
int s; |
|
|
{ |
|
|
STATIC char *q; |
|
|
STATIC int *x, *y; |
|
1303 |
|
|
1304 |
if (!MAYBE_DATA_P(p) || (enum type)type_map[page(p)] != t_contiguous) |
void |
1305 |
return; |
mark_contblock(void *p, int s) { |
1306 |
q = p + s; |
|
1307 |
x = (int *)ROUND_DOWN_PTR(p); |
STATIC char *q; |
1308 |
y = (int *)ROUND_UP_PTR(q); |
STATIC int *x, *y; |
1309 |
for (; x < y; x++) |
|
1310 |
set_mark_bit(x); |
if (!MAYBE_DATA_P(p) || (enum type)type_map[page(p)] != t_contiguous) |
1311 |
|
return; |
1312 |
|
q = p + s; |
1313 |
|
x = (int *)ROUND_DOWN_PTR(p); |
1314 |
|
y = (int *)ROUND_UP_PTR(q); |
1315 |
|
for (; x < y; x++) |
1316 |
|
set_mark_bit(x); |
1317 |
} |
} |
1318 |
|
|
1319 |
DEFUNO("GBC",object,fLgbc,LISP |
DEFUNO("GBC",object,fLgbc,LISP |
1320 |
,1,1,NONE,OO,OO,OO,OO,Lgbc,"")(x0) |
,1,1,NONE,OO,OO,OO,OO,Lgbc,"")(x0) |
1321 |
object x0; |
object x0; |
1322 |
{ |
{ |
1323 |
/* 1 args */ |
/* 1 args */ |
1324 |
|
|
1325 |
if (x0 == Ct) |
if (x0 == Ct) |
1326 |
GBC(t_contiguous); |
GBC(t_contiguous); |
1327 |
else if (x0 == Cnil) |
else if (x0 == Cnil) |
1328 |
GBC(t_cons); |
GBC(t_cons); |
1329 |
else |
else |
1330 |
{ x0 = small_fixnum(1); GBC(t_relocatable);} |
{ x0 = small_fixnum(1); GBC(t_relocatable);} |
1331 |
RETURN1(x0); |
RETURN1(x0); |
1332 |
} |
} |
1333 |
|
|
1334 |
siLgbc_time() |
void |
1335 |
{if (vs_top>vs_base) |
siLgbc_time(void) { |
1336 |
gc_time=fix(vs_base[0]); |
if (vs_top>vs_base) |
1337 |
else |
gc_time=fix(vs_base[0]); |
1338 |
{vs_base[0]=make_fixnum(gc_time); |
else { |
1339 |
vs_top=vs_base+1;} |
vs_base[0]=make_fixnum(gc_time); |
1340 |
|
vs_top=vs_base+1; |
1341 |
|
} |
1342 |
} |
} |
1343 |
|
|
1344 |
#ifdef SGC |
#ifdef SGC |
1350 |
DEFVAR("*GBC-MESSAGE*",sSAgbc_messageA,SI,Cnil,""); |
DEFVAR("*GBC-MESSAGE*",sSAgbc_messageA,SI,Cnil,""); |
1351 |
#endif |
#endif |
1352 |
|
|
1353 |
init_GBC() |
void |
1354 |
{ |
init_GBC(void) { |
|
make_si_function("ROOM-REPORT", siLroom_report); |
|
|
make_si_function("RESET-GBC-COUNT", siLreset_gbc_count); |
|
|
make_si_function("GBC-TIME",siLgbc_time); |
|
|
|
|
|
|
|
|
|
|
1355 |
|
|
1356 |
|
int i,j; |
1357 |
|
|
1358 |
|
make_si_function("ROOM-REPORT", siLroom_report); |
1359 |
|
make_si_function("RESET-GBC-COUNT", siLreset_gbc_count); |
1360 |
|
make_si_function("GBC-TIME",siLgbc_time); |
1361 |
|
|
1362 |
#ifdef SGC |
#ifdef SGC |
1363 |
/* we use that maxpage is a power of 2 in this |
/* we use that maxpage is a power of 2 in this |
1364 |
case, to quickly be able to look in our table */ |
case, to quickly be able to look in our table */ |
1365 |
{int i ; |
for(i=j=1 ; i< 32 ; i++) |
1366 |
for(i=1 ; i< 32 ; i++) |
if (MAXPAGE == (1 <<i)) |
1367 |
{if (MAXPAGE == (1 <<i)) |
j=0; |
1368 |
goto ok;} |
if (j) { |
1369 |
perror("MAXPAGE is not a power of 2. Recompile"); |
perror("MAXPAGE is not a power of 2. Recompile"); |
1370 |
exit(1); |
exit(1); |
1371 |
ok:;} |
} |
1372 |
make_si_function("SGC-ON",siLsgc_on); |
make_si_function("SGC-ON",siLsgc_on); |
1373 |
#endif |
#endif |
1374 |
} |
} |
|
|
|