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 | #ifndef timeradd |
---|
29 | # define timeradd(a, b, result) \ |
---|
30 | do { \ |
---|
31 | (result)->tv_sec = (a)->tv_sec + (b)->tv_sec; \ |
---|
32 | (result)->tv_usec = (a)->tv_usec + (b)->tv_usec; \ |
---|
33 | if ((result)->tv_usec >= 1000000) \ |
---|
34 | { \ |
---|
35 | ++(result)->tv_sec; \ |
---|
36 | (result)->tv_usec -= 1000000; \ |
---|
37 | } \ |
---|
38 | } while (0) |
---|
39 | #endif |
---|
40 | #ifndef timersub |
---|
41 | # define timersub(a, b, result) \ |
---|
42 | do { \ |
---|
43 | (result)->tv_sec = (a)->tv_sec - (b)->tv_sec; \ |
---|
44 | (result)->tv_usec = (a)->tv_usec - (b)->tv_usec; \ |
---|
45 | if ((result)->tv_usec < 0) { \ |
---|
46 | --(result)->tv_sec; \ |
---|
47 | (result)->tv_usec += 1000000; \ |
---|
48 | } \ |
---|
49 | } while (0) |
---|
50 | #endif |
---|
51 | |
---|
52 | void |
---|
53 | comma_output_decimal(char *buf, int len, natural n) |
---|
54 | { |
---|
55 | int nout = 0; |
---|
56 | |
---|
57 | buf[--len] = 0; |
---|
58 | do { |
---|
59 | buf[--len] = n%10+'0'; |
---|
60 | n = n/10; |
---|
61 | if (n == 0) { |
---|
62 | while (len) { |
---|
63 | buf[--len] = ' '; |
---|
64 | } |
---|
65 | return; |
---|
66 | } |
---|
67 | if (len == 0) return; |
---|
68 | nout ++; |
---|
69 | if (nout == 3) { |
---|
70 | buf[--len] = ','; |
---|
71 | nout = 0; |
---|
72 | } |
---|
73 | } while (len >= 0); |
---|
74 | } |
---|
75 | |
---|
76 | |
---|
77 | /* Heap sanity checking. */ |
---|
78 | |
---|
79 | void |
---|
80 | check_node(LispObj n) |
---|
81 | { |
---|
82 | int tag = fulltag_of(n), header_tag; |
---|
83 | area *a; |
---|
84 | LispObj header; |
---|
85 | |
---|
86 | if (n == (n & 0xff)) { |
---|
87 | return; |
---|
88 | } |
---|
89 | |
---|
90 | switch (tag) { |
---|
91 | case fulltag_even_fixnum: |
---|
92 | case fulltag_odd_fixnum: |
---|
93 | #ifdef X8632 |
---|
94 | case fulltag_imm: |
---|
95 | #endif |
---|
96 | #ifdef X8664 |
---|
97 | case fulltag_imm_0: |
---|
98 | case fulltag_imm_1: |
---|
99 | #endif |
---|
100 | return; |
---|
101 | |
---|
102 | #ifdef X8664 |
---|
103 | case fulltag_nil: |
---|
104 | if (n != lisp_nil) { |
---|
105 | Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n); |
---|
106 | } |
---|
107 | return; |
---|
108 | #endif |
---|
109 | |
---|
110 | #ifdef X8632 |
---|
111 | case fulltag_nodeheader: |
---|
112 | case fulltag_immheader: |
---|
113 | #endif |
---|
114 | #ifdef X8664 |
---|
115 | case fulltag_nodeheader_0: |
---|
116 | case fulltag_nodeheader_1: |
---|
117 | case fulltag_immheader_0: |
---|
118 | case fulltag_immheader_1: |
---|
119 | case fulltag_immheader_2: |
---|
120 | #endif |
---|
121 | Bug(NULL, "Header not expected : 0x%lx", n); |
---|
122 | return; |
---|
123 | |
---|
124 | #ifdef X8632 |
---|
125 | case fulltag_tra: |
---|
126 | #endif |
---|
127 | #ifdef X8664 |
---|
128 | case fulltag_tra_0: |
---|
129 | case fulltag_tra_1: |
---|
130 | #endif |
---|
131 | a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); |
---|
132 | if (a == NULL) { |
---|
133 | a = active_dynamic_area; |
---|
134 | if ((n > (ptr_to_lispobj(a->active))) && |
---|
135 | (n < (ptr_to_lispobj(a->high)))) { |
---|
136 | Bug(NULL, "TRA points to heap free space: 0x%lx", n); |
---|
137 | } |
---|
138 | return; |
---|
139 | } |
---|
140 | /* tra points into the heap. Check displacement, then |
---|
141 | check the function it (should) identify. |
---|
142 | */ |
---|
143 | #ifdef X8632 |
---|
144 | { |
---|
145 | LispObj fun = 0; |
---|
146 | |
---|
147 | if (*(unsigned char *)n == RECOVER_FN_OPCODE) |
---|
148 | fun = *(LispObj *)(n + 1); |
---|
149 | if (fun == 0 || |
---|
150 | (header_subtag(header_of(fun)) != subtag_function) || |
---|
151 | (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) { |
---|
152 | Bug(NULL, "TRA at 0x%x has bad function address 0x%x\n", n, fun); |
---|
153 | } |
---|
154 | n = fun; |
---|
155 | } |
---|
156 | #endif |
---|
157 | #ifdef X8664 |
---|
158 | { |
---|
159 | int disp = 0; |
---|
160 | LispObj m = n; |
---|
161 | |
---|
162 | if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
163 | (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { |
---|
164 | disp = (*(int *) (n+3)); |
---|
165 | n = RECOVER_FN_FROM_RIP_LENGTH+m+disp; |
---|
166 | } |
---|
167 | if ((disp == 0) || |
---|
168 | (fulltag_of(n) != fulltag_function) || |
---|
169 | (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) { |
---|
170 | Bug(NULL, "TRA at 0x%lx has bad displacement %d\n", n, disp); |
---|
171 | } |
---|
172 | } |
---|
173 | #endif |
---|
174 | /* Otherwise, fall through and check the header on the function |
---|
175 | that the tra references */ |
---|
176 | |
---|
177 | case fulltag_misc: |
---|
178 | case fulltag_cons: |
---|
179 | #ifdef X8664 |
---|
180 | case fulltag_symbol: |
---|
181 | case fulltag_function: |
---|
182 | #endif |
---|
183 | a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); |
---|
184 | |
---|
185 | if (a == NULL) { |
---|
186 | /* Can't do as much sanity checking as we'd like to |
---|
187 | if object is a defunct stack-consed object. |
---|
188 | If a dangling reference to the heap, that's |
---|
189 | bad .. */ |
---|
190 | a = active_dynamic_area; |
---|
191 | if ((n > (ptr_to_lispobj(a->active))) && |
---|
192 | (n < (ptr_to_lispobj(a->high)))) { |
---|
193 | Bug(NULL, "Node points to heap free space: 0x%lx", n); |
---|
194 | } |
---|
195 | return; |
---|
196 | } |
---|
197 | break; |
---|
198 | } |
---|
199 | /* Node points to heap area, so check header/lack thereof. */ |
---|
200 | header = header_of(n); |
---|
201 | header_tag = fulltag_of(header); |
---|
202 | if (tag == fulltag_cons) { |
---|
203 | if ((nodeheader_tag_p(header_tag)) || |
---|
204 | (immheader_tag_p(header_tag))) { |
---|
205 | Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header); |
---|
206 | } |
---|
207 | return; |
---|
208 | } |
---|
209 | |
---|
210 | if ((!nodeheader_tag_p(header_tag)) && |
---|
211 | (!immheader_tag_p(header_tag))) { |
---|
212 | Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header); |
---|
213 | } |
---|
214 | return; |
---|
215 | } |
---|
216 | |
---|
217 | void |
---|
218 | check_all_mark_bits(LispObj *nodepointer) |
---|
219 | { |
---|
220 | } |
---|
221 | |
---|
222 | |
---|
223 | Boolean GCDebug = true, GCverbose = true; |
---|
224 | |
---|
225 | |
---|
226 | |
---|
227 | void |
---|
228 | check_range(LispObj *start, LispObj *end, Boolean header_allowed) |
---|
229 | { |
---|
230 | LispObj node, *current = start, *prev; |
---|
231 | int tag; |
---|
232 | natural elements; |
---|
233 | |
---|
234 | while (current < end) { |
---|
235 | prev = current; |
---|
236 | node = *current++; |
---|
237 | tag = fulltag_of(node); |
---|
238 | if (immheader_tag_p(tag)) { |
---|
239 | if (! header_allowed) { |
---|
240 | Bug(NULL, "Header not expected at 0x%lx\n", prev); |
---|
241 | } |
---|
242 | current = (LispObj *)skip_over_ivector((natural)prev, node); |
---|
243 | } else if (nodeheader_tag_p(tag)) { |
---|
244 | if (! header_allowed) { |
---|
245 | Bug(NULL, "Header not expected at 0x%lx\n", prev); |
---|
246 | } |
---|
247 | elements = header_element_count(node) | 1; |
---|
248 | if (header_subtag(node) == subtag_function) { |
---|
249 | #ifdef X8632 |
---|
250 | int skip = *(unsigned short *)current; |
---|
251 | #else |
---|
252 | int skip = *(int *)current; |
---|
253 | #endif |
---|
254 | current += skip; |
---|
255 | elements -= skip; |
---|
256 | } |
---|
257 | while (elements--) { |
---|
258 | check_node(*current++); |
---|
259 | } |
---|
260 | } else { |
---|
261 | check_node(node); |
---|
262 | check_node(*current++); |
---|
263 | } |
---|
264 | } |
---|
265 | |
---|
266 | if (current != end) { |
---|
267 | Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x", |
---|
268 | start, end, prev, current); |
---|
269 | } |
---|
270 | } |
---|
271 | |
---|
272 | void |
---|
273 | check_all_areas() |
---|
274 | { |
---|
275 | area *a = active_dynamic_area; |
---|
276 | area_code code = a->code; |
---|
277 | |
---|
278 | while (code != AREA_VOID) { |
---|
279 | switch (code) { |
---|
280 | case AREA_DYNAMIC: |
---|
281 | case AREA_STATIC: |
---|
282 | case AREA_MANAGED_STATIC: |
---|
283 | check_range((LispObj *)a->low, (LispObj *)a->active, true); |
---|
284 | break; |
---|
285 | |
---|
286 | case AREA_VSTACK: |
---|
287 | { |
---|
288 | LispObj* low = (LispObj *)a->active; |
---|
289 | LispObj* high = (LispObj *)a->high; |
---|
290 | |
---|
291 | if (((natural)low) & node_size) { |
---|
292 | check_node(*low++); |
---|
293 | } |
---|
294 | check_range(low, high, false); |
---|
295 | } |
---|
296 | break; |
---|
297 | |
---|
298 | case AREA_TSTACK: |
---|
299 | { |
---|
300 | LispObj *current, *next, |
---|
301 | *start = (LispObj *) a->active, |
---|
302 | *end = start, |
---|
303 | *limit = (LispObj *) a->high; |
---|
304 | |
---|
305 | for (current = start; |
---|
306 | end != limit; |
---|
307 | current = next) { |
---|
308 | next = ptr_from_lispobj(*current); |
---|
309 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
310 | check_range(current+2, end, true); |
---|
311 | } |
---|
312 | } |
---|
313 | break; |
---|
314 | } |
---|
315 | a = a->succ; |
---|
316 | code = (a->code); |
---|
317 | } |
---|
318 | } |
---|
319 | |
---|
320 | natural |
---|
321 | static_dnodes_for_area(area *a) |
---|
322 | { |
---|
323 | if (a->low == tenured_area->low) { |
---|
324 | return tenured_area->static_dnodes; |
---|
325 | } |
---|
326 | return 0; |
---|
327 | } |
---|
328 | |
---|
329 | |
---|
330 | |
---|
331 | |
---|
332 | |
---|
333 | |
---|
334 | |
---|
335 | bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL; |
---|
336 | LispObj GCarealow, GCareadynamiclow; |
---|
337 | natural GCndnodes_in_area, GCndynamic_dnodes_in_area; |
---|
338 | LispObj GCweakvll = (LispObj)NULL; |
---|
339 | LispObj GCephemeral_low; |
---|
340 | natural GCn_ephemeral_dnodes; |
---|
341 | |
---|
342 | |
---|
343 | /* Sooner or later, this probably wants to be in assembler */ |
---|
344 | /* Return false if n is definitely not an ephemeral node, true if |
---|
345 | it might be */ |
---|
346 | void |
---|
347 | mark_root(LispObj n) |
---|
348 | { |
---|
349 | int tag_n = fulltag_of(n); |
---|
350 | natural dnode, bits, *bitsp, mask; |
---|
351 | |
---|
352 | if (!is_node_fulltag(tag_n)) { |
---|
353 | return; |
---|
354 | } |
---|
355 | |
---|
356 | #ifdef X8632 |
---|
357 | if (tag_n == fulltag_tra) { |
---|
358 | if (*(unsigned char *)n == RECOVER_FN_OPCODE) { |
---|
359 | n = *(LispObj *)(n + 1); |
---|
360 | tag_n = fulltag_misc; |
---|
361 | } else |
---|
362 | return; |
---|
363 | } |
---|
364 | #endif |
---|
365 | #ifdef X8664 |
---|
366 | if (tag_of(n) == tag_tra) { |
---|
367 | if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
368 | (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { |
---|
369 | int sdisp = (*(int *) (n+3)); |
---|
370 | n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; |
---|
371 | tag_n = fulltag_function; |
---|
372 | } |
---|
373 | else { |
---|
374 | return; |
---|
375 | } |
---|
376 | } |
---|
377 | #endif |
---|
378 | |
---|
379 | |
---|
380 | dnode = gc_area_dnode(n); |
---|
381 | if (dnode >= GCndnodes_in_area) { |
---|
382 | return; |
---|
383 | } |
---|
384 | set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask); |
---|
385 | if (bits & mask) { |
---|
386 | return; |
---|
387 | } |
---|
388 | *bitsp = (bits | mask); |
---|
389 | |
---|
390 | if (tag_n == fulltag_cons) { |
---|
391 | cons *c = (cons *) ptr_from_lispobj(untag(n)); |
---|
392 | |
---|
393 | rmark(c->car); |
---|
394 | rmark(c->cdr); |
---|
395 | return; |
---|
396 | } |
---|
397 | { |
---|
398 | LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); |
---|
399 | natural |
---|
400 | header = *((natural *) base), |
---|
401 | subtag = header_subtag(header), |
---|
402 | element_count = header_element_count(header), |
---|
403 | total_size_in_bytes, /* including 4/8-byte header */ |
---|
404 | suffix_dnodes; |
---|
405 | natural prefix_nodes = 0; |
---|
406 | |
---|
407 | tag_n = fulltag_of(header); |
---|
408 | |
---|
409 | #ifdef X8664 |
---|
410 | if ((nodeheader_tag_p(tag_n)) || |
---|
411 | (tag_n == ivector_class_64_bit)) { |
---|
412 | total_size_in_bytes = 8 + (element_count<<3); |
---|
413 | } else if (tag_n == ivector_class_32_bit) { |
---|
414 | total_size_in_bytes = 8 + (element_count<<2); |
---|
415 | } else { |
---|
416 | /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */ |
---|
417 | if (subtag == subtag_bit_vector) { |
---|
418 | total_size_in_bytes = 8 + ((element_count+7)>>3); |
---|
419 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
420 | total_size_in_bytes = 8 + element_count; |
---|
421 | } else { |
---|
422 | total_size_in_bytes = 8 + (element_count<<1); |
---|
423 | } |
---|
424 | } |
---|
425 | #endif |
---|
426 | #ifdef X8632 |
---|
427 | if ((tag_n == fulltag_nodeheader) || |
---|
428 | (subtag <= max_32_bit_ivector_subtag)) { |
---|
429 | total_size_in_bytes = 4 + (element_count<<2); |
---|
430 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
431 | total_size_in_bytes = 4 + element_count; |
---|
432 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
433 | total_size_in_bytes = 4 + (element_count<<1); |
---|
434 | } else if (subtag == subtag_double_float_vector) { |
---|
435 | total_size_in_bytes = 8 + (element_count<<3); |
---|
436 | } else { |
---|
437 | total_size_in_bytes = 4 + ((element_count+7)>>3); |
---|
438 | } |
---|
439 | #endif |
---|
440 | |
---|
441 | |
---|
442 | suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1; |
---|
443 | |
---|
444 | if (suffix_dnodes) { |
---|
445 | set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); |
---|
446 | } |
---|
447 | |
---|
448 | if (nodeheader_tag_p(tag_n)) { |
---|
449 | if (subtag == subtag_hash_vector) { |
---|
450 | /* Don't invalidate the cache here. It should get |
---|
451 | invalidated on the lisp side, if/when we know |
---|
452 | that rehashing is necessary. */ |
---|
453 | LispObj flags = ((hash_table_vector_header *) base)->flags; |
---|
454 | |
---|
455 | if (flags & nhash_weak_mask) { |
---|
456 | ((hash_table_vector_header *) base)->cache_key = undefined; |
---|
457 | ((hash_table_vector_header *) base)->cache_value = lisp_nil; |
---|
458 | } |
---|
459 | deref(ptr_to_lispobj(base),1) = GCweakvll; |
---|
460 | GCweakvll = n; |
---|
461 | return; |
---|
462 | } |
---|
463 | |
---|
464 | if (subtag == subtag_pool) { |
---|
465 | deref(ptr_to_lispobj(base), 1) = lisp_nil; |
---|
466 | } |
---|
467 | |
---|
468 | if (subtag == subtag_weak) { |
---|
469 | natural weak_type = (natural) base[2]; |
---|
470 | if (weak_type >> population_termination_bit) { |
---|
471 | element_count -= 2; |
---|
472 | } else { |
---|
473 | element_count -= 1; |
---|
474 | } |
---|
475 | } |
---|
476 | |
---|
477 | if (subtag == subtag_function) { |
---|
478 | #ifdef X8632 |
---|
479 | prefix_nodes = (natural) ((unsigned short) deref(base,1)); |
---|
480 | #else |
---|
481 | prefix_nodes = (natural) ((int) deref(base,1)); |
---|
482 | #endif |
---|
483 | if (prefix_nodes > element_count) { |
---|
484 | Bug(NULL, "Function 0x%lx trashed",n); |
---|
485 | } |
---|
486 | } |
---|
487 | base += (1+element_count); |
---|
488 | |
---|
489 | element_count -= prefix_nodes; |
---|
490 | |
---|
491 | while(element_count--) { |
---|
492 | rmark(*--base); |
---|
493 | } |
---|
494 | if (subtag == subtag_weak) { |
---|
495 | deref(ptr_to_lispobj(base),1) = GCweakvll; |
---|
496 | GCweakvll = n; |
---|
497 | } |
---|
498 | } |
---|
499 | } |
---|
500 | } |
---|
501 | |
---|
502 | |
---|
503 | /* |
---|
504 | This marks the node if it needs to; it returns true if the node |
---|
505 | is either a hash table vector header or a cons/misc-tagged pointer |
---|
506 | to ephemeral space. |
---|
507 | Note that it might be a pointer to ephemeral space even if it's |
---|
508 | not pointing to the current generation. |
---|
509 | */ |
---|
510 | |
---|
511 | Boolean |
---|
512 | mark_ephemeral_root(LispObj n) |
---|
513 | { |
---|
514 | int tag_n = fulltag_of(n); |
---|
515 | natural eph_dnode; |
---|
516 | |
---|
517 | if (nodeheader_tag_p(tag_n)) { |
---|
518 | return (header_subtag(n) == subtag_hash_vector); |
---|
519 | } |
---|
520 | |
---|
521 | if (is_node_fulltag (tag_n)) { |
---|
522 | eph_dnode = area_dnode(n, GCephemeral_low); |
---|
523 | if (eph_dnode < GCn_ephemeral_dnodes) { |
---|
524 | mark_root(n); /* May or may not mark it */ |
---|
525 | return true; /* but return true 'cause it's an ephemeral node */ |
---|
526 | } |
---|
527 | } |
---|
528 | return false; /* Not a heap pointer or not ephemeral */ |
---|
529 | } |
---|
530 | |
---|
531 | |
---|
532 | |
---|
533 | #ifdef X8664 |
---|
534 | #define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */ |
---|
535 | #define RMARK_PREV_CAR fulltag_nil /* fulltag_nil + node_size. Coincidence ? I think not. */ |
---|
536 | #else |
---|
537 | #define RMARK_PREV_ROOT fulltag_imm |
---|
538 | #define RMARK_PREV_CAR fulltag_immheader |
---|
539 | #endif |
---|
540 | |
---|
541 | natural |
---|
542 | GCstack_limit = 0; |
---|
543 | |
---|
544 | /* |
---|
545 | This wants to be in assembler even more than "mark_root" does. |
---|
546 | For now, it does link-inversion: hard as that is to express in C, |
---|
547 | reliable stack-overflow detection may be even harder ... |
---|
548 | */ |
---|
549 | void |
---|
550 | rmark(LispObj n) |
---|
551 | { |
---|
552 | int tag_n = fulltag_of(n); |
---|
553 | bitvector markbits = GCmarkbits; |
---|
554 | natural dnode, bits, *bitsp, mask, original_n = n; |
---|
555 | |
---|
556 | if (!is_node_fulltag(tag_n)) { |
---|
557 | return; |
---|
558 | } |
---|
559 | |
---|
560 | #ifdef X8632 |
---|
561 | if (tag_n == fulltag_tra) { |
---|
562 | if (*(unsigned char *)n == RECOVER_FN_OPCODE) { |
---|
563 | n = *(LispObj *)(n + 1); |
---|
564 | tag_n = fulltag_misc; |
---|
565 | } else { |
---|
566 | return; |
---|
567 | } |
---|
568 | } |
---|
569 | #endif |
---|
570 | #ifdef X8664 |
---|
571 | if (tag_of(n) == tag_tra) { |
---|
572 | if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
573 | (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { |
---|
574 | int sdisp = (*(int *) (n+3)); |
---|
575 | n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; |
---|
576 | tag_n = fulltag_function; |
---|
577 | } else { |
---|
578 | return; |
---|
579 | } |
---|
580 | } |
---|
581 | #endif |
---|
582 | |
---|
583 | dnode = gc_area_dnode(n); |
---|
584 | if (dnode >= GCndnodes_in_area) { |
---|
585 | return; |
---|
586 | } |
---|
587 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
588 | if (bits & mask) { |
---|
589 | return; |
---|
590 | } |
---|
591 | *bitsp = (bits | mask); |
---|
592 | |
---|
593 | if (current_stack_pointer() > GCstack_limit) { |
---|
594 | if (tag_n == fulltag_cons) { |
---|
595 | rmark(deref(n,1)); |
---|
596 | rmark(deref(n,0)); |
---|
597 | } else { |
---|
598 | LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); |
---|
599 | natural |
---|
600 | header = *((natural *) base), |
---|
601 | subtag = header_subtag(header), |
---|
602 | element_count = header_element_count(header), |
---|
603 | total_size_in_bytes, |
---|
604 | suffix_dnodes, |
---|
605 | nmark; |
---|
606 | |
---|
607 | tag_n = fulltag_of(header); |
---|
608 | |
---|
609 | #ifdef X8664 |
---|
610 | if ((nodeheader_tag_p(tag_n)) || |
---|
611 | (tag_n == ivector_class_64_bit)) { |
---|
612 | total_size_in_bytes = 8 + (element_count<<3); |
---|
613 | } else if (tag_n == ivector_class_32_bit) { |
---|
614 | total_size_in_bytes = 8 + (element_count<<2); |
---|
615 | } else { |
---|
616 | /* ivector_class_other_bit contains 16-bit arrays & bitvector */ |
---|
617 | if (subtag == subtag_bit_vector) { |
---|
618 | total_size_in_bytes = 8 + ((element_count+7)>>3); |
---|
619 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
620 | total_size_in_bytes = 8 + element_count; |
---|
621 | } else { |
---|
622 | total_size_in_bytes = 8 + (element_count<<1); |
---|
623 | } |
---|
624 | } |
---|
625 | #else |
---|
626 | if ((tag_n == fulltag_nodeheader) || |
---|
627 | (subtag <= max_32_bit_ivector_subtag)) { |
---|
628 | total_size_in_bytes = 4 + (element_count<<2); |
---|
629 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
630 | total_size_in_bytes = 4 + element_count; |
---|
631 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
632 | total_size_in_bytes = 4 + (element_count<<1); |
---|
633 | } else if (subtag == subtag_double_float_vector) { |
---|
634 | total_size_in_bytes = 8 + (element_count<<3); |
---|
635 | } else { |
---|
636 | total_size_in_bytes = 4 + ((element_count+7)>>3); |
---|
637 | } |
---|
638 | #endif |
---|
639 | |
---|
640 | suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; |
---|
641 | |
---|
642 | if (suffix_dnodes) { |
---|
643 | set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); |
---|
644 | } |
---|
645 | |
---|
646 | if (!nodeheader_tag_p(tag_n)) return; |
---|
647 | |
---|
648 | if (subtag == subtag_hash_vector) { |
---|
649 | /* Splice onto weakvll, then return */ |
---|
650 | /* In general, there's no reason to invalidate the cached |
---|
651 | key/value pair here. However, if the hash table's weak, |
---|
652 | we don't want to retain an otherwise unreferenced key |
---|
653 | or value simply because they're referenced from the |
---|
654 | cache. Clear the cached entries iff the hash table's |
---|
655 | weak in some sense. |
---|
656 | */ |
---|
657 | LispObj flags = ((hash_table_vector_header *) base)->flags; |
---|
658 | |
---|
659 | if (flags & nhash_weak_mask) { |
---|
660 | ((hash_table_vector_header *) base)->cache_key = undefined; |
---|
661 | ((hash_table_vector_header *) base)->cache_value = lisp_nil; |
---|
662 | } |
---|
663 | deref(ptr_to_lispobj(base),1) = GCweakvll; |
---|
664 | GCweakvll = n; |
---|
665 | return; |
---|
666 | } |
---|
667 | |
---|
668 | if (subtag == subtag_pool) { |
---|
669 | deref(n, 1) = lisp_nil; |
---|
670 | } |
---|
671 | |
---|
672 | if (subtag == subtag_weak) { |
---|
673 | natural weak_type = (natural) base[2]; |
---|
674 | if (weak_type >> population_termination_bit) |
---|
675 | element_count -= 2; |
---|
676 | else |
---|
677 | element_count -= 1; |
---|
678 | } |
---|
679 | |
---|
680 | nmark = element_count; |
---|
681 | |
---|
682 | if (subtag == subtag_function) { |
---|
683 | #ifdef X8664 |
---|
684 | int code_words = (int)base[1]; |
---|
685 | #else |
---|
686 | int code_words = (unsigned short)base[1]; |
---|
687 | #endif |
---|
688 | if (code_words >= nmark) { |
---|
689 | Bug(NULL,"Bad function at 0x%lx",n); |
---|
690 | } |
---|
691 | nmark -= code_words; |
---|
692 | } |
---|
693 | |
---|
694 | while (nmark--) { |
---|
695 | rmark(deref(n,element_count)); |
---|
696 | element_count--; |
---|
697 | } |
---|
698 | |
---|
699 | if (subtag == subtag_weak) { |
---|
700 | deref(n, 1) = GCweakvll; |
---|
701 | GCweakvll = n; |
---|
702 | } |
---|
703 | |
---|
704 | } |
---|
705 | } else { |
---|
706 | #ifdef X8632 |
---|
707 | fprintf(stderr, "probably in trouble here\n"); |
---|
708 | #endif |
---|
709 | /* This is all a bit more complicated than the PPC version: |
---|
710 | |
---|
711 | - a symbol-vector can be referenced via either a FULLTAG-MISC |
---|
712 | pointer or a FULLTAG-SYMBOL pointer. When we've finished |
---|
713 | marking the symbol-vector's elements, we need to know which tag |
---|
714 | the object that pointed to the symbol-vector had originally. |
---|
715 | |
---|
716 | - a function-vector can be referenced via either a FULLTAG-MISC |
---|
717 | pointer or a FULLTAG-FUNCTION pointer. That introduces pretty |
---|
718 | much the same set of issues, but ... |
---|
719 | |
---|
720 | - a function-vector can also be referenced via a TRA; the |
---|
721 | offset from the TRA to the function header is arbitrary (though |
---|
722 | we can probably put an upper bound on it, and it's certainly |
---|
723 | not going to be more than 32 bits.) |
---|
724 | |
---|
725 | - function-vectors contain a mixture of code and constants, |
---|
726 | with a "boundary" word (that doesn't look like a valid |
---|
727 | constant) in between them. There are 56 unused bits in the |
---|
728 | boundary word; the low 8 bits must be = to the constant |
---|
729 | 'function_boundary_marker'. We can store the byte displacement |
---|
730 | from the address of the object which references the function |
---|
731 | (tagged fulltag_misc, fulltag_function, or tra) to the address |
---|
732 | of the boundary marker when the function vector is first marked |
---|
733 | and recover that offset when we've finished marking the |
---|
734 | function vector. (Note that the offset is signed; it's |
---|
735 | probably simplest to keep it in the high 32 bits of the |
---|
736 | boundary word.) |
---|
737 | |
---|
738 | So: |
---|
739 | |
---|
740 | - while marking a CONS, the 'this' pointer as a 3-bit tag of |
---|
741 | tag_list; the 4-bit fulltag indicates which cell is being |
---|
742 | marked. |
---|
743 | |
---|
744 | - while marking a gvector (other than a symbol-vector or |
---|
745 | function-vector), the 'this' pointer is tagged tag_misc. |
---|
746 | (Obviously, it alternates between fulltag_misc and |
---|
747 | fulltag_nodeheader_0, arbitrarily.) When we encounter the |
---|
748 | gvector header when the 'this' pointer has been tagged as |
---|
749 | fulltag_misc, we can restore 'this' to the header's address + |
---|
750 | fulltag_misc and enter the 'climb' state. (Note that this |
---|
751 | value happens to be exactly what's in 'this' when the header's |
---|
752 | encountered.) |
---|
753 | |
---|
754 | - if we encounter a symbol-vector via the FULLTAG-MISC pointer |
---|
755 | to the symbol (not very likely, but legal and possible), it's |
---|
756 | treated exactly like the gvector case above. |
---|
757 | |
---|
758 | - in the more likely case where a symbol-vector is referenced |
---|
759 | via a FULLTAG-SYMBOL, we do the same loop as in the general |
---|
760 | gvector case, backing up through the vector with 'this' tagged |
---|
761 | as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter |
---|
762 | the symbol header, 'this' gets fulltag_symbol added to the |
---|
763 | dnode-aligned address of the header, and we climb. |
---|
764 | |
---|
765 | - if anything (fulltag_misc, fulltag_function, tra) references |
---|
766 | an unmarked function function vector, we store the byte offfset |
---|
767 | from the tagged reference to the address of the boundary word |
---|
768 | in the high 32 bits of the boundary word, then we back up |
---|
769 | through the function-vector's constants, with 'this' tagged |
---|
770 | tag_function/ fulltag_immheader_0, until the (specially-tagged) |
---|
771 | boundary word is encountered. The displacement stored in the boundary |
---|
772 | word is added to the aligned address of the boundary word (restoring |
---|
773 | the original 'this' pointer, and we climb. |
---|
774 | |
---|
775 | Not that bad. |
---|
776 | */ |
---|
777 | |
---|
778 | LispObj prev = undefined, this = n, next, *base; |
---|
779 | natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary; |
---|
780 | |
---|
781 | if (tag_n == fulltag_cons) goto MarkCons; |
---|
782 | goto MarkVector; |
---|
783 | |
---|
784 | ClimbCdr: |
---|
785 | prev = deref(this,0); |
---|
786 | deref(this,0) = next; |
---|
787 | |
---|
788 | Climb: |
---|
789 | next = this; |
---|
790 | this = prev; |
---|
791 | tag_n = fulltag_of(prev); |
---|
792 | switch(tag_n) { |
---|
793 | case tag_misc: |
---|
794 | case fulltag_misc: |
---|
795 | #ifdef X8664 |
---|
796 | case tag_symbol: |
---|
797 | case fulltag_symbol: |
---|
798 | case tag_function: |
---|
799 | case fulltag_function: |
---|
800 | #endif |
---|
801 | goto ClimbVector; |
---|
802 | |
---|
803 | case RMARK_PREV_ROOT: |
---|
804 | return; |
---|
805 | |
---|
806 | case fulltag_cons: |
---|
807 | goto ClimbCdr; |
---|
808 | |
---|
809 | case RMARK_PREV_CAR: |
---|
810 | goto ClimbCar; |
---|
811 | |
---|
812 | /* default: abort() */ |
---|
813 | } |
---|
814 | |
---|
815 | DescendCons: |
---|
816 | prev = this; |
---|
817 | this = next; |
---|
818 | |
---|
819 | MarkCons: |
---|
820 | next = deref(this,1); |
---|
821 | this += node_size; |
---|
822 | tag_n = fulltag_of(next); |
---|
823 | if (!is_node_fulltag(tag_n)) goto MarkCdr; |
---|
824 | dnode = gc_area_dnode(next); |
---|
825 | if (dnode >= GCndnodes_in_area) goto MarkCdr; |
---|
826 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
827 | if (bits & mask) goto MarkCdr; |
---|
828 | *bitsp = (bits | mask); |
---|
829 | deref(this,1) = prev; |
---|
830 | if (tag_n == fulltag_cons) goto DescendCons; |
---|
831 | goto DescendVector; |
---|
832 | |
---|
833 | ClimbCar: |
---|
834 | prev = deref(this,1); |
---|
835 | deref(this,1) = next; |
---|
836 | |
---|
837 | MarkCdr: |
---|
838 | next = deref(this, 0); |
---|
839 | this -= node_size; |
---|
840 | tag_n = fulltag_of(next); |
---|
841 | if (!is_node_fulltag(tag_n)) goto Climb; |
---|
842 | dnode = gc_area_dnode(next); |
---|
843 | if (dnode >= GCndnodes_in_area) goto Climb; |
---|
844 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
845 | if (bits & mask) goto Climb; |
---|
846 | *bitsp = (bits | mask); |
---|
847 | deref(this, 0) = prev; |
---|
848 | if (tag_n == fulltag_cons) goto DescendCons; |
---|
849 | /* goto DescendVector; */ |
---|
850 | |
---|
851 | DescendVector: |
---|
852 | prev = this; |
---|
853 | this = next; |
---|
854 | |
---|
855 | MarkVector: |
---|
856 | #ifdef X8664 |
---|
857 | if ((tag_n == fulltag_tra_0) || |
---|
858 | (tag_n == fulltag_tra_1)) { |
---|
859 | int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH; |
---|
860 | |
---|
861 | base = (LispObj *) (untag(n-disp)); |
---|
862 | header = *((natural *) base); |
---|
863 | subtag = header_subtag(header); |
---|
864 | boundary = base + (int)(base[1]); |
---|
865 | (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); |
---|
866 | this = (LispObj)(base)+fulltag_function; |
---|
867 | /* Need to set the initial markbit here */ |
---|
868 | dnode = gc_area_dnode(this); |
---|
869 | set_bit(markbits,dnode); |
---|
870 | } else { |
---|
871 | base = (LispObj *) ptr_from_lispobj(untag(this)); |
---|
872 | header = *((natural *) base); |
---|
873 | subtag = header_subtag(header); |
---|
874 | if (subtag == subtag_function) { |
---|
875 | boundary = base + (int)(base[1]); |
---|
876 | (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); |
---|
877 | } |
---|
878 | } |
---|
879 | element_count = header_element_count(header); |
---|
880 | tag_n = fulltag_of(header); |
---|
881 | |
---|
882 | if ((nodeheader_tag_p(tag_n)) || |
---|
883 | (tag_n == ivector_class_64_bit)) { |
---|
884 | total_size_in_bytes = 8 + (element_count<<3); |
---|
885 | } else if (tag_n == ivector_class_32_bit) { |
---|
886 | total_size_in_bytes = 8 + (element_count<<2); |
---|
887 | } else { |
---|
888 | /* ivector_class_other_bit contains 16-bit arrays & bitvector */ |
---|
889 | if (subtag == subtag_bit_vector) { |
---|
890 | total_size_in_bytes = 8 + ((element_count+7)>>3); |
---|
891 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
892 | total_size_in_bytes = 8 + element_count; |
---|
893 | } else { |
---|
894 | total_size_in_bytes = 8 + (element_count<<1); |
---|
895 | } |
---|
896 | } |
---|
897 | #else |
---|
898 | if (tag_n == fulltag_tra) { |
---|
899 | LispObj fn = *(LispObj *)(n + 1); |
---|
900 | |
---|
901 | base = (LispObj *)untag(fn); |
---|
902 | header = *(natural *)base; |
---|
903 | subtag = header_subtag(header); |
---|
904 | boundary = base + (unsigned short)base[1]; |
---|
905 | /* |
---|
906 | * On x8632, the upper 24 bits of the boundary word are zero. |
---|
907 | * Functions on x8632 can be no more than 2^16 words (or 2^24 |
---|
908 | * bytes) long (including the self-reference table but excluding |
---|
909 | * any constants). Therefore, we can do the same basic thing |
---|
910 | * that the x8664 port does: namely, we keep the byte |
---|
911 | * displacement from the address of the object (tagged tra or |
---|
912 | * fulltag_misc) that references the function to the address of |
---|
913 | * the boundary marker in those 24 bits, recovering it when |
---|
914 | * we've finished marking the function vector. |
---|
915 | */ |
---|
916 | ((int *)boundary)[1] &= 0xff; |
---|
917 | ((int *)boundary)[1] |= (this-(LispObj)boundary) << 8; |
---|
918 | this = (LispObj)(base)+fulltag_misc; |
---|
919 | dnode = gc_area_dnode(this); |
---|
920 | set_bit(markbits,dnode); |
---|
921 | } else { |
---|
922 | base = (LispObj *) ptr_from_lispobj(untag(this)); |
---|
923 | header = *((natural *) base); |
---|
924 | subtag = header_subtag(header); |
---|
925 | if (subtag == subtag_function) { |
---|
926 | boundary = base + (unsigned short)base[1]; |
---|
927 | ((int *)boundary)[1] &= 0xff; |
---|
928 | ((int *)boundary)[1] |= (this-((LispObj)boundary)) << 8; |
---|
929 | } |
---|
930 | } |
---|
931 | element_count = header_element_count(header); |
---|
932 | tag_n = fulltag_of(header); |
---|
933 | |
---|
934 | if ((tag_n == fulltag_nodeheader) || |
---|
935 | (subtag <= max_32_bit_ivector_subtag)) { |
---|
936 | total_size_in_bytes = 4 + (element_count<<2); |
---|
937 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
938 | total_size_in_bytes = 4 + element_count; |
---|
939 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
940 | total_size_in_bytes = 4 + (element_count<<1); |
---|
941 | } else if (subtag == subtag_double_float_vector) { |
---|
942 | total_size_in_bytes = 8 + (element_count<<3); |
---|
943 | } else { |
---|
944 | total_size_in_bytes = 4 + ((element_count+7)>>3); |
---|
945 | } |
---|
946 | #endif |
---|
947 | |
---|
948 | suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; |
---|
949 | |
---|
950 | if (suffix_dnodes) { |
---|
951 | set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); |
---|
952 | } |
---|
953 | |
---|
954 | if (!nodeheader_tag_p(tag_n)) goto Climb; |
---|
955 | |
---|
956 | if (subtag == subtag_hash_vector) { |
---|
957 | /* Splice onto weakvll, then climb */ |
---|
958 | LispObj flags = ((hash_table_vector_header *) base)->flags; |
---|
959 | |
---|
960 | if (flags & nhash_weak_mask) { |
---|
961 | ((hash_table_vector_header *) base)->cache_key = undefined; |
---|
962 | ((hash_table_vector_header *) base)->cache_value = lisp_nil; |
---|
963 | } |
---|
964 | |
---|
965 | deref(ptr_to_lispobj(base),1) = GCweakvll; |
---|
966 | GCweakvll = this; |
---|
967 | goto Climb; |
---|
968 | } |
---|
969 | |
---|
970 | if (subtag == subtag_pool) { |
---|
971 | deref(this, 1) = lisp_nil; |
---|
972 | } |
---|
973 | |
---|
974 | if (subtag == subtag_weak) { |
---|
975 | natural weak_type = (natural) base[2]; |
---|
976 | if (weak_type >> population_termination_bit) |
---|
977 | element_count -= 2; |
---|
978 | else |
---|
979 | element_count -= 1; |
---|
980 | } |
---|
981 | |
---|
982 | this = (LispObj)(base) + (tag_of(this)) + ((element_count+1) << node_shift); |
---|
983 | goto MarkVectorLoop; |
---|
984 | |
---|
985 | ClimbVector: |
---|
986 | prev = indirect_node(this); |
---|
987 | indirect_node(this) = next; |
---|
988 | |
---|
989 | MarkVectorLoop: |
---|
990 | this -= node_size; |
---|
991 | next = indirect_node(this); |
---|
992 | #ifdef X8664 |
---|
993 | if ((tag_of(this) == tag_function) && |
---|
994 | (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; |
---|
995 | #else |
---|
996 | if ((tag_of(this) == tag_misc) && |
---|
997 | (header_subtag(this) == subtag_function) && |
---|
998 | (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; |
---|
999 | #endif |
---|
1000 | |
---|
1001 | tag_n = fulltag_of(next); |
---|
1002 | if (nodeheader_tag_p(tag_n)) goto MarkVectorDone; |
---|
1003 | if (!is_node_fulltag(tag_n)) goto MarkVectorLoop; |
---|
1004 | dnode = gc_area_dnode(next); |
---|
1005 | if (dnode >= GCndnodes_in_area) goto MarkVectorLoop; |
---|
1006 | set_bits_vars(markbits,dnode,bitsp,bits,mask); |
---|
1007 | if (bits & mask) goto MarkVectorLoop; |
---|
1008 | *bitsp = (bits | mask); |
---|
1009 | indirect_node(this) = prev; |
---|
1010 | if (tag_n == fulltag_cons) goto DescendCons; |
---|
1011 | goto DescendVector; |
---|
1012 | |
---|
1013 | MarkVectorDone: |
---|
1014 | /* "next" is vector header; "this" tagged tag_misc or tag_symbol. |
---|
1015 | If header subtag = subtag_weak_header, put it on weakvll */ |
---|
1016 | this += node_size; /* make it fulltag_misc/fulltag_symbol */ |
---|
1017 | |
---|
1018 | if (header_subtag(next) == subtag_weak) { |
---|
1019 | deref(this, 1) = GCweakvll; |
---|
1020 | GCweakvll = this; |
---|
1021 | } |
---|
1022 | goto Climb; |
---|
1023 | |
---|
1024 | MarkFunctionDone: |
---|
1025 | boundary = (LispObj *)(node_aligned(this)); |
---|
1026 | #ifdef X8664 |
---|
1027 | this = ((LispObj)boundary) + (((int *)boundary)[1]); |
---|
1028 | (((int *)boundary)[1]) = 0; |
---|
1029 | #else |
---|
1030 | this = ((LispObj)boundary) + ((int *)boundary)[1] >> 8; |
---|
1031 | ((int *)boundary)[1] &= 0xff; |
---|
1032 | goto Climb; |
---|
1033 | #endif |
---|
1034 | } |
---|
1035 | } |
---|
1036 | |
---|
1037 | LispObj * |
---|
1038 | skip_over_ivector(natural start, LispObj header) |
---|
1039 | { |
---|
1040 | natural |
---|
1041 | element_count = header_element_count(header), |
---|
1042 | subtag = header_subtag(header), |
---|
1043 | nbytes; |
---|
1044 | |
---|
1045 | |
---|
1046 | #ifdef X8664 |
---|
1047 | switch (fulltag_of(header)) { |
---|
1048 | case ivector_class_64_bit: |
---|
1049 | nbytes = element_count << 3; |
---|
1050 | break; |
---|
1051 | case ivector_class_32_bit: |
---|
1052 | nbytes = element_count << 2; |
---|
1053 | break; |
---|
1054 | case ivector_class_other_bit: |
---|
1055 | default: |
---|
1056 | if (subtag == subtag_bit_vector) { |
---|
1057 | nbytes = (element_count+7)>>3; |
---|
1058 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
1059 | nbytes = element_count; |
---|
1060 | } else { |
---|
1061 | nbytes = element_count << 1; |
---|
1062 | } |
---|
1063 | } |
---|
1064 | return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15))); |
---|
1065 | #else |
---|
1066 | if (subtag <= max_32_bit_ivector_subtag) { |
---|
1067 | nbytes = element_count << 2; |
---|
1068 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
1069 | nbytes = element_count; |
---|
1070 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
1071 | nbytes = element_count << 1; |
---|
1072 | } else if (subtag == subtag_double_float_vector) { |
---|
1073 | nbytes = 4 + (element_count << 3); |
---|
1074 | } else { |
---|
1075 | nbytes = (element_count+7) >> 3; |
---|
1076 | } |
---|
1077 | return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7))); |
---|
1078 | #endif |
---|
1079 | } |
---|
1080 | |
---|
1081 | |
---|
1082 | void |
---|
1083 | check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits) |
---|
1084 | { |
---|
1085 | LispObj x1, *base = start, *prev = start; |
---|
1086 | int tag; |
---|
1087 | natural ref_dnode, node_dnode; |
---|
1088 | Boolean intergen_ref; |
---|
1089 | |
---|
1090 | while (start < end) { |
---|
1091 | x1 = *start; |
---|
1092 | prev = start; |
---|
1093 | tag = fulltag_of(x1); |
---|
1094 | if (immheader_tag_p(tag)) { |
---|
1095 | start = skip_over_ivector(ptr_to_lispobj(start), x1); |
---|
1096 | } else { |
---|
1097 | if (header_subtag(x1) == subtag_function) { |
---|
1098 | int skip = (int) deref(start,1); |
---|
1099 | start += ((1+skip)&~1); |
---|
1100 | x1 = *start; |
---|
1101 | tag = fulltag_of(x1); |
---|
1102 | } |
---|
1103 | intergen_ref = false; |
---|
1104 | if (is_node_fulltag(tag)) { |
---|
1105 | node_dnode = gc_area_dnode(x1); |
---|
1106 | if (node_dnode < GCndnodes_in_area) { |
---|
1107 | intergen_ref = true; |
---|
1108 | } |
---|
1109 | } |
---|
1110 | if (intergen_ref == false) { |
---|
1111 | x1 = start[1]; |
---|
1112 | tag = fulltag_of(x1); |
---|
1113 | if (is_node_fulltag(tag)) { |
---|
1114 | node_dnode = gc_area_dnode(x1); |
---|
1115 | if (node_dnode < GCndnodes_in_area) { |
---|
1116 | intergen_ref = true; |
---|
1117 | } |
---|
1118 | } |
---|
1119 | } |
---|
1120 | if (intergen_ref) { |
---|
1121 | ref_dnode = area_dnode(start, base); |
---|
1122 | if (!ref_bit(refbits, ref_dnode)) { |
---|
1123 | Bug(NULL, "Missing memoization in doublenode at 0x%08X", start); |
---|
1124 | set_bit(refbits, ref_dnode); |
---|
1125 | } |
---|
1126 | } |
---|
1127 | start += 2; |
---|
1128 | } |
---|
1129 | } |
---|
1130 | if (start > end) { |
---|
1131 | Bug(NULL, "Overran end of range!"); |
---|
1132 | } |
---|
1133 | } |
---|
1134 | |
---|
1135 | |
---|
1136 | |
---|
1137 | void |
---|
1138 | mark_memoized_area(area *a, natural num_memo_dnodes) |
---|
1139 | { |
---|
1140 | bitvector refbits = a->refbits; |
---|
1141 | LispObj *p = (LispObj *) a->low, x1, x2; |
---|
1142 | natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0; |
---|
1143 | Boolean keep_x1, keep_x2; |
---|
1144 | |
---|
1145 | if (GCDebug) { |
---|
1146 | check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); |
---|
1147 | } |
---|
1148 | |
---|
1149 | /* The distinction between "inbits" and "outbits" is supposed to help us |
---|
1150 | detect cases where "uninteresting" setfs have been memoized. Storing |
---|
1151 | NIL, fixnums, immediates (characters, etc.) or node pointers to static |
---|
1152 | or readonly areas is definitely uninteresting, but other cases are |
---|
1153 | more complicated (and some of these cases are hard to detect.) |
---|
1154 | |
---|
1155 | Some headers are "interesting", to the forwarder if not to us. |
---|
1156 | |
---|
1157 | We -don't- give anything any weak treatment here. Weak things have |
---|
1158 | to be seen by a full gc, for some value of 'full'. |
---|
1159 | */ |
---|
1160 | |
---|
1161 | /* |
---|
1162 | We need to ensure that there are no bits set at or beyond |
---|
1163 | "num_memo_dnodes" in the bitvector. (This can happen as the EGC |
---|
1164 | tenures/untenures things.) We find bits by grabbing a fullword at |
---|
1165 | a time and doing a cntlzw instruction; and don't want to have to |
---|
1166 | check for (< memo_dnode num_memo_dnodes) in the loop. |
---|
1167 | */ |
---|
1168 | |
---|
1169 | { |
---|
1170 | natural |
---|
1171 | bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask), |
---|
1172 | index_of_last_word = (num_memo_dnodes >> bitmap_shift); |
---|
1173 | |
---|
1174 | if (bits_in_last_word != 0) { |
---|
1175 | natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L); |
---|
1176 | refbits[index_of_last_word] &= mask; |
---|
1177 | } |
---|
1178 | } |
---|
1179 | |
---|
1180 | set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); |
---|
1181 | inbits = outbits = bits; |
---|
1182 | while (memo_dnode < num_memo_dnodes) { |
---|
1183 | if (bits == 0) { |
---|
1184 | int remain = nbits_in_word - bitidx; |
---|
1185 | memo_dnode += remain; |
---|
1186 | p += (remain+remain); |
---|
1187 | if (outbits != inbits) { |
---|
1188 | *bitsp = outbits; |
---|
1189 | } |
---|
1190 | bits = *++bitsp; |
---|
1191 | inbits = outbits = bits; |
---|
1192 | bitidx = 0; |
---|
1193 | } else { |
---|
1194 | nextbit = count_leading_zeros(bits); |
---|
1195 | if ((diff = (nextbit - bitidx)) != 0) { |
---|
1196 | memo_dnode += diff; |
---|
1197 | bitidx = nextbit; |
---|
1198 | p += (diff+diff); |
---|
1199 | } |
---|
1200 | x1 = *p++; |
---|
1201 | x2 = *p++; |
---|
1202 | bits &= ~(BIT0_MASK >> bitidx); |
---|
1203 | keep_x1 = mark_ephemeral_root(x1); |
---|
1204 | keep_x2 = mark_ephemeral_root(x2); |
---|
1205 | if ((keep_x1 == false) && |
---|
1206 | (keep_x2 == false)) { |
---|
1207 | outbits &= ~(BIT0_MASK >> bitidx); |
---|
1208 | } |
---|
1209 | memo_dnode++; |
---|
1210 | bitidx++; |
---|
1211 | } |
---|
1212 | } |
---|
1213 | if (GCDebug) { |
---|
1214 | p = (LispObj *) a->low; |
---|
1215 | check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); |
---|
1216 | } |
---|
1217 | } |
---|
1218 | |
---|
1219 | void |
---|
1220 | mark_headerless_area_range(LispObj *start, LispObj *end) |
---|
1221 | { |
---|
1222 | while (start < end) { |
---|
1223 | mark_root(*start++); |
---|
1224 | } |
---|
1225 | } |
---|
1226 | |
---|
1227 | void |
---|
1228 | mark_simple_area_range(LispObj *start, LispObj *end) |
---|
1229 | { |
---|
1230 | LispObj x1, *base; |
---|
1231 | int tag; |
---|
1232 | |
---|
1233 | while (start < end) { |
---|
1234 | x1 = *start; |
---|
1235 | tag = fulltag_of(x1); |
---|
1236 | if (immheader_tag_p(tag)) { |
---|
1237 | start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1)); |
---|
1238 | } else if (!nodeheader_tag_p(tag)) { |
---|
1239 | ++start; |
---|
1240 | mark_root(x1); |
---|
1241 | mark_root(*start++); |
---|
1242 | } else { |
---|
1243 | int subtag = header_subtag(x1); |
---|
1244 | natural element_count = header_element_count(x1); |
---|
1245 | natural size = (element_count+1 + 1) & ~1; |
---|
1246 | |
---|
1247 | if (subtag == subtag_hash_vector) { |
---|
1248 | LispObj flags = ((hash_table_vector_header *) start)->flags; |
---|
1249 | |
---|
1250 | if (flags & nhash_weak_mask) { |
---|
1251 | ((hash_table_vector_header *) start)->cache_key = undefined; |
---|
1252 | ((hash_table_vector_header *) start)->cache_value = lisp_nil; |
---|
1253 | } |
---|
1254 | |
---|
1255 | start[1] = GCweakvll; |
---|
1256 | GCweakvll = (LispObj) (((natural) start) + fulltag_misc); |
---|
1257 | } else { |
---|
1258 | |
---|
1259 | if (subtag == subtag_pool) { |
---|
1260 | start[1] = lisp_nil; |
---|
1261 | } |
---|
1262 | |
---|
1263 | if (subtag == subtag_weak) { |
---|
1264 | natural weak_type = (natural) start[2]; |
---|
1265 | if (weak_type >> population_termination_bit) |
---|
1266 | element_count -= 2; |
---|
1267 | else |
---|
1268 | element_count -= 1; |
---|
1269 | start[1] = GCweakvll; |
---|
1270 | GCweakvll = (LispObj) (((natural) start) + fulltag_misc); |
---|
1271 | } |
---|
1272 | |
---|
1273 | base = start + element_count + 1; |
---|
1274 | if (subtag == subtag_function) { |
---|
1275 | #ifdef X8632 |
---|
1276 | element_count -= (unsigned short)start[1]; |
---|
1277 | #else |
---|
1278 | element_count -= (int)start[1]; |
---|
1279 | #endif |
---|
1280 | } |
---|
1281 | while(element_count--) { |
---|
1282 | mark_root(*--base); |
---|
1283 | } |
---|
1284 | } |
---|
1285 | start += size; |
---|
1286 | } |
---|
1287 | } |
---|
1288 | } |
---|
1289 | |
---|
1290 | |
---|
1291 | /* Mark a tstack area */ |
---|
1292 | void |
---|
1293 | mark_tstack_area(area *a) |
---|
1294 | { |
---|
1295 | LispObj |
---|
1296 | *current, |
---|
1297 | *next, |
---|
1298 | *start = (LispObj *) (a->active), |
---|
1299 | *end = start, |
---|
1300 | *limit = (LispObj *) (a->high); |
---|
1301 | |
---|
1302 | for (current = start; |
---|
1303 | end != limit; |
---|
1304 | current = next) { |
---|
1305 | next = (LispObj *) ptr_from_lispobj(*current); |
---|
1306 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
1307 | mark_simple_area_range(current+2, end); |
---|
1308 | } |
---|
1309 | } |
---|
1310 | |
---|
1311 | /* |
---|
1312 | It's really important that headers never wind up in tagged registers. |
---|
1313 | Those registers would (possibly) get pushed on the vstack and confuse |
---|
1314 | the hell out of this routine. |
---|
1315 | |
---|
1316 | vstacks are just treated as a "simple area range", possibly with |
---|
1317 | an extra word at the top (where the area's active pointer points.) |
---|
1318 | */ |
---|
1319 | |
---|
1320 | void |
---|
1321 | mark_vstack_area(area *a) |
---|
1322 | { |
---|
1323 | LispObj |
---|
1324 | *start = (LispObj *) a->active, |
---|
1325 | *end = (LispObj *) a->high; |
---|
1326 | |
---|
1327 | #if 0 |
---|
1328 | fprintf(stderr, "mark VSP range: 0x%lx:0x%lx\n", start, end); |
---|
1329 | #endif |
---|
1330 | mark_headerless_area_range(start, end); |
---|
1331 | } |
---|
1332 | |
---|
1333 | |
---|
1334 | void |
---|
1335 | reapweakv(LispObj weakv) |
---|
1336 | { |
---|
1337 | /* |
---|
1338 | element 2 of the weak vector should be tagged as a cons: if it |
---|
1339 | isn't, just mark it as a root. if it is, cdr through it until a |
---|
1340 | "marked" cons is encountered. If the car of any unmarked cons is |
---|
1341 | marked, mark the cons which contains it; otherwise, splice the |
---|
1342 | cons out of the list. N.B. : elements 0 and 1 are already marked |
---|
1343 | (or are immediate, etc.) |
---|
1344 | */ |
---|
1345 | LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev; |
---|
1346 | LispObj termination_list = lisp_nil; |
---|
1347 | natural weak_type = (natural) deref(weakv,2); |
---|
1348 | Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist), |
---|
1349 | terminatablep = ((weak_type >> population_termination_bit) != 0); |
---|
1350 | Boolean done = false; |
---|
1351 | cons *rawcons; |
---|
1352 | natural dnode, car_dnode; |
---|
1353 | bitvector markbits = GCmarkbits; |
---|
1354 | |
---|
1355 | if (terminatablep) { |
---|
1356 | termination_list = deref(weakv,1+3); |
---|
1357 | } |
---|
1358 | |
---|
1359 | if (fulltag_of(cell) != fulltag_cons) { |
---|
1360 | mark_root(cell); |
---|
1361 | } else if (alistp) { |
---|
1362 | /* weak alist */ |
---|
1363 | while (! done) { |
---|
1364 | dnode = gc_area_dnode(cell); |
---|
1365 | if ((dnode >= GCndnodes_in_area) || |
---|
1366 | (ref_bit(markbits, dnode))) { |
---|
1367 | done = true; |
---|
1368 | } else { |
---|
1369 | /* Cons cell is unmarked. */ |
---|
1370 | LispObj alist_cell, thecar; |
---|
1371 | unsigned cell_tag; |
---|
1372 | |
---|
1373 | rawcons = (cons *) ptr_from_lispobj(untag(cell)); |
---|
1374 | alist_cell = rawcons->car; |
---|
1375 | cell_tag = fulltag_of(alist_cell); |
---|
1376 | |
---|
1377 | if ((cell_tag == fulltag_cons) && |
---|
1378 | ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) && |
---|
1379 | (! ref_bit(markbits, car_dnode)) && |
---|
1380 | (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) && |
---|
1381 | ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && |
---|
1382 | (! ref_bit(markbits, car_dnode))) { |
---|
1383 | *prev = rawcons->cdr; |
---|
1384 | if (terminatablep) { |
---|
1385 | rawcons->cdr = termination_list; |
---|
1386 | termination_list = cell; |
---|
1387 | } |
---|
1388 | } else { |
---|
1389 | set_bit(markbits, dnode); |
---|
1390 | prev = (LispObj *)(&(rawcons->cdr)); |
---|
1391 | mark_root(alist_cell); |
---|
1392 | } |
---|
1393 | cell = *prev; |
---|
1394 | } |
---|
1395 | } |
---|
1396 | } else { |
---|
1397 | /* weak list */ |
---|
1398 | while (! done) { |
---|
1399 | dnode = gc_area_dnode(cell); |
---|
1400 | if ((dnode >= GCndnodes_in_area) || |
---|
1401 | (ref_bit(markbits, dnode))) { |
---|
1402 | done = true; |
---|
1403 | } else { |
---|
1404 | /* Cons cell is unmarked. */ |
---|
1405 | LispObj thecar; |
---|
1406 | unsigned cartag; |
---|
1407 | |
---|
1408 | rawcons = (cons *) ptr_from_lispobj(untag(cell)); |
---|
1409 | thecar = rawcons->car; |
---|
1410 | cartag = fulltag_of(thecar); |
---|
1411 | |
---|
1412 | if (is_node_fulltag(cartag) && |
---|
1413 | ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && |
---|
1414 | (! ref_bit(markbits, car_dnode))) { |
---|
1415 | *prev = rawcons->cdr; |
---|
1416 | if (terminatablep) { |
---|
1417 | rawcons->cdr = termination_list; |
---|
1418 | termination_list = cell; |
---|
1419 | } |
---|
1420 | } else { |
---|
1421 | set_bit(markbits, dnode); |
---|
1422 | prev = (LispObj *)(&(rawcons->cdr)); |
---|
1423 | } |
---|
1424 | cell = *prev; |
---|
1425 | } |
---|
1426 | } |
---|
1427 | } |
---|
1428 | |
---|
1429 | if (terminatablep) { |
---|
1430 | deref(weakv,1+3) = termination_list; |
---|
1431 | if (termination_list != lisp_nil) { |
---|
1432 | deref(weakv,1) = GCweakvll; |
---|
1433 | GCweakvll = weakv; |
---|
1434 | } |
---|
1435 | } |
---|
1436 | } |
---|
1437 | |
---|
1438 | /* |
---|
1439 | Screw: doesn't deal with finalization. |
---|
1440 | */ |
---|
1441 | |
---|
1442 | void |
---|
1443 | reaphashv(LispObj hashv) |
---|
1444 | { |
---|
1445 | hash_table_vector_header |
---|
1446 | *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv)); |
---|
1447 | natural |
---|
1448 | dnode, |
---|
1449 | npairs = (header_element_count(hashp->header) - |
---|
1450 | ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1; |
---|
1451 | LispObj *pairp = (LispObj*) (hashp+1), weakelement; |
---|
1452 | Boolean |
---|
1453 | weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); |
---|
1454 | bitvector markbits = GCmarkbits; |
---|
1455 | int tag; |
---|
1456 | |
---|
1457 | while (npairs--) { |
---|
1458 | if (weak_on_value) { |
---|
1459 | weakelement = pairp[1]; |
---|
1460 | } else { |
---|
1461 | weakelement = pairp[0]; |
---|
1462 | } |
---|
1463 | tag = fulltag_of(weakelement); |
---|
1464 | if (is_node_fulltag(tag)) { |
---|
1465 | dnode = gc_area_dnode(weakelement); |
---|
1466 | if ((dnode < GCndnodes_in_area) && |
---|
1467 | ! ref_bit(markbits, dnode)) { |
---|
1468 | pairp[0] = slot_unbound; |
---|
1469 | pairp[1] = lisp_nil; |
---|
1470 | hashp->weak_deletions_count += (1<<fixnumshift); |
---|
1471 | } |
---|
1472 | } |
---|
1473 | pairp += 2; |
---|
1474 | } |
---|
1475 | } |
---|
1476 | |
---|
1477 | |
---|
1478 | |
---|
1479 | Boolean |
---|
1480 | mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements) |
---|
1481 | { |
---|
1482 | natural flags = hashp->flags, key_dnode, val_dnode; |
---|
1483 | Boolean |
---|
1484 | marked_new = false, |
---|
1485 | key_marked, |
---|
1486 | val_marked, |
---|
1487 | weak_value = ((flags & nhash_weak_value_mask) != 0); |
---|
1488 | int |
---|
1489 | skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1, |
---|
1490 | key_tag, |
---|
1491 | val_tag, |
---|
1492 | i; |
---|
1493 | LispObj |
---|
1494 | *pairp = (LispObj*) (hashp+1), |
---|
1495 | key, |
---|
1496 | val; |
---|
1497 | |
---|
1498 | /* Mark everything in the header */ |
---|
1499 | |
---|
1500 | for (i = 2; i<= skip; i++) { |
---|
1501 | mark_root(deref(ptr_to_lispobj(hashp),i)); |
---|
1502 | } |
---|
1503 | |
---|
1504 | elements -= skip; |
---|
1505 | |
---|
1506 | for (i = 0; i<elements; i+=2, pairp+=2) { |
---|
1507 | key = pairp[0]; |
---|
1508 | val = pairp[1]; |
---|
1509 | key_marked = val_marked = true; |
---|
1510 | key_tag = fulltag_of(key); |
---|
1511 | val_tag = fulltag_of(val); |
---|
1512 | if (is_node_fulltag(key_tag)) { |
---|
1513 | key_dnode = gc_area_dnode(key); |
---|
1514 | if ((key_dnode < GCndnodes_in_area) && |
---|
1515 | ! ref_bit(GCmarkbits,key_dnode)) { |
---|
1516 | key_marked = false; |
---|
1517 | } |
---|
1518 | } |
---|
1519 | if (is_node_fulltag(val_tag)) { |
---|
1520 | val_dnode = gc_area_dnode(val); |
---|
1521 | if ((val_dnode < GCndnodes_in_area) && |
---|
1522 | ! ref_bit(GCmarkbits,val_dnode)) { |
---|
1523 | val_marked = false; |
---|
1524 | } |
---|
1525 | } |
---|
1526 | |
---|
1527 | if (weak_value) { |
---|
1528 | if (val_marked & !key_marked) { |
---|
1529 | mark_root(key); |
---|
1530 | marked_new = true; |
---|
1531 | } |
---|
1532 | } else { |
---|
1533 | if (key_marked & !val_marked) { |
---|
1534 | mark_root(val); |
---|
1535 | marked_new = true; |
---|
1536 | } |
---|
1537 | } |
---|
1538 | } |
---|
1539 | return marked_new; |
---|
1540 | } |
---|
1541 | |
---|
1542 | |
---|
1543 | Boolean |
---|
1544 | mark_weak_alist(LispObj weak_alist, int weak_type) |
---|
1545 | { |
---|
1546 | natural |
---|
1547 | elements = header_element_count(header_of(weak_alist)), |
---|
1548 | dnode; |
---|
1549 | int pair_tag; |
---|
1550 | Boolean marked_new = false; |
---|
1551 | LispObj alist, pair, key, value; |
---|
1552 | bitvector markbits = GCmarkbits; |
---|
1553 | |
---|
1554 | if (weak_type >> population_termination_bit) { |
---|
1555 | elements -= 1; |
---|
1556 | } |
---|
1557 | for(alist = deref(weak_alist, elements); |
---|
1558 | (fulltag_of(alist) == fulltag_cons) && |
---|
1559 | ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) && |
---|
1560 | (! ref_bit(markbits,dnode)); |
---|
1561 | alist = cdr(alist)) { |
---|
1562 | pair = car(alist); |
---|
1563 | pair_tag = fulltag_of(pair); |
---|
1564 | if ((is_node_fulltag(pair_tag)) && |
---|
1565 | ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) && |
---|
1566 | (! ref_bit(markbits,dnode))) { |
---|
1567 | if (pair_tag == fulltag_cons) { |
---|
1568 | key = car(pair); |
---|
1569 | if ((! is_node_fulltag(fulltag_of(key))) || |
---|
1570 | ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) || |
---|
1571 | ref_bit(markbits,dnode)) { |
---|
1572 | /* key is marked, mark value if necessary */ |
---|
1573 | value = cdr(pair); |
---|
1574 | if (is_node_fulltag(fulltag_of(value)) && |
---|
1575 | ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) && |
---|
1576 | (! ref_bit(markbits,dnode))) { |
---|
1577 | mark_root(value); |
---|
1578 | marked_new = true; |
---|
1579 | } |
---|
1580 | } |
---|
1581 | } else { |
---|
1582 | mark_root(pair); |
---|
1583 | marked_new = true; |
---|
1584 | } |
---|
1585 | } |
---|
1586 | } |
---|
1587 | return marked_new; |
---|
1588 | } |
---|
1589 | |
---|
1590 | void |
---|
1591 | markhtabvs() |
---|
1592 | { |
---|
1593 | LispObj this, header, pending; |
---|
1594 | int subtag; |
---|
1595 | bitvector markbits = GCmarkbits; |
---|
1596 | hash_table_vector_header *hashp; |
---|
1597 | Boolean marked_new; |
---|
1598 | |
---|
1599 | do { |
---|
1600 | pending = (LispObj) NULL; |
---|
1601 | marked_new = false; |
---|
1602 | |
---|
1603 | while (GCweakvll) { |
---|
1604 | this = GCweakvll; |
---|
1605 | GCweakvll = deref(this,1); |
---|
1606 | |
---|
1607 | header = header_of(this); |
---|
1608 | subtag = header_subtag(header); |
---|
1609 | |
---|
1610 | if (subtag == subtag_weak) { |
---|
1611 | natural weak_type = deref(this,2); |
---|
1612 | deref(this,1) = pending; |
---|
1613 | pending = this; |
---|
1614 | if ((weak_type & population_type_mask) == population_weak_alist) { |
---|
1615 | if (mark_weak_alist(this, weak_type)) { |
---|
1616 | marked_new = true; |
---|
1617 | } |
---|
1618 | } |
---|
1619 | } else if (subtag == subtag_hash_vector) { |
---|
1620 | natural elements = header_element_count(header), i; |
---|
1621 | |
---|
1622 | hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this)); |
---|
1623 | if (hashp->flags & nhash_weak_mask) { |
---|
1624 | deref(this,1) = pending; |
---|
1625 | pending = this; |
---|
1626 | if (mark_weak_hash_vector(hashp, elements)) { |
---|
1627 | marked_new = true; |
---|
1628 | } |
---|
1629 | } else { |
---|
1630 | deref(this,1) = (LispObj)NULL; |
---|
1631 | for (i = 2; i <= elements; i++) { |
---|
1632 | mark_root(deref(this,i)); |
---|
1633 | } |
---|
1634 | } |
---|
1635 | } else { |
---|
1636 | Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this); |
---|
1637 | } |
---|
1638 | } |
---|
1639 | |
---|
1640 | if (marked_new) { |
---|
1641 | GCweakvll = pending; |
---|
1642 | } |
---|
1643 | } while (marked_new); |
---|
1644 | |
---|
1645 | /* Now, everything's marked that's going to be, and "pending" is a list |
---|
1646 | of populations and weak hash tables. CDR down that list and free |
---|
1647 | anything that isn't marked. |
---|
1648 | */ |
---|
1649 | |
---|
1650 | while (pending) { |
---|
1651 | this = pending; |
---|
1652 | pending = deref(this,1); |
---|
1653 | deref(this,1) = (LispObj)NULL; |
---|
1654 | |
---|
1655 | subtag = header_subtag(header_of(this)); |
---|
1656 | if (subtag == subtag_weak) { |
---|
1657 | reapweakv(this); |
---|
1658 | } else { |
---|
1659 | reaphashv(this); |
---|
1660 | } |
---|
1661 | } |
---|
1662 | |
---|
1663 | /* Finally, mark the termination lists in all terminatable weak vectors |
---|
1664 | They are now linked together on GCweakvll. |
---|
1665 | This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, |
---|
1666 | but it will force terminatable popualations to hold on to each other |
---|
1667 | (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). |
---|
1668 | */ |
---|
1669 | pending = GCweakvll; |
---|
1670 | GCweakvll = (LispObj)NULL; |
---|
1671 | while (pending) { |
---|
1672 | this = pending; |
---|
1673 | pending = deref(this,1); |
---|
1674 | deref(this,1) = (LispObj)NULL; |
---|
1675 | mark_root(deref(this,1+3)); |
---|
1676 | } |
---|
1677 | } |
---|
1678 | |
---|
1679 | /* Mark the lisp objects in an exception frame */ |
---|
1680 | #ifdef X8664 |
---|
1681 | void |
---|
1682 | mark_xp(ExceptionInformation *xp) |
---|
1683 | { |
---|
1684 | natural *regs = (natural *) xpGPRvector(xp), dnode; |
---|
1685 | LispObj rip; |
---|
1686 | |
---|
1687 | |
---|
1688 | |
---|
1689 | mark_root(regs[Iarg_z]); |
---|
1690 | mark_root(regs[Iarg_y]); |
---|
1691 | mark_root(regs[Iarg_x]); |
---|
1692 | mark_root(regs[Isave3]); |
---|
1693 | mark_root(regs[Isave2]); |
---|
1694 | mark_root(regs[Isave1]); |
---|
1695 | mark_root(regs[Isave0]); |
---|
1696 | mark_root(regs[Ifn]); |
---|
1697 | mark_root(regs[Itemp0]); |
---|
1698 | mark_root(regs[Itemp1]); |
---|
1699 | mark_root(regs[Itemp2]); |
---|
1700 | /* If the RIP isn't pointing into a marked function, |
---|
1701 | we can -maybe- recover from that if it's tagged as |
---|
1702 | a TRA. */ |
---|
1703 | rip = regs[Iip]; |
---|
1704 | dnode = gc_area_dnode(rip); |
---|
1705 | if ((dnode < GCndnodes_in_area) && |
---|
1706 | (! ref_bit(GCmarkbits,dnode))) { |
---|
1707 | if (tag_of(rip) == tag_tra) { |
---|
1708 | mark_root(rip); |
---|
1709 | } else if ((fulltag_of(rip) == fulltag_function) && |
---|
1710 | (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) && |
---|
1711 | (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) && |
---|
1712 | ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) { |
---|
1713 | mark_root(rip); |
---|
1714 | } else { |
---|
1715 | Bug(NULL, "Can't find function for rip 0x%16lx",rip); |
---|
1716 | } |
---|
1717 | } |
---|
1718 | } |
---|
1719 | #else |
---|
1720 | void |
---|
1721 | mark_xp(ExceptionInformation *xp, unsigned char node_regs_mask) |
---|
1722 | { |
---|
1723 | natural *regs = (natural *) xpGPRvector(xp), dnode; |
---|
1724 | LispObj eip; |
---|
1725 | int i; |
---|
1726 | |
---|
1727 | for (i = 0; i < 8; i++) |
---|
1728 | if (node_regs_mask & (1<<i)) |
---|
1729 | mark_root(regs[i]); |
---|
1730 | |
---|
1731 | /* If the EIP isn't pointing into a marked function, we're probably |
---|
1732 | in trouble. We can -maybe- recover from that if it's tagged as a |
---|
1733 | TRA. */ |
---|
1734 | eip = regs[Ieip]; |
---|
1735 | dnode = gc_area_dnode(eip); |
---|
1736 | if ((dnode < GCndnodes_in_area) && |
---|
1737 | (! ref_bit(GCmarkbits,dnode))) { |
---|
1738 | if (fulltag_of(eip) == fulltag_tra) { |
---|
1739 | mark_root(eip); |
---|
1740 | } else if ((fulltag_of(eip) == fulltag_misc) && |
---|
1741 | (header_subtag(header_of(eip)) == subtag_function) && |
---|
1742 | (*(unsigned char *)eip == RECOVER_FN_OPCODE) && |
---|
1743 | (*(LispObj *)(eip + 1)) == eip) { |
---|
1744 | mark_root(eip); |
---|
1745 | } else { |
---|
1746 | Bug(NULL, "Can't find function for eip 0x%4x", eip); |
---|
1747 | } |
---|
1748 | } |
---|
1749 | } |
---|
1750 | #endif |
---|
1751 | |
---|
1752 | void |
---|
1753 | mark_tcr_tlb(TCR *tcr) |
---|
1754 | { |
---|
1755 | natural n = tcr->tlb_limit; |
---|
1756 | LispObj |
---|
1757 | *start = tcr->tlb_pointer, |
---|
1758 | *end = (LispObj *) ((BytePtr)start+n), |
---|
1759 | node; |
---|
1760 | |
---|
1761 | while (start < end) { |
---|
1762 | node = *start; |
---|
1763 | if (node != no_thread_local_binding_marker) { |
---|
1764 | mark_root(node); |
---|
1765 | } |
---|
1766 | start++; |
---|
1767 | } |
---|
1768 | } |
---|
1769 | |
---|
1770 | /* |
---|
1771 | Mark things that're only reachable through some (suspended) TCR. |
---|
1772 | (This basically means the tcr's gc_context and the exception |
---|
1773 | frames on its xframe_list.) |
---|
1774 | */ |
---|
1775 | |
---|
1776 | void |
---|
1777 | mark_tcr_xframes(TCR *tcr) |
---|
1778 | { |
---|
1779 | xframe_list *xframes; |
---|
1780 | ExceptionInformation *xp; |
---|
1781 | |
---|
1782 | xp = tcr->gc_context; |
---|
1783 | if (xp) { |
---|
1784 | #ifdef X8664 |
---|
1785 | mark_xp(xp); |
---|
1786 | #else |
---|
1787 | mark_xp(xp, tcr->node_regs_mask); |
---|
1788 | #endif |
---|
1789 | } |
---|
1790 | #ifdef X8632 |
---|
1791 | mark_root(tcr->save0); |
---|
1792 | mark_root(tcr->save1); |
---|
1793 | mark_root(tcr->save2); |
---|
1794 | mark_root(tcr->save3); |
---|
1795 | mark_root(tcr->next_method_context); |
---|
1796 | #endif |
---|
1797 | |
---|
1798 | for (xframes = (xframe_list *) tcr->xframe; |
---|
1799 | xframes; |
---|
1800 | xframes = xframes->prev) { |
---|
1801 | #ifdef X8664 |
---|
1802 | mark_xp(xframes->curr); |
---|
1803 | #else |
---|
1804 | mark_xp(xframes->curr, xframes->node_regs_mask); |
---|
1805 | #endif |
---|
1806 | } |
---|
1807 | } |
---|
1808 | |
---|
1809 | |
---|
1810 | void *postGCptrs = NULL; |
---|
1811 | |
---|
1812 | void |
---|
1813 | postGCfree(void *p) |
---|
1814 | { |
---|
1815 | *(void **)p = postGCptrs; |
---|
1816 | postGCptrs = p; |
---|
1817 | } |
---|
1818 | |
---|
1819 | void |
---|
1820 | freeGCptrs() |
---|
1821 | { |
---|
1822 | void *p, *next; |
---|
1823 | |
---|
1824 | for (p = postGCptrs; p; p = next) { |
---|
1825 | next = *((void **)p); |
---|
1826 | free(p); |
---|
1827 | } |
---|
1828 | postGCptrs = NULL; |
---|
1829 | } |
---|
1830 | |
---|
1831 | void |
---|
1832 | reap_gcable_ptrs() |
---|
1833 | { |
---|
1834 | LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr; |
---|
1835 | xmacptr_flag flag; |
---|
1836 | natural dnode; |
---|
1837 | xmacptr *x; |
---|
1838 | |
---|
1839 | while((next = *prev) != (LispObj)NULL) { |
---|
1840 | dnode = gc_area_dnode(next); |
---|
1841 | x = (xmacptr *) ptr_from_lispobj(untag(next)); |
---|
1842 | |
---|
1843 | if ((dnode >= GCndnodes_in_area) || |
---|
1844 | (ref_bit(GCmarkbits,dnode))) { |
---|
1845 | prev = &(x->link); |
---|
1846 | } else { |
---|
1847 | *prev = x->link; |
---|
1848 | flag = (xmacptr_flag)(x->flags); |
---|
1849 | ptr = x->address; |
---|
1850 | |
---|
1851 | if (ptr) { |
---|
1852 | switch (flag) { |
---|
1853 | case xmacptr_flag_recursive_lock: |
---|
1854 | destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr)); |
---|
1855 | break; |
---|
1856 | |
---|
1857 | case xmacptr_flag_ptr: |
---|
1858 | postGCfree((void *)ptr_from_lispobj(ptr)); |
---|
1859 | break; |
---|
1860 | |
---|
1861 | case xmacptr_flag_rwlock: |
---|
1862 | break; |
---|
1863 | |
---|
1864 | case xmacptr_flag_semaphore: |
---|
1865 | destroy_semaphore((void**)&(x->address)); |
---|
1866 | break; |
---|
1867 | |
---|
1868 | default: |
---|
1869 | /* (warn "unknown xmacptr_flag: ~s" flag) */ |
---|
1870 | /* Unknowd, and perhaps unknowdable. */ |
---|
1871 | /* Fall in: */ |
---|
1872 | case xmacptr_flag_none: |
---|
1873 | break; |
---|
1874 | } |
---|
1875 | } |
---|
1876 | } |
---|
1877 | } |
---|
1878 | } |
---|
1879 | |
---|
1880 | |
---|
1881 | |
---|
1882 | #if WORD_SIZE == 64 |
---|
1883 | unsigned short *_one_bits = NULL; |
---|
1884 | |
---|
1885 | unsigned short |
---|
1886 | logcount16(unsigned short n) |
---|
1887 | { |
---|
1888 | unsigned short c=0; |
---|
1889 | |
---|
1890 | while(n) { |
---|
1891 | n = n & (n-1); |
---|
1892 | c++; |
---|
1893 | } |
---|
1894 | return c; |
---|
1895 | } |
---|
1896 | |
---|
1897 | void |
---|
1898 | gc_init() |
---|
1899 | { |
---|
1900 | int i; |
---|
1901 | |
---|
1902 | _one_bits = malloc(sizeof(unsigned short) * (1<<16)); |
---|
1903 | |
---|
1904 | for (i = 0; i < (1<<16); i++) { |
---|
1905 | _one_bits[i] = dnode_size*logcount16(i); |
---|
1906 | } |
---|
1907 | } |
---|
1908 | |
---|
1909 | #define one_bits(x) _one_bits[x] |
---|
1910 | |
---|
1911 | #else |
---|
1912 | const unsigned char _one_bits[256] = { |
---|
1913 | 0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8, |
---|
1914 | 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, |
---|
1915 | 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, |
---|
1916 | 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, |
---|
1917 | 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, |
---|
1918 | 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, |
---|
1919 | 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, |
---|
1920 | 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, |
---|
1921 | 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, |
---|
1922 | 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, |
---|
1923 | 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, |
---|
1924 | 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, |
---|
1925 | 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, |
---|
1926 | 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, |
---|
1927 | 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, |
---|
1928 | 4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8 |
---|
1929 | }; |
---|
1930 | |
---|
1931 | #define one_bits(x) _one_bits[x] |
---|
1932 | |
---|
1933 | void |
---|
1934 | gc_init() |
---|
1935 | { |
---|
1936 | } |
---|
1937 | |
---|
1938 | #endif |
---|
1939 | |
---|
1940 | /* A "pagelet" contains 32 doublewords. The relocation table contains |
---|
1941 | a word for each pagelet which defines the lowest address to which |
---|
1942 | dnodes on that pagelet will be relocated. |
---|
1943 | |
---|
1944 | The relocation address of a given pagelet is the sum of the relocation |
---|
1945 | address for the preceding pagelet and the number of bytes occupied by |
---|
1946 | marked objects on the preceding pagelet. |
---|
1947 | */ |
---|
1948 | |
---|
1949 | LispObj |
---|
1950 | calculate_relocation() |
---|
1951 | { |
---|
1952 | LispObj *relocptr = GCrelocptr; |
---|
1953 | LispObj current = GCareadynamiclow; |
---|
1954 | bitvector |
---|
1955 | markbits = GCdynamic_markbits; |
---|
1956 | qnode *q = (qnode *) markbits; |
---|
1957 | natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift); |
---|
1958 | natural thesebits; |
---|
1959 | LispObj first = 0; |
---|
1960 | |
---|
1961 | if (npagelets) { |
---|
1962 | do { |
---|
1963 | *relocptr++ = current; |
---|
1964 | thesebits = *markbits++; |
---|
1965 | if (thesebits == ALL_ONES) { |
---|
1966 | current += nbits_in_word*dnode_size; |
---|
1967 | q += 4; /* sic */ |
---|
1968 | } else { |
---|
1969 | if (!first) { |
---|
1970 | first = current; |
---|
1971 | while (thesebits & BIT0_MASK) { |
---|
1972 | first += dnode_size; |
---|
1973 | thesebits += thesebits; |
---|
1974 | } |
---|
1975 | } |
---|
1976 | /* We're counting bits in qnodes in the wrong order here, but |
---|
1977 | that's OK. I think ... */ |
---|
1978 | current += one_bits(*q++); |
---|
1979 | current += one_bits(*q++); |
---|
1980 | current += one_bits(*q++); |
---|
1981 | current += one_bits(*q++); |
---|
1982 | } |
---|
1983 | } while(--npagelets); |
---|
1984 | } |
---|
1985 | *relocptr++ = current; |
---|
1986 | return first ? first : current; |
---|
1987 | } |
---|
1988 | |
---|
1989 | |
---|
1990 | #if 0 |
---|
1991 | LispObj |
---|
1992 | dnode_forwarding_address(natural dnode, int tag_n) |
---|
1993 | { |
---|
1994 | natural pagelet, nbits; |
---|
1995 | unsigned int near_bits; |
---|
1996 | LispObj new; |
---|
1997 | |
---|
1998 | if (GCDebug) { |
---|
1999 | if (! ref_bit(GCdynamic_markbits, dnode)) { |
---|
2000 | Bug(NULL, "unmarked object being forwarded!\n"); |
---|
2001 | } |
---|
2002 | } |
---|
2003 | |
---|
2004 | pagelet = dnode >> bitmap_shift; |
---|
2005 | nbits = dnode & bitmap_shift_count_mask; |
---|
2006 | near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)]; |
---|
2007 | |
---|
2008 | if (nbits < 32) { |
---|
2009 | new = GCrelocptr[pagelet] + tag_n;; |
---|
2010 | /* Increment "new" by the count of 1 bits which precede the dnode */ |
---|
2011 | if (near_bits == 0xffffffff) { |
---|
2012 | return (new + (nbits << 4)); |
---|
2013 | } else { |
---|
2014 | near_bits &= (0xffffffff00000000 >> nbits); |
---|
2015 | if (nbits > 15) { |
---|
2016 | new += one_bits(near_bits & 0xffff); |
---|
2017 | } |
---|
2018 | return (new + (one_bits(near_bits >> 16))); |
---|
2019 | } |
---|
2020 | } else { |
---|
2021 | new = GCrelocptr[pagelet+1] + tag_n; |
---|
2022 | nbits = 64-nbits; |
---|
2023 | |
---|
2024 | if (near_bits == 0xffffffff) { |
---|
2025 | return (new - (nbits << 4)); |
---|
2026 | } else { |
---|
2027 | near_bits &= (1<<nbits)-1; |
---|
2028 | if (nbits > 15) { |
---|
2029 | new -= one_bits(near_bits >> 16); |
---|
2030 | } |
---|
2031 | return (new - one_bits(near_bits & 0xffff)); |
---|
2032 | } |
---|
2033 | } |
---|
2034 | } |
---|
2035 | #else |
---|
2036 | #ifdef X8664 |
---|
2037 | /* Quicker, dirtier */ |
---|
2038 | LispObj |
---|
2039 | dnode_forwarding_address(natural dnode, int tag_n) |
---|
2040 | { |
---|
2041 | natural pagelet, nbits, marked; |
---|
2042 | LispObj new; |
---|
2043 | |
---|
2044 | if (GCDebug) { |
---|
2045 | if (! ref_bit(GCdynamic_markbits, dnode)) { |
---|
2046 | Bug(NULL, "unmarked object being forwarded!\n"); |
---|
2047 | } |
---|
2048 | } |
---|
2049 | |
---|
2050 | pagelet = dnode >> bitmap_shift; |
---|
2051 | nbits = dnode & bitmap_shift_count_mask; |
---|
2052 | new = GCrelocptr[pagelet] + tag_n;; |
---|
2053 | if (nbits) { |
---|
2054 | marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits); |
---|
2055 | while (marked) { |
---|
2056 | new += one_bits((qnode)marked); |
---|
2057 | marked >>=16; |
---|
2058 | } |
---|
2059 | } |
---|
2060 | return new; |
---|
2061 | } |
---|
2062 | #endif |
---|
2063 | #ifdef X8632 |
---|
2064 | LispObj |
---|
2065 | dnode_forwarding_address(natural dnode, int tag_n) |
---|
2066 | { |
---|
2067 | natural pagelet, nbits; |
---|
2068 | unsigned short near_bits; |
---|
2069 | LispObj new; |
---|
2070 | |
---|
2071 | if (GCDebug) { |
---|
2072 | if (! ref_bit(GCdynamic_markbits, dnode)) { |
---|
2073 | Bug(NULL, "unmarked object being forwarded!\n"); |
---|
2074 | } |
---|
2075 | } |
---|
2076 | |
---|
2077 | pagelet = dnode >> 5; |
---|
2078 | nbits = dnode & 0x1f; |
---|
2079 | /* On little-endian x86, we have to flip the low bit of dnode>>4 to |
---|
2080 | get the near_bits from the appropriate half-word. */ |
---|
2081 | near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1]; |
---|
2082 | |
---|
2083 | if (nbits < 16) { |
---|
2084 | new = GCrelocptr[pagelet] + tag_n;; |
---|
2085 | /* Increment "new" by the count of 1 bits which precede the dnode */ |
---|
2086 | if (near_bits == 0xffff) { |
---|
2087 | return (new + (nbits << 3)); |
---|
2088 | } else { |
---|
2089 | near_bits &= (0xffff0000 >> nbits); |
---|
2090 | if (nbits > 7) { |
---|
2091 | new += one_bits(near_bits & 0xff); |
---|
2092 | } |
---|
2093 | return (new + (one_bits(near_bits >> 8))); |
---|
2094 | } |
---|
2095 | } else { |
---|
2096 | new = GCrelocptr[pagelet+1] + tag_n; |
---|
2097 | nbits = 32-nbits; |
---|
2098 | |
---|
2099 | if (near_bits == 0xffff) { |
---|
2100 | return (new - (nbits << 3)); |
---|
2101 | } else { |
---|
2102 | near_bits &= (1<<nbits)-1; |
---|
2103 | if (nbits > 7) { |
---|
2104 | new -= one_bits(near_bits >> 8); |
---|
2105 | } |
---|
2106 | return (new - one_bits(near_bits & 0xff)); |
---|
2107 | } |
---|
2108 | } |
---|
2109 | } |
---|
2110 | #endif |
---|
2111 | #endif |
---|
2112 | |
---|
2113 | LispObj |
---|
2114 | locative_forwarding_address(LispObj obj) |
---|
2115 | { |
---|
2116 | int tag_n = fulltag_of(obj); |
---|
2117 | natural dnode = gc_dynamic_area_dnode(obj); |
---|
2118 | |
---|
2119 | |
---|
2120 | if ((dnode >= GCndynamic_dnodes_in_area) || |
---|
2121 | (obj < GCfirstunmarked)) { |
---|
2122 | return obj; |
---|
2123 | } |
---|
2124 | |
---|
2125 | return dnode_forwarding_address(dnode, tag_n); |
---|
2126 | } |
---|
2127 | |
---|
2128 | LispObj |
---|
2129 | node_forwarding_address(LispObj node) |
---|
2130 | { |
---|
2131 | int tag_n; |
---|
2132 | natural dnode = gc_dynamic_area_dnode(node); |
---|
2133 | |
---|
2134 | if ((dnode >= GCndynamic_dnodes_in_area) || |
---|
2135 | (node < GCfirstunmarked)) { |
---|
2136 | return node; |
---|
2137 | } |
---|
2138 | |
---|
2139 | tag_n = fulltag_of(node); |
---|
2140 | if (!is_node_fulltag(tag_n)) { |
---|
2141 | return node; |
---|
2142 | } |
---|
2143 | |
---|
2144 | return dnode_forwarding_address(dnode, tag_n); |
---|
2145 | } |
---|
2146 | |
---|
2147 | Boolean |
---|
2148 | update_noderef(LispObj *noderef) |
---|
2149 | { |
---|
2150 | LispObj |
---|
2151 | node = *noderef, |
---|
2152 | new = node_forwarding_address(node); |
---|
2153 | |
---|
2154 | if (new != node) { |
---|
2155 | *noderef = new; |
---|
2156 | return true; |
---|
2157 | } |
---|
2158 | return false; |
---|
2159 | } |
---|
2160 | |
---|
2161 | void |
---|
2162 | update_locref(LispObj *locref) |
---|
2163 | { |
---|
2164 | LispObj |
---|
2165 | obj = *locref, |
---|
2166 | new = locative_forwarding_address(obj); |
---|
2167 | |
---|
2168 | if (new != obj) { |
---|
2169 | *locref = new; |
---|
2170 | } |
---|
2171 | } |
---|
2172 | |
---|
2173 | void |
---|
2174 | forward_gcable_ptrs() |
---|
2175 | { |
---|
2176 | LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; |
---|
2177 | |
---|
2178 | while ((next = *prev) != (LispObj)NULL) { |
---|
2179 | *prev = node_forwarding_address(next); |
---|
2180 | prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); |
---|
2181 | } |
---|
2182 | } |
---|
2183 | |
---|
2184 | void |
---|
2185 | forward_headerless_range(LispObj *range_start, LispObj *range_end) |
---|
2186 | { |
---|
2187 | LispObj *p = range_start; |
---|
2188 | |
---|
2189 | while (p < range_end) { |
---|
2190 | update_noderef(p); |
---|
2191 | p++; |
---|
2192 | } |
---|
2193 | } |
---|
2194 | |
---|
2195 | void |
---|
2196 | forward_range(LispObj *range_start, LispObj *range_end) |
---|
2197 | { |
---|
2198 | LispObj *p = range_start, node, new; |
---|
2199 | int tag_n; |
---|
2200 | natural nwords; |
---|
2201 | hash_table_vector_header *hashp; |
---|
2202 | |
---|
2203 | while (p < range_end) { |
---|
2204 | node = *p; |
---|
2205 | tag_n = fulltag_of(node); |
---|
2206 | if (immheader_tag_p(tag_n)) { |
---|
2207 | p = (LispObj *) skip_over_ivector((natural) p, node); |
---|
2208 | } else if (nodeheader_tag_p(tag_n)) { |
---|
2209 | nwords = header_element_count(node); |
---|
2210 | nwords += (1 - (nwords&1)); |
---|
2211 | if ((header_subtag(node) == subtag_hash_vector) && |
---|
2212 | ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { |
---|
2213 | natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
2214 | hashp = (hash_table_vector_header *) p; |
---|
2215 | p++; |
---|
2216 | nwords -= skip; |
---|
2217 | while(skip--) { |
---|
2218 | update_noderef(p); |
---|
2219 | p++; |
---|
2220 | } |
---|
2221 | /* "nwords" is odd at this point: there are (floor nwords 2) |
---|
2222 | key/value pairs to look at, and then an extra word for |
---|
2223 | alignment. Process them two at a time, then bump "p" |
---|
2224 | past the alignment word. */ |
---|
2225 | nwords >>= 1; |
---|
2226 | while(nwords--) { |
---|
2227 | if (update_noderef(p) && hashp) { |
---|
2228 | hashp->flags |= nhash_key_moved_mask; |
---|
2229 | hashp = NULL; |
---|
2230 | } |
---|
2231 | p++; |
---|
2232 | update_noderef(p); |
---|
2233 | p++; |
---|
2234 | } |
---|
2235 | *p++ = 0; |
---|
2236 | } else { |
---|
2237 | if (header_subtag(node) == subtag_function) { |
---|
2238 | #ifdef X8632 |
---|
2239 | int skip = (unsigned short)(p[1]); |
---|
2240 | #else |
---|
2241 | int skip = (int)(p[1]); |
---|
2242 | #endif |
---|
2243 | p += skip; |
---|
2244 | nwords -= skip; |
---|
2245 | } |
---|
2246 | p++; |
---|
2247 | while(nwords--) { |
---|
2248 | update_noderef(p); |
---|
2249 | p++; |
---|
2250 | } |
---|
2251 | } |
---|
2252 | } else { |
---|
2253 | new = node_forwarding_address(node); |
---|
2254 | if (new != node) { |
---|
2255 | *p = new; |
---|
2256 | } |
---|
2257 | p++; |
---|
2258 | update_noderef(p); |
---|
2259 | p++; |
---|
2260 | } |
---|
2261 | } |
---|
2262 | } |
---|
2263 | |
---|
2264 | |
---|
2265 | void |
---|
2266 | forward_memoized_area(area *a, natural num_memo_dnodes) |
---|
2267 | { |
---|
2268 | bitvector refbits = a->refbits; |
---|
2269 | LispObj *p = (LispObj *) a->low, x1, x2, new; |
---|
2270 | natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0; |
---|
2271 | int tag_x1; |
---|
2272 | hash_table_vector_header *hashp = NULL; |
---|
2273 | Boolean header_p; |
---|
2274 | |
---|
2275 | if (GCDebug) { |
---|
2276 | check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); |
---|
2277 | } |
---|
2278 | |
---|
2279 | /* This is pretty straightforward, but we have to note |
---|
2280 | when we move a key in a hash table vector that wants |
---|
2281 | us to tell it about that. */ |
---|
2282 | |
---|
2283 | set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); |
---|
2284 | while (memo_dnode < num_memo_dnodes) { |
---|
2285 | if (bits == 0) { |
---|
2286 | int remain = nbits_in_word - bitidx; |
---|
2287 | memo_dnode += remain; |
---|
2288 | p += (remain+remain); |
---|
2289 | bits = *++bitsp; |
---|
2290 | bitidx = 0; |
---|
2291 | } else { |
---|
2292 | nextbit = count_leading_zeros(bits); |
---|
2293 | if ((diff = (nextbit - bitidx)) != 0) { |
---|
2294 | memo_dnode += diff; |
---|
2295 | bitidx = nextbit; |
---|
2296 | p += (diff+diff); |
---|
2297 | } |
---|
2298 | x1 = p[0]; |
---|
2299 | x2 = p[1]; |
---|
2300 | tag_x1 = fulltag_of(x1); |
---|
2301 | bits &= ~(BIT0_MASK >> bitidx); |
---|
2302 | header_p = (nodeheader_tag_p(tag_x1)); |
---|
2303 | |
---|
2304 | if (header_p && |
---|
2305 | (header_subtag(x1) == subtag_hash_vector)) { |
---|
2306 | hashp = (hash_table_vector_header *) p; |
---|
2307 | if (hashp->flags & nhash_track_keys_mask) { |
---|
2308 | hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1); |
---|
2309 | } else { |
---|
2310 | hashp = NULL; |
---|
2311 | } |
---|
2312 | } |
---|
2313 | |
---|
2314 | |
---|
2315 | if (! header_p) { |
---|
2316 | new = node_forwarding_address(x1); |
---|
2317 | if (new != x1) { |
---|
2318 | *p = new; |
---|
2319 | } |
---|
2320 | } |
---|
2321 | p++; |
---|
2322 | |
---|
2323 | new = node_forwarding_address(x2); |
---|
2324 | if (new != x2) { |
---|
2325 | *p = new; |
---|
2326 | if (memo_dnode < hash_dnode_limit) { |
---|
2327 | hashp->flags |= nhash_key_moved_mask; |
---|
2328 | hash_dnode_limit = 0; |
---|
2329 | hashp = NULL; |
---|
2330 | } |
---|
2331 | } |
---|
2332 | p++; |
---|
2333 | memo_dnode++; |
---|
2334 | bitidx++; |
---|
2335 | |
---|
2336 | } |
---|
2337 | } |
---|
2338 | } |
---|
2339 | |
---|
2340 | |
---|
2341 | |
---|
2342 | /* Forward a tstack area */ |
---|
2343 | void |
---|
2344 | forward_tstack_area(area *a) |
---|
2345 | { |
---|
2346 | LispObj |
---|
2347 | *current, |
---|
2348 | *next, |
---|
2349 | *start = (LispObj *) a->active, |
---|
2350 | *end = start, |
---|
2351 | *limit = (LispObj *) (a->high); |
---|
2352 | |
---|
2353 | for (current = start; |
---|
2354 | end != limit; |
---|
2355 | current = next) { |
---|
2356 | next = ptr_from_lispobj(*current); |
---|
2357 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
2358 | forward_range(current+2, end); |
---|
2359 | } |
---|
2360 | } |
---|
2361 | |
---|
2362 | /* Forward a vstack area */ |
---|
2363 | void |
---|
2364 | forward_vstack_area(area *a) |
---|
2365 | { |
---|
2366 | LispObj |
---|
2367 | *p = (LispObj *) a->active, |
---|
2368 | *q = (LispObj *) a->high; |
---|
2369 | |
---|
2370 | forward_headerless_range(p, q); |
---|
2371 | } |
---|
2372 | |
---|
2373 | void |
---|
2374 | forward_xp(ExceptionInformation *xp) |
---|
2375 | { |
---|
2376 | natural *regs = (natural *) xpGPRvector(xp); |
---|
2377 | |
---|
2378 | #ifdef X8664 |
---|
2379 | update_noderef(&(regs[Iarg_z])); |
---|
2380 | update_noderef(&(regs[Iarg_y])); |
---|
2381 | update_noderef(&(regs[Iarg_x])); |
---|
2382 | update_noderef(&(regs[Isave3])); |
---|
2383 | update_noderef(&(regs[Isave2])); |
---|
2384 | update_noderef(&(regs[Isave1])); |
---|
2385 | update_noderef(&(regs[Isave0])); |
---|
2386 | update_noderef(&(regs[Ifn])); |
---|
2387 | update_noderef(&(regs[Itemp0])); |
---|
2388 | update_noderef(&(regs[Itemp1])); |
---|
2389 | update_noderef(&(regs[Itemp2])); |
---|
2390 | update_locref(&(regs[Iip])); |
---|
2391 | #else |
---|
2392 | update_noderef(&(regs[Iarg_z])); |
---|
2393 | update_noderef(&(regs[Iarg_y])); |
---|
2394 | update_noderef(&(regs[Ifn])); |
---|
2395 | update_noderef(&(regs[Itemp0])); |
---|
2396 | update_noderef(&(regs[Itemp1])); |
---|
2397 | update_locref(&(regs[Iip])); |
---|
2398 | #endif |
---|
2399 | } |
---|
2400 | |
---|
2401 | |
---|
2402 | void |
---|
2403 | forward_tcr_tlb(TCR *tcr) |
---|
2404 | { |
---|
2405 | natural n = tcr->tlb_limit; |
---|
2406 | LispObj |
---|
2407 | *start = tcr->tlb_pointer, |
---|
2408 | *end = (LispObj *) ((BytePtr)start+n), |
---|
2409 | node; |
---|
2410 | |
---|
2411 | while (start < end) { |
---|
2412 | node = *start; |
---|
2413 | if (node != no_thread_local_binding_marker) { |
---|
2414 | update_noderef(start); |
---|
2415 | } |
---|
2416 | start++; |
---|
2417 | } |
---|
2418 | } |
---|
2419 | |
---|
2420 | void |
---|
2421 | forward_tcr_xframes(TCR *tcr) |
---|
2422 | { |
---|
2423 | xframe_list *xframes; |
---|
2424 | ExceptionInformation *xp; |
---|
2425 | |
---|
2426 | xp = tcr->gc_context; |
---|
2427 | if (xp) { |
---|
2428 | forward_xp(xp); |
---|
2429 | } |
---|
2430 | for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { |
---|
2431 | forward_xp(xframes->curr); |
---|
2432 | } |
---|
2433 | } |
---|
2434 | |
---|
2435 | void |
---|
2436 | forward_and_resolve_static_references(area *a) |
---|
2437 | { |
---|
2438 | natural |
---|
2439 | nstatic = static_dnodes_for_area(a), |
---|
2440 | nstatic_bitmap_words = nstatic >> bitmap_shift; |
---|
2441 | if (nstatic != 0) { |
---|
2442 | /* exploit the fact that a cons is the same size as a dnode. */ |
---|
2443 | cons *pagelet_start = (cons *) a->low, *work; |
---|
2444 | bitvector markbits = GCmarkbits, |
---|
2445 | usedbits = tenured_area->static_used; |
---|
2446 | natural marked, used, used_but_not_marked, ndeleted = 0, i; |
---|
2447 | |
---|
2448 | while (nstatic_bitmap_words--) { |
---|
2449 | marked = *markbits++; |
---|
2450 | used = *usedbits; |
---|
2451 | if (marked != used) { |
---|
2452 | *usedbits = marked; |
---|
2453 | } |
---|
2454 | used |= marked; |
---|
2455 | used_but_not_marked = used & ~marked; |
---|
2456 | |
---|
2457 | while (marked) { |
---|
2458 | i = count_leading_zeros(marked); |
---|
2459 | marked &= ~(BIT0_MASK >> i); |
---|
2460 | work = pagelet_start+i; |
---|
2461 | update_noderef(&work->cdr); |
---|
2462 | update_noderef(&work->car); |
---|
2463 | } |
---|
2464 | |
---|
2465 | while (used_but_not_marked) { |
---|
2466 | i = count_leading_zeros(used_but_not_marked); |
---|
2467 | used_but_not_marked &= ~(BIT0_MASK >> i); |
---|
2468 | work = pagelet_start+i; |
---|
2469 | if ((work->cdr != undefined) && |
---|
2470 | (work->cdr != slot_unbound)) { |
---|
2471 | work->car = slot_unbound; |
---|
2472 | work->cdr = slot_unbound; |
---|
2473 | ndeleted++; |
---|
2474 | } |
---|
2475 | } |
---|
2476 | usedbits++; |
---|
2477 | pagelet_start += nbits_in_word; |
---|
2478 | } |
---|
2479 | lisp_global(DELETED_STATIC_PAIRS) += box_fixnum(ndeleted); |
---|
2480 | } |
---|
2481 | } |
---|
2482 | |
---|
2483 | #ifdef X8632 |
---|
2484 | void |
---|
2485 | update_self_references(LispObj *node) |
---|
2486 | { |
---|
2487 | LispObj fn = fulltag_misc + (LispObj)node; |
---|
2488 | unsigned char *p = (unsigned char *)node; |
---|
2489 | natural i, offset; |
---|
2490 | |
---|
2491 | i = ((unsigned short *)node)[2]; |
---|
2492 | offset = node[--i]; |
---|
2493 | while (offset) { |
---|
2494 | *(LispObj *)(p + offset) = fn; |
---|
2495 | offset = node[--i]; |
---|
2496 | } |
---|
2497 | } |
---|
2498 | #endif |
---|
2499 | |
---|
2500 | /* |
---|
2501 | Compact the dynamic heap (from GCfirstunmarked through its end.) |
---|
2502 | Return the doublenode address of the new freeptr. |
---|
2503 | */ |
---|
2504 | |
---|
2505 | LispObj |
---|
2506 | compact_dynamic_heap() |
---|
2507 | { |
---|
2508 | LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current, *prev = NULL; |
---|
2509 | natural |
---|
2510 | elements, |
---|
2511 | dnode = gc_area_dnode(GCfirstunmarked), |
---|
2512 | node_dnodes = 0, |
---|
2513 | imm_dnodes = 0, |
---|
2514 | bitidx, |
---|
2515 | *bitsp, |
---|
2516 | bits, |
---|
2517 | nextbit, |
---|
2518 | diff; |
---|
2519 | int tag; |
---|
2520 | bitvector markbits = GCmarkbits; |
---|
2521 | /* keep track of whether or not we saw any |
---|
2522 | code_vector headers, and only flush cache if so. */ |
---|
2523 | Boolean GCrelocated_code_vector = false; |
---|
2524 | |
---|
2525 | if (dnode < GCndnodes_in_area) { |
---|
2526 | lisp_global(FWDNUM) += (1<<fixnum_shift); |
---|
2527 | |
---|
2528 | set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); |
---|
2529 | while (dnode < GCndnodes_in_area) { |
---|
2530 | if (bits == 0) { |
---|
2531 | int remain = nbits_in_word - bitidx; |
---|
2532 | dnode += remain; |
---|
2533 | src += (remain+remain); |
---|
2534 | bits = *++bitsp; |
---|
2535 | bitidx = 0; |
---|
2536 | } else { |
---|
2537 | /* Have a non-zero markbits word; all bits more significant |
---|
2538 | than "bitidx" are 0. Count leading zeros in "bits" |
---|
2539 | (there'll be at least "bitidx" of them.) If there are more |
---|
2540 | than "bitidx" leading zeros, bump "dnode", "bitidx", and |
---|
2541 | "src" by the difference. */ |
---|
2542 | nextbit = count_leading_zeros(bits); |
---|
2543 | if ((diff = (nextbit - bitidx)) != 0) { |
---|
2544 | dnode += diff; |
---|
2545 | bitidx = nextbit; |
---|
2546 | src += (diff+diff); |
---|
2547 | } |
---|
2548 | prev = current; |
---|
2549 | current = src; |
---|
2550 | if (GCDebug) { |
---|
2551 | if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) { |
---|
2552 | Bug(NULL, "Out of synch in heap compaction. Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", |
---|
2553 | src, dest, locative_forwarding_address(ptr_to_lispobj(src))); |
---|
2554 | } |
---|
2555 | } |
---|
2556 | |
---|
2557 | node = *src++; |
---|
2558 | tag = fulltag_of(node); |
---|
2559 | if (nodeheader_tag_p(tag)) { |
---|
2560 | elements = header_element_count(node); |
---|
2561 | node_dnodes = (elements+2)>>1; |
---|
2562 | dnode += node_dnodes; |
---|
2563 | if (header_subtag(node) == subtag_function) { |
---|
2564 | #ifdef X8632 |
---|
2565 | int skip = *((unsigned short *)src); |
---|
2566 | LispObj *f = dest; |
---|
2567 | #else |
---|
2568 | int skip = *((int *)src); |
---|
2569 | #endif |
---|
2570 | *dest++ = node; |
---|
2571 | elements -= skip; |
---|
2572 | while(skip--) { |
---|
2573 | *dest++ = *src++; |
---|
2574 | } |
---|
2575 | update_self_references(f); |
---|
2576 | while(elements--) { |
---|
2577 | *dest++ = node_forwarding_address(*src++); |
---|
2578 | } |
---|
2579 | if (((LispObj)src) & node_size) { |
---|
2580 | src++; |
---|
2581 | *dest++ = 0; |
---|
2582 | } |
---|
2583 | } else { |
---|
2584 | if ((header_subtag(node) == subtag_hash_vector) && |
---|
2585 | (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) { |
---|
2586 | hash_table_vector_header *hashp = (hash_table_vector_header *) dest; |
---|
2587 | int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
2588 | |
---|
2589 | *dest++ = node; |
---|
2590 | elements -= skip; |
---|
2591 | while(skip--) { |
---|
2592 | *dest++ = node_forwarding_address(*src++); |
---|
2593 | } |
---|
2594 | /* There should be an even number of (key/value) pairs in elements; |
---|
2595 | an extra alignment word follows. */ |
---|
2596 | elements >>= 1; |
---|
2597 | while (elements--) { |
---|
2598 | if (hashp) { |
---|
2599 | node = *src++; |
---|
2600 | new = node_forwarding_address(node); |
---|
2601 | if (new != node) { |
---|
2602 | hashp->flags |= nhash_key_moved_mask; |
---|
2603 | hashp = NULL; |
---|
2604 | *dest++ = new; |
---|
2605 | } else { |
---|
2606 | *dest++ = node; |
---|
2607 | } |
---|
2608 | } else { |
---|
2609 | *dest++ = node_forwarding_address(*src++); |
---|
2610 | } |
---|
2611 | *dest++ = node_forwarding_address(*src++); |
---|
2612 | } |
---|
2613 | *dest++ = 0; |
---|
2614 | src++; |
---|
2615 | } else { |
---|
2616 | *dest++ = node; |
---|
2617 | *dest++ = node_forwarding_address(*src++); |
---|
2618 | while(--node_dnodes) { |
---|
2619 | *dest++ = node_forwarding_address(*src++); |
---|
2620 | *dest++ = node_forwarding_address(*src++); |
---|
2621 | } |
---|
2622 | } |
---|
2623 | } |
---|
2624 | set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); |
---|
2625 | } else if (immheader_tag_p(tag)) { |
---|
2626 | *dest++ = node; |
---|
2627 | *dest++ = *src++; |
---|
2628 | elements = header_element_count(node); |
---|
2629 | tag = header_subtag(node); |
---|
2630 | |
---|
2631 | #ifdef X8664 |
---|
2632 | switch(fulltag_of(tag)) { |
---|
2633 | case ivector_class_64_bit: |
---|
2634 | imm_dnodes = ((elements+1)+1)>>1; |
---|
2635 | break; |
---|
2636 | case ivector_class_32_bit: |
---|
2637 | imm_dnodes = (((elements+2)+3)>>2); |
---|
2638 | break; |
---|
2639 | case ivector_class_other_bit: |
---|
2640 | if (tag == subtag_bit_vector) { |
---|
2641 | imm_dnodes = (((elements+64)+127)>>7); |
---|
2642 | } else if (tag >= min_8_bit_ivector_subtag) { |
---|
2643 | imm_dnodes = (((elements+8)+15)>>4); |
---|
2644 | } else { |
---|
2645 | imm_dnodes = (((elements+4)+7)>>3); |
---|
2646 | } |
---|
2647 | } |
---|
2648 | #endif |
---|
2649 | #ifdef X8632 |
---|
2650 | if (tag <= max_32_bit_ivector_subtag) { |
---|
2651 | if (tag == subtag_code_vector) { |
---|
2652 | GCrelocated_code_vector = true; |
---|
2653 | } |
---|
2654 | imm_dnodes = (((elements+1)+1)>>1); |
---|
2655 | } else if (tag <= max_8_bit_ivector_subtag) { |
---|
2656 | imm_dnodes = (((elements+4)+7)>>3); |
---|
2657 | } else if (tag <= max_16_bit_ivector_subtag) { |
---|
2658 | imm_dnodes = (((elements+2)+3)>>2); |
---|
2659 | } else if (tag == subtag_bit_vector) { |
---|
2660 | imm_dnodes = (((elements+32)+63)>>6); |
---|
2661 | } else { |
---|
2662 | imm_dnodes = elements+1; |
---|
2663 | } |
---|
2664 | #endif |
---|
2665 | |
---|
2666 | dnode += imm_dnodes; |
---|
2667 | while (--imm_dnodes) { |
---|
2668 | *dest++ = *src++; |
---|
2669 | *dest++ = *src++; |
---|
2670 | } |
---|
2671 | set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); |
---|
2672 | } else { |
---|
2673 | *dest++ = node_forwarding_address(node); |
---|
2674 | *dest++ = node_forwarding_address(*src++); |
---|
2675 | bits &= ~(BIT0_MASK >> bitidx); |
---|
2676 | dnode++; |
---|
2677 | bitidx++; |
---|
2678 | } |
---|
2679 | } |
---|
2680 | } |
---|
2681 | } |
---|
2682 | return ptr_to_lispobj(dest); |
---|
2683 | } |
---|
2684 | |
---|
2685 | |
---|
2686 | Boolean |
---|
2687 | youngest_non_null_area_p (area *a) |
---|
2688 | { |
---|
2689 | if (a->active == a->high) { |
---|
2690 | return false; |
---|
2691 | } else { |
---|
2692 | for (a = a->younger; a; a = a->younger) { |
---|
2693 | if (a->active != a->high) { |
---|
2694 | return false; |
---|
2695 | } |
---|
2696 | } |
---|
2697 | }; |
---|
2698 | return true; |
---|
2699 | } |
---|
2700 | |
---|
2701 | Boolean just_purified_p = false; |
---|
2702 | |
---|
2703 | |
---|
2704 | /* |
---|
2705 | All thread's stack areas have been "normalized", as |
---|
2706 | has the dynamic heap. (The "active" pointer in these areas |
---|
2707 | matches the stack pointer/freeptr value at the time that |
---|
2708 | the exception occurred.) |
---|
2709 | */ |
---|
2710 | |
---|
2711 | |
---|
2712 | #define get_time(when) gettimeofday(&when, NULL) |
---|
2713 | |
---|
2714 | |
---|
2715 | |
---|
2716 | #ifdef FORCE_DWS_MARK |
---|
2717 | #warning recursive marker disabled for testing; remember to re-enable it |
---|
2718 | #endif |
---|
2719 | |
---|
2720 | void |
---|
2721 | gc(TCR *tcr, signed_natural param) |
---|
2722 | { |
---|
2723 | xframe_list *xframes = (tcr->xframe); |
---|
2724 | struct timeval start, stop; |
---|
2725 | area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; |
---|
2726 | unsigned timeidx = 1; |
---|
2727 | paging_info paging_info_start; |
---|
2728 | xframe_list *x; |
---|
2729 | LispObj |
---|
2730 | pkg, |
---|
2731 | itabvec = 0; |
---|
2732 | BytePtr oldfree = a->active; |
---|
2733 | TCR *other_tcr; |
---|
2734 | natural static_dnodes; |
---|
2735 | |
---|
2736 | #ifndef FORCE_DWS_MARK |
---|
2737 | if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { |
---|
2738 | GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; |
---|
2739 | } else { |
---|
2740 | GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size; |
---|
2741 | } |
---|
2742 | #else |
---|
2743 | GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; |
---|
2744 | #endif |
---|
2745 | |
---|
2746 | GCephemeral_low = lisp_global(OLDEST_EPHEMERAL); |
---|
2747 | if (GCephemeral_low) { |
---|
2748 | GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low); |
---|
2749 | } else { |
---|
2750 | GCn_ephemeral_dnodes = 0; |
---|
2751 | } |
---|
2752 | |
---|
2753 | if (GCn_ephemeral_dnodes) { |
---|
2754 | GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0); |
---|
2755 | } else { |
---|
2756 | GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0); |
---|
2757 | } |
---|
2758 | |
---|
2759 | if (GCephemeral_low) { |
---|
2760 | if ((oldfree-g1_area->low) < g1_area->threshold) { |
---|
2761 | to = g1_area; |
---|
2762 | note = a; |
---|
2763 | timeidx = 4; |
---|
2764 | } else if ((oldfree-g2_area->low) < g2_area->threshold) { |
---|
2765 | to = g2_area; |
---|
2766 | from = g1_area; |
---|
2767 | note = g1_area; |
---|
2768 | timeidx = 3; |
---|
2769 | } else { |
---|
2770 | to = tenured_area; |
---|
2771 | from = g2_area; |
---|
2772 | note = g2_area; |
---|
2773 | timeidx = 2; |
---|
2774 | } |
---|
2775 | } else { |
---|
2776 | note = tenured_area; |
---|
2777 | } |
---|
2778 | |
---|
2779 | if (GCverbose) { |
---|
2780 | char buf[16]; |
---|
2781 | |
---|
2782 | sample_paging_info(&paging_info_start); |
---|
2783 | comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift); |
---|
2784 | if (GCephemeral_low) { |
---|
2785 | fprintf(stderr, |
---|
2786 | "\n\n;;; Starting EGC of generation %d", |
---|
2787 | (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); |
---|
2788 | } else { |
---|
2789 | fprintf(stderr,"\n\n;;; Starting full GC"); |
---|
2790 | } |
---|
2791 | fprintf(stderr, ", %s bytes allocated.\n", buf); |
---|
2792 | } |
---|
2793 | |
---|
2794 | |
---|
2795 | get_time(start); |
---|
2796 | lisp_global(IN_GC) = (1<<fixnumshift); |
---|
2797 | |
---|
2798 | |
---|
2799 | if (just_purified_p) { |
---|
2800 | just_purified_p = false; |
---|
2801 | GCDebug = false; |
---|
2802 | } else { |
---|
2803 | GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0); |
---|
2804 | if (GCDebug) { |
---|
2805 | check_all_areas(); |
---|
2806 | } |
---|
2807 | } |
---|
2808 | |
---|
2809 | if (from) { |
---|
2810 | untenure_from_area(from); |
---|
2811 | } |
---|
2812 | static_dnodes = static_dnodes_for_area(a); |
---|
2813 | GCmarkbits = a->markbits; |
---|
2814 | GCarealow = ptr_to_lispobj(a->low); |
---|
2815 | GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift); |
---|
2816 | GCndnodes_in_area = gc_area_dnode(oldfree); |
---|
2817 | |
---|
2818 | if (GCndnodes_in_area) { |
---|
2819 | GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes; |
---|
2820 | GCdynamic_markbits = |
---|
2821 | GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift); |
---|
2822 | |
---|
2823 | zero_bits(GCmarkbits, GCndnodes_in_area); |
---|
2824 | GCweakvll = (LispObj)NULL; |
---|
2825 | |
---|
2826 | |
---|
2827 | if (GCn_ephemeral_dnodes == 0) { |
---|
2828 | /* For GCTWA, mark the internal package hash table vector of |
---|
2829 | *PACKAGE*, but don't mark its contents. */ |
---|
2830 | { |
---|
2831 | LispObj |
---|
2832 | itab; |
---|
2833 | natural |
---|
2834 | dnode, ndnodes; |
---|
2835 | |
---|
2836 | pkg = nrs_PACKAGE.vcell; |
---|
2837 | if ((fulltag_of(pkg) == fulltag_misc) && |
---|
2838 | (header_subtag(header_of(pkg)) == subtag_package)) { |
---|
2839 | itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab; |
---|
2840 | itabvec = car(itab); |
---|
2841 | dnode = gc_area_dnode(itabvec); |
---|
2842 | if (dnode < GCndnodes_in_area) { |
---|
2843 | ndnodes = (header_element_count(header_of(itabvec))+1) >> 1; |
---|
2844 | set_n_bits(GCmarkbits, dnode, ndnodes); |
---|
2845 | } |
---|
2846 | } |
---|
2847 | } |
---|
2848 | } |
---|
2849 | |
---|
2850 | { |
---|
2851 | area *next_area; |
---|
2852 | area_code code; |
---|
2853 | |
---|
2854 | /* Could make a jump table instead of the typecase */ |
---|
2855 | |
---|
2856 | for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { |
---|
2857 | switch (code) { |
---|
2858 | case AREA_TSTACK: |
---|
2859 | mark_tstack_area(next_area); |
---|
2860 | break; |
---|
2861 | |
---|
2862 | case AREA_VSTACK: |
---|
2863 | mark_vstack_area(next_area); |
---|
2864 | break; |
---|
2865 | |
---|
2866 | case AREA_STATIC: |
---|
2867 | case AREA_DYNAMIC: /* some heap that isn't "the" heap */ |
---|
2868 | /* In both of these cases, we -could- use the area's "markbits" |
---|
2869 | bitvector as a reference map. It's safe (but slower) to |
---|
2870 | ignore that map and process the entire area. |
---|
2871 | */ |
---|
2872 | if (next_area->younger == NULL) { |
---|
2873 | mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active); |
---|
2874 | } |
---|
2875 | break; |
---|
2876 | |
---|
2877 | default: |
---|
2878 | break; |
---|
2879 | } |
---|
2880 | } |
---|
2881 | } |
---|
2882 | |
---|
2883 | if (lisp_global(OLDEST_EPHEMERAL)) { |
---|
2884 | mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low)); |
---|
2885 | } |
---|
2886 | |
---|
2887 | other_tcr = tcr; |
---|
2888 | do { |
---|
2889 | mark_tcr_xframes(other_tcr); |
---|
2890 | mark_tcr_tlb(other_tcr); |
---|
2891 | other_tcr = other_tcr->next; |
---|
2892 | } while (other_tcr != tcr); |
---|
2893 | |
---|
2894 | |
---|
2895 | |
---|
2896 | |
---|
2897 | /* Go back through *package*'s internal symbols, marking |
---|
2898 | any that aren't worthless. |
---|
2899 | */ |
---|
2900 | |
---|
2901 | if (itabvec) { |
---|
2902 | natural |
---|
2903 | i, |
---|
2904 | n = header_element_count(header_of(itabvec)); |
---|
2905 | LispObj |
---|
2906 | sym, |
---|
2907 | *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); |
---|
2908 | |
---|
2909 | for (i = 0; i < n; i++) { |
---|
2910 | sym = *raw++; |
---|
2911 | #ifdef X8664 |
---|
2912 | if (fulltag_of(sym) == fulltag_symbol) { |
---|
2913 | #endif |
---|
2914 | #ifdef X8632 |
---|
2915 | if (fulltag_of(sym) == fulltag_misc) { |
---|
2916 | #endif |
---|
2917 | lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); |
---|
2918 | natural dnode = gc_area_dnode(sym); |
---|
2919 | |
---|
2920 | if ((dnode < GCndnodes_in_area) && |
---|
2921 | (!ref_bit(GCmarkbits,dnode))) { |
---|
2922 | /* Symbol is in GC area, not marked. |
---|
2923 | Mark it if fboundp, boundp, or if |
---|
2924 | it has a plist or another home package. |
---|
2925 | */ |
---|
2926 | |
---|
2927 | if (FBOUNDP(rawsym) || |
---|
2928 | BOUNDP(rawsym) || |
---|
2929 | (rawsym->flags != 0) || /* SPECIAL, etc. */ |
---|
2930 | (rawsym->plist != lisp_nil) || |
---|
2931 | ((rawsym->package_predicate != pkg) && |
---|
2932 | (rawsym->package_predicate != lisp_nil))) { |
---|
2933 | mark_root(sym); |
---|
2934 | } |
---|
2935 | } |
---|
2936 | } |
---|
2937 | } |
---|
2938 | } |
---|
2939 | |
---|
2940 | (void)markhtabvs(); |
---|
2941 | |
---|
2942 | if (itabvec) { |
---|
2943 | natural |
---|
2944 | i, |
---|
2945 | n = header_element_count(header_of(itabvec)); |
---|
2946 | LispObj |
---|
2947 | sym, |
---|
2948 | *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); |
---|
2949 | |
---|
2950 | for (i = 0; i < n; i++, raw++) { |
---|
2951 | sym = *raw; |
---|
2952 | #ifdef X8664 |
---|
2953 | if (fulltag_of(sym) == fulltag_symbol) { |
---|
2954 | #endif |
---|
2955 | #ifdef X8632 |
---|
2956 | if (fulltag_of(sym) == fulltag_misc) { |
---|
2957 | #endif |
---|
2958 | lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); |
---|
2959 | natural dnode = gc_area_dnode(sym); |
---|
2960 | |
---|
2961 | if ((dnode < GCndnodes_in_area) && |
---|
2962 | (!ref_bit(GCmarkbits,dnode))) { |
---|
2963 | *raw = unbound_marker; |
---|
2964 | } |
---|
2965 | } |
---|
2966 | } |
---|
2967 | } |
---|
2968 | |
---|
2969 | reap_gcable_ptrs(); |
---|
2970 | |
---|
2971 | GCrelocptr = global_reloctab; |
---|
2972 | GCfirstunmarked = calculate_relocation(); |
---|
2973 | |
---|
2974 | forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked)); |
---|
2975 | |
---|
2976 | other_tcr = tcr; |
---|
2977 | do { |
---|
2978 | forward_tcr_xframes(other_tcr); |
---|
2979 | forward_tcr_tlb(other_tcr); |
---|
2980 | other_tcr = other_tcr->next; |
---|
2981 | } while (other_tcr != tcr); |
---|
2982 | |
---|
2983 | |
---|
2984 | forward_gcable_ptrs(); |
---|
2985 | |
---|
2986 | |
---|
2987 | |
---|
2988 | { |
---|
2989 | area *next_area; |
---|
2990 | area_code code; |
---|
2991 | |
---|
2992 | /* Could make a jump table instead of the typecase */ |
---|
2993 | |
---|
2994 | for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { |
---|
2995 | switch (code) { |
---|
2996 | case AREA_TSTACK: |
---|
2997 | forward_tstack_area(next_area); |
---|
2998 | break; |
---|
2999 | |
---|
3000 | case AREA_VSTACK: |
---|
3001 | forward_vstack_area(next_area); |
---|
3002 | break; |
---|
3003 | |
---|
3004 | |
---|
3005 | case AREA_STATIC: |
---|
3006 | case AREA_DYNAMIC: /* some heap that isn't "the" heap */ |
---|
3007 | if (next_area->younger == NULL) { |
---|
3008 | forward_range((LispObj *) next_area->low, (LispObj *) next_area->active); |
---|
3009 | } |
---|
3010 | break; |
---|
3011 | |
---|
3012 | default: |
---|
3013 | break; |
---|
3014 | } |
---|
3015 | } |
---|
3016 | } |
---|
3017 | |
---|
3018 | if (GCephemeral_low) { |
---|
3019 | forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); |
---|
3020 | } else { |
---|
3021 | /* Full GC, need to process static space */ |
---|
3022 | forward_and_resolve_static_references(a); |
---|
3023 | } |
---|
3024 | |
---|
3025 | a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap()); |
---|
3026 | if (to) { |
---|
3027 | tenure_to_area(to); |
---|
3028 | } |
---|
3029 | |
---|
3030 | zero_memory_range(a->active, oldfree); |
---|
3031 | |
---|
3032 | resize_dynamic_heap(a->active, |
---|
3033 | (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0); |
---|
3034 | |
---|
3035 | /* |
---|
3036 | If the EGC is enabled: If there's no room for the youngest |
---|
3037 | generation, untenure everything. If this was a full GC and |
---|
3038 | there's now room for the youngest generation, tenure everything. |
---|
3039 | */ |
---|
3040 | if (a->older != NULL) { |
---|
3041 | natural nfree = (a->high - a->active); |
---|
3042 | |
---|
3043 | |
---|
3044 | if (nfree < a->threshold) { |
---|
3045 | untenure_from_area(tenured_area); |
---|
3046 | } else { |
---|
3047 | if (GCephemeral_low == 0) { |
---|
3048 | tenure_to_area(tenured_area); |
---|
3049 | } |
---|
3050 | } |
---|
3051 | } |
---|
3052 | } |
---|
3053 | lisp_global(GC_NUM) += (1<<fixnumshift); |
---|
3054 | if (note) { |
---|
3055 | note->gccount += (1<<fixnumshift); |
---|
3056 | } |
---|
3057 | |
---|
3058 | if (GCDebug) { |
---|
3059 | check_all_areas(); |
---|
3060 | } |
---|
3061 | |
---|
3062 | |
---|
3063 | lisp_global(IN_GC) = 0; |
---|
3064 | |
---|
3065 | nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending; |
---|
3066 | get_time(stop); |
---|
3067 | |
---|
3068 | { |
---|
3069 | lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS); |
---|
3070 | lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED); |
---|
3071 | LispObj val; |
---|
3072 | struct timeval *timeinfo, elapsed; |
---|
3073 | |
---|
3074 | val = total_gc_microseconds->vcell; |
---|
3075 | if ((fulltag_of(val) == fulltag_misc) && |
---|
3076 | (header_subtag(header_of(val)) == subtag_macptr)) { |
---|
3077 | timersub(&stop, &start, &elapsed); |
---|
3078 | timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address); |
---|
3079 | timeradd(timeinfo, &elapsed, timeinfo); |
---|
3080 | timeradd(timeinfo+timeidx, &elapsed, timeinfo+timeidx); |
---|
3081 | } |
---|
3082 | |
---|
3083 | val = total_bytes_freed->vcell; |
---|
3084 | if ((fulltag_of(val) == fulltag_misc) && |
---|
3085 | (header_subtag(header_of(val)) == subtag_macptr)) { |
---|
3086 | long long justfreed = oldfree - a->active; |
---|
3087 | *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed; |
---|
3088 | if (GCverbose) { |
---|
3089 | char buf[16]; |
---|
3090 | paging_info paging_info_stop; |
---|
3091 | |
---|
3092 | sample_paging_info(&paging_info_stop); |
---|
3093 | if (justfreed <= heap_segment_size) { |
---|
3094 | justfreed = 0; |
---|
3095 | } |
---|
3096 | comma_output_decimal(buf,16,justfreed); |
---|
3097 | if (note == tenured_area) { |
---|
3098 | fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec); |
---|
3099 | } else { |
---|
3100 | fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n", |
---|
3101 | (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, |
---|
3102 | buf, |
---|
3103 | elapsed.tv_sec, elapsed.tv_usec); |
---|
3104 | } |
---|
3105 | report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop); |
---|
3106 | } |
---|
3107 | } |
---|
3108 | } |
---|
3109 | } |
---|
3110 | |
---|
3111 | |
---|
3112 | |
---|
3113 | /* |
---|
3114 | Total the (physical) byte sizes of all ivectors in the indicated memory range |
---|
3115 | */ |
---|
3116 | |
---|
3117 | natural |
---|
3118 | unboxed_bytes_in_range(LispObj *start, LispObj *end) |
---|
3119 | { |
---|
3120 | natural total=0, elements, tag, subtag, bytes; |
---|
3121 | LispObj header; |
---|
3122 | |
---|
3123 | while (start < end) { |
---|
3124 | header = *start; |
---|
3125 | tag = fulltag_of(header); |
---|
3126 | |
---|
3127 | if ((nodeheader_tag_p(tag)) || |
---|
3128 | (immheader_tag_p(tag))) { |
---|
3129 | elements = header_element_count(header); |
---|
3130 | if (nodeheader_tag_p(tag)) { |
---|
3131 | start += ((elements+2) & ~1); |
---|
3132 | } else { |
---|
3133 | subtag = header_subtag(header); |
---|
3134 | |
---|
3135 | #ifdef X8664 |
---|
3136 | switch(fulltag_of(header)) { |
---|
3137 | case ivector_class_64_bit: |
---|
3138 | bytes = 8 + (elements<<3); |
---|
3139 | break; |
---|
3140 | case ivector_class_32_bit: |
---|
3141 | bytes = 8 + (elements<<2); |
---|
3142 | break; |
---|
3143 | case ivector_class_other_bit: |
---|
3144 | default: |
---|
3145 | if (subtag == subtag_bit_vector) { |
---|
3146 | bytes = 8 + ((elements+7)>>3); |
---|
3147 | } else if (subtag >= min_8_bit_ivector_subtag) { |
---|
3148 | bytes = 8 + elements; |
---|
3149 | } else { |
---|
3150 | bytes = 8 + (elements<<1); |
---|
3151 | } |
---|
3152 | } |
---|
3153 | #endif |
---|
3154 | #ifdef X8632 |
---|
3155 | if (subtag <= max_32_bit_ivector_subtag) { |
---|
3156 | bytes = 4 + (elements<<2); |
---|
3157 | } else if (subtag <= max_8_bit_ivector_subtag) { |
---|
3158 | bytes = 4 + elements; |
---|
3159 | } else if (subtag <= max_16_bit_ivector_subtag) { |
---|
3160 | bytes = 4 + (elements<<1); |
---|
3161 | } else if (subtag == subtag_double_float_vector) { |
---|
3162 | bytes = 8 + (elements<<3); |
---|
3163 | } else { |
---|
3164 | bytes = 4 + ((elements+7)>>3); |
---|
3165 | } |
---|
3166 | #endif |
---|
3167 | |
---|
3168 | bytes = (bytes+dnode_size-1) & ~(dnode_size-1); |
---|
3169 | total += bytes; |
---|
3170 | start += (bytes >> node_shift); |
---|
3171 | } |
---|
3172 | } else { |
---|
3173 | start += 2; |
---|
3174 | } |
---|
3175 | } |
---|
3176 | return total; |
---|
3177 | } |
---|
3178 | |
---|
3179 | |
---|
3180 | /* |
---|
3181 | This assumes that it's getting called with a simple-{base,general}-string |
---|
3182 | or code vector as an argument and that there's room for the object in the |
---|
3183 | destination area. |
---|
3184 | */ |
---|
3185 | |
---|
3186 | |
---|
3187 | LispObj |
---|
3188 | purify_displaced_object(LispObj obj, area *dest, natural disp) |
---|
3189 | { |
---|
3190 | #ifdef X8664 |
---|
3191 | BytePtr |
---|
3192 | free = dest->active, |
---|
3193 | *old = (BytePtr *) ptr_from_lispobj(untag(obj)); |
---|
3194 | LispObj |
---|
3195 | header = header_of(obj), |
---|
3196 | new; |
---|
3197 | natural |
---|
3198 | subtag = header_subtag(header), |
---|
3199 | element_count = header_element_count(header), |
---|
3200 | physbytes; |
---|
3201 | |
---|
3202 | switch(subtag) { |
---|
3203 | case subtag_simple_base_string: |
---|
3204 | physbytes = node_size + (element_count << 2); |
---|
3205 | break; |
---|
3206 | |
---|
3207 | #ifndef X86 |
---|
3208 | case subtag_code_vector: |
---|
3209 | physbytes = node_size + (element_count << 2); |
---|
3210 | break; |
---|
3211 | #endif |
---|
3212 | |
---|
3213 | default: |
---|
3214 | Bug(NULL, "Can't purify object at 0x%08x", obj); |
---|
3215 | return obj; |
---|
3216 | } |
---|
3217 | physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1); |
---|
3218 | dest->active += physbytes; |
---|
3219 | |
---|
3220 | new = ptr_to_lispobj(free)+disp; |
---|
3221 | |
---|
3222 | memcpy(free, (BytePtr)old, physbytes); |
---|
3223 | /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ |
---|
3224 | /* Actually, it's best to always leave a trail, for two reasons. |
---|
3225 | a) We may be walking the same heap that we're leaving forwaring |
---|
3226 | pointers in, so we don't want garbage that we leave behind to |
---|
3227 | look like a header. |
---|
3228 | b) We'd like to be able to forward code-vector locatives, and |
---|
3229 | it's easiest to do so if we leave a {forward_marker, dnode_locative} |
---|
3230 | pair at every doubleword in the old vector. |
---|
3231 | */ |
---|
3232 | while(physbytes) { |
---|
3233 | *old++ = (BytePtr) forward_marker; |
---|
3234 | *old++ = (BytePtr) free; |
---|
3235 | free += dnode_size; |
---|
3236 | physbytes -= dnode_size; |
---|
3237 | } |
---|
3238 | return new; |
---|
3239 | #endif |
---|
3240 | } |
---|
3241 | |
---|
3242 | LispObj |
---|
3243 | purify_object(LispObj obj, area *dest) |
---|
3244 | { |
---|
3245 | return purify_displaced_object(obj, dest, fulltag_of(obj)); |
---|
3246 | } |
---|
3247 | |
---|
3248 | |
---|
3249 | #define FORWARD_ONLY 0 |
---|
3250 | #define COPY_CODE (1<<0) |
---|
3251 | #define COPY_STRINGS (1<<1) |
---|
3252 | |
---|
3253 | |
---|
3254 | /* |
---|
3255 | This may overestimate a bit, if the same symbol is accessible from multiple |
---|
3256 | packages. |
---|
3257 | */ |
---|
3258 | natural |
---|
3259 | interned_pname_bytes_in_range(LispObj *start, LispObj *end) |
---|
3260 | { |
---|
3261 | lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES)); |
---|
3262 | LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header; |
---|
3263 | package *p; |
---|
3264 | cons *c; |
---|
3265 | natural elements, i, nbytes = 0; |
---|
3266 | |
---|
3267 | #ifdef X8664 |
---|
3268 | while (fulltag_of(pkg_list) == fulltag_cons) { |
---|
3269 | c = (cons *) ptr_from_lispobj(untag(pkg_list)); |
---|
3270 | p = (package *) ptr_from_lispobj(untag(c->car)); |
---|
3271 | pkg_list = c->cdr; |
---|
3272 | c = (cons *) ptr_from_lispobj(untag(p->itab)); |
---|
3273 | htab = c->car; |
---|
3274 | elements = header_element_count(header_of(htab)); |
---|
3275 | for (i = 1; i<= elements; i++) { |
---|
3276 | obj = deref(htab,i); |
---|
3277 | if (fulltag_of(obj) == fulltag_symbol) { |
---|
3278 | rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); |
---|
3279 | pname = rawsym->pname; |
---|
3280 | |
---|
3281 | if ((pname >= (LispObj)start) && (pname < (LispObj)end)) { |
---|
3282 | pname_header = header_of(pname); |
---|
3283 | nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15); |
---|
3284 | } |
---|
3285 | } |
---|
3286 | } |
---|
3287 | c = (cons *) ptr_from_lispobj(untag(p->etab)); |
---|
3288 | htab = c->car; |
---|
3289 | elements = header_element_count(header_of(htab)); |
---|
3290 | for (i = 1; i<= elements; i++) { |
---|
3291 | obj = deref(htab,i); |
---|
3292 | if (fulltag_of(obj) == fulltag_symbol) { |
---|
3293 | rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); |
---|
3294 | pname = rawsym->pname; |
---|
3295 | |
---|
3296 | if ((pname >= (LispObj)start) && (pname < (LispObj)end)) { |
---|
3297 | pname_header = header_of(pname); |
---|
3298 | nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15); |
---|
3299 | } |
---|
3300 | } |
---|
3301 | } |
---|
3302 | } |
---|
3303 | #endif |
---|
3304 | return nbytes; |
---|
3305 | } |
---|
3306 | |
---|
3307 | Boolean |
---|
3308 | copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy) |
---|
3309 | { |
---|
3310 | LispObj obj = *ref, header, new; |
---|
3311 | natural tag = fulltag_of(obj), header_tag, header_subtag; |
---|
3312 | Boolean changed = false; |
---|
3313 | |
---|
3314 | #ifdef X8664 |
---|
3315 | if ((tag == fulltag_misc) && |
---|
3316 | (((BytePtr)ptr_from_lispobj(obj)) > low) && |
---|
3317 | (((BytePtr)ptr_from_lispobj(obj)) < high)) { |
---|
3318 | header = deref(obj, 0); |
---|
3319 | if (header == forward_marker) { /* already copied */ |
---|
3320 | *ref = (untag(deref(obj,1)) + tag); |
---|
3321 | changed = true; |
---|
3322 | } else { |
---|
3323 | header_tag = fulltag_of(header); |
---|
3324 | if (immheader_tag_p(header_tag)) { |
---|
3325 | header_subtag = header_subtag(header); |
---|
3326 | if ((what_to_copy & COPY_STRINGS) && |
---|
3327 | ((header_subtag == subtag_simple_base_string))) { |
---|
3328 | new = purify_object(obj, dest); |
---|
3329 | *ref = new; |
---|
3330 | changed = (new != obj); |
---|
3331 | } |
---|
3332 | } |
---|
3333 | } |
---|
3334 | } |
---|
3335 | #endif |
---|
3336 | return changed; |
---|
3337 | } |
---|
3338 | |
---|
3339 | |
---|
3340 | void purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) |
---|
3341 | { |
---|
3342 | while (start < end) { |
---|
3343 | copy_ivector_reference(start, low, high, to, what); |
---|
3344 | start++; |
---|
3345 | } |
---|
3346 | } |
---|
3347 | |
---|
3348 | void |
---|
3349 | purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) |
---|
3350 | { |
---|
3351 | LispObj header; |
---|
3352 | unsigned tag; |
---|
3353 | natural nwords; |
---|
3354 | hash_table_vector_header *hashp; |
---|
3355 | |
---|
3356 | while (start < end) { |
---|
3357 | header = *start; |
---|
3358 | if (header == forward_marker) { |
---|
3359 | start += 2; |
---|
3360 | } else { |
---|
3361 | tag = fulltag_of(header); |
---|
3362 | if (immheader_tag_p(tag)) { |
---|
3363 | start = (LispObj *)skip_over_ivector((natural)start, header); |
---|
3364 | } else if (nodeheader_tag_p(tag)) { |
---|
3365 | nwords = header_element_count(header); |
---|
3366 | nwords += (1 - (nwords&1)); |
---|
3367 | if ((header_subtag(header) == subtag_hash_vector) && |
---|
3368 | ((((hash_table_vector_header *)start)->flags) & |
---|
3369 | nhash_track_keys_mask)) { |
---|
3370 | natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
3371 | |
---|
3372 | hashp = (hash_table_vector_header *) start; |
---|
3373 | start++; |
---|
3374 | nwords -= skip; |
---|
3375 | while(skip--) { |
---|
3376 | copy_ivector_reference(start, low, high, to, what); |
---|
3377 | start++; |
---|
3378 | } |
---|
3379 | /* "nwords" is odd at this point: there are (floor nwords 2) |
---|
3380 | key/value pairs to look at, and then an extra word for |
---|
3381 | alignment. Process them two at a time, then bump "start" |
---|
3382 | past the alignment word. */ |
---|
3383 | nwords >>= 1; |
---|
3384 | while(nwords--) { |
---|
3385 | if (copy_ivector_reference(start, low, high, to, what) && hashp) { |
---|
3386 | hashp->flags |= nhash_key_moved_mask; |
---|
3387 | hashp = NULL; |
---|
3388 | } |
---|
3389 | start++; |
---|
3390 | copy_ivector_reference(start, low, high, to, what); |
---|
3391 | start++; |
---|
3392 | } |
---|
3393 | *start++ = 0; |
---|
3394 | } else { |
---|
3395 | if (header_subtag(header) == subtag_function) { |
---|
3396 | #ifdef X8632 |
---|
3397 | int skip = (unsigned short)(start[1]); |
---|
3398 | #else |
---|
3399 | int skip = (int)(start[1]); |
---|
3400 | #endif |
---|
3401 | start += skip; |
---|
3402 | nwords -= skip; |
---|
3403 | } |
---|
3404 | start++; |
---|
3405 | while(nwords--) { |
---|
3406 | copy_ivector_reference(start, low, high, to, what); |
---|
3407 | start++; |
---|
3408 | } |
---|
3409 | } |
---|
3410 | } else { |
---|
3411 | /* Not a header, just a cons cell */ |
---|
3412 | copy_ivector_reference(start, low, high, to, what); |
---|
3413 | start++; |
---|
3414 | copy_ivector_reference(start, low, high, to, what); |
---|
3415 | start++; |
---|
3416 | } |
---|
3417 | } |
---|
3418 | } |
---|
3419 | } |
---|
3420 | |
---|
3421 | /* Purify references from tstack areas */ |
---|
3422 | void |
---|
3423 | purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) |
---|
3424 | { |
---|
3425 | LispObj |
---|
3426 | *current, |
---|
3427 | *next, |
---|
3428 | *start = (LispObj *) (a->active), |
---|
3429 | *end = start, |
---|
3430 | *limit = (LispObj *) (a->high); |
---|
3431 | |
---|
3432 | for (current = start; |
---|
3433 | end != limit; |
---|
3434 | current = next) { |
---|
3435 | next = (LispObj *) ptr_from_lispobj(*current); |
---|
3436 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
3437 | if (current[1] == 0) { |
---|
3438 | purify_range(current+2, end, low, high, to, what); |
---|
3439 | } |
---|
3440 | } |
---|
3441 | } |
---|
3442 | |
---|
3443 | /* Purify a vstack area */ |
---|
3444 | void |
---|
3445 | purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) |
---|
3446 | { |
---|
3447 | LispObj |
---|
3448 | *p = (LispObj *) a->active, |
---|
3449 | *q = (LispObj *) a->high; |
---|
3450 | |
---|
3451 | purify_headerless_range(p, q, low, high, to, what); |
---|
3452 | } |
---|
3453 | |
---|
3454 | |
---|
3455 | void |
---|
3456 | purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what) |
---|
3457 | { |
---|
3458 | natural *regs = (natural *) xpGPRvector(xp); |
---|
3459 | |
---|
3460 | |
---|
3461 | #ifdef X8664 |
---|
3462 | copy_ivector_reference(&(regs[Iarg_z]), low, high, to, what); |
---|
3463 | copy_ivector_reference(&(regs[Iarg_y]), low, high, to, what); |
---|
3464 | copy_ivector_reference(&(regs[Iarg_x]), low, high, to, what); |
---|
3465 | copy_ivector_reference(&(regs[Isave3]), low, high, to, what); |
---|
3466 | copy_ivector_reference(&(regs[Isave2]), low, high, to, what); |
---|
3467 | copy_ivector_reference(&(regs[Isave1]), low, high, to, what); |
---|
3468 | copy_ivector_reference(&(regs[Isave0]), low, high, to, what); |
---|
3469 | copy_ivector_reference(&(regs[Ifn]), low, high, to, what); |
---|
3470 | copy_ivector_reference(&(regs[Itemp0]), low, high, to, what); |
---|
3471 | copy_ivector_reference(&(regs[Itemp1]), low, high, to, what); |
---|
3472 | copy_ivector_reference(&(regs[Itemp2]), low, high, to, what); |
---|
3473 | #if 0 |
---|
3474 | purify_locref(&(regs[Iip]), low, high, to, what); |
---|
3475 | #endif |
---|
3476 | #else |
---|
3477 | #endif |
---|
3478 | } |
---|
3479 | |
---|
3480 | void |
---|
3481 | purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) |
---|
3482 | { |
---|
3483 | natural n = tcr->tlb_limit; |
---|
3484 | LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); |
---|
3485 | |
---|
3486 | purify_range(start, end, low, high, to, what); |
---|
3487 | } |
---|
3488 | |
---|
3489 | void |
---|
3490 | purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) |
---|
3491 | { |
---|
3492 | xframe_list *xframes; |
---|
3493 | ExceptionInformation *xp; |
---|
3494 | |
---|
3495 | xp = tcr->gc_context; |
---|
3496 | if (xp) { |
---|
3497 | purify_xp(xp, low, high, to, what); |
---|
3498 | } |
---|
3499 | |
---|
3500 | for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { |
---|
3501 | purify_xp(xframes->curr, low, high, to, what); |
---|
3502 | } |
---|
3503 | } |
---|
3504 | |
---|
3505 | |
---|
3506 | void |
---|
3507 | purify_areas(BytePtr low, BytePtr high, area *target, int what) |
---|
3508 | { |
---|
3509 | area *next_area; |
---|
3510 | area_code code; |
---|
3511 | |
---|
3512 | for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { |
---|
3513 | switch (code) { |
---|
3514 | case AREA_TSTACK: |
---|
3515 | purify_tstack_area(next_area, low, high, target, what); |
---|
3516 | break; |
---|
3517 | |
---|
3518 | case AREA_VSTACK: |
---|
3519 | purify_vstack_area(next_area, low, high, target, what); |
---|
3520 | break; |
---|
3521 | |
---|
3522 | case AREA_CSTACK: |
---|
3523 | #ifdef PPC |
---|
3524 | purify_cstack_area(next_area, low, high, target, what); |
---|
3525 | #endif |
---|
3526 | break; |
---|
3527 | |
---|
3528 | case AREA_STATIC: |
---|
3529 | case AREA_DYNAMIC: |
---|
3530 | purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what); |
---|
3531 | break; |
---|
3532 | |
---|
3533 | default: |
---|
3534 | break; |
---|
3535 | } |
---|
3536 | } |
---|
3537 | } |
---|
3538 | |
---|
3539 | /* |
---|
3540 | So far, this is mostly for save_application's benefit. |
---|
3541 | We -should- be able to return to lisp code after doing this, |
---|
3542 | however. |
---|
3543 | |
---|
3544 | */ |
---|
3545 | |
---|
3546 | |
---|
3547 | int |
---|
3548 | purify(TCR *tcr, signed_natural param) |
---|
3549 | { |
---|
3550 | extern area *extend_readonly_area(unsigned); |
---|
3551 | area |
---|
3552 | *a = active_dynamic_area, |
---|
3553 | *new_pure_area; |
---|
3554 | |
---|
3555 | TCR *other_tcr; |
---|
3556 | natural max_pure_size; |
---|
3557 | OSErr err; |
---|
3558 | BytePtr new_pure_start; |
---|
3559 | |
---|
3560 | #ifdef X8664 |
---|
3561 | |
---|
3562 | max_pure_size = interned_pname_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), |
---|
3563 | (LispObj *) a->active); |
---|
3564 | new_pure_area = extend_readonly_area(max_pure_size); |
---|
3565 | if (new_pure_area) { |
---|
3566 | new_pure_start = new_pure_area->active; |
---|
3567 | lisp_global(IN_GC) = (1<<fixnumshift); |
---|
3568 | |
---|
3569 | /* |
---|
3570 | First, loop thru *all-packages* and purify the pnames of all |
---|
3571 | interned symbols. Then walk every place that could reference |
---|
3572 | a heap-allocated object (all_areas, the xframe_list) and |
---|
3573 | purify code_vectors (and update the odd case of a shared |
---|
3574 | reference to a pname.) |
---|
3575 | |
---|
3576 | Make the new_pure_area executable, just in case. |
---|
3577 | |
---|
3578 | Caller will typically GC again (and that should recover quite a bit of |
---|
3579 | the dynamic heap.) |
---|
3580 | */ |
---|
3581 | |
---|
3582 | { |
---|
3583 | lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES)); |
---|
3584 | LispObj pkg_list = rawsym->vcell, htab, obj; |
---|
3585 | package *p; |
---|
3586 | cons *c; |
---|
3587 | natural elements, i; |
---|
3588 | |
---|
3589 | while (fulltag_of(pkg_list) == fulltag_cons) { |
---|
3590 | c = (cons *) ptr_from_lispobj(untag(pkg_list)); |
---|
3591 | p = (package *) ptr_from_lispobj(untag(c->car)); |
---|
3592 | pkg_list = c->cdr; |
---|
3593 | c = (cons *) ptr_from_lispobj(untag(p->itab)); |
---|
3594 | htab = c->car; |
---|
3595 | elements = header_element_count(header_of(htab)); |
---|
3596 | for (i = 1; i<= elements; i++) { |
---|
3597 | obj = deref(htab,i); |
---|
3598 | if (fulltag_of(obj) == fulltag_symbol) { |
---|
3599 | rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); |
---|
3600 | copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); |
---|
3601 | } |
---|
3602 | } |
---|
3603 | c = (cons *) ptr_from_lispobj(untag(p->etab)); |
---|
3604 | htab = c->car; |
---|
3605 | elements = header_element_count(header_of(htab)); |
---|
3606 | for (i = 1; i<= elements; i++) { |
---|
3607 | obj = deref(htab,i); |
---|
3608 | if (fulltag_of(obj) == fulltag_symbol) { |
---|
3609 | rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); |
---|
3610 | copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); |
---|
3611 | } |
---|
3612 | } |
---|
3613 | } |
---|
3614 | } |
---|
3615 | |
---|
3616 | purify_areas(a->low, a->active, new_pure_area, FORWARD_ONLY); |
---|
3617 | |
---|
3618 | other_tcr = tcr; |
---|
3619 | do { |
---|
3620 | purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY); |
---|
3621 | purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY); |
---|
3622 | other_tcr = other_tcr->next; |
---|
3623 | } while (other_tcr != tcr); |
---|
3624 | |
---|
3625 | |
---|
3626 | { |
---|
3627 | natural puresize = (unsigned) (new_pure_area->active-new_pure_start); |
---|
3628 | if (puresize != 0) { |
---|
3629 | xMakeDataExecutable(new_pure_start, puresize); |
---|
3630 | |
---|
3631 | } |
---|
3632 | } |
---|
3633 | ProtectMemory(new_pure_area->low, |
---|
3634 | align_to_power_of_2(new_pure_area->active-new_pure_area->low, |
---|
3635 | log2_page_size)); |
---|
3636 | lisp_global(IN_GC) = 0; |
---|
3637 | just_purified_p = true; |
---|
3638 | return 0; |
---|
3639 | } |
---|
3640 | #endif |
---|
3641 | return -1; |
---|
3642 | } |
---|
3643 | |
---|
3644 | |
---|
3645 | |
---|
3646 | Boolean |
---|
3647 | impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta) |
---|
3648 | { |
---|
3649 | LispObj q = *p; |
---|
3650 | |
---|
3651 | if (is_node_fulltag(fulltag_of(q)) && |
---|
3652 | (q >= low) && |
---|
3653 | (q < high)) { |
---|
3654 | *p = (q+delta); |
---|
3655 | return true; |
---|
3656 | } |
---|
3657 | return false; |
---|
3658 | } |
---|
3659 | |
---|
3660 | |
---|
3661 | |
---|
3662 | void |
---|
3663 | impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta) |
---|
3664 | { |
---|
3665 | natural *regs = (natural *) xpGPRvector(xp); |
---|
3666 | |
---|
3667 | |
---|
3668 | #ifdef X8664 |
---|
3669 | impurify_noderef(&(regs[Iarg_z]), low, high, delta); |
---|
3670 | impurify_noderef(&(regs[Iarg_y]), low, high, delta); |
---|
3671 | impurify_noderef(&(regs[Iarg_x]), low, high, delta); |
---|
3672 | impurify_noderef(&(regs[Isave3]), low, high, delta); |
---|
3673 | impurify_noderef(&(regs[Isave2]), low, high, delta); |
---|
3674 | impurify_noderef(&(regs[Isave1]), low, high, delta); |
---|
3675 | impurify_noderef(&(regs[Isave0]), low, high, delta); |
---|
3676 | impurify_noderef(&(regs[Ifn]), low, high, delta); |
---|
3677 | impurify_noderef(&(regs[Itemp0]), low, high, delta); |
---|
3678 | impurify_noderef(&(regs[Itemp1]), low, high, delta); |
---|
3679 | #if 0 |
---|
3680 | impurify_locref(&(regs[Iip]), low, high, delta); |
---|
3681 | #endif |
---|
3682 | #else |
---|
3683 | #endif |
---|
3684 | |
---|
3685 | } |
---|
3686 | |
---|
3687 | void |
---|
3688 | impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta) |
---|
3689 | { |
---|
3690 | while (start < end) { |
---|
3691 | impurify_noderef(start, low, high, delta); |
---|
3692 | start++; |
---|
3693 | } |
---|
3694 | } |
---|
3695 | |
---|
3696 | |
---|
3697 | void |
---|
3698 | impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta) |
---|
3699 | { |
---|
3700 | #ifdef X8664 |
---|
3701 | |
---|
3702 | LispObj header; |
---|
3703 | unsigned tag; |
---|
3704 | natural nwords; |
---|
3705 | hash_table_vector_header *hashp; |
---|
3706 | |
---|
3707 | while (start < end) { |
---|
3708 | header = *start; |
---|
3709 | if (header == forward_marker) { |
---|
3710 | start += 2; |
---|
3711 | } else { |
---|
3712 | tag = fulltag_of(header); |
---|
3713 | if (immheader_tag_p(tag)) { |
---|
3714 | start = (LispObj *)skip_over_ivector((natural)start, header); |
---|
3715 | } else if (nodeheader_tag_p(tag)) { |
---|
3716 | nwords = header_element_count(header); |
---|
3717 | nwords += (1 - (nwords&1)); |
---|
3718 | if ((header_subtag(header) == subtag_hash_vector) && |
---|
3719 | ((((hash_table_vector_header *)start)->flags) & |
---|
3720 | nhash_track_keys_mask)) { |
---|
3721 | natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; |
---|
3722 | |
---|
3723 | hashp = (hash_table_vector_header *) start; |
---|
3724 | start++; |
---|
3725 | nwords -= skip; |
---|
3726 | while(skip--) { |
---|
3727 | impurify_noderef(start, low, high, delta); |
---|
3728 | start++; |
---|
3729 | } |
---|
3730 | /* "nwords" is odd at this point: there are (floor nwords 2) |
---|
3731 | key/value pairs to look at, and then an extra word for |
---|
3732 | alignment. Process them two at a time, then bump "start" |
---|
3733 | past the alignment word. */ |
---|
3734 | nwords >>= 1; |
---|
3735 | while(nwords--) { |
---|
3736 | if (impurify_noderef(start, low, high, delta) && hashp) { |
---|
3737 | hashp->flags |= nhash_key_moved_mask; |
---|
3738 | hashp = NULL; |
---|
3739 | } |
---|
3740 | start++; |
---|
3741 | impurify_noderef(start, low, high, delta); |
---|
3742 | start++; |
---|
3743 | } |
---|
3744 | *start++ = 0; |
---|
3745 | } else { |
---|
3746 | if (header_subtag(header) == subtag_function) { |
---|
3747 | int skip = (int)(start[1]); |
---|
3748 | start += skip; |
---|
3749 | nwords -= skip; |
---|
3750 | } |
---|
3751 | start++; |
---|
3752 | while(nwords--) { |
---|
3753 | impurify_noderef(start, low, high, delta); |
---|
3754 | start++; |
---|
3755 | } |
---|
3756 | } |
---|
3757 | } else { |
---|
3758 | /* Not a header, just a cons cell */ |
---|
3759 | impurify_noderef(start, low, high, delta); |
---|
3760 | start++; |
---|
3761 | impurify_noderef(start, low, high, delta); |
---|
3762 | start++; |
---|
3763 | } |
---|
3764 | } |
---|
3765 | } |
---|
3766 | #endif |
---|
3767 | } |
---|
3768 | |
---|
3769 | |
---|
3770 | |
---|
3771 | |
---|
3772 | void |
---|
3773 | impurify_tcr_tlb(TCR *tcr, LispObj low, LispObj high, int delta) |
---|
3774 | { |
---|
3775 | unsigned n = tcr->tlb_limit; |
---|
3776 | LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); |
---|
3777 | |
---|
3778 | impurify_range(start, end, low, high, delta); |
---|
3779 | } |
---|
3780 | |
---|
3781 | void |
---|
3782 | impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta) |
---|
3783 | { |
---|
3784 | xframe_list *xframes; |
---|
3785 | ExceptionInformation *xp; |
---|
3786 | |
---|
3787 | xp = tcr->gc_context; |
---|
3788 | if (xp) { |
---|
3789 | impurify_xp(xp, low, high, delta); |
---|
3790 | } |
---|
3791 | |
---|
3792 | for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { |
---|
3793 | impurify_xp(xframes->curr, low, high, delta); |
---|
3794 | } |
---|
3795 | } |
---|
3796 | |
---|
3797 | void |
---|
3798 | impurify_tstack_area(area *a, LispObj low, LispObj high, int delta) |
---|
3799 | { |
---|
3800 | LispObj |
---|
3801 | *current, |
---|
3802 | *next, |
---|
3803 | *start = (LispObj *) (a->active), |
---|
3804 | *end = start, |
---|
3805 | *limit = (LispObj *) (a->high); |
---|
3806 | |
---|
3807 | for (current = start; |
---|
3808 | end != limit; |
---|
3809 | current = next) { |
---|
3810 | next = (LispObj *) ptr_from_lispobj(*current); |
---|
3811 | end = ((next >= start) && (next < limit)) ? next : limit; |
---|
3812 | if (current[1] == 0) { |
---|
3813 | impurify_range(current+2, end, low, high, delta); |
---|
3814 | } |
---|
3815 | } |
---|
3816 | } |
---|
3817 | void |
---|
3818 | impurify_vstack_area(area *a, LispObj low, LispObj high, int delta) |
---|
3819 | { |
---|
3820 | LispObj |
---|
3821 | *p = (LispObj *) a->active, |
---|
3822 | *q = (LispObj *) a->high; |
---|
3823 | |
---|
3824 | impurify_headerless_range(p, q, low, high, delta); |
---|
3825 | } |
---|
3826 | |
---|
3827 | |
---|
3828 | void |
---|
3829 | impurify_areas(LispObj low, LispObj high, int delta) |
---|
3830 | { |
---|
3831 | area *next_area; |
---|
3832 | area_code code; |
---|
3833 | |
---|
3834 | for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { |
---|
3835 | switch (code) { |
---|
3836 | case AREA_TSTACK: |
---|
3837 | impurify_tstack_area(next_area, low, high, delta); |
---|
3838 | break; |
---|
3839 | |
---|
3840 | case AREA_VSTACK: |
---|
3841 | impurify_vstack_area(next_area, low, high, delta); |
---|
3842 | break; |
---|
3843 | |
---|
3844 | case AREA_CSTACK: |
---|
3845 | #ifdef PPC |
---|
3846 | impurify_cstack_area(next_area, low, high, delta); |
---|
3847 | #endif |
---|
3848 | break; |
---|
3849 | |
---|
3850 | case AREA_STATIC: |
---|
3851 | case AREA_DYNAMIC: |
---|
3852 | impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta); |
---|
3853 | break; |
---|
3854 | |
---|
3855 | default: |
---|
3856 | break; |
---|
3857 | } |
---|
3858 | } |
---|
3859 | } |
---|
3860 | |
---|
3861 | int |
---|
3862 | impurify(TCR *tcr, signed_natural param) |
---|
3863 | { |
---|
3864 | area *r = find_readonly_area(); |
---|
3865 | |
---|
3866 | if (r) { |
---|
3867 | area *a = active_dynamic_area; |
---|
3868 | BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active, |
---|
3869 | oldhigh = a->high, newhigh; |
---|
3870 | unsigned n = ro_limit - ro_base; |
---|
3871 | int delta = oldfree-ro_base; |
---|
3872 | TCR *other_tcr; |
---|
3873 | |
---|
3874 | if (n) { |
---|
3875 | lisp_global(IN_GC) = 1; |
---|
3876 | newhigh = (BytePtr) (align_to_power_of_2(oldfree+n, |
---|
3877 | log2_heap_segment_size)); |
---|
3878 | if (newhigh > oldhigh) { |
---|
3879 | grow_dynamic_area(newhigh-oldhigh); |
---|
3880 | } |
---|
3881 | a->active += n; |
---|
3882 | bcopy(ro_base, oldfree, n); |
---|
3883 | munmap((void *)ro_base, n); |
---|
3884 | a->ndnodes = area_dnode(a, a->active); |
---|
3885 | pure_space_active = r->active = r->low; |
---|
3886 | r->ndnodes = 0; |
---|
3887 | |
---|
3888 | impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
3889 | |
---|
3890 | other_tcr = tcr; |
---|
3891 | do { |
---|
3892 | impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
3893 | impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); |
---|
3894 | other_tcr = other_tcr->next; |
---|
3895 | } while (other_tcr != tcr); |
---|
3896 | lisp_global(IN_GC) = 0; |
---|
3897 | } |
---|
3898 | return 0; |
---|
3899 | } |
---|
3900 | return -1; |
---|
3901 | } |
---|
3902 | |
---|
3903 | |
---|
3904 | void |
---|
3905 | adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta) |
---|
3906 | { |
---|
3907 | LispObj p = *loc; |
---|
3908 | |
---|
3909 | if (area_dnode(p, base) < limit) { |
---|
3910 | *loc = p+delta; |
---|
3911 | } |
---|
3912 | } |
---|
3913 | |
---|
3914 | /* like adjust_locref() above, but only changes the contents of LOC if it's |
---|
3915 | a tagged lisp pointer */ |
---|
3916 | void |
---|
3917 | adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta) |
---|
3918 | { |
---|
3919 | LispObj p = *loc; |
---|
3920 | int tag_n = fulltag_of(p); |
---|
3921 | |
---|
3922 | if (is_node_fulltag(tag_n)) { |
---|
3923 | if (area_dnode(p, base) < limit) { |
---|
3924 | *loc = p+delta; |
---|
3925 | } |
---|
3926 | } |
---|
3927 | } |
---|
3928 | |
---|
3929 | /* |
---|
3930 | If *loc is a tagged pointer into the address range denoted by BASE and LIMIT, |
---|
3931 | nuke it (set it to NIL.) |
---|
3932 | */ |
---|
3933 | void |
---|
3934 | nuke_noderef(LispObj *loc, LispObj base, LispObj limit) |
---|
3935 | { |
---|
3936 | LispObj p = *loc; |
---|
3937 | int tag_n = fulltag_of(p); |
---|
3938 | |
---|
3939 | if (is_node_fulltag(tag_n)) { |
---|
3940 | if (area_dnode(p, base) < limit) { |
---|
3941 | *loc = lisp_nil; |
---|
3942 | } |
---|
3943 | } |
---|
3944 | } |
---|
3945 | |
---|
3946 | |
---|
3947 | void |
---|
3948 | adjust_pointers_in_xp(ExceptionInformation *xp, |
---|
3949 | LispObj base, |
---|
3950 | LispObj limit, |
---|
3951 | signed_natural delta) |
---|
3952 | { |
---|
3953 | natural *regs = (natural *) xpGPRvector(xp); |
---|
3954 | |
---|
3955 | #ifdef X8664 |
---|
3956 | adjust_noderef((LispObj *) (&(regs[Iarg_z])),base,limit,delta); |
---|
3957 | adjust_noderef((LispObj *) (&(regs[Iarg_y])),base,limit,delta); |
---|
3958 | adjust_noderef((LispObj *) (&(regs[Iarg_x])),base,limit,delta); |
---|
3959 | adjust_noderef((LispObj *) (&(regs[Isave3])),base,limit,delta); |
---|
3960 | adjust_noderef((LispObj *) (&(regs[Isave2])),base,limit,delta); |
---|
3961 | adjust_noderef((LispObj *) (&(regs[Isave1])),base,limit,delta); |
---|
3962 | adjust_noderef((LispObj *) (&(regs[Isave0])),base,limit,delta); |
---|
3963 | adjust_noderef((LispObj *) (&(regs[Ifn])),base,limit,delta); |
---|
3964 | adjust_noderef((LispObj *) (&(regs[Itemp0])),base,limit,delta); |
---|
3965 | adjust_noderef((LispObj *) (&(regs[Itemp1])),base,limit,delta); |
---|
3966 | adjust_noderef((LispObj *) (&(regs[Itemp2])),base,limit,delta); |
---|
3967 | adjust_locref((LispObj *) (&(xpPC(xp))),base,limit,delta); |
---|
3968 | #endif |
---|
3969 | } |
---|
3970 | |
---|
3971 | void |
---|
3972 | nuke_pointers_in_xp(ExceptionInformation *xp, |
---|
3973 | LispObj base, |
---|
3974 | LispObj limit) |
---|
3975 | { |
---|
3976 | natural *regs = (natural *) xpGPRvector(xp); |
---|
3977 | |
---|
3978 | #ifdef X8664 |
---|
3979 | nuke_noderef((LispObj *) (&(regs[Iarg_z])),base,limit); |
---|
3980 | nuke_noderef((LispObj *) (&(regs[Iarg_y])),base,limit); |
---|
3981 | nuke_noderef((LispObj *) (&(regs[Iarg_x])),base,limit); |
---|
3982 | nuke_noderef((LispObj *) (&(regs[Isave3])),base,limit); |
---|
3983 | nuke_noderef((LispObj *) (&(regs[Isave2])),base,limit); |
---|
3984 | nuke_noderef((LispObj *) (&(regs[Isave1])),base,limit); |
---|
3985 | nuke_noderef((LispObj *) (&(regs[Isave0])),base,limit); |
---|
3986 | nuke_noderef((LispObj *) (&(regs[Ifn])),base,limit); |
---|
3987 | nuke_noderef((LispObj *) (&(regs[Itemp0])),base,limit); |
---|
3988 | nuke_noderef((LispObj *) (&(regs[Itemp1])),base,limit); |
---|
3989 | nuke_noderef((LispObj *) (&(regs[Itemp2])),base,limit); |
---|
3990 | #endif |
---|
3991 | } |
---|
3992 | |
---|
3993 | void |
---|
3994 | adjust_pointers_in_headerless_range(LispObj *range_start, |
---|
3995 | LispObj *range_end, |
---|
3996 | LispObj base, |
---|
3997 | LispObj limit, |
---|
3998 | signed_natural delta) |
---|
3999 | { |
---|
4000 | LispObj *p = range_start; |
---|
4001 | |
---|
4002 | while (p < range_end) { |
---|
4003 | adjust_noderef(p, base, limit, delta); |
---|
4004 | p++; |
---|
4005 | } |
---|
4006 | } |
---|
4007 | |
---|
4008 | |
---|
4009 | void |
---|
4010 | adjust_pointers_in_range(LispObj *range_start, |
---|
4011 | LispObj *range_end, |
---|
4012 | LispObj base, |
---|
4013 | LispObj limit, |
---|
4014 | signed_natural delta) |
---|
4015 | { |
---|
4016 | LispObj *p = range_start, node, new; |
---|
4017 | int tag_n; |
---|
4018 | natural nwords; |
---|
4019 | hash_table_vector_header *hashp; |
---|
4020 | |
---|
4021 | while (p < range_end) { |
---|
4022 | node = *p; |
---|
4023 | tag_n = fulltag_of(node); |
---|
4024 | if (immheader_tag_p(tag_n)) { |
---|
4025 | p = (LispObj *) skip_over_ivector((natural) p, node); |
---|
4026 | } else if (nodeheader_tag_p(tag_n)) { |
---|
4027 | nwords = header_element_count(node); |
---|
4028 | nwords += (1 - (nwords&1)); |
---|
4029 | if ((header_subtag(node) == subtag_hash_vector) && |
---|
4030 | ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { |
---|
4031 | hashp = (hash_table_vector_header *) p; |
---|
4032 | hashp->flags |= nhash_key_moved_mask; |
---|
4033 | } else if (header_subtag(node) == subtag_function) { |
---|
4034 | int skip = (int)(p[1]); |
---|
4035 | p += skip; |
---|
4036 | nwords -= skip; |
---|
4037 | } |
---|
4038 | p++; |
---|
4039 | while (nwords--) { |
---|
4040 | adjust_noderef(p, base, limit, delta); |
---|
4041 | p++; |
---|
4042 | } |
---|
4043 | } else { |
---|
4044 | /* just a cons */ |
---|
4045 | adjust_noderef(p, base, limit, delta); |
---|
4046 | p++; |
---|
4047 | adjust_noderef(p, base, limit, delta); |
---|
4048 | p++; |
---|
4049 | } |
---|
4050 | } |
---|
4051 | } |
---|
4052 | |
---|
4053 | void |
---|
4054 | nuke_pointers_in_headerless_range(LispObj *range_start, |
---|
4055 | LispObj *range_end, |
---|
4056 | LispObj base, |
---|
4057 | LispObj limit) |
---|
4058 | { |
---|
4059 | LispObj *p = range_start; |
---|
4060 | |
---|
4061 | while (p < range_end) { |
---|
4062 | nuke_noderef(p, base, limit); |
---|
4063 | p++; |
---|
4064 | } |
---|
4065 | } |
---|
4066 | |
---|
4067 | |
---|
4068 | void |
---|
4069 | nuke_pointers_in_range(LispObj *range_start, |
---|
4070 | LispObj *range_end, |
---|
4071 | LispObj base, |
---|
4072 | LispObj limit) |
---|
4073 | { |
---|
4074 | LispObj *p = range_start, node, new; |
---|
4075 | int tag_n; |
---|
4076 | natural nwords; |
---|
4077 | |
---|
4078 | while (p < range_end) { |
---|
4079 | node = *p; |
---|
4080 | tag_n = fulltag_of(node); |
---|
4081 | if (immheader_tag_p(tag_n)) { |
---|
4082 | p = (LispObj *) skip_over_ivector((natural) p, node); |
---|
4083 | } else if (nodeheader_tag_p(tag_n)) { |
---|
4084 | nwords = header_element_count(node); |
---|
4085 | nwords += (1 - (nwords&1)); |
---|
4086 | if (header_subtag(node) == subtag_function) { |
---|
4087 | int skip = (int)(p[1]); |
---|
4088 | p += skip; |
---|
4089 | nwords -= skip; |
---|
4090 | } |
---|
4091 | p++; |
---|
4092 | while (nwords--) { |
---|
4093 | nuke_noderef(p, base, limit); |
---|
4094 | p++; |
---|
4095 | } |
---|
4096 | } else { |
---|
4097 | /* just a cons */ |
---|
4098 | nuke_noderef(p, base, limit); |
---|
4099 | p++; |
---|
4100 | nuke_noderef(p, base, limit); |
---|
4101 | p++; |
---|
4102 | } |
---|
4103 | } |
---|
4104 | } |
---|
4105 | |
---|
4106 | void |
---|
4107 | adjust_pointers_in_tstack_area(area *a, |
---|
4108 | LispObj base, |
---|
4109 | LispObj limit, |
---|
4110 | LispObj delta) |
---|
4111 | { |
---|
4112 | LispObj |
---|
4113 | *current, |
---|
4114 | *next, |
---|
4115 | *start = (LispObj *) a->active, |
---|
4116 | *end = start, |
---|
4117 | *area_limit = (LispObj *) (a->high); |
---|
4118 | |
---|
4119 | for (current = start; |
---|
4120 | end != area_limit; |
---|
4121 | current = next) { |
---|
4122 | next = ptr_from_lispobj(*current); |
---|
4123 | end = ((next >= start) && (next < area_limit)) ? next : area_limit; |
---|
4124 | adjust_pointers_in_range(current+2, end, base, limit, delta); |
---|
4125 | } |
---|
4126 | } |
---|
4127 | |
---|
4128 | void |
---|
4129 | nuke_pointers_in_tstack_area(area *a, |
---|
4130 | LispObj base, |
---|
4131 | LispObj limit) |
---|
4132 | { |
---|
4133 | LispObj |
---|
4134 | *current, |
---|
4135 | *next, |
---|
4136 | *start = (LispObj *) a->active, |
---|
4137 | *end = start, |
---|
4138 | *area_limit = (LispObj *) (a->high); |
---|
4139 | |
---|
4140 | for (current = start; |
---|
4141 | end != area_limit; |
---|
4142 | current = next) { |
---|
4143 | next = ptr_from_lispobj(*current); |
---|
4144 | end = ((next >= start) && (next < area_limit)) ? next : area_limit; |
---|
4145 | if (current[1] == 0) { |
---|
4146 | nuke_pointers_in_range(current+2, end, base, limit); |
---|
4147 | } |
---|
4148 | } |
---|
4149 | } |
---|
4150 | |
---|
4151 | void |
---|
4152 | adjust_pointers_in_vstack_area(area *a, |
---|
4153 | LispObj base, |
---|
4154 | LispObj limit, |
---|
4155 | LispObj delta) |
---|
4156 | { |
---|
4157 | LispObj |
---|
4158 | *p = (LispObj *) a->active, |
---|
4159 | *q = (LispObj *) a->high; |
---|
4160 | |
---|
4161 | adjust_pointers_in_headerless_range(p, q, base, limit, delta); |
---|
4162 | } |
---|
4163 | |
---|
4164 | void |
---|
4165 | nuke_pointers_in_vstack_area(area *a, |
---|
4166 | LispObj base, |
---|
4167 | LispObj limit) |
---|
4168 | { |
---|
4169 | LispObj |
---|
4170 | *p = (LispObj *) a->active, |
---|
4171 | *q = (LispObj *) a->high; |
---|
4172 | |
---|
4173 | nuke_pointers_in_headerless_range(p, q, base, limit); |
---|
4174 | } |
---|
4175 | |
---|
4176 | #ifdef PPC |
---|
4177 | void |
---|
4178 | adjust_pointers_in_cstack_area(area *a, |
---|
4179 | LispObj base, |
---|
4180 | LispObj limit, |
---|
4181 | LispObj delta) |
---|
4182 | { |
---|
4183 | BytePtr |
---|
4184 | current, |
---|
4185 | next, |
---|
4186 | area_limit = a->high, |
---|
4187 | low = a->low; |
---|
4188 | |
---|
4189 | for (current = a->active; (current >= low) && (current < area_limit); current = next) { |
---|
4190 | next = *((BytePtr *)current); |
---|
4191 | if (next == NULL) break; |
---|
4192 | if (((next - current) == sizeof(lisp_frame)) && |
---|
4193 | (((((lisp_frame *)current)->savefn) == 0) || |
---|
4194 | (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { |
---|
4195 | adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta); |
---|
4196 | adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta); |
---|
4197 | } |
---|
4198 | } |
---|
4199 | } |
---|
4200 | #endif |
---|
4201 | |
---|
4202 | |
---|
4203 | |
---|
4204 | void |
---|
4205 | adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta) |
---|
4206 | { |
---|
4207 | TCR *tcr = current; |
---|
4208 | xframe_list *xframes; |
---|
4209 | LispObj *tlb_start, *tlb_end; |
---|
4210 | ExceptionInformation *xp; |
---|
4211 | |
---|
4212 | do { |
---|
4213 | xp = tcr->gc_context; |
---|
4214 | if (xp) { |
---|
4215 | adjust_pointers_in_xp(xp, base, limit, delta); |
---|
4216 | } |
---|
4217 | for (xframes = (xframe_list *) tcr->xframe; |
---|
4218 | xframes; |
---|
4219 | xframes = xframes->prev) { |
---|
4220 | adjust_pointers_in_xp(xframes->curr, base, limit, delta); |
---|
4221 | } |
---|
4222 | adjust_pointers_in_range(tcr->tlb_pointer, |
---|
4223 | (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit), |
---|
4224 | base, |
---|
4225 | limit, |
---|
4226 | delta); |
---|
4227 | tcr = tcr->next; |
---|
4228 | } while (tcr != current); |
---|
4229 | } |
---|
4230 | |
---|
4231 | void |
---|
4232 | nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit) |
---|
4233 | { |
---|
4234 | TCR *tcr = current; |
---|
4235 | xframe_list *xframes; |
---|
4236 | LispObj *tlb_start, *tlb_end; |
---|
4237 | ExceptionInformation *xp; |
---|
4238 | |
---|
4239 | do { |
---|
4240 | xp = tcr->gc_context; |
---|
4241 | if (xp) { |
---|
4242 | nuke_pointers_in_xp(xp, base, limit); |
---|
4243 | } |
---|
4244 | for (xframes = (xframe_list *) tcr->xframe; |
---|
4245 | xframes; |
---|
4246 | xframes = xframes->prev) { |
---|
4247 | nuke_pointers_in_xp(xframes->curr, base, limit); |
---|
4248 | } |
---|
4249 | nuke_pointers_in_range(tcr->tlb_pointer, |
---|
4250 | (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit), |
---|
4251 | base, |
---|
4252 | limit); |
---|
4253 | tcr = tcr->next; |
---|
4254 | } while (tcr != current); |
---|
4255 | } |
---|
4256 | |
---|
4257 | void |
---|
4258 | adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta) |
---|
4259 | { |
---|
4260 | /* These need to be special-cased, because xmacptrs are immediate |
---|
4261 | objects that contain (in their "link" fields") tagged pointers |
---|
4262 | to other xmacptrs */ |
---|
4263 | LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; |
---|
4264 | |
---|
4265 | while ((next = *prev) != (LispObj)NULL) { |
---|
4266 | adjust_noderef(prev, base, limit, delta); |
---|
4267 | if (delta < 0) { |
---|
4268 | /* Assume that we've already moved things */ |
---|
4269 | next = *prev; |
---|
4270 | } |
---|
4271 | prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); |
---|
4272 | } |
---|
4273 | } |
---|
4274 | |
---|
4275 | |
---|
4276 | void |
---|
4277 | adjust_pointers_in_dynamic_area(area *a, |
---|
4278 | LispObj base, |
---|
4279 | LispObj limit, |
---|
4280 | signed_natural delta) |
---|
4281 | { |
---|
4282 | natural |
---|
4283 | nstatic = static_dnodes_for_area(a), |
---|
4284 | nstatic_bitmap_words = nstatic >> bitmap_shift; |
---|
4285 | LispObj |
---|
4286 | *low = (LispObj *) (a->low), |
---|
4287 | *active = (LispObj *) (a->active), |
---|
4288 | *dynamic_low = low + (2 * nstatic); |
---|
4289 | |
---|
4290 | adjust_pointers_in_range(dynamic_low, active, base, limit, delta); |
---|
4291 | |
---|
4292 | if (nstatic && (nstatic <= a->ndnodes)) { |
---|
4293 | cons *pagelet_start = (cons *) a->low, *work; |
---|
4294 | bitvector usedbits = tenured_area->static_used; |
---|
4295 | natural used, i; |
---|
4296 | |
---|
4297 | while (nstatic_bitmap_words--) { |
---|
4298 | used = *usedbits++; |
---|
4299 | |
---|
4300 | while (used) { |
---|
4301 | i = count_leading_zeros(used); |
---|
4302 | used &= ~(BIT0_MASK >> i); |
---|
4303 | work = pagelet_start+i; |
---|
4304 | adjust_noderef(&(work->cdr), base, limit, delta); |
---|
4305 | adjust_noderef(&(work->car), base, limit, delta); |
---|
4306 | } |
---|
4307 | pagelet_start += nbits_in_word; |
---|
4308 | } |
---|
4309 | } |
---|
4310 | } |
---|
4311 | |
---|
4312 | void |
---|
4313 | nuke_pointers_in_dynamic_area(area *a, |
---|
4314 | LispObj base, |
---|
4315 | LispObj limit) |
---|
4316 | { |
---|
4317 | natural |
---|
4318 | nstatic = static_dnodes_for_area(a), |
---|
4319 | nstatic_bitmap_words = nstatic >> bitmap_shift; |
---|
4320 | LispObj |
---|
4321 | *low = (LispObj *) (a->low), |
---|
4322 | *active = (LispObj *) (a->active), |
---|
4323 | *dynamic_low = low + (2 * nstatic); |
---|
4324 | |
---|
4325 | nuke_pointers_in_range(dynamic_low, active, base, limit); |
---|
4326 | |
---|
4327 | if (nstatic && (nstatic <= a->ndnodes)) { |
---|
4328 | cons *pagelet_start = (cons *) a->low, *work; |
---|
4329 | bitvector usedbits = tenured_area->static_used; |
---|
4330 | natural used, i; |
---|
4331 | |
---|
4332 | while (nstatic_bitmap_words--) { |
---|
4333 | used = *usedbits++; |
---|
4334 | |
---|
4335 | while (used) { |
---|
4336 | i = count_leading_zeros(used); |
---|
4337 | used &= ~(BIT0_MASK >> i); |
---|
4338 | work = pagelet_start+i; |
---|
4339 | nuke_noderef(&(work->cdr), base, limit); |
---|
4340 | nuke_noderef(&(work->car), base, limit); |
---|
4341 | } |
---|
4342 | pagelet_start += nbits_in_word; |
---|
4343 | } |
---|
4344 | } |
---|
4345 | } |
---|
4346 | |
---|
4347 | |
---|
4348 | void |
---|
4349 | adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta) |
---|
4350 | { |
---|
4351 | area *next_area; |
---|
4352 | area_code code; |
---|
4353 | |
---|
4354 | for (next_area = active_dynamic_area; |
---|
4355 | (code = next_area->code) != AREA_VOID; |
---|
4356 | next_area = next_area->succ) { |
---|
4357 | switch (code) { |
---|
4358 | case AREA_TSTACK: |
---|
4359 | adjust_pointers_in_tstack_area(next_area, base, limit, delta); |
---|
4360 | break; |
---|
4361 | |
---|
4362 | case AREA_VSTACK: |
---|
4363 | adjust_pointers_in_vstack_area(next_area, base, limit, delta); |
---|
4364 | break; |
---|
4365 | |
---|
4366 | case AREA_CSTACK: |
---|
4367 | #ifndef X86 |
---|
4368 | adjust_pointers_in_cstack_area(next_area, base, limit, delta); |
---|
4369 | #endif |
---|
4370 | break; |
---|
4371 | |
---|
4372 | case AREA_STATIC: |
---|
4373 | case AREA_MANAGED_STATIC: |
---|
4374 | adjust_pointers_in_range((LispObj *) (next_area->low), |
---|
4375 | (LispObj *) (next_area->active), |
---|
4376 | base, |
---|
4377 | limit, |
---|
4378 | delta); |
---|
4379 | break; |
---|
4380 | |
---|
4381 | case AREA_DYNAMIC: |
---|
4382 | adjust_pointers_in_dynamic_area(next_area, base, limit, delta); |
---|
4383 | break; |
---|
4384 | } |
---|
4385 | } |
---|
4386 | adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta); |
---|
4387 | adjust_gcable_ptrs(base, limit, delta); |
---|
4388 | } |
---|
4389 | |
---|
4390 | void |
---|
4391 | nuke_all_pointers(LispObj base, LispObj limit) |
---|
4392 | { |
---|
4393 | area *next_area; |
---|
4394 | area_code code; |
---|
4395 | |
---|
4396 | for (next_area = active_dynamic_area; |
---|
4397 | (code = next_area->code) != AREA_VOID; |
---|
4398 | next_area = next_area->succ) { |
---|
4399 | switch (code) { |
---|
4400 | case AREA_TSTACK: |
---|
4401 | nuke_pointers_in_tstack_area(next_area, base, limit); |
---|
4402 | break; |
---|
4403 | |
---|
4404 | case AREA_VSTACK: |
---|
4405 | nuke_pointers_in_vstack_area(next_area, base, limit); |
---|
4406 | break; |
---|
4407 | |
---|
4408 | case AREA_CSTACK: |
---|
4409 | /* There aren't any "nukable" pointers in a cstack area */ |
---|
4410 | break; |
---|
4411 | |
---|
4412 | case AREA_STATIC: |
---|
4413 | case AREA_MANAGED_STATIC: |
---|
4414 | nuke_pointers_in_range((LispObj *) (next_area->low), |
---|
4415 | (LispObj *) (next_area->active), |
---|
4416 | base, |
---|
4417 | limit); |
---|
4418 | break; |
---|
4419 | |
---|
4420 | case AREA_DYNAMIC: |
---|
4421 | nuke_pointers_in_dynamic_area(next_area, base, limit); |
---|
4422 | break; |
---|
4423 | } |
---|
4424 | } |
---|
4425 | nuke_pointers_in_tcrs(get_tcr(false), base, limit); |
---|
4426 | } |
---|
4427 | |
---|
4428 | #ifndef MREMAP_MAYMOVE |
---|
4429 | #define MREMAP_MAYMOVE 1 |
---|
4430 | #endif |
---|
4431 | |
---|
4432 | #if defined(FREEBSD) || defined(SOLARIS) |
---|
4433 | void * |
---|
4434 | freebsd_mremap(void *old_address, |
---|
4435 | size_t old_size, |
---|
4436 | size_t new_size, |
---|
4437 | unsigned long flags) |
---|
4438 | { |
---|
4439 | return old_address; |
---|
4440 | } |
---|
4441 | #define mremap freebsd_mremap |
---|
4442 | |
---|
4443 | #endif |
---|
4444 | |
---|
4445 | #ifdef DARWIN |
---|
4446 | void * |
---|
4447 | darwin_mremap(void *old_address, |
---|
4448 | size_t old_size, |
---|
4449 | size_t new_size, |
---|
4450 | unsigned long flags) |
---|
4451 | { |
---|
4452 | void *end = (void *) ((char *)old_address+old_size); |
---|
4453 | |
---|
4454 | if (old_size == new_size) { |
---|
4455 | return old_address; |
---|
4456 | } |
---|
4457 | if (new_size < old_size) { |
---|
4458 | munmap(end, old_size-new_size); |
---|
4459 | return old_address; |
---|
4460 | } |
---|
4461 | { |
---|
4462 | void * new_address = mmap(NULL, |
---|
4463 | new_size, |
---|
4464 | PROT_READ|PROT_WRITE, |
---|
4465 | MAP_PRIVATE | MAP_ANON, |
---|
4466 | -1, |
---|
4467 | 0); |
---|
4468 | if (new_address != MAP_FAILED) { |
---|
4469 | vm_copy(mach_task_self(), |
---|
4470 | (vm_address_t)old_address, |
---|
4471 | old_size, |
---|
4472 | (vm_address_t)new_address); |
---|
4473 | munmap(old_address, old_size); |
---|
4474 | } |
---|
4475 | return new_address; |
---|
4476 | } |
---|
4477 | } |
---|
4478 | |
---|
4479 | #define mremap darwin_mremap |
---|
4480 | #endif |
---|
4481 | |
---|
4482 | Boolean |
---|
4483 | resize_used_bitvector(natural new_dnodes, bitvector *newbits) |
---|
4484 | { |
---|
4485 | natural |
---|
4486 | old_dnodes = tenured_area->static_dnodes, |
---|
4487 | old_page_aligned_size = |
---|
4488 | (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3), |
---|
4489 | log2_page_size)), |
---|
4490 | new_page_aligned_size = |
---|
4491 | (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3), |
---|
4492 | log2_page_size)); |
---|
4493 | bitvector old_used = tenured_area->static_used, new_used = NULL; |
---|
4494 | |
---|
4495 | if (old_page_aligned_size == new_page_aligned_size) { |
---|
4496 | *newbits = old_used; |
---|
4497 | return true; |
---|
4498 | } |
---|
4499 | |
---|
4500 | if (old_used == NULL) { |
---|
4501 | new_used = (bitvector)mmap(NULL, |
---|
4502 | new_page_aligned_size, |
---|
4503 | PROT_READ|PROT_WRITE, |
---|
4504 | MAP_PRIVATE | MAP_ANON, |
---|
4505 | -1, |
---|
4506 | 0); |
---|
4507 | if (new_used == MAP_FAILED) { |
---|
4508 | *newbits = NULL; |
---|
4509 | return false; |
---|
4510 | } else { |
---|
4511 | *newbits = new_used; |
---|
4512 | return true; |
---|
4513 | } |
---|
4514 | } |
---|
4515 | if (new_page_aligned_size == 0) { |
---|
4516 | munmap((void *)old_used, old_page_aligned_size); |
---|
4517 | *newbits = NULL; |
---|
4518 | return true; |
---|
4519 | } |
---|
4520 | |
---|
4521 | /* Have to try to remap the old bitmap. That's implementation-dependent, |
---|
4522 | and (naturally) Mach sucks, but no one understands how. |
---|
4523 | */ |
---|
4524 | new_used = mremap(old_used, |
---|
4525 | old_page_aligned_size, |
---|
4526 | new_page_aligned_size, |
---|
4527 | MREMAP_MAYMOVE); |
---|
4528 | if (new_used == MAP_FAILED) { |
---|
4529 | *newbits = NULL; |
---|
4530 | return false; |
---|
4531 | } |
---|
4532 | *newbits = new_used; |
---|
4533 | return true; |
---|
4534 | } |
---|
4535 | |
---|
4536 | |
---|
4537 | int |
---|
4538 | grow_hons_area(signed_natural delta_in_bytes) |
---|
4539 | { |
---|
4540 | bitvector new_used; |
---|
4541 | area *ada = active_dynamic_area; |
---|
4542 | natural |
---|
4543 | delta_in_dnodes = delta_in_bytes >> dnode_shift, |
---|
4544 | current_static_dnodes = tenured_area->static_dnodes, |
---|
4545 | new_static_dnodes; |
---|
4546 | |
---|
4547 | delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word); |
---|
4548 | new_static_dnodes = current_static_dnodes+delta_in_dnodes; |
---|
4549 | delta_in_bytes = delta_in_dnodes << dnode_shift; |
---|
4550 | if (grow_dynamic_area((natural) delta_in_bytes)) { |
---|
4551 | LispObj |
---|
4552 | base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)), |
---|
4553 | oldactive = (LispObj) ada->active, |
---|
4554 | limit = area_dnode(oldactive, base); |
---|
4555 | if (!resize_used_bitvector(new_static_dnodes, &new_used)) { |
---|
4556 | shrink_dynamic_area(delta_in_bytes); |
---|
4557 | return -1; |
---|
4558 | } |
---|
4559 | tenured_area->static_used = new_used; |
---|
4560 | adjust_all_pointers(base, limit, delta_in_bytes); |
---|
4561 | memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base); |
---|
4562 | ada->ndnodes = area_dnode(ada->high, ada->low); |
---|
4563 | ada->active += delta_in_bytes; |
---|
4564 | { |
---|
4565 | LispObj *p; |
---|
4566 | natural i; |
---|
4567 | for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0; |
---|
4568 | i< delta_in_dnodes; |
---|
4569 | i++ ) { |
---|
4570 | *p++ = undefined; |
---|
4571 | *p++ = undefined; |
---|
4572 | } |
---|
4573 | tenured_area->static_dnodes += delta_in_dnodes; |
---|
4574 | |
---|
4575 | } |
---|
4576 | return 0; |
---|
4577 | } |
---|
4578 | return -1; |
---|
4579 | } |
---|
4580 | |
---|
4581 | int |
---|
4582 | shrink_hons_area(signed_natural delta_in_bytes) |
---|
4583 | { |
---|
4584 | area *ada = active_dynamic_area; |
---|
4585 | signed_natural |
---|
4586 | delta_in_dnodes = delta_in_bytes >> dnode_shift; |
---|
4587 | natural |
---|
4588 | current_static_dnodes = tenured_area->static_dnodes, |
---|
4589 | new_static_dnodes; |
---|
4590 | LispObj base, limit, oldactive; |
---|
4591 | bitvector newbits; |
---|
4592 | |
---|
4593 | |
---|
4594 | delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word); |
---|
4595 | new_static_dnodes = current_static_dnodes+delta_in_dnodes; |
---|
4596 | delta_in_bytes = delta_in_dnodes << dnode_shift; |
---|
4597 | oldactive = (LispObj) (ada->active); |
---|
4598 | |
---|
4599 | resize_used_bitvector(new_static_dnodes, &newbits); |
---|
4600 | tenured_area->static_used = newbits; /* redundant */ |
---|
4601 | |
---|
4602 | memmove(ada->low+(new_static_dnodes << dnode_shift), |
---|
4603 | ada->low+(current_static_dnodes << dnode_shift), |
---|
4604 | oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift))); |
---|
4605 | tenured_area->static_dnodes = new_static_dnodes; |
---|
4606 | ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */ |
---|
4607 | shrink_dynamic_area(-delta_in_bytes); |
---|
4608 | |
---|
4609 | base = (LispObj) (tenured_area->low + |
---|
4610 | (new_static_dnodes << dnode_shift)); |
---|
4611 | limit = area_dnode(tenured_area->low + |
---|
4612 | (current_static_dnodes << dnode_shift), base); |
---|
4613 | nuke_all_pointers(base, limit); |
---|
4614 | |
---|
4615 | base = (LispObj) (tenured_area->low + |
---|
4616 | (current_static_dnodes << dnode_shift)); |
---|
4617 | limit = area_dnode(oldactive, base); |
---|
4618 | adjust_all_pointers(base, limit, delta_in_bytes); |
---|
4619 | |
---|
4620 | xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift), |
---|
4621 | ada->active-(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift))); |
---|
4622 | return 0; |
---|
4623 | } |
---|
4624 | |
---|
4625 | int |
---|
4626 | change_hons_area_size(TCR *tcr, signed_natural delta_in_bytes) |
---|
4627 | { |
---|
4628 | if (delta_in_bytes > 0) { |
---|
4629 | return grow_hons_area(delta_in_bytes); |
---|
4630 | } |
---|
4631 | if (delta_in_bytes < 0) { |
---|
4632 | return shrink_hons_area(delta_in_bytes); |
---|
4633 | } |
---|
4634 | return 0; |
---|
4635 | } |
---|
4636 | |
---|