/[cmucl]/src/lisp/purify.c
ViewVC logotype

Contents of /src/lisp/purify.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (show annotations)
Thu Jun 11 16:04:01 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, merged-unicode-utf16-extfmt-2009-06-11, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, portable-clx-import-2009-06-16, cross-sparc-branch-base, intl-branch-base, portable-clx-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.42: +10 -2 lines
File MIME type: text/plain
Merge Unicode work to trunk.  From label
unicode-utf16-extfmt-2009-06-11.
1 /* Purify.
2
3 This code is based on public domain codes from CMUCL. It is placed
4 in the public domain and is provided as-is.
5
6 Stack direction changes, the x86/CGC stack scavenging, and static
7 blue bag feature, by Paul Werkowski, 1995, 1996.
8
9 Bug fixes, x86 code movement support, the scavenger hook support,
10 and x86/GENCGC stack scavenging, by Douglas Crosher, 1996, 1997,
11 1998.
12
13 $Header: /tiger/var/lib/cvsroots/cmucl/src/lisp/purify.c,v 1.43 2009/06/11 16:04:01 rtoy Rel $
14
15 */
16 #include <stdio.h>
17 #include <sys/types.h>
18 #include <stdlib.h>
19 #include <string.h>
20
21 #include "lisp.h"
22 #include "arch.h"
23 #include "os.h"
24 #include "internals.h"
25 #include "globals.h"
26 #include "validate.h"
27 #include "interrupt.h"
28 #include "purify.h"
29 #include "interr.h"
30 #ifdef GENCGC
31 #include "gencgc.h"
32 #endif
33
34 #undef PRINTNOISE
35
36 #if (defined(i386) || defined(__x86_64))
37 static lispobj *current_dynamic_space_free_pointer;
38 #endif
39
40 #define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
41 __FILE__, __LINE__)
42
43 #if 1
44 #define gc_assert(ex) do { \
45 if (!(ex)) gc_abort(); \
46 } while (0)
47 #else
48 #define gc_assert(ex)
49 #endif
50
51
52 #define assert_static_space_bounds(ptr) do { \
53 if (!((lispobj*)STATIC_SPACE_START <= ptr && ptr < (lispobj*)(STATIC_SPACE_START + STATIC_SPACE_SIZE))) \
54 lose ("static-space overflow! File \"%s\", line %d\n", \
55 __FILE__, __LINE__); \
56 } while (0)
57
58 #define assert_readonly_space_bounds(ptr) do { \
59 if (!((lispobj*)READ_ONLY_SPACE_START <= ptr && ptr < (lispobj*)(READ_ONLY_SPACE_START + READ_ONLY_SPACE_SIZE))) \
60 lose ("readonly-space overflow! File \"%s\", line %d\n", \
61 __FILE__, __LINE__); \
62 } while (0)
63
64
65
66 /* These hold the original end of the read_only and static spaces so we can */
67 /* tell what are forwarding pointers. */
68
69 static lispobj *read_only_end, *static_end;
70
71 static lispobj *read_only_free, *static_free;
72 static lispobj *pscav(lispobj * addr, int nwords, boolean constant);
73
74 #define LATERBLOCKSIZE 1020
75 #define LATERMAXCOUNT 10
76
77 static struct later {
78 struct later *next;
79 union {
80 lispobj *ptr;
81 int count;
82 } u[LATERBLOCKSIZE];
83 } *later_blocks = NULL;
84 static int later_count = 0;
85
86 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
87 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
88
89 #if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
90 #define RAW_ADDR_OFFSET 0
91 #else
92 #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
93 #endif
94
95 static boolean
96 forwarding_pointer_p(lispobj obj)
97 {
98 lispobj *ptr;
99
100 ptr = (lispobj *) obj;
101
102 return ((static_end <= ptr && ptr <= static_free) ||
103 (read_only_end <= ptr && ptr <= read_only_free));
104 }
105
106 static boolean
107 dynamic_pointer_p(lispobj ptr)
108 {
109 #if !(defined(i386) || defined(__x86_64))
110 return (ptr >= (lispobj) dynamic_0_space);
111 #else
112 /* Be more conservative, and remember, this is a maybe */
113 return (ptr >= (lispobj) current_dynamic_space
114 && ptr < (lispobj) current_dynamic_space_free_pointer);
115 #endif
116 }
117
118
119 #if (defined(i386) || defined(__x86_64))
120
121 #ifdef WANT_CGC
122 /* Original x86/CGC stack scavenging code by Paul Werkowski */
123
124 static int
125 maybe_can_move_p(lispobj thing)
126 {
127 lispobj *thingp, header;
128
129 if (dynamic_pointer_p(thing)) { /* in dynamic space */
130 thingp = (lispobj *) PTR(thing);
131 header = *thingp;
132 if (Pointerp(header) && forwarding_pointer_p(header))
133 return -1; /* must change it */
134 if (LowtagOf(thing) == type_ListPointer)
135 return type_ListPointer; /* can we check this somehow */
136 else if (thing & 3) { /* not fixnum */
137 int kind = TypeOf(header);
138
139 /* printf(" %x %x",header,kind); */
140 switch (kind) { /* something with a header */
141 case type_Bignum:
142 case type_SingleFloat:
143 case type_DoubleFloat:
144 #ifdef type_LongFloat
145 case type_LongFloat:
146 #endif
147 #ifdef type_DoubleDoubleFloat
148 case type_DoubleDoubleFloat:
149 #endif
150 case type_Sap:
151 case type_SimpleVector:
152 case type_SimpleString:
153 case type_SimpleBitVector:
154 case type_SimpleArrayUnsignedByte2:
155 case type_SimpleArrayUnsignedByte4:
156 case type_SimpleArrayUnsignedByte8:
157 case type_SimpleArrayUnsignedByte16:
158 case type_SimpleArrayUnsignedByte32:
159 #ifdef type_SimpleArraySignedByte8
160 case type_SimpleArraySignedByte8:
161 #endif
162 #ifdef type_SimpleArraySignedByte16
163 case type_SimpleArraySignedByte16:
164 #endif
165 #ifdef type_SimpleArraySignedByte30
166 case type_SimpleArraySignedByte30:
167 #endif
168 #ifdef type_SimpleArraySignedByte32
169 case type_SimpleArraySignedByte32:
170 #endif
171 case type_SimpleArraySingleFloat:
172 case type_SimpleArrayDoubleFloat:
173 #ifdef type_SimpleArrayLongFloat
174 case type_SimpleArrayLongFloat:
175 #endif
176 #ifdef type_SimpleArrayDoubleDoubleFloat
177 case type_SimpleArrayDoubleDoubleFloat:
178 #endif
179 #ifdef type_SimpleArrayComplexSingleFloat
180 case type_SimpleArrayComplexSingleFloat:
181 #endif
182 #ifdef type_SimpleArrayComplexDoubleFloat
183 case type_SimpleArrayComplexDoubleFloat:
184 #endif
185 #ifdef type_SimpleArrayComplexLongFloat
186 case type_SimpleArrayComplexLongFloat:
187 #endif
188 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
189 case type_SimpleArrayComplexDoubleDoubleFloat:
190 #endif
191 case type_CodeHeader:
192 case type_FunctionHeader:
193 case type_ClosureFunctionHeader:
194 case type_ReturnPcHeader:
195 case type_ClosureHeader:
196 case type_FuncallableInstanceHeader:
197 case type_InstanceHeader:
198 case type_ValueCellHeader:
199 case type_ByteCodeFunction:
200 case type_ByteCodeClosure:
201 #ifdef type_DylanFunctionHeader
202 case type_DylanFunctionHeader:
203 #endif
204 case type_WeakPointer:
205 case type_Fdefn:
206 #ifdef type_ScavengerHook
207 case type_ScavengerHook:
208 #endif
209 return kind;
210 break;
211 default:
212 return 0;
213 }
214 }
215 }
216 return 0;
217 }
218
219 static int pverbose = 0;
220
221 #define PVERBOSE pverbose
222 static void
223 carefully_pscav_stack(lispobj * lowaddr, lispobj * base)
224 {
225 lispobj *sp = lowaddr;
226
227 while (sp < base) {
228 int k;
229 lispobj thing = *sp;
230
231 if ((unsigned) thing & 0x3) { /* may be pointer */
232 /* need to check for valid float/double? */
233 k = maybe_can_move_p(thing);
234 if (PVERBOSE)
235 printf("%8x %8x %d\n", sp, thing, k);
236 if (k)
237 pscav(sp, 1, FALSE);
238 }
239 sp++;
240 }
241 }
242 #endif
243
244 #if defined(GENCGC) && (defined(i386) || defined(__x86_64))
245 /*
246 * Enhanced x86/GENCGC stack scavenging by Douglas Crosher.
247 *
248 * Scavenging the stack on the i386 is problematic due to conservative
249 * roots and raw return addresses. Here it is handled in two passes:
250 * the first pass runs before any objects are moved and tries to
251 * identify valid pointers and return address on the stack, the second
252 * pass scavenges these.
253 */
254
255 static unsigned pointer_filter_verbose = 0;
256
257 static int
258 valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
259 {
260 /* If it's not a return address then it needs to be a valid lisp
261 pointer. */
262 if (!Pointerp((lispobj) pointer))
263 return FALSE;
264
265 /* Check that the object pointed to is consistent with the pointer
266 low tag. */
267 switch (LowtagOf((lispobj) pointer)) {
268 case type_FunctionPointer:
269 /* Start_addr should be the enclosing code object, or a closure
270 header. */
271 switch (TypeOf(*start_addr)) {
272 case type_CodeHeader:
273 /* This case is probably caught above. */
274 break;
275 case type_ClosureHeader:
276 case type_FuncallableInstanceHeader:
277 case type_ByteCodeFunction:
278 case type_ByteCodeClosure:
279 #ifdef type_DylanFunctionHeader
280 case type_DylanFunctionHeader:
281 #endif
282 if ((int) pointer != ((int) start_addr + type_FunctionPointer)) {
283 if (pointer_filter_verbose)
284 fprintf(stderr, "*Wf2: %p %p %lx\n", pointer,
285 start_addr, *start_addr);
286 return FALSE;
287 }
288 break;
289 default:
290 if (pointer_filter_verbose)
291 fprintf(stderr, "*Wf3: %p %p %lx\n", pointer, start_addr,
292 *start_addr);
293 return FALSE;
294 }
295 break;
296 case type_ListPointer:
297 if ((int) pointer != ((int) start_addr + type_ListPointer)) {
298 if (pointer_filter_verbose)
299 fprintf(stderr, "*Wl1: %p %p %lx\n", pointer, start_addr,
300 *start_addr);
301 return FALSE;
302 }
303 /* Is it plausible cons? */
304 if ((Pointerp(start_addr[0])
305 || ((start_addr[0] & 3) == 0) /* fixnum */
306 ||(TypeOf(start_addr[0]) == type_BaseChar)
307 || (TypeOf(start_addr[0]) == type_UnboundMarker))
308 && (Pointerp(start_addr[1])
309 || ((start_addr[1] & 3) == 0) /* fixnum */
310 ||(TypeOf(start_addr[1]) == type_BaseChar)
311 || (TypeOf(start_addr[1]) == type_UnboundMarker)))
312 break;
313 else {
314 if (pointer_filter_verbose)
315 fprintf(stderr, "*Wl2: %p %p %lx\n", pointer, start_addr,
316 *start_addr);
317 return FALSE;
318 }
319 case type_InstancePointer:
320 if ((int) pointer != ((int) start_addr + type_InstancePointer)) {
321 if (pointer_filter_verbose)
322 fprintf(stderr, "*Wi1: %p %p %lx\n", pointer, start_addr,
323 *start_addr);
324 return FALSE;
325 }
326 if (TypeOf(start_addr[0]) != type_InstanceHeader) {
327 if (pointer_filter_verbose)
328 fprintf(stderr, "*Wi2: %p %p %lx\n", pointer, start_addr,
329 *start_addr);
330 return FALSE;
331 }
332 break;
333 case type_OtherPointer:
334 if ((int) pointer != ((int) start_addr + type_OtherPointer)) {
335 if (pointer_filter_verbose)
336 fprintf(stderr, "*Wo1: %p %p %lx\n", pointer, start_addr,
337 *start_addr);
338 return FALSE;
339 }
340 /* Is it plausible? Not a cons. X should check the headers. */
341 if (Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
342 if (pointer_filter_verbose)
343 fprintf(stderr, "*Wo2: %p %p %lx\n", pointer, start_addr,
344 *start_addr);
345 return FALSE;
346 }
347 switch (TypeOf(start_addr[0])) {
348 case type_UnboundMarker:
349 case type_BaseChar:
350 if (pointer_filter_verbose)
351 fprintf(stderr, "*Wo3: %p %p %lx\n", pointer, start_addr,
352 *start_addr);
353 return FALSE;
354
355 /* Only pointed to by function pointers? */
356 case type_ClosureHeader:
357 case type_FuncallableInstanceHeader:
358 case type_ByteCodeFunction:
359 case type_ByteCodeClosure:
360 #ifdef type_DylanFunctionHeader
361 case type_DylanFunctionHeader:
362 #endif
363 if (pointer_filter_verbose)
364 fprintf(stderr, "*Wo4: %p %p %lx\n", pointer, start_addr,
365 *start_addr);
366 return FALSE;
367
368 case type_InstanceHeader:
369 if (pointer_filter_verbose)
370 fprintf(stderr, "*Wo5: %p %p %lx\n", pointer, start_addr,
371 *start_addr);
372 return FALSE;
373
374 /* The valid other immediate pointer objects */
375 case type_SimpleVector:
376 case type_Ratio:
377 case type_Complex:
378 #ifdef type_ComplexSingleFloat
379 case type_ComplexSingleFloat:
380 #endif
381 #ifdef type_ComplexDoubleFloat
382 case type_ComplexDoubleFloat:
383 #endif
384 #ifdef type_ComplexLongFloat
385 case type_ComplexLongFloat:
386 #endif
387 #ifdef type_ComplexDoubleDoubleFloat
388 case type_ComplexDoubleDoubleFloat:
389 #endif
390 case type_SimpleArray:
391 case type_ComplexString:
392 case type_ComplexBitVector:
393 case type_ComplexVector:
394 case type_ComplexArray:
395 case type_ValueCellHeader:
396 case type_SymbolHeader:
397 case type_Fdefn:
398 case type_CodeHeader:
399 case type_Bignum:
400 case type_SingleFloat:
401 case type_DoubleFloat:
402 #ifdef type_LongFloat
403 case type_LongFloat:
404 #endif
405 #ifdef type_DoubleDoubleFloat
406 case type_DoubleDoubleFloat:
407 #endif
408 case type_SimpleString:
409 case type_SimpleBitVector:
410 case type_SimpleArrayUnsignedByte2:
411 case type_SimpleArrayUnsignedByte4:
412 case type_SimpleArrayUnsignedByte8:
413 case type_SimpleArrayUnsignedByte16:
414 case type_SimpleArrayUnsignedByte32:
415 #ifdef type_SimpleArraySignedByte8
416 case type_SimpleArraySignedByte8:
417 #endif
418 #ifdef type_SimpleArraySignedByte16
419 case type_SimpleArraySignedByte16:
420 #endif
421 #ifdef type_SimpleArraySignedByte30
422 case type_SimpleArraySignedByte30:
423 #endif
424 #ifdef type_SimpleArraySignedByte32
425 case type_SimpleArraySignedByte32:
426 #endif
427 case type_SimpleArraySingleFloat:
428 case type_SimpleArrayDoubleFloat:
429 #ifdef type_SimpleArrayLongFloat
430 case type_SimpleArrayLongFloat:
431 #endif
432 #ifdef type_SimpleArrayDoubleDoubleFloat
433 case type_SimpleArrayDoubleDoubleFloat:
434 #endif
435 #ifdef type_SimpleArrayComplexSingleFloat
436 case type_SimpleArrayComplexSingleFloat:
437 #endif
438 #ifdef type_SimpleArrayComplexDoubleFloat
439 case type_SimpleArrayComplexDoubleFloat:
440 #endif
441 #ifdef type_SimpleArrayComplexLongFloat
442 case type_SimpleArrayComplexLongFloat:
443 #endif
444 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
445 case type_SimpleArrayComplexDoubleDoubleFloat:
446 #endif
447 case type_Sap:
448 case type_WeakPointer:
449 case type_ScavengerHook:
450 break;
451
452 default:
453 if (pointer_filter_verbose)
454 fprintf(stderr, "*Wo6: %p %p %lx\n", pointer, start_addr,
455 *start_addr);
456 return FALSE;
457 }
458 break;
459 default:
460 if (pointer_filter_verbose)
461 fprintf(stderr, "*W?: %p %p %lx\n", pointer, start_addr,
462 *start_addr);
463 return FALSE;
464 }
465
466 /* Looks good */
467 return TRUE;
468 }
469
470 #define MAX_STACK_POINTERS 1024
471 lispobj *valid_stack_locations[MAX_STACK_POINTERS];
472 unsigned int num_valid_stack_locations;
473
474 #define MAX_STACK_RETURN_ADDRESSES 128
475 lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
476 lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
477 unsigned int num_valid_stack_ra_locations;
478
479 /*
480 * Identify valid stack slots.
481 */
482
483 static void
484 setup_i386_stack_scav(lispobj * lowaddr, lispobj * base)
485 {
486 lispobj *sp = lowaddr;
487
488 num_valid_stack_locations = 0;
489 num_valid_stack_ra_locations = 0;
490
491 for (sp = lowaddr; sp < base; sp++) {
492 lispobj thing = *sp;
493 lispobj *start_addr;
494
495 /* Find the object start address */
496 if ((start_addr = search_dynamic_space((void *) thing)) != NULL) {
497 /*
498 * Need to allow raw pointers into Code objects for return
499 * addresses. This will also pickup pointers to functions in code
500 * objects.
501 */
502 if (TypeOf(*start_addr) == type_CodeHeader) {
503 gc_assert(num_valid_stack_ra_locations <
504 MAX_STACK_RETURN_ADDRESSES);
505 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
506 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
507 (lispobj *) ((int) start_addr + type_OtherPointer);
508 } else {
509 if (valid_dynamic_space_pointer((void *) thing, start_addr)) {
510 gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
511 valid_stack_locations[num_valid_stack_locations++] = sp;
512 }
513 }
514 }
515 }
516 if (pointer_filter_verbose) {
517 fprintf(stderr, "Number of valid stack pointers = %d\n",
518 num_valid_stack_locations);
519 fprintf(stderr, "Number of stack return addresses = %d\n",
520 num_valid_stack_ra_locations);
521 }
522 }
523
524 static void
525 pscav_i386_stack(void)
526 {
527 int i;
528
529 for (i = 0; i < num_valid_stack_locations; i++)
530 pscav(valid_stack_locations[i], 1, FALSE);
531
532 for (i = 0; i < num_valid_stack_ra_locations; i++) {
533 lispobj code_obj = (lispobj) (valid_stack_ra_code_objects[i]);
534
535 pscav(&code_obj, 1, FALSE);
536 if (pointer_filter_verbose)
537 fprintf(stderr,
538 "*C moved RA %lx to %x; for code object %p to %lx\n",
539 *valid_stack_ra_locations[i],
540 (int) (*valid_stack_ra_locations[i])
541 - ((int) valid_stack_ra_code_objects[i] - (int) code_obj),
542 valid_stack_ra_code_objects[i], code_obj);
543 *valid_stack_ra_locations[i] =
544 (lispobj) ((int) (*valid_stack_ra_locations[i])
545 - ((int) valid_stack_ra_code_objects[i] -
546 (int) code_obj));
547 }
548 }
549 #endif
550 #endif
551
552
553 static void
554 pscav_later(lispobj * where, int count)
555 {
556 struct later *new;
557
558 if (count > LATERMAXCOUNT) {
559 while (count > LATERMAXCOUNT) {
560 pscav_later(where, LATERMAXCOUNT);
561 count -= LATERMAXCOUNT;
562 where += LATERMAXCOUNT;
563 }
564 } else {
565 if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
566 (later_count == LATERBLOCKSIZE - 1 && count > 1)) {
567 new = (struct later *) malloc(sizeof(struct later));
568
569 new->next = later_blocks;
570 if (later_blocks && later_count < LATERBLOCKSIZE)
571 later_blocks->u[later_count].ptr = NULL;
572 later_blocks = new;
573 later_count = 0;
574 }
575
576 if (count != 1)
577 later_blocks->u[later_count++].count = count;
578 later_blocks->u[later_count++].ptr = where;
579 }
580 }
581
582 static lispobj
583 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
584 {
585 int nwords;
586 lispobj result, *new, *old;
587
588 nwords = 1 + HeaderValue(header);
589
590 /* Allocate it */
591 old = (lispobj *) PTR(thing);
592 if (constant) {
593 new = read_only_free;
594 read_only_free += CEILING(nwords, 2);
595 assert_readonly_space_bounds(read_only_free);
596 } else {
597 new = static_free;
598 static_free += CEILING(nwords, 2);
599 assert_static_space_bounds(static_free);
600 }
601
602 /* Copy it. */
603 memmove(new, old, nwords * sizeof(lispobj));
604
605 /* Deposit forwarding pointer. */
606 result = (lispobj) new | LowtagOf(thing);
607 *old = result;
608
609 /* Scavenge it. */
610 pscav(new, nwords, constant);
611
612 return result;
613 }
614
615 /* need to look at the layout to see if it is a pure structure class, and
616 only then can we transport as constant. If it is pure, we can
617 ALWAYS transport as a constant */
618
619 static lispobj
620 ptrans_instance(lispobj thing, lispobj header, boolean constant)
621 {
622 lispobj layout = ((struct instance *) PTR(thing))->slots[0];
623 lispobj pure = ((struct instance *) PTR(layout))->slots[15];
624
625 switch (pure) {
626 case T:
627 return (ptrans_boxed(thing, header, 1));
628 case NIL:
629 return (ptrans_boxed(thing, header, 0));
630 case 0:{
631 /* Substructure: special case for the compact-info-envs, where
632 the instance may have a point to the dynamic space placed
633 into it (e.g. the cache-name slot), but the lists and arrays
634 at the time of a purify can be moved to the RO space. */
635 int nwords;
636 lispobj result, *new, *old;
637
638 nwords = 1 + HeaderValue(header);
639
640 /* Allocate it */
641 old = (lispobj *) PTR(thing);
642 new = static_free;
643 static_free += CEILING(nwords, 2);
644 assert_static_space_bounds(static_free);
645
646 /* Copy it. */
647 memmove(new, old, nwords * sizeof(lispobj));
648
649 /* Deposit forwarding pointer. */
650 result = (lispobj) new | LowtagOf(thing);
651 *old = result;
652
653 /* Scavenge it. */
654 pscav(new, nwords, 1);
655
656 return result;
657 }
658 default:
659 gc_abort();
660 return 0; /* squelch stupid warning */
661 }
662 }
663
664 static lispobj
665 ptrans_fdefn(lispobj thing, lispobj header)
666 {
667 int nwords;
668 lispobj result, *new, *old, oldfn;
669 struct fdefn *fdefn;
670
671 nwords = 1 + HeaderValue(header);
672
673 /* Allocate it */
674 old = (lispobj *) PTR(thing);
675 new = static_free;
676 static_free += CEILING(nwords, 2);
677 assert_static_space_bounds(static_free);
678
679 /* Copy it. */
680 memmove(new, old, nwords * sizeof(lispobj));
681
682 /* Deposit forwarding pointer. */
683 result = (lispobj) new | LowtagOf(thing);
684 *old = result;
685
686 /* Scavenge the function. */
687 fdefn = (struct fdefn *) new;
688 oldfn = fdefn->function;
689 pscav(&fdefn->function, 1, FALSE);
690 if ((char *) oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr)
691 fdefn->raw_addr = (char *) fdefn->function + RAW_ADDR_OFFSET;
692
693 return result;
694 }
695
696 static lispobj
697 ptrans_unboxed(lispobj thing, lispobj header)
698 {
699 int nwords;
700 lispobj result, *new, *old;
701
702 nwords = 1 + HeaderValue(header);
703
704 /* Allocate it */
705 old = (lispobj *) PTR(thing);
706 new = read_only_free;
707 read_only_free += CEILING(nwords, 2);
708 assert_readonly_space_bounds(read_only_free);
709
710 /* Copy it. */
711 memmove(new, old, nwords * sizeof(lispobj));
712
713 /* Deposit forwarding pointer. */
714 result = (lispobj) new | LowtagOf(thing);
715 *old = result;
716
717 return result;
718 }
719
720 static lispobj
721 ptrans_vector(lispobj thing, int bits, int extra,
722 boolean boxed, boolean constant)
723 {
724 struct vector *vector;
725 int nwords;
726 lispobj result, *new;
727
728 vector = (struct vector *) PTR(thing);
729 #ifdef __x86_64
730 nwords =
731 2 + (CEILING((fixnum_value(vector->length) + extra) * bits, 64) >> 6);
732 #else
733 nwords =
734 2 + (CEILING((fixnum_value(vector->length) + extra) * bits, 32) >> 5);
735 #endif
736
737 if (boxed && !constant) {
738 new = static_free;
739 static_free += CEILING(nwords, 2);
740 assert_static_space_bounds(static_free);
741 } else {
742 new = read_only_free;
743 read_only_free += CEILING(nwords, 2);
744 assert_readonly_space_bounds(read_only_free);
745 }
746
747 memmove(new, vector, nwords * sizeof(lispobj));
748
749 result = (lispobj) new | LowtagOf(thing);
750 vector->header = result;
751
752 if (boxed)
753 pscav(new, nwords, constant);
754
755 return result;
756 }
757
758 #if (defined(i386) || defined(__x86_64))
759 static void
760 apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
761 {
762 int nheader_words, ncode_words, nwords;
763 void *code_start_addr;
764 lispobj fixups = NIL;
765 unsigned displacement = (unsigned) new_code - (unsigned) old_code;
766 struct vector *fixups_vector;
767
768 /* Byte compiled code has no fixups. The trace table offset will be
769 a fixnum if it's x86 compiled code - check. */
770 if (new_code->trace_table_offset & 0x3)
771 return;
772
773 /* Else it's x86 machine code. */
774 ncode_words = fixnum_value(new_code->code_size);
775 nheader_words = HeaderValue(*(lispobj *) new_code);
776 nwords = ncode_words + nheader_words;
777
778 code_start_addr = (void *) new_code + nheader_words * sizeof(lispobj);
779
780 /* The first constant should be a pointer to the fixups for this
781 code objects. Check. */
782 fixups = new_code->constants[0];
783
784 /* It will be 0 or the unbound-marker if there are no fixups, and
785 will be an other-pointer to a vector if it is valid. */
786 if ((fixups == 0) || (fixups == type_UnboundMarker) || !Pointerp(fixups)) {
787 #if defined(GENCGC) && (defined(i386) || defined(__x86_64))
788 /* Check for a possible errors. */
789 sniff_code_object(new_code, displacement);
790 #endif
791 return;
792 }
793
794 fixups_vector = (struct vector *) PTR(fixups);
795
796 /* Could be pointing to a forwarding pointer. */
797 if (Pointerp(fixups) && (dynamic_pointer_p(fixups))
798 && forwarding_pointer_p(*(lispobj *) fixups_vector)) {
799 /* If so then follow it. */
800 fixups_vector = (struct vector *) PTR(*(lispobj *) fixups_vector);
801 }
802
803 if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
804 /* Got the fixups for the code block. Now work through the vector,
805 and apply a fixup at each address. */
806 int length = fixnum_value(fixups_vector->length);
807
808 /* offset_vector still has 32-bit elements on amd64.
809 Eventually we will make this consistent with internals.h */
810 unsigned int *offset_vector = (unsigned int *) fixups_vector->data;
811 int i;
812
813 for (i = 0; i < length; i++) {
814 unsigned offset = offset_vector[i];
815
816 /* Now check the current value of offset. */
817 unsigned old_value =
818
819 *(unsigned *) ((unsigned) code_start_addr + offset);
820
821 /* If it's within the old_code object then it must be an
822 absolute fixup (relative ones are not saved) */
823 if ((old_value >= (unsigned) old_code)
824 && (old_value <
825 ((unsigned) old_code + nwords * sizeof(lispobj))))
826 /* So add the dispacement. */
827 *(unsigned *) ((unsigned) code_start_addr + offset) = old_value
828 + displacement;
829 else
830 /* It is outside the old code object so it must be a relative
831 fixup (absolute fixups are not saved). So subtract the
832 displacement. */
833 *(unsigned *) ((unsigned) code_start_addr + offset) = old_value
834 - displacement;
835 }
836 }
837
838 /* No longer need the fixups. */
839 new_code->constants[0] = 0;
840
841 #if defined(GENCGC) && (defined(i386) || defined(__x86_64))
842 /* Check for possible errors. */
843 sniff_code_object(new_code, displacement);
844 #endif
845 }
846 #endif
847
848 static lispobj
849 ptrans_code(lispobj thing)
850 {
851 struct code *code, *new;
852 int nwords;
853 lispobj func, result;
854
855 code = (struct code *) PTR(thing);
856 nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
857
858 new = (struct code *) read_only_free;
859 read_only_free += CEILING(nwords, 2);
860 assert_readonly_space_bounds(read_only_free);
861
862 memmove(new, code, nwords * sizeof(lispobj));
863
864 #if (defined(i386) || defined(__x86_64))
865 apply_code_fixups_during_purify(code, new);
866 #endif
867
868 result = (lispobj) new | type_OtherPointer;
869
870 /* Stick in a forwarding pointer for the code object. */
871 *(lispobj *) code = result;
872
873 /* Put in forwarding pointers for all the functions. */
874 for (func = code->entry_points;
875 func != NIL; func = ((struct function *) PTR(func))->next) {
876
877 gc_assert(LowtagOf(func) == type_FunctionPointer);
878
879 *(lispobj *) PTR(func) = result + (func - thing);
880 }
881
882 /* Arrange to scavenge the debug info later. */
883 pscav_later(&new->debug_info, 1);
884
885 if (new->trace_table_offset & 0x3)
886 #if 0
887 pscav(&new->trace_table_offset, 1, FALSE);
888 #else
889 new->trace_table_offset = NIL; /* limit lifetime */
890 #endif
891
892 /* Scavenge the constants. */
893 pscav(new->constants, HeaderValue(new->header) - 5, TRUE);
894
895 /* Scavenge all the functions. */
896 pscav(&new->entry_points, 1, TRUE);
897 for (func = new->entry_points;
898 func != NIL; func = ((struct function *) PTR(func))->next) {
899 gc_assert(LowtagOf(func) == type_FunctionPointer);
900 gc_assert(!dynamic_pointer_p(func));
901
902 #if (defined(i386) || defined(__x86_64))
903 /* Temporarily convert the self pointer to a real function
904 pointer. */
905 ((struct function *) PTR(func))->self -= RAW_ADDR_OFFSET;
906 #endif
907 pscav(&((struct function *) PTR(func))->self, 2, TRUE);
908 #if (defined(i386) || defined(__x86_64))
909 ((struct function *) PTR(func))->self += RAW_ADDR_OFFSET;
910 #endif
911 pscav_later(&((struct function *) PTR(func))->name, 3);
912 }
913
914 return result;
915 }
916
917 static lispobj
918 ptrans_func(lispobj thing, lispobj header)
919 {
920 int nwords;
921 lispobj code, *new, *old, result;
922 struct function *function;
923
924 /* THING can either be a function header, a closure function header, */
925 /* a closure, or a funcallable-instance. If it's a closure or a */
926 /* funcallable-instance, we do the same as ptrans_boxed. */
927 /* Otherwise we have to do something strange, 'cause it is buried inside */
928 /* a code object. */
929
930 if (TypeOf(header) == type_FunctionHeader ||
931 TypeOf(header) == type_ClosureFunctionHeader) {
932
933 /* We can only end up here if the code object has not been */
934 /* scavenged, because if it had been scavenged, forwarding pointers */
935 /* would have been left behind for all the entry points. */
936
937 function = (struct function *) PTR(thing);
938 code =
939 (PTR(thing) -
940 (HeaderValue(function->header) *
941 sizeof(lispobj))) | type_OtherPointer;
942
943 /* This will cause the function's header to be replaced with a */
944 /* forwarding pointer. */
945 ptrans_code(code);
946
947 /* So we can just return that. */
948 return function->header;
949 } else {
950 /* It's some kind of closure-like thing. */
951 nwords = 1 + HeaderValue(header);
952 old = (lispobj *) PTR(thing);
953
954 /* Allocate the new one. */
955 if (TypeOf(header) == type_FuncallableInstanceHeader) {
956 /* FINs *must* not go in read_only space. */
957 new = static_free;
958 static_free += CEILING(nwords, 2);
959 assert_static_space_bounds(static_free);
960 } else {
961 /* Closures can always go in read-only space, 'caues */
962 /* they never change. */
963
964 new = read_only_free;
965 read_only_free += CEILING(nwords, 2);
966 assert_readonly_space_bounds(read_only_free);
967 }
968 /* Copy it. */
969 memmove(new, old, nwords * sizeof(lispobj));
970
971 /* Deposit forwarding pointer. */
972 result = (lispobj) new | LowtagOf(thing);
973 *old = result;
974
975 /* Scavenge it. */
976 pscav(new, nwords, FALSE);
977
978 return result;
979 }
980 }
981
982 static lispobj
983 ptrans_returnpc(lispobj thing, lispobj header)
984 {
985 lispobj code, new;
986
987 /* Find the corresponding code object. */
988 code = thing - HeaderValue(header) * sizeof(lispobj);
989
990 /* Make sure it's been transported. */
991 new = *(lispobj *) PTR(code);
992 if (!forwarding_pointer_p(new))
993 new = ptrans_code(code);
994
995 /* Maintain the offset: */
996 return new + (thing - code);
997 }
998
999 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
1000
1001 static lispobj
1002 ptrans_list(lispobj thing, boolean constant)
1003 {
1004 struct cons *old, *new, *orig;
1005 int length;
1006
1007 if (constant)
1008 orig = (struct cons *) read_only_free;
1009 else
1010 orig = (struct cons *) static_free;
1011 length = 0;
1012
1013 do {
1014 /* Allocate a new cons cell. */
1015 old = (struct cons *) PTR(thing);
1016 if (constant) {
1017 new = (struct cons *) read_only_free;
1018 read_only_free += WORDS_PER_CONS;
1019 assert_readonly_space_bounds(read_only_free);
1020 } else {
1021 new = (struct cons *) static_free;
1022 static_free += WORDS_PER_CONS;
1023 assert_static_space_bounds(static_free);
1024 }
1025
1026 /* Copy the cons cell and keep a pointer to the cdr. */
1027 new->car = old->car;
1028 thing = new->cdr = old->cdr;
1029
1030 /* Set up the forwarding pointer. */
1031 *(lispobj *) old = ((lispobj) new) | type_ListPointer;
1032
1033 /* And count this cell. */
1034 length++;
1035 } while (LowtagOf(thing) == type_ListPointer &&
1036 dynamic_pointer_p(thing) &&
1037 !(forwarding_pointer_p(*(lispobj *) PTR(thing))));
1038
1039 /* Scavenge the list we just copied. */
1040 pscav((lispobj *) orig, length * WORDS_PER_CONS, constant);
1041
1042 return ((lispobj) orig) | type_ListPointer;
1043 }
1044
1045 static lispobj
1046 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
1047 {
1048 switch (TypeOf(header)) {
1049 case type_Bignum:
1050 case type_SingleFloat:
1051 case type_DoubleFloat:
1052 #ifdef type_LongFloat
1053 case type_LongFloat:
1054 #endif
1055 #ifdef type_DoubleDoubleFloat
1056 case type_DoubleDoubleFloat:
1057 #endif
1058 #ifdef type_ComplexSingleFloat
1059 case type_ComplexSingleFloat:
1060 #endif
1061 #ifdef type_ComplexDoubleFloat
1062 case type_ComplexDoubleFloat:
1063 #endif
1064 #ifdef type_ComplexLongFloat
1065 case type_ComplexLongFloat:
1066 #endif
1067 #ifdef type_ComplexDoubleDoubleFloat
1068 case type_ComplexDoubleDoubleFloat:
1069 #endif
1070 case type_Sap:
1071 return ptrans_unboxed(thing, header);
1072
1073 case type_Ratio:
1074 case type_Complex:
1075 case type_SimpleArray:
1076 case type_ComplexString:
1077 case type_ComplexVector:
1078 case type_ComplexArray:
1079 return ptrans_boxed(thing, header, constant);
1080
1081 case type_ValueCellHeader:
1082 case type_WeakPointer:
1083 #ifdef type_ScavengerHook
1084 case type_ScavengerHook:
1085 #endif
1086 return ptrans_boxed(thing, header, FALSE);
1087
1088 case type_SymbolHeader:
1089 return ptrans_boxed(thing, header, FALSE);
1090
1091 case type_SimpleString:
1092 #ifndef UNICODE
1093 return ptrans_vector(thing, 8, 1, FALSE, constant);
1094 #else
1095 return ptrans_vector(thing, 16, 1, FALSE, constant);
1096 #endif
1097 case type_SimpleBitVector:
1098 return ptrans_vector(thing, 1, 0, FALSE, constant);
1099
1100 case type_SimpleVector:
1101 #ifdef __x86_64
1102 return ptrans_vector(thing, 64, 0, TRUE, constant);
1103 #else
1104 return ptrans_vector(thing, 32, 0, TRUE, constant);
1105 #endif
1106
1107 case type_SimpleArrayUnsignedByte2:
1108 return ptrans_vector(thing, 2, 0, FALSE, constant);
1109
1110 case type_SimpleArrayUnsignedByte4:
1111 return ptrans_vector(thing, 4, 0, FALSE, constant);
1112
1113 case type_SimpleArrayUnsignedByte8:
1114 #ifdef type_SimpleArraySignedByte8
1115 case type_SimpleArraySignedByte8:
1116 #endif
1117 return ptrans_vector(thing, 8, 0, FALSE, constant);
1118
1119 case type_SimpleArrayUnsignedByte16:
1120 #ifdef type_SimpleArraySignedByte16
1121 case type_SimpleArraySignedByte16:
1122 #endif
1123 return ptrans_vector(thing, 16, 0, FALSE, constant);
1124
1125 case type_SimpleArrayUnsignedByte32:
1126 #ifdef type_SimpleArraySignedByte30
1127 case type_SimpleArraySignedByte30:
1128 #endif
1129 #ifdef type_SimpleArraySignedByte32
1130 case type_SimpleArraySignedByte32:
1131 #endif
1132 return ptrans_vector(thing, 32, 0, FALSE, constant);
1133
1134 case type_SimpleArraySingleFloat:
1135 return ptrans_vector(thing, 32, 0, FALSE, constant);
1136
1137 case type_SimpleArrayDoubleFloat:
1138 return ptrans_vector(thing, 64, 0, FALSE, constant);
1139
1140 #ifdef type_SimpleArrayLongFloat
1141 case type_SimpleArrayLongFloat:
1142 #if (defined(i386) || defined(__x86_64))
1143 return ptrans_vector(thing, 96, 0, FALSE, constant);
1144 #endif
1145 #ifdef sparc
1146 return ptrans_vector(thing, 128, 0, FALSE, constant);
1147 #endif
1148 #endif
1149
1150 #ifdef type_SimpleArrayDoubleDoubleFloat
1151 case type_SimpleArrayDoubleDoubleFloat:
1152 return ptrans_vector(thing, 128, 0, FALSE, constant);
1153 #endif
1154
1155 #ifdef type_SimpleArrayComplexSingleFloat
1156 case type_SimpleArrayComplexSingleFloat:
1157 return ptrans_vector(thing, 64, 0, FALSE, constant);
1158 #endif
1159
1160 #ifdef type_SimpleArrayComplexDoubleFloat
1161 case type_SimpleArrayComplexDoubleFloat:
1162 return ptrans_vector(thing, 128, 0, FALSE, constant);
1163 #endif
1164
1165 #ifdef type_SimpleArrayComplexLongFloat
1166 case type_SimpleArrayComplexLongFloat:
1167 #if (defined(i386) || defined(__x86_64))
1168 return ptrans_vector(thing, 192, 0, FALSE, constant);
1169 #endif
1170 #ifdef sparc
1171 return ptrans_vector(thing, 256, 0, FALSE, constant);
1172 #endif
1173 #endif
1174
1175 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
1176 case type_SimpleArrayComplexDoubleDoubleFloat:
1177 return ptrans_vector(thing, 256, 0, FALSE, constant);
1178 #endif
1179
1180
1181 case type_CodeHeader:
1182 return ptrans_code(thing);
1183
1184 case type_ReturnPcHeader:
1185 return ptrans_returnpc(thing, header);
1186
1187 case type_Fdefn:
1188 return ptrans_fdefn(thing, header);
1189
1190 default:
1191 /* Should only come across other pointers to the above stuff. */
1192 gc_abort();
1193 return NIL;
1194 }
1195 }
1196
1197 static int
1198 pscav_fdefn(struct fdefn *fdefn)
1199 {
1200 boolean fix_func;
1201
1202 fix_func =
1203 ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr);
1204 pscav(&fdefn->name, 1, TRUE);
1205 pscav(&fdefn->function, 1, FALSE);
1206 if (fix_func)
1207 fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);
1208 return sizeof(struct fdefn) / sizeof(lispobj);
1209 }
1210
1211 #if (defined(i386) || defined(__x86_64))
1212 /* now putting code objects in static space */
1213 static int
1214 pscav_code(struct code *code)
1215 {
1216 int nwords;
1217 lispobj func;
1218
1219 nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
1220
1221 /* pw--The trace_table_offset slot can contain a list pointer. This
1222 * occurs when the code object is a top level form that initializes
1223 * a byte-compiled function. The fact that purify was ignoring this
1224 * slot may be a bug unrelated to the x86 port, except that TLF's
1225 * normally become unreachable after the loader calls them and
1226 * won't be seen by purify at all!!
1227 */
1228 if (code->trace_table_offset & 0x3)
1229 #if 0
1230 pscav(&code->trace_table_offset, 1, FALSE);
1231 #else
1232 code->trace_table_offset = NIL; /* limit lifetime */
1233 #endif
1234
1235 /* Arrange to scavenge the debug info later. */
1236 pscav_later(&code->debug_info, 1);
1237
1238 /* Scavenge the constants. */
1239 pscav(code->constants, HeaderValue(code->header) - 5, TRUE);
1240
1241 /* Scavenge all the functions. */
1242 pscav(&code->entry_points, 1, TRUE);
1243 for (func = code->entry_points;
1244 func != NIL; func = ((struct function *) PTR(func))->next) {
1245 gc_assert(LowtagOf(func) == type_FunctionPointer);
1246 gc_assert(!dynamic_pointer_p(func));
1247
1248 /* Temporarly convert the self pointer to a real function
1249 pointer. */
1250 ((struct function *) PTR(func))->self -= RAW_ADDR_OFFSET;
1251 pscav(&((struct function *) PTR(func))->self, 2, TRUE);
1252 ((struct function *) PTR(func))->self += RAW_ADDR_OFFSET;
1253 pscav_later(&((struct function *) PTR(func))->name, 3);
1254 }
1255
1256 return CEILING(nwords, 2);
1257 }
1258 #endif
1259
1260 #ifdef type_ScavengerHook
1261 static struct scavenger_hook *scavenger_hooks = (void *) NIL;
1262
1263 static int
1264 pscav_scavenger_hook(struct scavenger_hook *scav_hook)
1265 {
1266 lispobj old_value = scav_hook->value;
1267
1268 /* Scavenge the value */
1269 pscav((lispobj *) scav_hook + 1, 1, FALSE);
1270
1271 /* Did the value object move? */
1272 if (scav_hook->value != old_value) {
1273 /* Check if this hook is already noted. */
1274 if (scav_hook->next == NULL) {
1275 scav_hook->next = scavenger_hooks;
1276 scavenger_hooks =
1277 (struct scavenger_hook *) ((unsigned long) scav_hook |
1278 type_OtherPointer);
1279 }
1280 }
1281
1282 /* Scavenge the function */
1283 pscav((lispobj *) scav_hook + 2, 1, FALSE);
1284
1285 return 4;
1286 }
1287 #endif
1288
1289 static lispobj *
1290 pscav(lispobj * addr, int nwords, boolean constant)
1291 {
1292 lispobj thing, *thingp, header;
1293 int count = 0;
1294 struct vector *vector;
1295
1296 while (nwords > 0) {
1297 thing = *addr;
1298 if (Pointerp(thing)) {
1299 /* It's a pointer. Is it something we might have to move? */
1300 if (dynamic_pointer_p(thing)) {
1301 /* Maybe. Have we already moved it? */
1302 thingp = (lispobj *) PTR(thing);
1303 header = *thingp;
1304 if (Pointerp(header) && forwarding_pointer_p(header))
1305 /* Yep, so just copy the forwarding pointer. */
1306 thing = header;
1307 else {
1308 /* Nope, copy the object. */
1309 switch (LowtagOf(thing)) {
1310 case type_FunctionPointer:
1311 thing = ptrans_func(thing, header);
1312 break;
1313
1314 case type_ListPointer:
1315 thing = ptrans_list(thing, constant);
1316 break;
1317
1318 case type_InstancePointer:
1319 thing = ptrans_instance(thing, header, constant);
1320 break;
1321
1322 case type_OtherPointer:
1323 thing = ptrans_otherptr(thing, header, constant);
1324 break;
1325
1326 default:
1327 /* It was a pointer, but not one of them? */
1328 gc_abort();
1329 }
1330 }
1331 *addr = thing;
1332 }
1333 count = 1;
1334 } else if (thing & 3) {
1335 /* It's an other immediate. Maybe the header for an unboxed */
1336 /* object. */
1337 switch (TypeOf(thing)) {
1338 case type_Bignum:
1339 case type_SingleFloat:
1340 case type_DoubleFloat:
1341 #ifdef type_LongFloat
1342 case type_LongFloat:
1343 #endif
1344 #ifdef type_DoubleDoubleFloat
1345 case type_DoubleDoubleFloat:
1346 #endif
1347 case type_Sap:
1348 /* It's an unboxed simple object. */
1349 count = HeaderValue(thing) + 1;
1350 break;
1351
1352 case type_SimpleVector:
1353 if (HeaderValue(thing) == subtype_VectorValidHashing)
1354 *addr = (subtype_VectorMustRehash << type_Bits) |
1355 type_SimpleVector;
1356 count = 1;
1357 break;
1358
1359 case type_SimpleString:
1360 vector = (struct vector *) addr;
1361 #ifdef __x86_64
1362 count =
1363 CEILING(NWORDS(fixnum_value(vector->length) + 1, 8) + 2,
1364 2);
1365 #else
1366 count =
1367 #ifndef UNICODE
1368 CEILING(NWORDS(fixnum_value(vector->length) + 1, 4) + 2,
1369 2);
1370 #else
1371 CEILING(NWORDS(fixnum_value(vector->length) + 1, 2) + 2,
1372 2);
1373 #endif
1374 #endif
1375 break;
1376
1377 case type_SimpleBitVector:
1378 vector = (struct vector *) addr;
1379 #ifdef __x86_64
1380 count =
1381 CEILING(NWORDS(fixnum_value(vector->length), 64) + 2, 2);
1382 #else
1383 count =
1384 CEILING(NWORDS(fixnum_value(vector->length), 32) + 2, 2);
1385 #endif
1386 break;
1387
1388 case type_SimpleArrayUnsignedByte2:
1389 vector = (struct vector *) addr;
1390 #ifdef __x86_64
1391 count =
1392 CEILING(NWORDS(fixnum_value(vector->length), 32) + 2, 2);
1393 #else
1394 count =
1395 CEILING(NWORDS(fixnum_value(vector->length), 16) + 2, 2);
1396 #endif
1397 break;
1398
1399 case type_SimpleArrayUnsignedByte4:
1400 vector = (struct vector *) addr;
1401 #ifdef __x86_64
1402 count =
1403 CEILING(NWORDS(fixnum_value(vector->length), 16) + 2, 2);
1404 #else
1405 count =
1406 CEILING(NWORDS(fixnum_value(vector->length), 8) + 2, 2);
1407 #endif
1408 break;
1409
1410 case type_SimpleArrayUnsignedByte8:
1411 #ifdef type_SimpleArraySignedByte8
1412 case type_SimpleArraySignedByte8:
1413 #endif
1414 vector = (struct vector *) addr;
1415 #ifdef __x86_64
1416 count =
1417 CEILING(NWORDS(fixnum_value(vector->length), 8) + 2, 2);
1418 #else
1419 count =
1420 CEILING(NWORDS(fixnum_value(vector->length), 4) + 2, 2);
1421 #endif
1422 break;
1423
1424 case type_SimpleArrayUnsignedByte16:
1425 #ifdef type_SimpleArraySignedByte16
1426 case type_SimpleArraySignedByte16:
1427 #endif
1428 vector = (struct vector *) addr;
1429 #ifdef __x86_64
1430 count =
1431 CEILING(NWORDS(fixnum_value(vector->length), 4) + 2, 2);
1432 #else
1433 count =
1434 CEILING(NWORDS(fixnum_value(vector->length), 2) + 2, 2);
1435 #endif
1436 break;
1437
1438 case type_SimpleArrayUnsignedByte32:
1439 #ifdef type_SimpleArraySignedByte30
1440 case type_SimpleArraySignedByte30:
1441 #endif
1442 #ifdef type_SimpleArraySignedByte32
1443 case type_SimpleArraySignedByte32:
1444 #endif
1445 vector = (struct vector *) addr;
1446 #ifdef __x86_64
1447 count =
1448 CEILING(NWORDS(fixnum_value(vector->length), 2) + 2, 2);
1449 #else
1450 count = CEILING(fixnum_value(vector->length) + 2, 2);
1451 #endif
1452 break;
1453
1454 case type_SimpleArraySingleFloat:
1455 vector = (struct vector *) addr;
1456 #ifdef __x86_64
1457 count =
1458 CEILING(NWORDS(fixnum_value(vector->length), 2) + 2, 2);
1459 #else
1460 count = CEILING(fixnum_value(vector->length) + 2, 2);
1461 #endif
1462 break;
1463
1464 case type_SimpleArrayDoubleFloat:
1465 #ifdef type_SimpleArrayComplexSingleFloat
1466 case type_SimpleArrayComplexSingleFloat:
1467 #endif
1468 vector = (struct vector *) addr;
1469 #ifdef __x86_64
1470 count = CEILING(fixnum_value(vector->length) + 2, 2);
1471 #else
1472 count = fixnum_value(vector->length) * 2 + 2;
1473 #endif
1474 break;
1475
1476 #ifdef type_SimpleArrayLongFloat
1477 case type_SimpleArrayLongFloat:
1478 vector = (struct vector *) addr;
1479 #ifdef i386
1480 count = fixnum_value(vector->length) * 3 + 2;
1481 #endif
1482 #ifdef __x86_64
1483 count = fixnum_value(vector->length) * 2 + 2;
1484 #endif
1485 #ifdef sparc
1486 count = fixnum_value(vector->length) * 4 + 2;
1487 #endif
1488 break;
1489 #endif
1490
1491 #ifdef type_SimpleArrayComplexDoubleFloat
1492 case type_SimpleArrayComplexDoubleFloat:
1493 vector = (struct vector *) addr;
1494 #ifdef __x86_64
1495 count = fixnum_value(vector->length) * 2 + 2;
1496 #else
1497 count = fixnum_value(vector->length) * 4 + 2;
1498 #endif
1499 break;
1500 #endif
1501
1502 #ifdef type_SimpleArrayComplexLongFloat
1503 case type_SimpleArrayComplexLongFloat:
1504 vector = (struct vector *) addr;
1505 #ifdef i386
1506 count = fixnum_value(vector->length) * 6 + 2;
1507 #endif
1508 #ifdef __x86_64
1509 count = fixnum_value(vector->length) * 4 + 2;
1510 #endif
1511 #ifdef sparc
1512 count = fixnum_value(vector->length) * 8 + 2;
1513 #endif
1514 break;
1515 #endif
1516
1517 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
1518 case type_SimpleArrayComplexDoubleDoubleFloat:
1519 vector = (struct vector *) addr;
1520 count = fixnum_value(vector->length) * 8 + 2;
1521 break;
1522 #endif
1523
1524 case type_CodeHeader:
1525 #if !(defined(i386) || defined(__x86_64))
1526 gc_abort(); /* No code headers in static space */
1527 #else
1528 count = pscav_code((struct code *) addr);
1529 #endif
1530 break;
1531
1532 case type_FunctionHeader:
1533 case type_ClosureFunctionHeader:
1534 case type_ReturnPcHeader:
1535 /* We should never hit any of these, 'cause they occur */
1536 /* buried in the middle of code objects. */
1537
1538 gc_abort();
1539
1540
1541 break;
1542
1543 #if (defined(i386) || defined(__x86_64))
1544 case type_ClosureHeader:
1545 case type_FuncallableInstanceHeader:
1546 case type_ByteCodeFunction:
1547 case type_ByteCodeClosure:
1548 #ifdef type_DylanFunctionHeader
1549 case type_DylanFunctionHeader:
1550 #endif
1551 /* The function self pointer needs special care on the
1552 x86 because it is the real entry point. */
1553 {
1554 lispobj fun = ((struct closure *) addr)->function
1555
1556 - RAW_ADDR_OFFSET;
1557 pscav(&fun, 1, constant);
1558 ((struct closure *) addr)->function = fun + RAW_ADDR_OFFSET;
1559 }
1560 count = 2;
1561 break;
1562 #endif
1563
1564 case type_WeakPointer:
1565 /* Weak pointers get preserved during purify, 'cause I don't */
1566 /* feel like figuring out how to break them. */
1567 pscav(addr + 1, 2, constant);
1568 count = 4;
1569 break;
1570
1571 case type_Fdefn:
1572 /* We have to handle fdefn objects specially, so we can fix */
1573 /* up the raw function address. */
1574 count = pscav_fdefn((struct fdefn *) addr);
1575 break;
1576
1577 #ifdef type_ScavengerHook
1578 case type_ScavengerHook:
1579 count = pscav_scavenger_hook((struct scavenger_hook *) addr);
1580 break;
1581 #endif
1582
1583 default:
1584 count = 1;
1585 break;
1586 }
1587 } else {
1588 /* It's a fixnum. */
1589 count = 1;
1590 }
1591
1592 addr += count;
1593 nwords -= count;
1594 }
1595
1596 return addr;
1597 }
1598
1599 int
1600 purify(lispobj static_roots, lispobj read_only_roots)
1601 {
1602 lispobj *clean;
1603 int count, i;
1604 struct later *laters, *next;
1605
1606 #ifdef PRINTNOISE
1607 printf("[Doing purification:");
1608 fflush(stdout);
1609 #endif
1610
1611 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
1612 printf(" Ack! Can't purify interrupt contexts. ");
1613 fflush(stdout);
1614 return 0;
1615 }
1616 #if defined(ibmrt) || defined(i386) || defined(__x86_64)
1617 current_dynamic_space_free_pointer =
1618 (lispobj *) SymbolValue(ALLOCATION_POINTER);
1619 #endif
1620
1621 read_only_end = read_only_free =
1622 (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1623 static_end = static_free =
1624 (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
1625
1626 #ifdef PRINTNOISE
1627 printf(" roots");
1628 fflush(stdout);
1629 #endif
1630
1631 #ifdef GENCGC
1632 #if (defined(i386) || defined(__x86_64))
1633 gc_assert(control_stack_end > ((&read_only_roots) + 1));
1634 setup_i386_stack_scav(((&static_roots) - 2), control_stack_end);
1635 #elif defined(sparc)
1636 #endif
1637 #endif
1638
1639 pscav(&static_roots, 1, FALSE);
1640 pscav(&read_only_roots, 1, TRUE);
1641
1642 #ifdef PRINTNOISE
1643 printf(" handlers");
1644 fflush(stdout);
1645 #endif
1646 pscav((lispobj *) interrupt_handlers,
1647 sizeof(interrupt_handlers) / sizeof(lispobj), FALSE);
1648
1649 #ifdef PRINTNOISE
1650 printf(" stack");
1651 fflush(stdout);
1652 #endif
1653 #if !(defined(i386) || defined(__x86_64))
1654 pscav(control_stack, current_control_stack_pointer - control_stack, FALSE);
1655 #else
1656 #ifdef GENCGC
1657 pscav_i386_stack();
1658 #endif
1659 #ifdef WANT_CGC
1660 gc_assert(control_stack_end > ((&read_only_roots) + 1));
1661 carefully_pscav_stack(((&read_only_roots) + 1), control_stack_end);
1662 #endif
1663 #endif
1664
1665 #ifdef PRINTNOISE
1666 printf(" bindings");
1667 fflush(stdout);
1668 #endif
1669 #if !defined(ibmrt) && !defined(i386) && !defined(__x86_64)
1670 pscav(binding_stack, current_binding_stack_pointer - binding_stack, FALSE);
1671 #else
1672 pscav(binding_stack,
1673 (lispobj *) SymbolValue(BINDING_STACK_POINTER) - binding_stack,
1674 FALSE);
1675 #endif
1676
1677 #ifdef SCAVENGE_READ_ONLY_SPACE
1678 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
1679 && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
1680 unsigned read_only_space_size =
1681 (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
1682
1683 read_only_space;
1684 fprintf(stderr, "Scavenge read only space: %lu bytes\n",
1685 (unsigned long) (read_only_space_size * sizeof(lispobj)));
1686 pscav(read_only_space, read_only_space_size, FALSE);
1687 }
1688 #endif
1689
1690 #ifdef PRINTNOISE
1691 printf(" static");
1692 fflush(stdout);
1693 #endif
1694 clean = static_space;
1695 do {
1696 while (clean < static_free)
1697 clean = pscav(clean, static_free - clean, FALSE);
1698 if (clean != static_free) {
1699 fprintf(stderr, "*** clean (%p) != static_free (%p)\n",
1700 clean, static_free);
1701 fprintf(stderr, " Possible heap corruption?\n");
1702 }
1703
1704 laters = later_blocks;
1705 count = later_count;
1706 later_blocks = NULL;
1707 later_count = 0;
1708 while (laters != NULL) {
1709 for (i = 0; i < count; i++) {
1710 if (laters->u[i].count == 0);
1711 else if (laters->u[i].count <= LATERMAXCOUNT) {
1712 pscav(laters->u[i + 1].ptr, laters->u[i].count, TRUE);
1713 i++;
1714 } else
1715 pscav(laters->u[i].ptr, 1, TRUE);
1716 }
1717 next = laters->next;
1718 free(laters);
1719 laters = next;
1720 count = LATERBLOCKSIZE;
1721 }
1722 } while (clean < static_free || later_blocks != NULL);
1723
1724 if (clean != static_free) {
1725 fprintf(stderr, "*** clean (%p) != static_free (%p)\n",
1726 clean, static_free);
1727 fprintf(stderr, " Possible heap corruption?\n");
1728 }
1729
1730
1731
1732 #ifdef PRINTNOISE
1733 printf(" cleanup");
1734 fflush(stdout);
1735 #endif
1736
1737 #if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
1738 if (SymbolValue(X86_CGC_ACTIVE_P) != T)
1739 os_zero((os_vm_address_t) current_dynamic_space,
1740 (os_vm_size_t) dynamic_space_size);
1741 #else
1742 #if !defined(GENCGC)
1743 os_zero((os_vm_address_t) current_dynamic_space,
1744 (os_vm_size_t) dynamic_space_size);
1745 #endif
1746 #endif
1747
1748 /*
1749 * Zero stack. Note the stack is also zeroed by sub-gc calling
1750 * scrub-control-stack - this zeros the stack on the x86.
1751 */
1752 #if !(defined(i386) || defined(__x86_64))
1753 os_zero((os_vm_address_t) current_control_stack_pointer,
1754 (os_vm_size_t) (CONTROL_STACK_SIZE -
1755 ((current_control_stack_pointer - control_stack) *
1756 sizeof(lispobj))));
1757 #endif
1758
1759 #if defined(WANT_CGC) && defined(STATIC_BLUE_BAG)
1760 {
1761 lispobj bag = SymbolValue(STATIC_BLUE_BAG);
1762 struct cons *cons = (struct cons *) static_free;
1763 struct cons *pair = cons + 1;
1764
1765 static_free += 2 * WORDS_PER_CONS;
1766 if (bag == type_UnboundMarker)
1767 bag = NIL;
1768 cons->cdr = bag;
1769 cons->car = (lispobj) pair | type_ListPointer;
1770 pair->car = (lispobj) static_end;
1771 pair->cdr = (lispobj) static_free;
1772 bag = (lispobj) cons | type_ListPointer;
1773 SetSymbolValue(STATIC_BLUE_BAG, bag);
1774 }
1775 #endif
1776
1777 /*
1778 * It helps to update the heap free pointers so that free_heap can
1779 * verify after it's done.
1780 */
1781 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj) read_only_free);
1782 SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj) static_free);
1783
1784 #if 0
1785 /*
1786 * Test the static space for validity. This was useful in
1787 * catching some corruption problems on x86. Should we enable
1788 * this all the time?
1789 */
1790 verify_space((lispobj *) static_space, static_free - static_space);
1791 #endif
1792
1793 #if !defined(ibmrt) && !defined(i386) && !defined(__x86_64) && !((defined(sparc) || (defined(DARWIN) && defined(__ppc__))) && defined(GENCGC))
1794 current_dynamic_space_free_pointer = current_dynamic_space;
1795 #else
1796 #if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
1797 /* X86 using CGC */
1798 if (SymbolValue(X86_CGC_ACTIVE_P) != T)
1799 SetSymbolValue(ALLOCATION_POINTER, (lispobj) current_dynamic_space);
1800 else
1801 cgc_free_heap();
1802 #else
1803 #ifdef GENCGC
1804 gc_free_heap();
1805 #else
1806 /* ibmrt using GC */
1807 SetSymbolValue(ALLOCATION_POINTER, (lispobj) current_dynamic_space);
1808 #endif
1809 #endif
1810 #endif
1811
1812 #ifdef type_ScavengerHook
1813 /* Call the scavenger hook functions */
1814 {
1815 struct scavenger_hook *sh;
1816
1817 for (sh = (struct scavenger_hook *) PTR((int) scavenger_hooks);
1818 (lispobj) sh != PTR(NIL);) {
1819 struct scavenger_hook *sh_next =
1820 (struct scavenger_hook *) PTR((unsigned long) sh->next);
1821
1822 funcall0(sh->function);
1823 sh->next = NULL;
1824 sh = sh_next;
1825 }
1826 scavenger_hooks = (struct scavenger_hook *) NIL;
1827 }
1828 #endif
1829
1830 #ifdef PRINTNOISE
1831 printf(" Done.]\n");
1832 fflush(stdout);
1833 #endif
1834
1835 return 0;
1836 }

  ViewVC Help
Powered by ViewVC 1.1.5