1 | /* |
---|
2 | Copyright (C) 1994-2001 Digitool, Inc |
---|
3 | This file is part of OpenMCL. |
---|
4 | |
---|
5 | OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
6 | License , known as the LLGPL and distributed with OpenMCL as the |
---|
7 | file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
8 | which is distributed with OpenMCL as the file "LGPL". Where these |
---|
9 | conflict, the preamble takes precedence. |
---|
10 | |
---|
11 | OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
12 | |
---|
13 | The LLGPL is also available online at |
---|
14 | http://opensource.franz.com/preamble.html |
---|
15 | */ |
---|
16 | |
---|
17 | #include "lisp.h" |
---|
18 | #include "lisp_globals.h" |
---|
19 | #include "bits.h" |
---|
20 | #include "gc.h" |
---|
21 | #include "area.h" |
---|
22 | #include "Threads.h" |
---|
23 | #include <stddef.h> |
---|
24 | #include <stdlib.h> |
---|
25 | #include <string.h> |
---|
26 | #include <sys/time.h> |
---|
27 | |
---|
28 | |
---|
29 | /* Heap sanity checking. */ |
---|
30 | |
---|
31 | void |
---|
32 | check_node(LispObj n) |
---|
33 | { |
---|
34 | int tag = fulltag_of(n), header_tag; |
---|
35 | area *a; |
---|
36 | LispObj header; |
---|
37 | |
---|
38 | if (n == (n & 0xff)) { |
---|
39 | return; |
---|
40 | } |
---|
41 | |
---|
42 | switch (tag) { |
---|
43 | case fulltag_even_fixnum: |
---|
44 | case fulltag_odd_fixnum: |
---|
45 | #ifdef X8632 |
---|
46 | case fulltag_imm: |
---|
47 | #endif |
---|
48 | #ifdef X8664 |
---|
49 | case fulltag_imm_0: |
---|
50 | case fulltag_imm_1: |
---|
51 | #endif |
---|
52 | return; |
---|
53 | |
---|
54 | #ifdef X8664 |
---|
55 | case fulltag_nil: |
---|
56 | if (n != lisp_nil) { |
---|
57 | Bug(NULL,"Object tagged as nil, not nil : " LISP, n); |
---|
58 | } |
---|
59 | return; |
---|
60 | #endif |
---|
61 | |
---|
62 | #ifdef X8632 |
---|
63 | case fulltag_nodeheader: |
---|
64 | case fulltag_immheader: |
---|
65 | #endif |
---|
66 | #ifdef X8664 |
---|
67 | case fulltag_nodeheader_0: |
---|
68 | case fulltag_nodeheader_1: |
---|
69 | case fulltag_immheader_0: |
---|
70 | case fulltag_immheader_1: |
---|
71 | case fulltag_immheader_2: |
---|
72 | #endif |
---|
73 | Bug(NULL, "Header not expected : 0x" LISP, n); |
---|
74 | return; |
---|
75 | |
---|
76 | #ifdef X8632 |
---|
77 | case fulltag_tra: |
---|
78 | #endif |
---|
79 | #ifdef X8664 |
---|
80 | case fulltag_tra_0: |
---|
81 | case fulltag_tra_1: |
---|
82 | #endif |
---|
83 | a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); |
---|
84 | if (a == NULL) { |
---|
85 | a = active_dynamic_area; |
---|
86 | if ((n > (ptr_to_lispobj(a->active))) && |
---|
87 | (n < (ptr_to_lispobj(a->high)))) { |
---|
88 | Bug(NULL, "TRA points to heap free space: 0x" LISP, n); |
---|
89 | } |
---|
90 | return; |
---|
91 | } |
---|
92 | /* tra points into the heap. Check displacement, then |
---|
93 | check the function it (should) identify. |
---|
94 | */ |
---|
95 | #ifdef X8632 |
---|
96 | { |
---|
97 | LispObj fun = 0; |
---|
98 | |
---|
99 | if (*(unsigned char *)n == RECOVER_FN_OPCODE) |
---|
100 | fun = *(LispObj *)(n + 1); |
---|
101 | if (fun == 0 || |
---|
102 | (header_subtag(header_of(fun)) != subtag_function) || |
---|
103 | (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) { |
---|
104 | Bug(NULL, "TRA at 0x" LISP " has bad function address 0x" LISP "\n", n, fun); |
---|
105 | } |
---|
106 | n = fun; |
---|
107 | } |
---|
108 | #endif |
---|
109 | #ifdef X8664 |
---|
110 | { |
---|
111 | int disp = 0; |
---|
112 | LispObj m = n; |
---|
113 | |
---|
114 | if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
115 | (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { |
---|
116 | disp = (*(int *) (n+3)); |
---|
117 | n = RECOVER_FN_FROM_RIP_LENGTH+m+disp; |
---|
118 | } |
---|
119 | if ((disp == 0) || |
---|
120 | (fulltag_of(n) != fulltag_function) || |
---|
121 | (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) { |
---|
122 | Bug(NULL, "TRA at 0x" LISP " has bad displacement %d\n", n, disp); |
---|
123 | } |
---|
124 | } |
---|
125 | #endif |
---|
126 | /* Otherwise, fall through and check the header on the function |
---|
127 | that the tra references */ |
---|
128 | |
---|
129 | case fulltag_misc: |
---|
130 | case fulltag_cons: |
---|
131 | #ifdef X8664 |
---|
132 | case fulltag_symbol: |
---|
133 | case fulltag_function: |
---|
134 | #endif |
---|
135 | a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); |
---|
136 | |
---|
137 | if (a == NULL) { |
---|
138 | /* Can't do as much sanity checking as we'd like to |
---|
139 | if object is a defunct stack-consed object. |
---|
140 | If a dangling reference to the heap, that's |
---|
141 | bad .. */ |
---|
142 | a = active_dynamic_area; |
---|
143 | if ((n > (ptr_to_lispobj(a->active))) && |
---|
144 | (n < (ptr_to_lispobj(a->high)))) { |
---|
145 | Bug(NULL, "Node points to heap free space: 0x" LISP, n); |
---|
146 | } |
---|
147 | return; |
---|
148 | } |
---|
149 | break; |
---|
150 | } |
---|
151 | /* Node points to heap area, so check header/lack thereof. */ |
---|
152 | header = header_of(n); |
---|
153 | header_tag = fulltag_of(header); |
---|
154 | if (tag == fulltag_cons) { |
---|
155 | if ((nodeheader_tag_p(header_tag)) || |
---|
156 | (immheader_tag_p(header_tag))) { |
---|
157 | Bug(NULL, "Cons cell at 0x" LISP " has bogus header : 0x" LISP, n, header); |
---|
158 | } |
---|
159 | return; |
---|
160 | } |
---|
161 | |
---|
162 | if ((!nodeheader_tag_p(header_tag)) && |
---|
163 | (!immheader_tag_p(header_tag))) { |
---|
164 | Bug(NULL,"Vector at 0x" LISP " has bogus header : 0x" LISP, n, header); |
---|
165 | } |
---|
166 | return; |
---|
167 | } |
---|
168 | |
---|
169 | void |
---|
170 | check_all_mark_bits(LispObj *nodepointer) |
---|
171 | { |
---|
172 | } |
---|
173 | |
---|
174 | |
---|
175 | |
---|
176 | |
---|
177 | |
---|
178 | void |
---|
179 | check_range(LispObj *start, LispObj *end, Boolean header_allowed) |
---|
180 | { |
---|
181 | LispObj node, *current = start, *prev = NULL; |
---|
182 | int tag; |
---|
183 | natural elements; |
---|
184 | |
---|
185 | while (current < end) { |
---|
186 | prev = current; |
---|
187 | node = *current++; |
---|
188 | tag = fulltag_of(node); |
---|
189 | if (immheader_tag_p(tag)) { |
---|
190 | if (! header_allowed) { |
---|
191 | Bug(NULL, "Header not expected at 0x" LISP "\n", prev); |
---|
192 | } |
---|
193 | current = (LispObj *)skip_over_ivector((natural)prev, node); |
---|
194 | } else if (nodeheader_tag_p(tag)) { |
---|
195 | if (! header_allowed) { |
---|
196 | Bug(NULL, "Header not expected at 0x" LISP "\n", prev); |
---|
197 | } |
---|
198 | elements = header_element_count(node) | 1; |
---|
199 | if (header_subtag(node) == subtag_function) { |
---|
200 | #ifdef X8632 |
---|
201 | int skip = *(unsigned short *)current; |
---|
202 | #else |
---|
203 | int skip = *(int *)current; |
---|
204 | #endif |
---|
205 | current += skip; |
---|
206 | elements -= skip; |
---|
207 | } |
---|
208 | while (elements--) { |
---|
209 | check_node(*current++); |
---|
210 | } |
---|
211 | } else { |
---|
212 | check_node(node); |
---|
213 | check_node(*current++); |
---|
214 | } |
---|
215 | } |
---|
216 | |
---|
217 | if (current != end) { |
---|
218 | Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x", |
---|
219 | start, end, prev, current); |
---|
220 | } |
---|
221 | } |
---|
222 | |
---|
223 | #ifdef X8632 |
---|
224 | void |
---|
225 | check_xp(ExceptionInformation *xp, natural node_regs_mask) |
---|
226 | { |
---|
227 | natural *regs = (natural *) xpGPRvector(xp), dnode; |
---|
228 | |
---|
229 | if (node_regs_mask & (1<<0)) check_node(regs[REG_EAX]); |
---|
230 | if (node_regs_mask & (1<<1)) check_node(regs[REG_ECX]); |
---|
231 | if (regs[REG_EFL] & EFL_DF) { |
---|
232 | /* DF set means EDX should be treated as an imm reg */ |
---|
233 | ; |
---|
234 | } else |
---|
235 | if (node_regs_mask & (1<<2)) check_node(regs[REG_EDX]); |
---|
236 | |
---|
237 | if (node_regs_mask & (1<<3)) check_node(regs[REG_EBX]); |
---|
238 | if (node_regs_mask & (1<<4)) check_node(regs[REG_ESP]); |
---|
239 | if (node_regs_mask & (1<<5)) check_node(regs[REG_EBP]); |
---|
240 | if (node_regs_mask & (1<<6)) check_node(regs[REG_ESI]); |
---|
241 | if (node_regs_mask & (1<<7)) check_node(regs[REG_EDI]); |
---|
242 | } |
---|
243 | #else |
---|
244 | void |
---|
245 | check_xp(ExceptionInformation *xp) |
---|
246 | { |
---|
247 | natural *regs = (natural *) xpGPRvector(xp), dnode; |
---|
248 | |
---|
249 | check_node(regs[Iarg_z]); |
---|
250 | check_node(regs[Iarg_y]); |
---|
251 | check_node(regs[Iarg_x]); |
---|
252 | check_node(regs[Isave3]); |
---|
253 | check_node(regs[Isave2]); |
---|
254 | check_node(regs[Isave1]); |
---|
255 | check_node(regs[Isave0]); |
---|
256 | check_node(regs[Ifn]); |
---|
257 | check_node(regs[Itemp0]); |
---|
258 | check_node(regs[Itemp1]); |
---|
259 | check_node(regs[Itemp2]); |
---|
260 | } |
---|
261 | #endif |
---|
262 | |
---|
263 | void |
---|
264 | check_tcrs(TCR *first) |
---|
265 | { |
---|
266 | xframe_list *xframes; |
---|
267 | ExceptionInformation *xp; |
---|
268 | |
---|
269 | TCR *tcr = first; |
---|
270 | LispObj *tlb_start,*tlb_end; |
---|
271 | |
---|
272 | do { |
---|
273 | xp = tcr->gc_context; |
---|
274 | if (xp) { |
---|
275 | #ifdef X8632 |
---|
276 | check_xp(xp,tcr->node_regs_mask); |
---|
277 | #else |
---|
278 | check_xp(xp); |
---|
279 | #endif |
---|
280 | } |
---|
281 | #ifdef X8632 |
---|
282 | check_node(tcr->save0); |
---|
283 | check_node(tcr->save1); |
---|
284 | check_node(tcr->save2); |
---|
285 | check_node(tcr->save3); |
---|
286 | check_node(tcr->next_method_context); |
---|
287 | #endif |
---|
288 | for (xframes = (xframe_list *) tcr->xframe; |
---|
289 | xframes; |
---|
290 | xframes = xframes->prev) { |
---|
291 | #ifndef X8632 |
---|
292 | check_xp(xframes->curr); |
---|
293 | #else |
---|
294 | check_xp(xframes->curr, xframes->node_regs_mask); |
---|
295 | #endif |
---|
296 | } |
---|
297 | tlb_start = tcr->tlb_pointer; |
---|
298 | if (tlb_start) { |
---|
299 | tlb_end = tlb_start + ((tcr->tlb_limit)>>fixnumshift); |
---|
300 | check_range(tlb_start,tlb_end,false); |
---|
301 | } |
---|
302 | tcr = tcr->next; |
---|
303 | } while (tcr != first); |
---|
304 | } |
---|
305 | |
---|
306 | |
---|
307 | void |
---|
308 | check_all_areas(TCR *tcr) |
---|
309 | { |
---|
310 | area *a = active_dynamic_area; |
---|
311 | area_code code = a->code; |
---|
312 | |
---|
313 | while (code != AREA_VOID) { |
---|
314 | switch (code) { |
---|
315 | case AREA_DYNAMIC: |
---|
316 | case AREA_STATIC: |
---|
317 | case AREA_MANAGED_STATIC: |
---|
318 | check_range((LispObj *)a->low, (LispObj *)a->active, true); |
---|
319 | break; |
---|
320 | |
---|
321 | case AREA_VSTACK: |
---|
322 | { |
---|
323 | LispObj* low = (LispObj *)a->active; |
---|
324 | LispObj* high = (LispObj *)a->high; |
---|
325 | |
---|
326 | if (((natural)low) & node_size) { |
---|
327 | check_node(*low++); |
---|
328 | } |
---|
329 | check_range(low, high, false); |
---|
330 | } |
---|
331 | break; |
---|
332 | |
---|
333 | case AREA_TSTACK: |
---|
334 | { |
---|
335 | LispObj *current, *next, |
---|
336 | *start = (LispObj *) a->active, |
---|
337 | *end = start, |
---|
338 | *limit = (LispObj *) a->high; |
---|
339 | |
---|
340 | for (current = start; |
---|
341 | end != limit; |
---|
342 | current = next) { |
---|
343 | next = ptr_from_lispobj(*current); |
---|
344 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
345 | check_range(current+2, end, true); |
---|
346 | } |
---|
347 | } |
---|
348 | break; |
---|
349 | } |
---|
350 | a = a->succ; |
---|
351 | code = (a->code); |
---|
352 | } |
---|
353 | |
---|
354 | check_tcrs(tcr); |
---|
355 | } |
---|
356 | |
---|
357 | |
---|
358 | |
---|
359 | |
---|
360 | |
---|
361 | |
---|
362 | |
---|
363 | /* Sooner or later, this probably wants to be in assembler */ |
---|
364 | /* Return false if n is definitely not an ephemeral node, true if |
---|
365 | it might be */ |
---|
366 | void |
---|
367 | mark_root(LispObj n) |
---|
368 | { |
---|
369 | int tag_n = fulltag_of(n); |
---|
370 | natural dnode, bits, *bitsp, mask; |
---|
371 | |
---|
372 | if (!is_node_fulltag(tag_n)) { |
---|
373 | return; |
---|
374 | } |
---|
375 | |
---|
376 | dnode = gc_area_dnode(n); |
---|
377 | if (dnode >= GCndnodes_in_area) { |
---|
378 | return; |
---|
379 | } |
---|
380 | |
---|
381 | #ifdef X8632 |
---|
382 | if (tag_n == fulltag_tra) { |
---|
383 | if (*(unsigned char *)n == RECOVER_FN_OPCODE) { |
---|
384 | n = *(LispObj *)(n + 1); |
---|
385 | tag_n = fulltag_misc; |
---|
386 | dnode = gc_area_dnode(n); |
---|
387 | } else |
---|
388 | return; |
---|
389 | } |
---|
390 | #endif |
---|
391 | #ifdef X8664 |
---|
392 | if (tag_of(n) == tag_tra) { |
---|
393 | if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
394 | (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { |
---|
395 | int sdisp = (*(int *) (n+3)); |
---|
396 | n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; |
---|
397 | tag_n = fulltag_function; |
---|
398 | dnode = gc_area_dnode(n); |
---|
399 | } |
---|
400 | else { |
---|
401 | return; |
---|
402 | } |
---|
403 | } |
---|
404 | #endif |
---|
405 | |
---|
406 | set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask); |
---|
407 | if (bits & mask) { |
---|
408 | return; |
---|
409 | } |
---|
410 | *bitsp = (bits | mask); |
---|
411 | |
---|
412 | if (tag_n == fulltag_cons) { |
---|
413 | cons *c = (cons *) ptr_from_lispobj(untag(n)); |
---|
414 | |
---|
415 | rmark(c->car); |
---|
416 | rmark(c->cdr); |
---|
417 | return; |
---|
418 | } |
---|
419 | { |
---|
420 | LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); |
---|
421 | natural |
---|
422 | header = *((natural *) base), |
---|
423 | subtag = header_subtag(header), |
---|
424 | element_count = header_element_count(header), |
---|
425 | total_size_in_bytes, /* including 4/8-byte header */ |
---|
426 | suffix_dnodes; |
---|
427 | natural prefix_nodes = 0; |
---|
428 | |
---|
429 | tag_n = fulltag_of(header); |
---|
430 | |
---|
431 | #ifdef X8664 |
---|
432 | if ((nodeheader_tag_p(tag_n)) || |
---|
433 | (tag_n == ivector_class_64_bit)) { |
---|
434 | total_size_in_bytes = 8 + (element_count<<3); |
---|
435 | } else if (tag_n == ivector_class_32_bit) { |
---|
436 | total_size_in_bytes = 8 + (element_count<<2); |
---|
437 | } else { |
---|
438 | /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */ |
---|
439 | if (subtag == subtag_bit_vector) { |
---|
440 | total_size_in_bytes = 8 + ((element_count+7)>>3); |
---|
441 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
442 | total_size_in_bytes = 8 + element_count; |
---|
443 | } else { |
---|
444 | total_size_in_bytes = 8 + (element_count<<1); |
---|
445 | } |
---|
446 | } |
---|
447 | #endif |
---|
448 | #ifdef X8632 |
---|
449 | if ((tag_n == fulltag_nodeheader) || |
---|
450 | (subtag <= max_32_bit_ivector_subtag)) { |
---|
451 | total_size_in_bytes = 4 + (element_count<<2); |
---|
452 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
453 | total_size_in_bytes = 4 + element_count; |
---|
454 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
455 | total_size_in_bytes = 4 + (element_count<<1); |
---|
456 | } else if (subtag == subtag_double_float_vector) { |
---|
457 | total_size_in_bytes = 8 + (element_count<<3); |
---|
458 | } else { |
---|
459 | total_size_in_bytes = 4 + ((element_count+7)>>3); |
---|
460 | } |
---|
461 | #endif |
---|
462 | |
---|
463 | |
---|
464 | suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1; |
---|
465 | |
---|
466 | if (suffix_dnodes) { |
---|
467 | set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); |
---|
468 | } |
---|
469 | |
---|
470 | if (nodeheader_tag_p(tag_n)) { |
---|
471 | if (subtag == subtag_hash_vector) { |
---|
472 | /* Don't invalidate the cache here. It should get |
---|
473 | invalidated on the lisp side, if/when we know |
---|
474 | that rehashing is necessary. */ |
---|
475 | LispObj flags = ((hash_table_vector_header *) base)->flags; |
---|
476 | |
---|
477 | if ((flags & nhash_keys_frozen_mask) && |
---|
478 | (((hash_table_vector_header *) base)->deleted_count > 0)) { |
---|
479 | /* We're responsible for clearing out any deleted keys, since |
---|
480 | lisp side can't do it without breaking the state machine |
---|
481 | */ |
---|
482 | LispObj *pairp = base + hash_table_vector_header_count; |
---|
483 | natural |
---|
484 | npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1; |
---|
485 | |
---|
486 | while (npairs--) { |
---|
487 | if ((pairp[1] == unbound) && (pairp[0] != unbound)) { |
---|
488 | pairp[0] = slot_unbound; |
---|
489 | } |
---|
490 | pairp +=2; |
---|
491 | } |
---|
492 | ((hash_table_vector_header *) base)->deleted_count = 0; |
---|
493 | } |
---|
494 | |
---|
495 | if (flags & nhash_weak_mask) { |
---|
496 | ((hash_table_vector_header *) base)->cache_key = undefined; |
---|
497 | ((hash_table_vector_header *) base)->cache_value = lisp_nil; |
---|
498 | mark_weak_htabv(n); |
---|
499 | return; |
---|
500 | } |
---|
501 | } |
---|
502 | |
---|
503 | if (subtag == subtag_pool) { |
---|
504 | deref(base, 1) = lisp_nil; |
---|
505 | } |
---|
506 | |
---|
507 | if (subtag == subtag_weak) { |
---|
508 | natural weak_type = (natural) base[2]; |
---|
509 | if (weak_type >> population_termination_bit) { |
---|
510 | element_count -= 2; |
---|
511 | } else { |
---|
512 | element_count -= 1; |
---|
513 | } |
---|
514 | } |
---|
515 | |
---|
516 | if (subtag == subtag_function) { |
---|
517 | #ifdef X8632 |
---|
518 | prefix_nodes = (natural) ((unsigned short) deref(base,1)); |
---|
519 | #else |
---|
520 | prefix_nodes = (natural) ((int) deref(base,1)); |
---|
521 | #endif |
---|
522 | if (prefix_nodes > element_count) { |
---|
523 | Bug(NULL, "Function 0x" LISP " trashed",n); |
---|
524 | } |
---|
525 | } |
---|
526 | base += (1+element_count); |
---|
527 | |
---|
528 | element_count -= prefix_nodes; |
---|
529 | |
---|
530 | while(element_count--) { |
---|
531 | rmark(*--base); |
---|
532 | } |
---|
533 | if (subtag == subtag_weak) { |
---|
534 | deref(ptr_to_lispobj(base),1) = GCweakvll; |
---|
535 | GCweakvll = n; |
---|
536 | } |
---|
537 | } |
---|
538 | } |
---|
539 | } |
---|
540 | |
---|
541 | |
---|
542 | /* |
---|
543 | This marks the node if it needs to; it returns true if the node |
---|
544 | is either a hash table vector header or a cons/misc-tagged pointer |
---|
545 | to ephemeral space. |
---|
546 | Note that it might be a pointer to ephemeral space even if it's |
---|
547 | not pointing to the current generation. |
---|
548 | */ |
---|
549 | |
---|
550 | Boolean |
---|
551 | mark_ephemeral_root(LispObj n) |
---|
552 | { |
---|
553 | int tag_n = fulltag_of(n); |
---|
554 | natural eph_dnode; |
---|
555 | |
---|
556 | if (nodeheader_tag_p(tag_n)) { |
---|
557 | return (header_subtag(n) == subtag_hash_vector); |
---|
558 | } |
---|
559 | |
---|
560 | if (is_node_fulltag (tag_n)) { |
---|
561 | eph_dnode = area_dnode(n, GCephemeral_low); |
---|
562 | if (eph_dnode < GCn_ephemeral_dnodes) { |
---|
563 | mark_root(n); /* May or may not mark it */ |
---|
564 | return true; /* but return true 'cause it's an ephemeral node */ |
---|
565 | } |
---|
566 | } |
---|
567 | return false; /* Not a heap pointer or not ephemeral */ |
---|
568 | } |
---|
569 | |
---|
570 | |
---|
571 | |
---|
572 | #ifdef X8664 |
---|
573 | #define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */ |
---|
574 | #define RMARK_PREV_CAR fulltag_nil /* fulltag_cons + node_size. Coincidence ? I think not. */ |
---|
575 | #else |
---|
576 | #define RMARK_PREV_ROOT fulltag_imm /* fulltag of 'undefined' value */ |
---|
577 | #define RMARK_PREV_CAR fulltag_odd_fixnum |
---|
578 | #endif |
---|
579 | |
---|
580 | |
---|
581 | /* |
---|
582 | This wants to be in assembler even more than "mark_root" does. |
---|
583 | For now, it does link-inversion: hard as that is to express in C, |
---|
584 | reliable stack-overflow detection may be even harder ... |
---|
585 | */ |
---|
586 | void |
---|
587 | rmark(LispObj n) |
---|
588 | { |
---|
589 | int tag_n = fulltag_of(n); |
---|
590 | bitvector markbits = GCmarkbits; |
---|
591 | natural dnode, bits, *bitsp, mask; |
---|
592 | |
---|
593 | if (!is_node_fulltag(tag_n)) { |
---|
594 | return; |
---|
595 | } |
---|
596 | |
---|
597 | dnode = gc_area_dnode(n); |
---|
598 | if (dnode >= GCndnodes_in_area) { |
---|
599 | return; |
---|
600 | } |
---|
601 | |
---|
602 | #ifdef X8632 |
---|
603 | if (tag_n == fulltag_tra) { |
---|
604 | if (*(unsigned char *)n == RECOVER_FN_OPCODE) { |
---|
605 | n = *(LispObj *)(n + 1); |
---|
606 | tag_n = fulltag_misc; |
---|
607 | dnode = gc_area_dnode(n); |
---|
608 | } else { |
---|
609 | return; |
---|
610 | } |
---|
611 | } |
---|
612 | #endif |
---|
613 | #ifdef X8664 |
---|
614 | if (tag_of(n) == tag_tra) { |
---|
615 | if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
616 | (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { |
---|
617 | int sdisp = (*(int *) (n+3)); |
---|
618 | n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; |
---|
619 | tag_n = fulltag_function; |
---|
620 | dnode = gc_area_dnode(n); |
---|
621 | } else { |
---|
622 | return; |
---|
623 | } |
---|
624 | } |
---|
625 | #endif |
---|
626 | |
---|
627 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
628 | if (bits & mask) { |
---|
629 | return; |
---|
630 | } |
---|
631 | *bitsp = (bits | mask); |
---|
632 | |
---|
633 | if (current_stack_pointer() > GCstack_limit) { |
---|
634 | if (tag_n == fulltag_cons) { |
---|
635 | rmark(deref(n,1)); |
---|
636 | rmark(deref(n,0)); |
---|
637 | } else { |
---|
638 | LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); |
---|
639 | natural |
---|
640 | header = *((natural *) base), |
---|
641 | subtag = header_subtag(header), |
---|
642 | element_count = header_element_count(header), |
---|
643 | total_size_in_bytes, |
---|
644 | suffix_dnodes, |
---|
645 | nmark; |
---|
646 | |
---|
647 | tag_n = fulltag_of(header); |
---|
648 | |
---|
649 | #ifdef X8664 |
---|
650 | if ((nodeheader_tag_p(tag_n)) || |
---|
651 | (tag_n == ivector_class_64_bit)) { |
---|
652 | total_size_in_bytes = 8 + (element_count<<3); |
---|
653 | } else if (tag_n == ivector_class_32_bit) { |
---|
654 | total_size_in_bytes = 8 + (element_count<<2); |
---|
655 | } else { |
---|
656 | /* ivector_class_other_bit contains 16-bit arrays & bitvector */ |
---|
657 | if (subtag == subtag_bit_vector) { |
---|
658 | total_size_in_bytes = 8 + ((element_count+7)>>3); |
---|
659 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
660 | total_size_in_bytes = 8 + element_count; |
---|
661 | } else { |
---|
662 | total_size_in_bytes = 8 + (element_count<<1); |
---|
663 | } |
---|
664 | } |
---|
665 | #else |
---|
666 | if ((tag_n == fulltag_nodeheader) || |
---|
667 | (subtag <= max_32_bit_ivector_subtag)) { |
---|
668 | total_size_in_bytes = 4 + (element_count<<2); |
---|
669 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
670 | total_size_in_bytes = 4 + element_count; |
---|
671 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
672 | total_size_in_bytes = 4 + (element_count<<1); |
---|
673 | } else if (subtag == subtag_double_float_vector) { |
---|
674 | total_size_in_bytes = 8 + (element_count<<3); |
---|
675 | } else { |
---|
676 | total_size_in_bytes = 4 + ((element_count+7)>>3); |
---|
677 | } |
---|
678 | #endif |
---|
679 | |
---|
680 | suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; |
---|
681 | |
---|
682 | if (suffix_dnodes) { |
---|
683 | set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); |
---|
684 | } |
---|
685 | |
---|
686 | if (!nodeheader_tag_p(tag_n)) return; |
---|
687 | |
---|
688 | if (subtag == subtag_hash_vector) { |
---|
689 | /* Splice onto weakvll, then return */ |
---|
690 | /* In general, there's no reason to invalidate the cached |
---|
691 | key/value pair here. However, if the hash table's weak, |
---|
692 | we don't want to retain an otherwise unreferenced key |
---|
693 | or value simply because they're referenced from the |
---|
694 | cache. Clear the cached entries iff the hash table's |
---|
695 | weak in some sense. |
---|
696 | */ |
---|
697 | LispObj flags = ((hash_table_vector_header *) base)->flags; |
---|
698 | |
---|
699 | if (flags & nhash_weak_mask) { |
---|
700 | ((hash_table_vector_header *) base)->cache_key = undefined; |
---|
701 | ((hash_table_vector_header *) base)->cache_value = lisp_nil; |
---|
702 | mark_weak_htabv(n); |
---|
703 | return; |
---|
704 | } |
---|
705 | } |
---|
706 | |
---|
707 | if (subtag == subtag_pool) { |
---|
708 | deref(n, 1) = lisp_nil; |
---|
709 | } |
---|
710 | |
---|
711 | if (subtag == subtag_weak) { |
---|
712 | natural weak_type = (natural) base[2]; |
---|
713 | if (weak_type >> population_termination_bit) |
---|
714 | element_count -= 2; |
---|
715 | else |
---|
716 | element_count -= 1; |
---|
717 | } |
---|
718 | |
---|
719 | nmark = element_count; |
---|
720 | |
---|
721 | if (subtag == subtag_function) { |
---|
722 | #ifdef X8664 |
---|
723 | int code_words = (int)base[1]; |
---|
724 | #else |
---|
725 | int code_words = (unsigned short)base[1]; |
---|
726 | #endif |
---|
727 | if (code_words >= nmark) { |
---|
728 | Bug(NULL,"Bad function at 0x" LISP,n); |
---|
729 | } |
---|
730 | nmark -= code_words; |
---|
731 | } |
---|
732 | |
---|
733 | while (nmark--) { |
---|
734 | rmark(deref(n,element_count)); |
---|
735 | element_count--; |
---|
736 | } |
---|
737 | |
---|
738 | if (subtag == subtag_weak) { |
---|
739 | deref(n, 1) = GCweakvll; |
---|
740 | GCweakvll = n; |
---|
741 | } |
---|
742 | |
---|
743 | } |
---|
744 | } else { |
---|
745 | /* This is all a bit more complicated than the PPC version: |
---|
746 | |
---|
747 | - a symbol-vector can be referenced via either a FULLTAG-MISC |
---|
748 | pointer or a FULLTAG-SYMBOL pointer. When we've finished |
---|
749 | marking the symbol-vector's elements, we need to know which tag |
---|
750 | the object that pointed to the symbol-vector had originally. |
---|
751 | |
---|
752 | - a function-vector can be referenced via either a FULLTAG-MISC |
---|
753 | pointer or a FULLTAG-FUNCTION pointer. That introduces pretty |
---|
754 | much the same set of issues, but ... |
---|
755 | |
---|
756 | - a function-vector can also be referenced via a TRA; the |
---|
757 | offset from the TRA to the function header is arbitrary (though |
---|
758 | we can probably put an upper bound on it, and it's certainly |
---|
759 | not going to be more than 32 bits.) |
---|
760 | |
---|
761 | - function-vectors contain a mixture of code and constants, |
---|
762 | with a "boundary" word (that doesn't look like a valid |
---|
763 | constant) in between them. There are 56 unused bits in the |
---|
764 | boundary word; the low 8 bits must be = to the constant |
---|
765 | 'function_boundary_marker'. We can store the byte displacement |
---|
766 | from the address of the object which references the function |
---|
767 | (tagged fulltag_misc, fulltag_function, or tra) to the address |
---|
768 | of the boundary marker when the function vector is first marked |
---|
769 | and recover that offset when we've finished marking the |
---|
770 | function vector. (Note that the offset is signed; it's |
---|
771 | probably simplest to keep it in the high 32 bits of the |
---|
772 | boundary word.) |
---|
773 | |
---|
774 | So: |
---|
775 | |
---|
776 | - while marking a CONS, the 'this' pointer as a 3-bit tag of |
---|
777 | tag_list; the 4-bit fulltag indicates which cell is being |
---|
778 | marked. |
---|
779 | |
---|
780 | - while marking a gvector (other than a symbol-vector or |
---|
781 | function-vector), the 'this' pointer is tagged tag_misc. |
---|
782 | (Obviously, it alternates between fulltag_misc and |
---|
783 | fulltag_nodeheader_0, arbitrarily.) When we encounter the |
---|
784 | gvector header when the 'this' pointer has been tagged as |
---|
785 | fulltag_misc, we can restore 'this' to the header's address + |
---|
786 | fulltag_misc and enter the 'climb' state. (Note that this |
---|
787 | value happens to be exactly what's in 'this' when the header's |
---|
788 | encountered.) |
---|
789 | |
---|
790 | - if we encounter a symbol-vector via the FULLTAG-MISC pointer |
---|
791 | to the symbol (not very likely, but legal and possible), it's |
---|
792 | treated exactly like the gvector case above. |
---|
793 | |
---|
794 | - in the more likely case where a symbol-vector is referenced |
---|
795 | via a FULLTAG-SYMBOL, we do the same loop as in the general |
---|
796 | gvector case, backing up through the vector with 'this' tagged |
---|
797 | as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter |
---|
798 | the symbol header, 'this' gets fulltag_symbol added to the |
---|
799 | dnode-aligned address of the header, and we climb. |
---|
800 | |
---|
801 | - if anything (fulltag_misc, fulltag_function, tra) references |
---|
802 | an unmarked function function vector, we store the byte offfset |
---|
803 | from the tagged reference to the address of the boundary word |
---|
804 | in the high 32 bits of the boundary word, then we back up |
---|
805 | through the function-vector's constants, with 'this' tagged |
---|
806 | tag_function/ fulltag_immheader_0, until the (specially-tagged) |
---|
807 | boundary word is encountered. The displacement stored in the boundary |
---|
808 | word is added to the aligned address of the boundary word (restoring |
---|
809 | the original 'this' pointer, and we climb. |
---|
810 | |
---|
811 | Not that bad. |
---|
812 | */ |
---|
813 | |
---|
814 | LispObj prev = undefined, this = n, next, *base; |
---|
815 | natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary; |
---|
816 | |
---|
817 | if (tag_n == fulltag_cons) goto MarkCons; |
---|
818 | goto MarkVector; |
---|
819 | |
---|
820 | ClimbCdr: |
---|
821 | prev = deref(this,0); |
---|
822 | deref(this,0) = next; |
---|
823 | |
---|
824 | Climb: |
---|
825 | next = this; |
---|
826 | this = prev; |
---|
827 | tag_n = fulltag_of(prev); |
---|
828 | switch(tag_n) { |
---|
829 | case tag_misc: |
---|
830 | case fulltag_misc: |
---|
831 | #ifdef X8664 |
---|
832 | case tag_symbol: |
---|
833 | case fulltag_symbol: |
---|
834 | case tag_function: |
---|
835 | case fulltag_function: |
---|
836 | #endif |
---|
837 | goto ClimbVector; |
---|
838 | |
---|
839 | case RMARK_PREV_ROOT: |
---|
840 | return; |
---|
841 | |
---|
842 | case fulltag_cons: |
---|
843 | goto ClimbCdr; |
---|
844 | |
---|
845 | case RMARK_PREV_CAR: |
---|
846 | goto ClimbCar; |
---|
847 | |
---|
848 | default: abort(); |
---|
849 | } |
---|
850 | |
---|
851 | DescendCons: |
---|
852 | prev = this; |
---|
853 | this = next; |
---|
854 | |
---|
855 | MarkCons: |
---|
856 | next = deref(this,1); |
---|
857 | #ifdef X8632 |
---|
858 | this += (RMARK_PREV_CAR-fulltag_cons); |
---|
859 | #else |
---|
860 | this += node_size; |
---|
861 | #endif |
---|
862 | tag_n = fulltag_of(next); |
---|
863 | if (!is_node_fulltag(tag_n)) goto MarkCdr; |
---|
864 | dnode = gc_area_dnode(next); |
---|
865 | if (dnode >= GCndnodes_in_area) goto MarkCdr; |
---|
866 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
867 | if (bits & mask) goto MarkCdr; |
---|
868 | *bitsp = (bits | mask); |
---|
869 | deref(this,1) = prev; |
---|
870 | if (tag_n == fulltag_cons) goto DescendCons; |
---|
871 | goto DescendVector; |
---|
872 | |
---|
873 | ClimbCar: |
---|
874 | prev = deref(this,1); |
---|
875 | deref(this,1) = next; |
---|
876 | |
---|
877 | MarkCdr: |
---|
878 | next = deref(this, 0); |
---|
879 | #ifdef X8632 |
---|
880 | this -= (RMARK_PREV_CAR-fulltag_cons); |
---|
881 | #else |
---|
882 | this -= node_size; |
---|
883 | #endif |
---|
884 | tag_n = fulltag_of(next); |
---|
885 | if (!is_node_fulltag(tag_n)) goto Climb; |
---|
886 | dnode = gc_area_dnode(next); |
---|
887 | if (dnode >= GCndnodes_in_area) goto Climb; |
---|
888 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
889 | if (bits & mask) goto Climb; |
---|
890 | *bitsp = (bits | mask); |
---|
891 | deref(this, 0) = prev; |
---|
892 | if (tag_n == fulltag_cons) goto DescendCons; |
---|
893 | /* goto DescendVector; */ |
---|
894 | |
---|
895 | DescendVector: |
---|
896 | prev = this; |
---|
897 | this = next; |
---|
898 | |
---|
899 | MarkVector: |
---|
900 | #ifdef X8664 |
---|
901 | if ((tag_n == fulltag_tra_0) || |
---|
902 | (tag_n == fulltag_tra_1)) { |
---|
903 | int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH; |
---|
904 | |
---|
905 | base = (LispObj *) (untag(n-disp)); |
---|
906 | header = *((natural *) base); |
---|
907 | subtag = header_subtag(header); |
---|
908 | boundary = base + (int)(base[1]); |
---|
909 | (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); |
---|
910 | this = (LispObj)(base)+fulltag_function; |
---|
911 | /* Need to set the initial markbit here */ |
---|
912 | dnode = gc_area_dnode(this); |
---|
913 | set_bit(markbits,dnode); |
---|
914 | } else { |
---|
915 | base = (LispObj *) ptr_from_lispobj(untag(this)); |
---|
916 | header = *((natural *) base); |
---|
917 | subtag = header_subtag(header); |
---|
918 | if (subtag == subtag_function) { |
---|
919 | boundary = base + (int)(base[1]); |
---|
920 | (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); |
---|
921 | } |
---|
922 | } |
---|
923 | element_count = header_element_count(header); |
---|
924 | tag_n = fulltag_of(header); |
---|
925 | |
---|
926 | if ((nodeheader_tag_p(tag_n)) || |
---|
927 | (tag_n == ivector_class_64_bit)) { |
---|
928 | total_size_in_bytes = 8 + (element_count<<3); |
---|
929 | } else if (tag_n == ivector_class_32_bit) { |
---|
930 | total_size_in_bytes = 8 + (element_count<<2); |
---|
931 | } else { |
---|
932 | /* ivector_class_other_bit contains 16-bit arrays & bitvector */ |
---|
933 | if (subtag == subtag_bit_vector) { |
---|
934 | total_size_in_bytes = 8 + ((element_count+7)>>3); |
---|
935 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
936 | total_size_in_bytes = 8 + element_count; |
---|
937 | } else { |
---|
938 | total_size_in_bytes = 8 + (element_count<<1); |
---|
939 | } |
---|
940 | } |
---|
941 | #else |
---|
942 | if (tag_n == fulltag_tra) { |
---|
943 | LispObj fn = *(LispObj *)(n + 1); |
---|
944 | |
---|
945 | base = (LispObj *)untag(fn); |
---|
946 | header = *(natural *)base; |
---|
947 | subtag = header_subtag(header); |
---|
948 | boundary = base + (unsigned short)base[1]; |
---|
949 | /* |
---|
950 | * On x8632, the upper 24 bits of the boundary word are zero. |
---|
951 | * Functions on x8632 can be no more than 2^16 words (or 2^24 |
---|
952 | * bytes) long (including the self-reference table but excluding |
---|
953 | * any constants). Therefore, we can do the same basic thing |
---|
954 | * that the x8664 port does: namely, we keep the byte |
---|
955 | * displacement from the address of the object (tagged tra or |
---|
956 | * fulltag_misc) that references the function to the address of |
---|
957 | * the boundary marker in those 24 bits, recovering it when |
---|
958 | * we've finished marking the function vector. |
---|
959 | */ |
---|
960 | *((int *)boundary) &= 0xff; |
---|
961 | *((int *)boundary) |= ((this-(LispObj)boundary) << 8); |
---|
962 | this = (LispObj)(base)+fulltag_misc; |
---|
963 | dnode = gc_area_dnode(this); |
---|
964 | set_bit(markbits,dnode); |
---|
965 | } else { |
---|
966 | base = (LispObj *) ptr_from_lispobj(untag(this)); |
---|
967 | header = *((natural *) base); |
---|
968 | subtag = header_subtag(header); |
---|
969 | if (subtag == subtag_function) { |
---|
970 | boundary = base + (unsigned short)base[1]; |
---|
971 | *((int *)boundary) &= 0xff; |
---|
972 | *((int *)boundary) |= ((this-((LispObj)boundary)) << 8); |
---|
973 | } |
---|
974 | } |
---|
975 | element_count = header_element_count(header); |
---|
976 | tag_n = fulltag_of(header); |
---|
977 | |
---|
978 | if ((tag_n == fulltag_nodeheader) || |
---|
979 | (subtag <= max_32_bit_ivector_subtag)) { |
---|
980 | total_size_in_bytes = 4 + (element_count<<2); |
---|
981 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
982 | total_size_in_bytes = 4 + element_count; |
---|
983 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
984 | total_size_in_bytes = 4 + (element_count<<1); |
---|
985 | } else if (subtag == subtag_double_float_vector) { |
---|
986 | total_size_in_bytes = 8 + (element_count<<3); |
---|
987 | } else { |
---|
988 | total_size_in_bytes = 4 + ((element_count+7)>>3); |
---|
989 | } |
---|
990 | #endif |
---|
991 | |
---|
992 | suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; |
---|
993 | |
---|
994 | if (suffix_dnodes) { |
---|
995 | set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); |
---|
996 | } |
---|
997 | |
---|
998 | if (!nodeheader_tag_p(tag_n)) goto Climb; |
---|
999 | |
---|
1000 | if (subtag == subtag_hash_vector) { |
---|
1001 | /* Splice onto weakvll, then climb */ |
---|
1002 | LispObj flags = ((hash_table_vector_header *) base)->flags; |
---|
1003 | |
---|
1004 | if (flags & nhash_weak_mask) { |
---|
1005 | ((hash_table_vector_header *) base)->cache_key = undefined; |
---|
1006 | ((hash_table_vector_header *) base)->cache_value = lisp_nil; |
---|
1007 | dws_mark_weak_htabv(this); |
---|
1008 | element_count = hash_table_vector_header_count; |
---|
1009 | } |
---|
1010 | } |
---|
1011 | |
---|
1012 | if (subtag == subtag_pool) { |
---|
1013 | deref(this, 1) = lisp_nil; |
---|
1014 | } |
---|
1015 | |
---|
1016 | if (subtag == subtag_weak) { |
---|
1017 | natural weak_type = (natural) base[2]; |
---|
1018 | if (weak_type >> population_termination_bit) |
---|
1019 | element_count -= 2; |
---|
1020 | else |
---|
1021 | element_count -= 1; |
---|
1022 | } |
---|
1023 | |
---|
1024 | this = (LispObj)(base) + (tag_of(this)) + ((element_count+1) << node_shift); |
---|
1025 | goto MarkVectorLoop; |
---|
1026 | |
---|
1027 | ClimbVector: |
---|
1028 | prev = indirect_node(this); |
---|
1029 | indirect_node(this) = next; |
---|
1030 | |
---|
1031 | MarkVectorLoop: |
---|
1032 | this -= node_size; |
---|
1033 | next = indirect_node(this); |
---|
1034 | #ifdef X8664 |
---|
1035 | if ((tag_of(this) == tag_function) && |
---|
1036 | (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; |
---|
1037 | #else |
---|
1038 | if ((tag_of(this) == tag_misc) && |
---|
1039 | (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; |
---|
1040 | #endif |
---|
1041 | |
---|
1042 | tag_n = fulltag_of(next); |
---|
1043 | if (nodeheader_tag_p(tag_n)) goto MarkVectorDone; |
---|
1044 | if (!is_node_fulltag(tag_n)) goto MarkVectorLoop; |
---|
1045 | dnode = gc_area_dnode(next); |
---|
1046 | if (dnode >= GCndnodes_in_area) goto MarkVectorLoop; |
---|
1047 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
1048 | if (bits & mask) goto MarkVectorLoop; |
---|
1049 | *bitsp = (bits | mask); |
---|
1050 | indirect_node(this) = prev; |
---|
1051 | if (tag_n == fulltag_cons) goto DescendCons; |
---|
1052 | goto DescendVector; |
---|
1053 | |
---|
1054 | MarkVectorDone: |
---|
1055 | /* "next" is vector header; "this" tagged tag_misc or tag_symbol. |
---|
1056 | If header subtag = subtag_weak_header, put it on weakvll */ |
---|
1057 | this += node_size; /* make it fulltag_misc/fulltag_symbol */ |
---|
1058 | |
---|
1059 | if (header_subtag(next) == subtag_weak) { |
---|
1060 | deref(this, 1) = GCweakvll; |
---|
1061 | GCweakvll = this; |
---|
1062 | } |
---|
1063 | goto Climb; |
---|
1064 | |
---|
1065 | MarkFunctionDone: |
---|
1066 | boundary = (LispObj *)(node_aligned(this)); |
---|
1067 | #ifdef X8664 |
---|
1068 | this = ((LispObj)boundary) + (((int *)boundary)[1]); |
---|
1069 | (((int *)boundary)[1]) = 0; |
---|
1070 | #else |
---|
1071 | this = ((LispObj)boundary) + ((*((int *)boundary)) >> 8); |
---|
1072 | ((int *)boundary)[0] &= 0xff; |
---|
1073 | #endif |
---|
1074 | goto Climb; |
---|
1075 | } |
---|
1076 | } |
---|
1077 | |
---|
1078 | LispObj * |
---|
1079 | skip_over_ivector(natural start, LispObj header) |
---|
1080 | { |
---|
1081 | natural |
---|
1082 | element_count = header_element_count(header), |
---|
1083 | subtag = header_subtag(header), |
---|
1084 | nbytes; |
---|
1085 | |
---|
1086 | |
---|
1087 | #ifdef X8664 |
---|
1088 | switch (fulltag_of(header)) { |
---|
1089 | case ivector_class_64_bit: |
---|
1090 | nbytes = element_count << 3; |
---|
1091 | break; |
---|
1092 | case ivector_class_32_bit: |
---|
1093 | nbytes = element_count << 2; |
---|
1094 | break; |
---|
1095 | case ivector_class_other_bit: |
---|
1096 | default: |
---|
1097 | if (subtag == subtag_bit_vector) { |
---|
1098 | nbytes = (element_count+7)>>3; |
---|
1099 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
1100 | nbytes = element_count; |
---|
1101 | } else { |
---|
1102 | nbytes = element_count << 1; |
---|
1103 | } |
---|
1104 | } |
---|
1105 | return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15))); |
---|
1106 | #else |
---|
1107 | if (subtag <= max_32_bit_ivector_subtag) { |
---|
1108 | nbytes = element_count << 2; |
---|
1109 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
1110 | nbytes = element_count; |
---|
1111 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
1112 | nbytes = element_count << 1; |
---|
1113 | } else if (subtag == subtag_double_float_vector) { |
---|
1114 | nbytes = 4 + (element_count << 3); |
---|
1115 | } else { |
---|
1116 | nbytes = (element_count+7) >> 3; |
---|
1117 | } |
---|
1118 | return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7))); |
---|
1119 | #endif |
---|
1120 | } |
---|
1121 | |
---|
1122 | |
---|
1123 | void |
---|
1124 | check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits) |
---|
1125 | { |
---|
1126 | LispObj x1, *base = start, *prev = start; |
---|
1127 | int tag; |
---|
1128 | natural ref_dnode, node_dnode; |
---|
1129 | Boolean intergen_ref; |
---|
1130 | |
---|
1131 | while (start < end) { |
---|
1132 | x1 = *start; |
---|
1133 | prev = start; |
---|
1134 | tag = fulltag_of(x1); |
---|
1135 | if (immheader_tag_p(tag)) { |
---|
1136 | start = skip_over_ivector(ptr_to_lispobj(start), x1); |
---|
1137 | } else { |
---|
1138 | if (header_subtag(x1) == subtag_function) { |
---|
1139 | #ifdef X8632 |
---|
1140 | int skip = (unsigned short)deref(start,1); |
---|
1141 | #else |
---|
1142 | int skip = (int) deref(start,1); |
---|
1143 | #endif |
---|
1144 | start += ((1+skip)&~1); |
---|
1145 | x1 = *start; |
---|
1146 | tag = fulltag_of(x1); |
---|
1147 | } |
---|
1148 | intergen_ref = false; |
---|
1149 | if (is_node_fulltag(tag)) { |
---|
1150 | node_dnode = gc_area_dnode(x1); |
---|
1151 | if (node_dnode < GCndnodes_in_area) { |
---|
1152 | intergen_ref = true; |
---|
1153 | } |
---|
1154 | } |
---|
1155 | if (intergen_ref == false) { |
---|
1156 | x1 = start[1]; |
---|
1157 | tag = fulltag_of(x1); |
---|
1158 | if (is_node_fulltag(tag)) { |
---|
1159 | node_dnode = gc_area_dnode(x1); |
---|
1160 | if (node_dnode < GCndnodes_in_area) { |
---|
1161 | intergen_ref = true; |
---|
1162 | } |
---|
1163 | } |
---|
1164 | } |
---|
1165 | if (intergen_ref) { |
---|
1166 | ref_dnode = area_dnode(start, base); |
---|
1167 | if (!ref_bit(refbits, ref_dnode)) { |
---|
1168 | Bug(NULL, "Missing memoization in doublenode at 0x%08X", start); |
---|
1169 | set_bit(refbits, ref_dnode); |
---|
1170 | } |
---|
1171 | } |
---|
1172 | start += 2; |
---|
1173 | } |
---|
1174 | } |
---|
1175 | if (start > end) { |
---|
1176 | Bug(NULL, "Overran end of range!"); |
---|
1177 | } |
---|
1178 | } |
---|
1179 | |
---|
1180 | |
---|
1181 | |
---|
1182 | void |
---|
1183 | mark_memoized_area(area *a, natural num_memo_dnodes) |
---|
1184 | { |
---|
1185 | bitvector refbits = a->refbits; |
---|
1186 | LispObj *p = (LispObj *) a->low, x1, x2; |
---|
1187 | natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0; |
---|
1188 | Boolean keep_x1, keep_x2; |
---|
1189 | |
---|
1190 | if (GCDebug) { |
---|
1191 | check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); |
---|
1192 | } |
---|
1193 | |
---|
1194 | /* The distinction between "inbits" and "outbits" is supposed to help us |
---|
1195 | detect cases where "uninteresting" setfs have been memoized. Storing |
---|
1196 | NIL, fixnums, immediates (characters, etc.) or node pointers to static |
---|
1197 | or readonly areas is definitely uninteresting, but other cases are |
---|
1198 | more complicated (and some of these cases are hard to detect.) |
---|
1199 | |
---|
1200 | Some headers are "interesting", to the forwarder if not to us. |
---|
1201 | |
---|
1202 | We -don't- give anything any weak treatment here. Weak things have |
---|
1203 | to be seen by a full gc, for some value of 'full'. |
---|
1204 | */ |
---|
1205 | |
---|
1206 | /* |
---|
1207 | We need to ensure that there are no bits set at or beyond |
---|
1208 | "num_memo_dnodes" in the bitvector. (This can happen as the EGC |
---|
1209 | tenures/untenures things.) We find bits by grabbing a fullword at |
---|
1210 | a time and doing a cntlzw instruction; and don't want to have to |
---|
1211 | check for (< memo_dnode num_memo_dnodes) in the loop. |
---|
1212 | */ |
---|
1213 | |
---|
1214 | { |
---|
1215 | natural |
---|
1216 | bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask), |
---|
1217 | index_of_last_word = (num_memo_dnodes >> bitmap_shift); |
---|
1218 | |
---|
1219 | if (bits_in_last_word != 0) { |
---|
1220 | natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1); |
---|
1221 | refbits[index_of_last_word] &= mask; |
---|
1222 | } |
---|
1223 | } |
---|
1224 | |
---|
1225 | set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); |
---|
1226 | inbits = outbits = bits; |
---|
1227 | while (memo_dnode < num_memo_dnodes) { |
---|
1228 | if (bits == 0) { |
---|
1229 | int remain = nbits_in_word - bitidx; |
---|
1230 | memo_dnode += remain; |
---|
1231 | p += (remain+remain); |
---|
1232 | if (outbits != inbits) { |
---|
1233 | *bitsp = outbits; |
---|
1234 | } |
---|
1235 | bits = *++bitsp; |
---|
1236 | inbits = outbits = bits; |
---|
1237 | bitidx = 0; |
---|
1238 | } else { |
---|
1239 | nextbit = count_leading_zeros(bits); |
---|
1240 | if ((diff = (nextbit - bitidx)) != 0) { |
---|
1241 | memo_dnode += diff; |
---|
1242 | bitidx = nextbit; |
---|
1243 | p += (diff+diff); |
---|
1244 | } |
---|
1245 | x1 = *p++; |
---|
1246 | x2 = *p++; |
---|
1247 | bits &= ~(BIT0_MASK >> bitidx); |
---|
1248 | keep_x1 = mark_ephemeral_root(x1); |
---|
1249 | keep_x2 = mark_ephemeral_root(x2); |
---|
1250 | if ((keep_x1 == false) && |
---|
1251 | (keep_x2 == false)) { |
---|
1252 | outbits &= ~(BIT0_MASK >> bitidx); |
---|
1253 | } |
---|
1254 | memo_dnode++; |
---|
1255 | bitidx++; |
---|
1256 | } |
---|
1257 | } |
---|
1258 | if (GCDebug) { |
---|
1259 | p = (LispObj *) a->low; |
---|
1260 | check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); |
---|
1261 | } |
---|
1262 | } |
---|
1263 | |
---|
1264 | void |
---|
1265 | mark_headerless_area_range(LispObj *start, LispObj *end) |
---|
1266 | { |
---|
1267 | while (start < end) { |
---|
1268 | mark_root(*start++); |
---|
1269 | } |
---|
1270 | } |
---|
1271 | |
---|
1272 | void |
---|
1273 | mark_simple_area_range(LispObj *start, LispObj *end) |
---|
1274 | { |
---|
1275 | LispObj x1, *base; |
---|
1276 | int tag; |
---|
1277 | |
---|
1278 | while (start < end) { |
---|
1279 | x1 = *start; |
---|
1280 | tag = fulltag_of(x1); |
---|
1281 | if (immheader_tag_p(tag)) { |
---|
1282 | start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1)); |
---|
1283 | } else if (!nodeheader_tag_p(tag)) { |
---|
1284 | ++start; |
---|
1285 | mark_root(x1); |
---|
1286 | mark_root(*start++); |
---|
1287 | } else { |
---|
1288 | int subtag = header_subtag(x1); |
---|
1289 | natural element_count = header_element_count(x1); |
---|
1290 | natural size = (element_count+1 + 1) & ~1; |
---|
1291 | |
---|
1292 | if (subtag == subtag_hash_vector) { |
---|
1293 | LispObj flags = ((hash_table_vector_header *) start)->flags; |
---|
1294 | |
---|
1295 | if (flags & nhash_weak_mask) { |
---|
1296 | ((hash_table_vector_header *) start)->cache_key = undefined; |
---|
1297 | ((hash_table_vector_header *) start)->cache_value = lisp_nil; |
---|
1298 | mark_weak_htabv((LispObj)start); |
---|
1299 | element_count = 0; |
---|
1300 | } |
---|
1301 | } |
---|
1302 | if (subtag == subtag_pool) { |
---|
1303 | start[1] = lisp_nil; |
---|
1304 | } |
---|
1305 | |
---|
1306 | if (subtag == subtag_weak) { |
---|
1307 | natural weak_type = (natural) start[2]; |
---|
1308 | if (weak_type >> population_termination_bit) |
---|
1309 | element_count -= 2; |
---|
1310 | else |
---|
1311 | element_count -= 1; |
---|
1312 | start[1] = GCweakvll; |
---|
1313 | GCweakvll = (LispObj) (((natural) start) + fulltag_misc); |
---|
1314 | } |
---|
1315 | |
---|
1316 | base = start + element_count + 1; |
---|
1317 | if (subtag == subtag_function) { |
---|
1318 | #ifdef X8632 |
---|
1319 | element_count -= (unsigned short)start[1]; |
---|
1320 | #else |
---|
1321 | element_count -= (int)start[1]; |
---|
1322 | #endif |
---|
1323 | } |
---|
1324 | while(element_count--) { |
---|
1325 | mark_root(*--base); |
---|
1326 | } |
---|
1327 | start += size; |
---|
1328 | } |
---|
1329 | } |
---|
1330 | } |
---|
1331 | |
---|
1332 | |
---|
1333 | /* Mark a tstack area */ |
---|
1334 | void |
---|
1335 | mark_tstack_area(area *a) |
---|
1336 | { |
---|
1337 | LispObj |
---|
1338 | *current, |
---|
1339 | *next, |
---|
1340 | *start = (LispObj *) (a->active), |
---|
1341 | *end = start, |
---|
1342 | *limit = (LispObj *) (a->high); |
---|
1343 | |
---|
1344 | for (current = start; |
---|
1345 | end != limit; |
---|
1346 | current = next) { |
---|
1347 | next = (LispObj *) ptr_from_lispobj(*current); |
---|
1348 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
1349 | mark_simple_area_range(current+2, end); |
---|
1350 | } |
---|
1351 | } |
---|
1352 | |
---|
1353 | /* |
---|
1354 | It's really important that headers never wind up in tagged registers. |
---|
1355 | Those registers would (possibly) get pushed on the vstack and confuse |
---|
1356 | the hell out of this routine. |
---|
1357 | |
---|
1358 | vstacks are just treated as a "simple area range", possibly with |
---|
1359 | an extra word at the top (where the area's active pointer points.) |
---|
1360 | */ |
---|
1361 | |
---|
1362 | void |
---|
1363 | mark_vstack_area(area *a) |
---|
1364 | { |
---|
1365 | LispObj |
---|
1366 | *start = (LispObj *) a->active, |
---|
1367 | *end = (LispObj *) a->high; |
---|
1368 | |
---|
1369 | #if 0 |
---|
1370 | fprintf(stderr, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end); |
---|
1371 | #endif |
---|
1372 | mark_headerless_area_range(start, end); |
---|
1373 | } |
---|
1374 | |
---|
1375 | /* No lisp objects on cstack on x86, at least x86-64 */ |
---|
1376 | void |
---|
1377 | mark_cstack_area(area *a) |
---|
1378 | { |
---|
1379 | } |
---|
1380 | |
---|
1381 | |
---|
1382 | /* Mark the lisp objects in an exception frame */ |
---|
1383 | #ifdef X8664 |
---|
1384 | void |
---|
1385 | mark_xp(ExceptionInformation *xp) |
---|
1386 | { |
---|
1387 | natural *regs = (natural *) xpGPRvector(xp), dnode; |
---|
1388 | LispObj rip; |
---|
1389 | |
---|
1390 | |
---|
1391 | |
---|
1392 | mark_root(regs[Iarg_z]); |
---|
1393 | mark_root(regs[Iarg_y]); |
---|
1394 | mark_root(regs[Iarg_x]); |
---|
1395 | mark_root(regs[Isave3]); |
---|
1396 | mark_root(regs[Isave2]); |
---|
1397 | mark_root(regs[Isave1]); |
---|
1398 | mark_root(regs[Isave0]); |
---|
1399 | mark_root(regs[Ifn]); |
---|
1400 | mark_root(regs[Itemp0]); |
---|
1401 | mark_root(regs[Itemp1]); |
---|
1402 | mark_root(regs[Itemp2]); |
---|
1403 | /* If the RIP isn't pointing into a marked function, |
---|
1404 | we can -maybe- recover from that if it's tagged as |
---|
1405 | a TRA. */ |
---|
1406 | rip = regs[Iip]; |
---|
1407 | dnode = gc_area_dnode(rip); |
---|
1408 | if ((dnode < GCndnodes_in_area) && |
---|
1409 | (! ref_bit(GCmarkbits,dnode))) { |
---|
1410 | if (tag_of(rip) == tag_tra) { |
---|
1411 | mark_root(rip); |
---|
1412 | } else if ((fulltag_of(rip) == fulltag_function) && |
---|
1413 | (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
1414 | (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) && |
---|
1415 | ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) { |
---|
1416 | mark_root(rip); |
---|
1417 | } else { |
---|
1418 | Bug(NULL, "Can't find function for rip 0x%16lx",rip); |
---|
1419 | } |
---|
1420 | } |
---|
1421 | } |
---|
1422 | #else |
---|
1423 | void |
---|
1424 | mark_xp(ExceptionInformation *xp, natural node_regs_mask) |
---|
1425 | { |
---|
1426 | natural *regs = (natural *) xpGPRvector(xp), dnode; |
---|
1427 | LispObj eip; |
---|
1428 | int i; |
---|
1429 | |
---|
1430 | if (node_regs_mask & (1<<0)) mark_root(regs[REG_EAX]); |
---|
1431 | if (node_regs_mask & (1<<1)) mark_root(regs[REG_ECX]); |
---|
1432 | if (regs[REG_EFL] & EFL_DF) { |
---|
1433 | /* DF set means EDX should be treated as an imm reg */ |
---|
1434 | ; |
---|
1435 | } else |
---|
1436 | if (node_regs_mask & (1<<2)) mark_root(regs[REG_EDX]); |
---|
1437 | |
---|
1438 | if (node_regs_mask & (1<<3)) mark_root(regs[REG_EBX]); |
---|
1439 | if (node_regs_mask & (1<<4)) mark_root(regs[REG_ESP]); |
---|
1440 | if (node_regs_mask & (1<<5)) mark_root(regs[REG_EBP]); |
---|
1441 | if (node_regs_mask & (1<<6)) mark_root(regs[REG_ESI]); |
---|
1442 | if (node_regs_mask & (1<<7)) mark_root(regs[REG_EDI]); |
---|
1443 | |
---|
1444 | /* If the EIP isn't pointing into a marked function, we're probably |
---|
1445 | in trouble. We can -maybe- recover from that if it's tagged as a |
---|
1446 | TRA. */ |
---|
1447 | eip = regs[Ieip]; |
---|
1448 | dnode = gc_area_dnode(eip); |
---|
1449 | if ((dnode < GCndnodes_in_area) && |
---|
1450 | (! ref_bit(GCmarkbits,dnode))) { |
---|
1451 | if (fulltag_of(eip) == fulltag_tra) { |
---|
1452 | mark_root(eip); |
---|
1453 | } else if ((fulltag_of(eip) == fulltag_misc) && |
---|
1454 | (header_subtag(header_of(eip)) == subtag_function) && |
---|
1455 | (*(unsigned char *)eip == RECOVER_FN_OPCODE) && |
---|
1456 | (*(LispObj *)(eip + 1)) == eip) { |
---|
1457 | mark_root(eip); |
---|
1458 | } else { |
---|
1459 | Bug(NULL, "Can't find function for eip 0x%4x", eip); |
---|
1460 | } |
---|
1461 | } |
---|
1462 | } |
---|
1463 | #endif |
---|
1464 | |
---|
1465 | /* A "pagelet" contains 32 doublewords. The relocation table contains |
---|
1466 | a word for each pagelet which defines the lowest address to which |
---|
1467 | dnodes on that pagelet will be relocated. |
---|
1468 | |
---|
1469 | The relocation address of a given pagelet is the sum of the relocation |
---|
1470 | address for the preceding pagelet and the number of bytes occupied by |
---|
1471 | marked objects on the preceding pagelet. |
---|
1472 | */ |
---|
1473 | |
---|
1474 | LispObj |
---|
1475 | calculate_relocation() |
---|
1476 | { |
---|
1477 | LispObj *relocptr = GCrelocptr; |
---|
1478 | LispObj current = GCareadynamiclow; |
---|
1479 | bitvector |
---|
1480 | markbits = GCdynamic_markbits; |
---|
1481 | qnode *q = (qnode *) markbits; |
---|
1482 | natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift); |
---|
1483 | natural thesebits; |
---|
1484 | LispObj first = 0; |
---|
1485 | |
---|
1486 | if (npagelets) { |
---|
1487 | do { |
---|
1488 | *relocptr++ = current; |
---|
1489 | thesebits = *markbits++; |
---|
1490 | if (thesebits == ALL_ONES) { |
---|
1491 | current += nbits_in_word*dnode_size; |
---|
1492 | q += 4; /* sic */ |
---|
1493 | } else { |
---|
1494 | if (!first) { |
---|
1495 | first = current; |
---|
1496 | while (thesebits & BIT0_MASK) { |
---|
1497 | first += dnode_size; |
---|
1498 | thesebits += thesebits; |
---|
1499 | } |
---|
1500 | } |
---|
1501 | /* We're counting bits in qnodes in the wrong order here, but |
---|
1502 | that's OK. I think ... */ |
---|
1503 | current += one_bits(*q++); |
---|
1504 | current += one_bits(*q++); |
---|
1505 | current += one_bits(*q++); |
---|
1506 | current += one_bits(*q++); |
---|
1507 | } |
---|
1508 | } while(--npagelets); |
---|
1509 | } |
---|
1510 | *relocptr++ = current; |
---|
1511 | return first ? first : current; |
---|
1512 | } |
---|
1513 | |
---|
1514 | |
---|
1515 | #if 0 |
---|
1516 | LispObj |
---|
1517 | dnode_forwarding_address(natural dnode, int tag_n) |
---|
1518 | { |
---|
1519 | natural pagelet, nbits; |
---|
1520 | unsigned int near_bits; |
---|
1521 | LispObj new; |
---|
1522 | |
---|
1523 | if (GCDebug) { |
---|
1524 | if (! ref_bit(GCdynamic_markbits, dnode)) { |
---|
1525 | Bug(NULL, "unmarked object being forwarded!\n"); |
---|
1526 | } |
---|
1527 | } |
---|
1528 | |
---|
1529 | pagelet = dnode >> bitmap_shift; |
---|
1530 | nbits = dnode & bitmap_shift_count_mask; |
---|
1531 | near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)]; |
---|
1532 | |
---|
1533 | if (nbits < 32) { |
---|
1534 | new = GCrelocptr[pagelet] + tag_n;; |
---|
1535 | /* Increment "new" by the count of 1 bits which precede the dnode */ |
---|
1536 | if (near_bits == 0xffffffff) { |
---|
1537 | return (new + (nbits << 4)); |
---|
1538 | } else { |
---|
1539 | near_bits &= (0xffffffff00000000 >> nbits); |
---|
1540 | if (nbits > 15) { |
---|
1541 | new += one_bits(near_bits & 0xffff); |
---|
1542 | } |
---|
1543 | return (new + (one_bits(near_bits >> 16))); |
---|
1544 | } |
---|
1545 | } else { |
---|
1546 | new = GCrelocptr[pagelet+1] + tag_n; |
---|
1547 | nbits = 64-nbits; |
---|
1548 | |
---|
1549 | if (near_bits == 0xffffffff) { |
---|
1550 | return (new - (nbits << 4)); |
---|
1551 | } else { |
---|
1552 | near_bits &= (1<<nbits)-1; |
---|
1553 | if (nbits > 15) { |
---|
1554 | new -= one_bits(near_bits >> 16); |
---|
1555 | } |
---|
1556 | return (new - one_bits(near_bits & 0xffff)); |
---|
1557 | } |
---|
1558 | } |
---|
1559 | } |
---|
1560 | #else |
---|
1561 | #ifdef X8664 |
---|
1562 | /* Quicker, dirtier */ |
---|
1563 | LispObj |
---|
1564 | dnode_forwarding_address(natural dnode, int tag_n) |
---|
1565 | { |
---|
1566 | natural pagelet, nbits, marked; |
---|
1567 | LispObj new; |
---|
1568 | |
---|
1569 | if (GCDebug) { |
---|
1570 | if (! ref_bit(GCdynamic_markbits, dnode)) { |
---|
1571 | Bug(NULL, "unmarked object being forwarded!\n"); |
---|
1572 | } |
---|
1573 | } |
---|
1574 | |
---|
1575 | pagelet = dnode >> bitmap_shift; |
---|
1576 | nbits = dnode & bitmap_shift_count_mask; |
---|
1577 | new = GCrelocptr[pagelet] + tag_n;; |
---|
1578 | if (nbits) { |
---|
1579 | marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits); |
---|
1580 | while (marked) { |
---|
1581 | new += one_bits((qnode)marked); |
---|
1582 | marked >>=16; |
---|
1583 | } |
---|
1584 | } |
---|
1585 | return new; |
---|
1586 | } |
---|
1587 | #endif |
---|
1588 | #ifdef X8632 |
---|
1589 | LispObj |
---|
1590 | dnode_forwarding_address(natural dnode, int tag_n) |
---|
1591 | { |
---|
1592 | natural pagelet, nbits; |
---|
1593 | unsigned short near_bits; |
---|
1594 | LispObj new; |
---|
1595 | |
---|
1596 | if (GCDebug) { |
---|
1597 | if (! ref_bit(GCdynamic_markbits, dnode)) { |
---|
1598 | Bug(NULL, "unmarked object being forwarded!\n"); |
---|
1599 | } |
---|
1600 | } |
---|
1601 | |
---|
1602 | pagelet = dnode >> 5; |
---|
1603 | nbits = dnode & 0x1f; |
---|
1604 | /* On little-endian x86, we have to flip the low bit of dnode>>4 to |
---|
1605 | get the near_bits from the appropriate half-word. */ |
---|
1606 | near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1]; |
---|
1607 | |
---|
1608 | if (nbits < 16) { |
---|
1609 | new = GCrelocptr[pagelet] + tag_n;; |
---|
1610 | /* Increment "new" by the count of 1 bits which precede the dnode */ |
---|
1611 | if (near_bits == 0xffff) { |
---|
1612 | return (new + (nbits << 3)); |
---|
1613 | } else { |
---|
1614 | near_bits &= (0xffff0000 >> nbits); |
---|
1615 | if (nbits > 7) { |
---|
1616 | new += one_bits(near_bits & 0xff); |
---|
1617 | } |
---|
1618 | return (new + (one_bits(near_bits >> 8))); |
---|
1619 | } |
---|
1620 | } else { |
---|
1621 | new = GCrelocptr[pagelet+1] + tag_n; |
---|
1622 | nbits = 32-nbits; |
---|
1623 | |
---|
1624 | if (near_bits == 0xffff) { |
---|
1625 | return (new - (nbits << 3)); |
---|
1626 | } else { |
---|
1627 | near_bits &= (1<<nbits)-1; |
---|
1628 | if (nbits > 7) { |
---|
1629 | new -= one_bits(near_bits >> 8); |
---|
1630 | } |
---|
1631 | return (new - one_bits(near_bits & 0xff)); |
---|
1632 | } |
---|
1633 | } |
---|
1634 | } |
---|
1635 | #endif |
---|
1636 | #endif |
---|
1637 | |
---|
1638 | LispObj |
---|
1639 | locative_forwarding_address(LispObj obj) |
---|
1640 | { |
---|
1641 | int tag_n = fulltag_of(obj); |
---|
1642 | natural dnode = gc_dynamic_area_dnode(obj); |
---|
1643 | |
---|
1644 | |
---|
1645 | if ((dnode >= GCndynamic_dnodes_in_area) || |
---|
1646 | (obj < GCfirstunmarked)) { |
---|
1647 | return obj; |
---|
1648 | } |
---|
1649 | |
---|
1650 | return dnode_forwarding_address(dnode, tag_n); |
---|
1651 | } |
---|
1652 | |
---|
1653 | |
---|
1654 | void |
---|
1655 | forward_headerless_range(LispObj *range_start, LispObj *range_end) |
---|
1656 | { |
---|
1657 | LispObj *p = range_start; |
---|
1658 | |
---|
1659 | while (p < range_end) { |
---|
1660 | update_noderef(p); |
---|
1661 | p++; |
---|
1662 | } |
---|
1663 | } |
---|
1664 | |
---|
1665 | void |
---|
1666 | forward_range(LispObj *range_start, LispObj *range_end) |
---|
1667 | { |
---|
1668 | LispObj *p = range_start, node, new; |
---|
1669 | int tag_n; |
---|
1670 | natural nwords; |
---|
1671 | hash_table_vector_header *hashp; |
---|
1672 | |
---|
1673 | while (p < range_end) { |
---|
1674 | node = *p; |
---|
1675 | tag_n = fulltag_of(node); |
---|
1676 | if (immheader_tag_p(tag_n)) { |
---|
1677 | p = (LispObj *) skip_over_ivector((natural) p, node); |
---|
1678 | } else if (nodeheader_tag_p(tag_n)) { |
---|
1679 | nwords = header_element_count(node); |
---|
1680 | nwords += (1 - (nwords&1)); |
---|
1681 | if ((header_subtag(node) == subtag_hash_vector) && |
---|
1682 | ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { |
---|
1683 | natural skip = hash_table_vector_header_count-1; |
---|
1684 | hashp = (hash_table_vector_header *) p; |
---|
1685 | p++; |
---|
1686 | nwords -= skip; |
---|
1687 | while(skip--) { |
---|
1688 | update_noderef(p); |
---|
1689 | p++; |
---|
1690 | } |
---|
1691 | /* "nwords" is odd at this point: there are (floor nwords 2) |
---|
1692 | key/value pairs to look at, and then an extra word for |
---|
1693 | alignment. Process them two at a time, then bump "p" |
---|
1694 | past the alignment word. */ |
---|
1695 | nwords >>= 1; |
---|
1696 | while(nwords--) { |
---|
1697 | if (update_noderef(p) && hashp) { |
---|
1698 | hashp->flags |= nhash_key_moved_mask; |
---|
1699 | hashp = NULL; |
---|
1700 | } |
---|
1701 | p++; |
---|
1702 | update_noderef(p); |
---|
1703 | p++; |
---|
1704 | } |
---|
1705 | *p++ = 0; |
---|
1706 | } else { |
---|
1707 | if (header_subtag(node) == subtag_function) { |
---|
1708 | #ifdef X8632 |
---|
1709 | int skip = (unsigned short)(p[1]); |
---|
1710 | #else |
---|
1711 | int skip = (int)(p[1]); |
---|
1712 | #endif |
---|
1713 | p += skip; |
---|
1714 | nwords -= skip; |
---|
1715 | } |
---|
1716 | p++; |
---|
1717 | while(nwords--) { |
---|
1718 | update_noderef(p); |
---|
1719 | p++; |
---|
1720 | } |
---|
1721 | } |
---|
1722 | } else { |
---|
1723 | new = node_forwarding_address(node); |
---|
1724 | if (new != node) { |
---|
1725 | *p = new; |
---|
1726 | } |
---|
1727 | p++; |
---|
1728 | update_noderef(p); |
---|
1729 | p++; |
---|
1730 | } |
---|
1731 | } |
---|
1732 | } |
---|
1733 | |
---|
1734 | |
---|
1735 | |
---|
1736 | |
---|
1737 | |
---|
1738 | |
---|
1739 | /* Forward a tstack area */ |
---|
1740 | void |
---|
1741 | forward_tstack_area(area *a) |
---|
1742 | { |
---|
1743 | LispObj |
---|
1744 | *current, |
---|
1745 | *next, |
---|
1746 | *start = (LispObj *) a->active, |
---|
1747 | *end = start, |
---|
1748 | *limit = (LispObj *) (a->high); |
---|
1749 | |
---|
1750 | for (current = start; |
---|
1751 | end != limit; |
---|
1752 | current = next) { |
---|
1753 | next = ptr_from_lispobj(*current); |
---|
1754 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
1755 | forward_range(current+2, end); |
---|
1756 | } |
---|
1757 | } |
---|
1758 | |
---|
1759 | /* Forward a vstack area */ |
---|
1760 | void |
---|
1761 | forward_vstack_area(area *a) |
---|
1762 | { |
---|
1763 | LispObj |
---|
1764 | *p = (LispObj *) a->active, |
---|
1765 | *q = (LispObj *) a->high; |
---|
1766 | |
---|
1767 | forward_headerless_range(p, q); |
---|
1768 | } |
---|
1769 | |
---|
1770 | /* Nothing of interest on x86 cstack */ |
---|
1771 | void |
---|
1772 | forward_cstack_area(area *a) |
---|
1773 | { |
---|
1774 | } |
---|
1775 | |
---|
1776 | #ifdef X8664 |
---|
1777 | void |
---|
1778 | forward_xp(ExceptionInformation *xp) |
---|
1779 | { |
---|
1780 | natural *regs = (natural *) xpGPRvector(xp); |
---|
1781 | |
---|
1782 | update_noderef(&(regs[Iarg_z])); |
---|
1783 | update_noderef(&(regs[Iarg_y])); |
---|
1784 | update_noderef(&(regs[Iarg_x])); |
---|
1785 | update_noderef(&(regs[Isave3])); |
---|
1786 | update_noderef(&(regs[Isave2])); |
---|
1787 | update_noderef(&(regs[Isave1])); |
---|
1788 | update_noderef(&(regs[Isave0])); |
---|
1789 | update_noderef(&(regs[Ifn])); |
---|
1790 | update_noderef(&(regs[Itemp0])); |
---|
1791 | update_noderef(&(regs[Itemp1])); |
---|
1792 | update_noderef(&(regs[Itemp2])); |
---|
1793 | update_locref(&(regs[Iip])); |
---|
1794 | } |
---|
1795 | #else |
---|
1796 | void |
---|
1797 | forward_xp(ExceptionInformation *xp, natural node_regs_mask) |
---|
1798 | { |
---|
1799 | natural *regs = (natural *) xpGPRvector(xp); |
---|
1800 | |
---|
1801 | if (node_regs_mask & (1<<0)) update_noderef(®s[REG_EAX]); |
---|
1802 | if (node_regs_mask & (1<<1)) update_noderef(®s[REG_ECX]); |
---|
1803 | |
---|
1804 | if (regs[REG_EFL] & EFL_DF) { |
---|
1805 | /* then EDX is an imm reg */ |
---|
1806 | ; |
---|
1807 | } else |
---|
1808 | if (node_regs_mask & (1<<2)) update_noderef(®s[REG_EDX]); |
---|
1809 | |
---|
1810 | if (node_regs_mask & (1<<3)) update_noderef(®s[REG_EBX]); |
---|
1811 | if (node_regs_mask & (1<<4)) update_noderef(®s[REG_ESP]); |
---|
1812 | if (node_regs_mask & (1<<5)) update_noderef(®s[REG_EBP]); |
---|
1813 | if (node_regs_mask & (1<<6)) update_noderef(®s[REG_ESI]); |
---|
1814 | if (node_regs_mask & (1<<7)) update_noderef(®s[REG_EDI]); |
---|
1815 | |
---|
1816 | update_locref(&(regs[Iip])); |
---|
1817 | } |
---|
1818 | #endif |
---|
1819 | |
---|
1820 | |
---|
1821 | void |
---|
1822 | forward_tcr_xframes(TCR *tcr) |
---|
1823 | { |
---|
1824 | xframe_list *xframes; |
---|
1825 | ExceptionInformation *xp; |
---|
1826 | |
---|
1827 | xp = tcr->gc_context; |
---|
1828 | if (xp) { |
---|
1829 | #ifdef X8664 |
---|
1830 | forward_xp(xp); |
---|
1831 | #else |
---|
1832 | forward_xp(xp, tcr->node_regs_mask); |
---|
1833 | |
---|
1834 | update_noderef(&tcr->save0); |
---|
1835 | update_noderef(&tcr->save1); |
---|
1836 | update_noderef(&tcr->save2); |
---|
1837 | update_noderef(&tcr->save3); |
---|
1838 | update_noderef(&tcr->next_method_context); |
---|
1839 | #endif |
---|
1840 | } |
---|
1841 | for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { |
---|
1842 | #ifdef X8664 |
---|
1843 | forward_xp(xframes->curr); |
---|
1844 | #else |
---|
1845 | forward_xp(xframes->curr, xframes->node_regs_mask); |
---|
1846 | #endif |
---|
1847 | } |
---|
1848 | } |
---|
1849 | |
---|
1850 | |
---|
1851 | #ifdef X8632 |
---|
1852 | void |
---|
1853 | update_self_references(LispObj *node) |
---|
1854 | { |
---|
1855 | LispObj fn = fulltag_misc + (LispObj)node; |
---|
1856 | unsigned char *p = (unsigned char *)node; |
---|
1857 | natural i, offset; |
---|
1858 | |
---|
1859 | i = ((unsigned short *)node)[2]; |
---|
1860 | offset = node[--i]; |
---|
1861 | while (offset) { |
---|
1862 | *(LispObj *)(p + offset) = fn; |
---|
1863 | offset = node[--i]; |
---|
1864 | } |
---|
1865 | } |
---|
1866 | #endif |
---|
1867 | |
---|
1868 | /* |
---|
1869 | Compact the dynamic heap (from GCfirstunmarked through its end.) |
---|
1870 | Return the doublenode address of the new freeptr. |
---|
1871 | */ |
---|
1872 | |
---|
1873 | LispObj |
---|
1874 | compact_dynamic_heap() |
---|
1875 | { |
---|
1876 | LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current, *prev = NULL; |
---|
1877 | natural |
---|
1878 | elements, |
---|
1879 | dnode = gc_area_dnode(GCfirstunmarked), |
---|
1880 | node_dnodes = 0, |
---|
1881 | imm_dnodes = 0, |
---|
1882 | bitidx, |
---|
1883 | *bitsp, |
---|
1884 | bits, |
---|
1885 | nextbit, |
---|
1886 | diff; |
---|
1887 | int tag; |
---|
1888 | bitvector markbits = GCmarkbits; |
---|
1889 | |
---|
1890 | if (dnode < GCndnodes_in_area) { |
---|
1891 | lisp_global(FWDNUM) += (1<<fixnum_shift); |
---|
1892 | |
---|
1893 | set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); |
---|
1894 | while (dnode < GCndnodes_in_area) { |
---|
1895 | if (bits == 0) { |
---|
1896 | int remain = nbits_in_word - bitidx; |
---|
1897 | dnode += remain; |
---|
1898 | src += (remain+remain); |
---|
1899 | bits = *++bitsp; |
---|
1900 | bitidx = 0; |
---|
1901 | } else { |
---|
1902 | /* Have a non-zero markbits word; all bits more significant |
---|
1903 | than "bitidx" are 0. Count leading zeros in "bits" |
---|
1904 | (there'll be at least "bitidx" of them.) If there are more |
---|
1905 | than "bitidx" leading zeros, bump "dnode", "bitidx", and |
---|
1906 | "src" by the difference. */ |
---|
1907 | nextbit = count_leading_zeros(bits); |
---|
1908 | if ((diff = (nextbit - bitidx)) != 0) { |
---|
1909 | dnode += diff; |
---|
1910 | bitidx = nextbit; |
---|
1911 | src += (diff+diff); |
---|
1912 | } |
---|
1913 | prev = current; |
---|
1914 | current = src; |
---|
1915 | if (GCDebug) { |
---|
1916 | if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) { |
---|
1917 | Bug(NULL, "Out of synch in heap compaction. Forwarding from 0x" LISP " to 0x" LISP ",\n expected to go to 0x" LISP "\n", |
---|
1918 | src, dest, locative_forwarding_address(ptr_to_lispobj(src))); |
---|
1919 | } |
---|
1920 | } |
---|
1921 | |
---|
1922 | node = *src++; |
---|
1923 | tag = fulltag_of(node); |
---|
1924 | if (nodeheader_tag_p(tag)) { |
---|
1925 | elements = header_element_count(node); |
---|
1926 | node_dnodes = (elements+2)>>1; |
---|
1927 | dnode += node_dnodes; |
---|
1928 | if (header_subtag(node) == subtag_function) { |
---|
1929 | #ifdef X8632 |
---|
1930 | int skip = *((unsigned short *)src); |
---|
1931 | LispObj *f = dest; |
---|
1932 | #else |
---|
1933 | int skip = *((int *)src); |
---|
1934 | #endif |
---|
1935 | *dest++ = node; |
---|
1936 | elements -= skip; |
---|
1937 | while(skip--) { |
---|
1938 | *dest++ = *src++; |
---|
1939 | } |
---|
1940 | #ifdef X8632 |
---|
1941 | update_self_references(f); |
---|
1942 | #endif |
---|
1943 | while(elements--) { |
---|
1944 | *dest++ = node_forwarding_address(*src++); |
---|
1945 | } |
---|
1946 | if (((LispObj)src) & node_size) { |
---|
1947 | src++; |
---|
1948 | *dest++ = 0; |
---|
1949 | } |
---|
1950 | } else { |
---|
1951 | if ((header_subtag(node) == subtag_hash_vector) && |
---|
1952 | (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) { |
---|
1953 | hash_table_vector_header *hashp = (hash_table_vector_header *) dest; |
---|
1954 | int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
1955 | |
---|
1956 | *dest++ = node; |
---|
1957 | elements -= skip; |
---|
1958 | while(skip--) { |
---|
1959 | *dest++ = node_forwarding_address(*src++); |
---|
1960 | } |
---|
1961 | /* There should be an even number of (key/value) pairs in elements; |
---|
1962 | an extra alignment word follows. */ |
---|
1963 | elements >>= 1; |
---|
1964 | while (elements--) { |
---|
1965 | if (hashp) { |
---|
1966 | node = *src++; |
---|
1967 | new = node_forwarding_address(node); |
---|
1968 | if (new != node) { |
---|
1969 | hashp->flags |= nhash_key_moved_mask; |
---|
1970 | hashp = NULL; |
---|
1971 | *dest++ = new; |
---|
1972 | } else { |
---|
1973 | *dest++ = node; |
---|
1974 | } |
---|
1975 | } else { |
---|
1976 | *dest++ = node_forwarding_address(*src++); |
---|
1977 | } |
---|
1978 | *dest++ = node_forwarding_address(*src++); |
---|
1979 | } |
---|
1980 | *dest++ = 0; |
---|
1981 | src++; |
---|
1982 | } else { |
---|
1983 | *dest++ = node; |
---|
1984 | *dest++ = node_forwarding_address(*src++); |
---|
1985 | while(--node_dnodes) { |
---|
1986 | *dest++ = node_forwarding_address(*src++); |
---|
1987 | *dest++ = node_forwarding_address(*src++); |
---|
1988 | } |
---|
1989 | } |
---|
1990 | } |
---|
1991 | set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); |
---|
1992 | } else if (immheader_tag_p(tag)) { |
---|
1993 | *dest++ = node; |
---|
1994 | *dest++ = *src++; |
---|
1995 | elements = header_element_count(node); |
---|
1996 | tag = header_subtag(node); |
---|
1997 | |
---|
1998 | #ifdef X8664 |
---|
1999 | switch(fulltag_of(tag)) { |
---|
2000 | case ivector_class_64_bit: |
---|
2001 | imm_dnodes = ((elements+1)+1)>>1; |
---|
2002 | break; |
---|
2003 | case ivector_class_32_bit: |
---|
2004 | imm_dnodes = (((elements+2)+3)>>2); |
---|
2005 | break; |
---|
2006 | case ivector_class_other_bit: |
---|
2007 | if (tag == subtag_bit_vector) { |
---|
2008 | imm_dnodes = (((elements+64)+127)>>7); |
---|
2009 | } else if (tag >= min_8_bit_ivector_subtag) { |
---|
2010 | imm_dnodes = (((elements+8)+15)>>4); |
---|
2011 | } else { |
---|
2012 | imm_dnodes = (((elements+4)+7)>>3); |
---|
2013 | } |
---|
2014 | } |
---|
2015 | #endif |
---|
2016 | #ifdef X8632 |
---|
2017 | if (tag <= max_32_bit_ivector_subtag) { |
---|
2018 | imm_dnodes = (((elements+1)+1)>>1); |
---|
2019 | } else if (tag <= max_8_bit_ivector_subtag) { |
---|
2020 | imm_dnodes = (((elements+4)+7)>>3); |
---|
2021 | } else if (tag <= max_16_bit_ivector_subtag) { |
---|
2022 | imm_dnodes = (((elements+2)+3)>>2); |
---|
2023 | } else if (tag == subtag_bit_vector) { |
---|
2024 | imm_dnodes = (((elements+32)+63)>>6); |
---|
2025 | } else { |
---|
2026 | imm_dnodes = elements+1; |
---|
2027 | } |
---|
2028 | #endif |
---|
2029 | |
---|
2030 | dnode += imm_dnodes; |
---|
2031 | while (--imm_dnodes) { |
---|
2032 | *dest++ = *src++; |
---|
2033 | *dest++ = *src++; |
---|
2034 | } |
---|
2035 | set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); |
---|
2036 | } else { |
---|
2037 | *dest++ = node_forwarding_address(node); |
---|
2038 | *dest++ = node_forwarding_address(*src++); |
---|
2039 | bits &= ~(BIT0_MASK >> bitidx); |
---|
2040 | dnode++; |
---|
2041 | bitidx++; |
---|
2042 | } |
---|
2043 | } |
---|
2044 | } |
---|
2045 | } |
---|
2046 | return ptr_to_lispobj(dest); |
---|
2047 | } |
---|
2048 | |
---|
2049 | |
---|
2050 | |
---|
2051 | |
---|
2052 | |
---|
2053 | |
---|
2054 | |
---|
2055 | /* |
---|
2056 | Total the (physical) byte sizes of all ivectors in the indicated memory range |
---|
2057 | */ |
---|
2058 | |
---|
2059 | natural |
---|
2060 | unboxed_bytes_in_range(LispObj *start, LispObj *end) |
---|
2061 | { |
---|
2062 | natural total=0, elements, tag, subtag, bytes; |
---|
2063 | LispObj header; |
---|
2064 | |
---|
2065 | while (start < end) { |
---|
2066 | header = *start; |
---|
2067 | tag = fulltag_of(header); |
---|
2068 | |
---|
2069 | if ((nodeheader_tag_p(tag)) || |
---|
2070 | (immheader_tag_p(tag))) { |
---|
2071 | elements = header_element_count(header); |
---|
2072 | if (nodeheader_tag_p(tag)) { |
---|
2073 | start += ((elements+2) & ~1); |
---|
2074 | } else { |
---|
2075 | subtag = header_subtag(header); |
---|
2076 | |
---|
2077 | #ifdef X8664 |
---|
2078 | switch(fulltag_of(header)) { |
---|
2079 | case ivector_class_64_bit: |
---|
2080 | bytes = 8 + (elements<<3); |
---|
2081 | break; |
---|
2082 | case ivector_class_32_bit: |
---|
2083 | bytes = 8 + (elements<<2); |
---|
2084 | break; |
---|
2085 | case ivector_class_other_bit: |
---|
2086 | default: |
---|
2087 | if (subtag == subtag_bit_vector) { |
---|
2088 | bytes = 8 + ((elements+7)>>3); |
---|
2089 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
2090 | bytes = 8 + elements; |
---|
2091 | } else { |
---|
2092 | bytes = 8 + (elements<<1); |
---|
2093 | } |
---|
2094 | } |
---|
2095 | #endif |
---|
2096 | #ifdef X8632 |
---|
2097 | if (subtag <= max_32_bit_ivector_subtag) { |
---|
2098 | bytes = 4 + (elements<<2); |
---|
2099 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
2100 | bytes = 4 + elements; |
---|
2101 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
2102 | bytes = 4 + (elements<<1); |
---|
2103 | } else if (subtag == subtag_double_float_vector) { |
---|
2104 | bytes = 8 + (elements<<3); |
---|
2105 | } else { |
---|
2106 | bytes = 4 + ((elements+7)>>3); |
---|
2107 | } |
---|
2108 | #endif |
---|
2109 | |
---|
2110 | bytes = (bytes+dnode_size-1) & ~(dnode_size-1); |
---|
2111 | total += bytes; |
---|
2112 | start += (bytes >> node_shift); |
---|
2113 | } |
---|
2114 | } else { |
---|
2115 | start += 2; |
---|
2116 | } |
---|
2117 | } |
---|
2118 | return total; |
---|
2119 | } |
---|
2120 | |
---|
2121 | |
---|
2122 | /* |
---|
2123 | This assumes that it's getting called with a simple-{base,general}-string |
---|
2124 | or code vector as an argument and that there's room for the object in the |
---|
2125 | destination area. |
---|
2126 | */ |
---|
2127 | |
---|
2128 | |
---|
2129 | LispObj |
---|
2130 | purify_displaced_object(LispObj obj, area *dest, natural disp) |
---|
2131 | { |
---|
2132 | BytePtr |
---|
2133 | free = dest->active, |
---|
2134 | *old = (BytePtr *) ptr_from_lispobj(untag(obj)); |
---|
2135 | LispObj |
---|
2136 | header = header_of(obj), |
---|
2137 | new; |
---|
2138 | natural |
---|
2139 | start = (natural)old, |
---|
2140 | physbytes; |
---|
2141 | |
---|
2142 | physbytes = ((natural)(skip_over_ivector(start,header))) - start; |
---|
2143 | |
---|
2144 | dest->active += physbytes; |
---|
2145 | |
---|
2146 | new = ptr_to_lispobj(free)+disp; |
---|
2147 | |
---|
2148 | memcpy(free, (BytePtr)old, physbytes); |
---|
2149 | /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ |
---|
2150 | /* Actually, it's best to always leave a trail, for two reasons. |
---|
2151 | a) We may be walking the same heap that we're leaving forwaring |
---|
2152 | pointers in, so we don't want garbage that we leave behind to |
---|
2153 | look like a header. |
---|
2154 | b) We'd like to be able to forward code-vector locatives, and |
---|
2155 | it's easiest to do so if we leave a {forward_marker, dnode_locative} |
---|
2156 | pair at every doubleword in the old vector. |
---|
2157 | */ |
---|
2158 | while(physbytes) { |
---|
2159 | *old++ = (BytePtr) forward_marker; |
---|
2160 | *old++ = (BytePtr) free; |
---|
2161 | free += dnode_size; |
---|
2162 | physbytes -= dnode_size; |
---|
2163 | } |
---|
2164 | return new; |
---|
2165 | } |
---|
2166 | |
---|
2167 | LispObj |
---|
2168 | purify_object(LispObj obj, area *dest) |
---|
2169 | { |
---|
2170 | return purify_displaced_object(obj, dest, fulltag_of(obj)); |
---|
2171 | } |
---|
2172 | |
---|
2173 | Boolean |
---|
2174 | copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest) |
---|
2175 | { |
---|
2176 | LispObj obj = *ref, header, new; |
---|
2177 | natural tag = fulltag_of(obj), header_tag; |
---|
2178 | Boolean changed = false; |
---|
2179 | |
---|
2180 | if ((tag == fulltag_misc) && |
---|
2181 | (((BytePtr)ptr_from_lispobj(obj)) > low) && |
---|
2182 | (((BytePtr)ptr_from_lispobj(obj)) < high)) { |
---|
2183 | header = deref(obj, 0); |
---|
2184 | if (header == forward_marker) { /* already copied */ |
---|
2185 | *ref = (untag(deref(obj,1)) + tag); |
---|
2186 | changed = true; |
---|
2187 | } else { |
---|
2188 | header_tag = fulltag_of(header); |
---|
2189 | if (immheader_tag_p(header_tag)) { |
---|
2190 | if (header_subtag(header) != subtag_macptr) { |
---|
2191 | new = purify_object(obj, dest); |
---|
2192 | *ref = new; |
---|
2193 | changed = (new != obj); |
---|
2194 | } |
---|
2195 | } |
---|
2196 | } |
---|
2197 | } |
---|
2198 | return changed; |
---|
2199 | } |
---|
2200 | |
---|
2201 | |
---|
2202 | void |
---|
2203 | purify_gcable_ptrs(BytePtr low, BytePtr high, area *to) |
---|
2204 | { |
---|
2205 | LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; |
---|
2206 | |
---|
2207 | while ((*prev) != (LispObj)NULL) { |
---|
2208 | copy_ivector_reference(prev, low, high, to); |
---|
2209 | next = *prev; |
---|
2210 | prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); |
---|
2211 | } |
---|
2212 | } |
---|
2213 | |
---|
2214 | void |
---|
2215 | purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) |
---|
2216 | { |
---|
2217 | while (start < end) { |
---|
2218 | copy_ivector_reference(start, low, high, to); |
---|
2219 | start++; |
---|
2220 | } |
---|
2221 | } |
---|
2222 | |
---|
2223 | void |
---|
2224 | purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) |
---|
2225 | { |
---|
2226 | LispObj header; |
---|
2227 | unsigned tag; |
---|
2228 | natural nwords; |
---|
2229 | hash_table_vector_header *hashp; |
---|
2230 | |
---|
2231 | while (start < end) { |
---|
2232 | header = *start; |
---|
2233 | if (header == forward_marker) { |
---|
2234 | start += 2; |
---|
2235 | } else { |
---|
2236 | tag = fulltag_of(header); |
---|
2237 | if (immheader_tag_p(tag)) { |
---|
2238 | start = (LispObj *)skip_over_ivector((natural)start, header); |
---|
2239 | } else if (nodeheader_tag_p(tag)) { |
---|
2240 | nwords = header_element_count(header); |
---|
2241 | nwords += (1 - (nwords&1)); |
---|
2242 | if ((header_subtag(header) == subtag_hash_vector) && |
---|
2243 | ((((hash_table_vector_header *)start)->flags) & |
---|
2244 | nhash_track_keys_mask)) { |
---|
2245 | natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
2246 | |
---|
2247 | hashp = (hash_table_vector_header *) start; |
---|
2248 | start++; |
---|
2249 | nwords -= skip; |
---|
2250 | while(skip--) { |
---|
2251 | copy_ivector_reference(start, low, high, to); |
---|
2252 | start++; |
---|
2253 | } |
---|
2254 | /* "nwords" is odd at this point: there are (floor nwords 2) |
---|
2255 | key/value pairs to look at, and then an extra word for |
---|
2256 | alignment. Process them two at a time, then bump "start" |
---|
2257 | past the alignment word. */ |
---|
2258 | nwords >>= 1; |
---|
2259 | while(nwords--) { |
---|
2260 | if (copy_ivector_reference(start, low, high, to) && hashp) { |
---|
2261 | hashp->flags |= nhash_key_moved_mask; |
---|
2262 | hashp = NULL; |
---|
2263 | } |
---|
2264 | start++; |
---|
2265 | copy_ivector_reference(start, low, high, to); |
---|
2266 | start++; |
---|
2267 | } |
---|
2268 | *start++ = 0; |
---|
2269 | } else { |
---|
2270 | if (header_subtag(header) == subtag_function) { |
---|
2271 | #ifdef X8632 |
---|
2272 | int skip = (unsigned short)(start[1]); |
---|
2273 | #else |
---|
2274 | int skip = (int)(start[1]); |
---|
2275 | #endif |
---|
2276 | start += skip; |
---|
2277 | nwords -= skip; |
---|
2278 | } |
---|
2279 | start++; |
---|
2280 | while(nwords--) { |
---|
2281 | copy_ivector_reference(start, low, high, to); |
---|
2282 | start++; |
---|
2283 | } |
---|
2284 | } |
---|
2285 | } else { |
---|
2286 | /* Not a header, just a cons cell */ |
---|
2287 | copy_ivector_reference(start, low, high, to); |
---|
2288 | start++; |
---|
2289 | copy_ivector_reference(start, low, high, to); |
---|
2290 | start++; |
---|
2291 | } |
---|
2292 | } |
---|
2293 | } |
---|
2294 | } |
---|
2295 | |
---|
2296 | /* Purify references from tstack areas */ |
---|
2297 | void |
---|
2298 | purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to) |
---|
2299 | { |
---|
2300 | LispObj |
---|
2301 | *current, |
---|
2302 | *next, |
---|
2303 | *start = (LispObj *) (a->active), |
---|
2304 | *end = start, |
---|
2305 | *limit = (LispObj *) (a->high); |
---|
2306 | |
---|
2307 | for (current = start; |
---|
2308 | end != limit; |
---|
2309 | current = next) { |
---|
2310 | next = (LispObj *) ptr_from_lispobj(*current); |
---|
2311 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
2312 | purify_range(current+2, end, low, high, to); |
---|
2313 | } |
---|
2314 | } |
---|
2315 | |
---|
2316 | /* Purify a vstack area */ |
---|
2317 | void |
---|
2318 | purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to) |
---|
2319 | { |
---|
2320 | LispObj |
---|
2321 | *p = (LispObj *) a->active, |
---|
2322 | *q = (LispObj *) a->high; |
---|
2323 | |
---|
2324 | purify_headerless_range(p, q, low, high, to); |
---|
2325 | } |
---|
2326 | |
---|
2327 | |
---|
2328 | void |
---|
2329 | purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to) |
---|
2330 | { |
---|
2331 | natural *regs = (natural *) xpGPRvector(xp); |
---|
2332 | |
---|
2333 | |
---|
2334 | #ifdef X8664 |
---|
2335 | copy_ivector_reference(&(regs[Iarg_z]), low, high, to); |
---|
2336 | copy_ivector_reference(&(regs[Iarg_y]), low, high, to); |
---|
2337 | copy_ivector_reference(&(regs[Iarg_x]), low, high, to); |
---|
2338 | copy_ivector_reference(&(regs[Isave3]), low, high, to); |
---|
2339 | copy_ivector_reference(&(regs[Isave2]), low, high, to); |
---|
2340 | copy_ivector_reference(&(regs[Isave1]), low, high, to); |
---|
2341 | copy_ivector_reference(&(regs[Isave0]), low, high, to); |
---|
2342 | copy_ivector_reference(&(regs[Ifn]), low, high, to); |
---|
2343 | copy_ivector_reference(&(regs[Itemp0]), low, high, to); |
---|
2344 | copy_ivector_reference(&(regs[Itemp1]), low, high, to); |
---|
2345 | copy_ivector_reference(&(regs[Itemp2]), low, high, to); |
---|
2346 | #if 0 |
---|
2347 | purify_locref(&(regs[Iip]), low, high, to); |
---|
2348 | #endif |
---|
2349 | #else |
---|
2350 | #endif |
---|
2351 | } |
---|
2352 | |
---|
2353 | void |
---|
2354 | purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to) |
---|
2355 | { |
---|
2356 | natural n = tcr->tlb_limit; |
---|
2357 | LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); |
---|
2358 | |
---|
2359 | purify_range(start, end, low, high, to); |
---|
2360 | } |
---|
2361 | |
---|
2362 | void |
---|
2363 | purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to) |
---|
2364 | { |
---|
2365 | xframe_list *xframes; |
---|
2366 | ExceptionInformation *xp; |
---|
2367 | |
---|
2368 | xp = tcr->gc_context; |
---|
2369 | if (xp) { |
---|
2370 | purify_xp(xp, low, high, to); |
---|
2371 | } |
---|
2372 | |
---|
2373 | for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { |
---|
2374 | purify_xp(xframes->curr, low, high, to); |
---|
2375 | } |
---|
2376 | } |
---|
2377 | |
---|
2378 | |
---|
2379 | void |
---|
2380 | purify_areas(BytePtr low, BytePtr high, area *target) |
---|
2381 | { |
---|
2382 | area *next_area; |
---|
2383 | area_code code; |
---|
2384 | |
---|
2385 | for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { |
---|
2386 | switch (code) { |
---|
2387 | case AREA_TSTACK: |
---|
2388 | purify_tstack_area(next_area, low, high, target); |
---|
2389 | break; |
---|
2390 | |
---|
2391 | case AREA_VSTACK: |
---|
2392 | purify_vstack_area(next_area, low, high, target); |
---|
2393 | break; |
---|
2394 | |
---|
2395 | case AREA_CSTACK: |
---|
2396 | break; |
---|
2397 | |
---|
2398 | case AREA_STATIC: |
---|
2399 | case AREA_DYNAMIC: |
---|
2400 | purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target); |
---|
2401 | break; |
---|
2402 | |
---|
2403 | default: |
---|
2404 | break; |
---|
2405 | } |
---|
2406 | } |
---|
2407 | } |
---|
2408 | |
---|
2409 | /* |
---|
2410 | So far, this is mostly for save_application's benefit. |
---|
2411 | We -should- be able to return to lisp code after doing this, |
---|
2412 | however. |
---|
2413 | |
---|
2414 | */ |
---|
2415 | |
---|
2416 | |
---|
2417 | int |
---|
2418 | purify(TCR *tcr, signed_natural param) |
---|
2419 | { |
---|
2420 | extern area *extend_readonly_area(unsigned); |
---|
2421 | area |
---|
2422 | *a = active_dynamic_area, |
---|
2423 | *new_pure_area; |
---|
2424 | |
---|
2425 | TCR *other_tcr; |
---|
2426 | natural max_pure_size; |
---|
2427 | BytePtr new_pure_start, |
---|
2428 | low = (a->low + (static_dnodes_for_area(a) << dnode_shift)), |
---|
2429 | high = a->active; |
---|
2430 | |
---|
2431 | |
---|
2432 | max_pure_size = unboxed_bytes_in_range((LispObj *) low, (LispObj *) high); |
---|
2433 | new_pure_area = extend_readonly_area(max_pure_size); |
---|
2434 | if (new_pure_area) { |
---|
2435 | new_pure_start = new_pure_area->active; |
---|
2436 | lisp_global(IN_GC) = (1<<fixnumshift); |
---|
2437 | |
---|
2438 | /* |
---|
2439 | |
---|
2440 | |
---|
2441 | Make the new_pure_area executable, just in case. |
---|
2442 | |
---|
2443 | Caller will typically GC again (and that should recover quite a bit of |
---|
2444 | the dynamic heap.) |
---|
2445 | */ |
---|
2446 | |
---|
2447 | |
---|
2448 | |
---|
2449 | purify_areas(low, high, new_pure_area); |
---|
2450 | |
---|
2451 | other_tcr = tcr; |
---|
2452 | do { |
---|
2453 | purify_tcr_xframes(other_tcr, low, high, new_pure_area); |
---|
2454 | purify_tcr_tlb(other_tcr, low, high, new_pure_area); |
---|
2455 | other_tcr = other_tcr->next; |
---|
2456 | } while (other_tcr != tcr); |
---|
2457 | |
---|
2458 | purify_gcable_ptrs(low, high, new_pure_area); |
---|
2459 | { |
---|
2460 | natural puresize = (unsigned) (new_pure_area->active-new_pure_start); |
---|
2461 | if (puresize != 0) { |
---|
2462 | xMakeDataExecutable(new_pure_start, puresize); |
---|
2463 | |
---|
2464 | } |
---|
2465 | } |
---|
2466 | ProtectMemory(new_pure_area->low, |
---|
2467 | align_to_power_of_2(new_pure_area->active-new_pure_area->low, |
---|
2468 | log2_page_size)); |
---|
2469 | lisp_global(IN_GC) = 0; |
---|
2470 | just_purified_p = true; |
---|
2471 | return 0; |
---|
2472 | } |
---|
2473 | return -1; |
---|
2474 | } |
---|
2475 | |
---|
2476 | |
---|
2477 | |
---|
2478 | Boolean |
---|
2479 | impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta) |
---|
2480 | { |
---|
2481 | LispObj q = *p; |
---|
2482 | |
---|
2483 | if (is_node_fulltag(fulltag_of(q)) && |
---|
2484 | (q >= low) && |
---|
2485 | (q < high)) { |
---|
2486 | *p = (q+delta); |
---|
2487 | return true; |
---|
2488 | } |
---|
2489 | return false; |
---|
2490 | } |
---|
2491 | |
---|
2492 | |
---|
2493 | void |
---|
2494 | impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) |
---|
2495 | { |
---|
2496 | LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; |
---|
2497 | |
---|
2498 | while ((*prev) != (LispObj)NULL) { |
---|
2499 | impurify_noderef(prev, low, high, delta); |
---|
2500 | next = *prev; |
---|
2501 | prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); |
---|
2502 | } |
---|
2503 | } |
---|
2504 | |
---|
2505 | |
---|
2506 | void |
---|
2507 | impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta) |
---|
2508 | { |
---|
2509 | natural *regs = (natural *) xpGPRvector(xp); |
---|
2510 | |
---|
2511 | |
---|
2512 | #ifdef X8664 |
---|
2513 | impurify_noderef(&(regs[Iarg_z]), low, high, delta); |
---|
2514 | impurify_noderef(&(regs[Iarg_y]), low, high, delta); |
---|
2515 | impurify_noderef(&(regs[Iarg_x]), low, high, delta); |
---|
2516 | #ifndef WINDOWS |
---|
2517 | impurify_noderef(&(regs[Isave3]), low, high, delta); |
---|
2518 | #endif |
---|
2519 | impurify_noderef(&(regs[Isave2]), low, high, delta); |
---|
2520 | impurify_noderef(&(regs[Isave1]), low, high, delta); |
---|
2521 | impurify_noderef(&(regs[Isave0]), low, high, delta); |
---|
2522 | impurify_noderef(&(regs[Ifn]), low, high, delta); |
---|
2523 | impurify_noderef(&(regs[Itemp0]), low, high, delta); |
---|
2524 | impurify_noderef(&(regs[Itemp1]), low, high, delta); |
---|
2525 | #if 0 |
---|
2526 | impurify_locref(&(regs[Iip]), low, high, delta); |
---|
2527 | #endif |
---|
2528 | #else |
---|
2529 | #endif |
---|
2530 | |
---|
2531 | } |
---|
2532 | |
---|
2533 | void |
---|
2534 | impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta) |
---|
2535 | { |
---|
2536 | while (start < end) { |
---|
2537 | impurify_noderef(start, low, high, delta); |
---|
2538 | start++; |
---|
2539 | } |
---|
2540 | } |
---|
2541 | |
---|
2542 | |
---|
2543 | void |
---|
2544 | impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta) |
---|
2545 | { |
---|
2546 | LispObj header; |
---|
2547 | unsigned tag; |
---|
2548 | natural nwords; |
---|
2549 | hash_table_vector_header *hashp; |
---|
2550 | |
---|
2551 | while (start < end) { |
---|
2552 | header = *start; |
---|
2553 | if (header == forward_marker) { |
---|
2554 | start += 2; |
---|
2555 | } else { |
---|
2556 | tag = fulltag_of(header); |
---|
2557 | if (immheader_tag_p(tag)) { |
---|
2558 | start = (LispObj *)skip_over_ivector((natural)start, header); |
---|
2559 | } else if (nodeheader_tag_p(tag)) { |
---|
2560 | nwords = header_element_count(header); |
---|
2561 | nwords += (1 - (nwords&1)); |
---|
2562 | if ((header_subtag(header) == subtag_hash_vector) && |
---|
2563 | ((((hash_table_vector_header *)start)->flags) & |
---|
2564 | nhash_track_keys_mask)) { |
---|
2565 | natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
2566 | |
---|
2567 | hashp = (hash_table_vector_header *) start; |
---|
2568 | start++; |
---|
2569 | nwords -= skip; |
---|
2570 | while(skip--) { |
---|
2571 | impurify_noderef(start, low, high, delta); |
---|
2572 | start++; |
---|
2573 | } |
---|
2574 | /* "nwords" is odd at this point: there are (floor nwords 2) |
---|
2575 | key/value pairs to look at, and then an extra word for |
---|
2576 | alignment. Process them two at a time, then bump "start" |
---|
2577 | past the alignment word. */ |
---|
2578 | nwords >>= 1; |
---|
2579 | while(nwords--) { |
---|
2580 | if (impurify_noderef(start, low, high, delta) && hashp) { |
---|
2581 | hashp->flags |= nhash_key_moved_mask; |
---|
2582 | hashp = NULL; |
---|
2583 | } |
---|
2584 | start++; |
---|
2585 | impurify_noderef(start, low, high, delta); |
---|
2586 | start++; |
---|
2587 | } |
---|
2588 | *start++ = 0; |
---|
2589 | } else { |
---|
2590 | if (header_subtag(header) == subtag_function) { |
---|
2591 | int skip = (int)(start[1]); |
---|
2592 | start += skip; |
---|
2593 | nwords -= skip; |
---|
2594 | } |
---|
2595 | start++; |
---|
2596 | while(nwords--) { |
---|
2597 | impurify_noderef(start, low, high, delta); |
---|
2598 | start++; |
---|
2599 | } |
---|
2600 | } |
---|
2601 | } else { |
---|
2602 | /* Not a header, just a cons cell */ |
---|
2603 | impurify_noderef(start, low, high, delta); |
---|
2604 | start++; |
---|
2605 | impurify_noderef(start, low, high, delta); |
---|
2606 | start++; |
---|
2607 | } |
---|
2608 | } |
---|
2609 | } |
---|
2610 | } |
---|
2611 | |
---|
2612 | |
---|
2613 | |
---|
2614 | |
---|
2615 | void |
---|
2616 | impurify_tcr_tlb(TCR *tcr, LispObj low, LispObj high, signed_natural delta) |
---|
2617 | { |
---|
2618 | unsigned n = tcr->tlb_limit; |
---|
2619 | LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); |
---|
2620 | |
---|
2621 | impurify_range(start, end, low, high, delta); |
---|
2622 | } |
---|
2623 | |
---|
2624 | void |
---|
2625 | impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta) |
---|
2626 | { |
---|
2627 | xframe_list *xframes; |
---|
2628 | ExceptionInformation *xp; |
---|
2629 | |
---|
2630 | xp = tcr->gc_context; |
---|
2631 | if (xp) { |
---|
2632 | impurify_xp(xp, low, high, delta); |
---|
2633 | } |
---|
2634 | |
---|
2635 | for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { |
---|
2636 | impurify_xp(xframes->curr, low, high, delta); |
---|
2637 | } |
---|
2638 | } |
---|
2639 | |
---|
2640 | void |
---|
2641 | impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta) |
---|
2642 | { |
---|
2643 | LispObj |
---|
2644 | *current, |
---|
2645 | *next, |
---|
2646 | *start = (LispObj *) (a->active), |
---|
2647 | *end = start, |
---|
2648 | *limit = (LispObj *) (a->high); |
---|
2649 | |
---|
2650 | for (current = start; |
---|
2651 | end != limit; |
---|
2652 | current = next) { |
---|
2653 | next = (LispObj *) ptr_from_lispobj(*current); |
---|
2654 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
2655 | if (current[1] == 0) { |
---|
2656 | impurify_range(current+2, end, low, high, delta); |
---|
2657 | } |
---|
2658 | } |
---|
2659 | } |
---|
2660 | void |
---|
2661 | impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta) |
---|
2662 | { |
---|
2663 | LispObj |
---|
2664 | *p = (LispObj *) a->active, |
---|
2665 | *q = (LispObj *) a->high; |
---|
2666 | |
---|
2667 | impurify_headerless_range(p, q, low, high, delta); |
---|
2668 | } |
---|
2669 | |
---|
2670 | |
---|
2671 | void |
---|
2672 | impurify_areas(LispObj low, LispObj high, signed_natural delta) |
---|
2673 | { |
---|
2674 | area *next_area; |
---|
2675 | area_code code; |
---|
2676 | |
---|
2677 | for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { |
---|
2678 | switch (code) { |
---|
2679 | case AREA_TSTACK: |
---|
2680 | impurify_tstack_area(next_area, low, high, delta); |
---|
2681 | break; |
---|
2682 | |
---|
2683 | case AREA_VSTACK: |
---|
2684 | impurify_vstack_area(next_area, low, high, delta); |
---|
2685 | break; |
---|
2686 | |
---|
2687 | case AREA_CSTACK: |
---|
2688 | break; |
---|
2689 | |
---|
2690 | case AREA_STATIC: |
---|
2691 | case AREA_DYNAMIC: |
---|
2692 | impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta); |
---|
2693 | break; |
---|
2694 | |
---|
2695 | default: |
---|
2696 | break; |
---|
2697 | } |
---|
2698 | } |
---|
2699 | } |
---|
2700 | |
---|
2701 | int |
---|
2702 | impurify(TCR *tcr, signed_natural param) |
---|
2703 | { |
---|
2704 | area *r = find_readonly_area(); |
---|
2705 | |
---|
2706 | if (r) { |
---|
2707 | area *a = active_dynamic_area; |
---|
2708 | BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active, |
---|
2709 | oldhigh = a->high, newhigh; |
---|
2710 | unsigned n = ro_limit - ro_base; |
---|
2711 | signed_natural delta = oldfree-ro_base; |
---|
2712 | TCR *other_tcr; |
---|
2713 | |
---|
2714 | if (n) { |
---|
2715 | lisp_global(IN_GC) = 1; |
---|
2716 | newhigh = (BytePtr) (align_to_power_of_2(oldfree+n, |
---|
2717 | log2_heap_segment_size)); |
---|
2718 | if (newhigh > oldhigh) { |
---|
2719 | grow_dynamic_area(newhigh-oldhigh); |
---|
2720 | } |
---|
2721 | a->active += n; |
---|
2722 | memmove(oldfree, ro_base, n); |
---|
2723 | UnMapMemory((void *)ro_base, n); |
---|
2724 | a->ndnodes = area_dnode(a, a->active); |
---|
2725 | pure_space_active = r->active = r->low; |
---|
2726 | r->ndnodes = 0; |
---|
2727 | |
---|
2728 | impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
2729 | |
---|
2730 | other_tcr = tcr; |
---|
2731 | do { |
---|
2732 | impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
2733 | impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
2734 | other_tcr = other_tcr->next; |
---|
2735 | } while (other_tcr != tcr); |
---|
2736 | |
---|
2737 | impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
2738 | lisp_global(IN_GC) = 0; |
---|
2739 | } |
---|
2740 | return 0; |
---|
2741 | } |
---|
2742 | return -1; |
---|
2743 | } |
---|