Clean up RCS ids
[projects/cmucl/cmucl.git] / src / lisp / gencgc.c
CommitLineData
0c41e522 1/*
2 * Generational Conservative Garbage Collector for CMUCL x86.
3 *
4 * This code was written by Douglas T. Crosher, based on Public Domain
5 * codes from Carnegie Mellon University. This code has been placed in
6 * the public domain, and is provided 'as is'.
7 *
2bf0de4c 8 * Douglas Crosher, 1996, 1997, 1998, 1999.
0c41e522 9 *
2bf0de4c 10 */
0c41e522 11
f0d2aa86 12#include <limits.h>
0c41e522 13#include <stdio.h>
9e89e4e5 14#include <stdlib.h>
0c41e522 15#include <signal.h>
5a1bf534 16#include <string.h>
0c41e522 17#include "lisp.h"
c66586ed 18#include "arch.h"
0c41e522 19#include "internals.h"
20#include "os.h"
21#include "globals.h"
22#include "interrupt.h"
23#include "validate.h"
24#include "lispregs.h"
c66586ed 25#include "interr.h"
0c41e522 26#include "gencgc.h"
27
eff841d2 28/*
29 * This value in a hash table hash-vector means that the key uses
30 * EQ-based hashing. That is, the key might be using EQ or EQL for
31 * the test. This MUST match the value used in hash-new.lisp!
32 */
33#define EQ_BASED_HASH_VALUE 0x80000000
46a4f482 34
0c41e522 35#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
36 __FILE__, __LINE__)
37
3f2ead72 38#if (defined(i386) || defined(__x86_64))
e31f8138 39
40#define set_alloc_pointer(value) \
41 SetSymbolValue (ALLOCATION_POINTER, (value))
42#define get_alloc_pointer() \
43 SymbolValue (ALLOCATION_POINTER)
44#define get_binding_stack_pointer() \
45 SymbolValue (BINDING_STACK_POINTER)
46#define get_pseudo_atomic_atomic() \
47 SymbolValue (PSEUDO_ATOMIC_ATOMIC)
48#define set_pseudo_atomic_atomic() \
49 SetSymbolValue (PSEUDO_ATOMIC_ATOMIC, make_fixnum (1))
50#define clr_pseudo_atomic_atomic() \
51 SetSymbolValue (PSEUDO_ATOMIC_ATOMIC, make_fixnum (0))
52#define get_pseudo_atomic_interrupted() \
53 SymbolValue (PSEUDO_ATOMIC_INTERRUPTED)
54#define clr_pseudo_atomic_interrupted() \
55 SetSymbolValue (PSEUDO_ATOMIC_INTERRUPTED, make_fixnum (0))
56
723055bb 57#define set_current_region_free(value) \
58 SetSymbolValue(CURRENT_REGION_FREE_POINTER, (value))
59#define set_current_region_end(value) \
60 SetSymbolValue(CURRENT_REGION_END_ADDR, (value))
61#define get_current_region_free() \
62 SymbolValue(CURRENT_REGION_FREE_POINTER)
63
64#define set_current_region_end(value) \
65 SetSymbolValue(CURRENT_REGION_END_ADDR, (value))
66
af867264 67#elif defined(sparc)
e31f8138 68
b76a726f 69/*
70 * current_dynamic_space_free_pointer contains the pseudo-atomic
71 * stuff, so we need to preserve those bits when we give it a value.
72 * This value better not have any bits set there either!
73 */
feaa7104 74
75/*
76 * On sparc, we don't need to set the alloc_pointer in the code here
77 * because the alloc pointer (current_dynamic_space_free_pointer) is
78 * the same as *current-region-free-pointer* and is stored in
79 * alloc-tn.
80 */
9a8c1c2f 81#define set_alloc_pointer(value)
e31f8138 82#define get_alloc_pointer() \
12e350c5 83 ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)
e31f8138 84#define get_binding_stack_pointer() \
85 (current_binding_stack_pointer)
af867264 86#define get_pseudo_atomic_atomic() \
263f0353 87 ((unsigned long)current_dynamic_space_free_pointer & pseudo_atomic_Value)
af867264 88#define set_pseudo_atomic_atomic() \
e31f8138 89 (current_dynamic_space_free_pointer \
263f0353 90 = (lispobj*) ((unsigned long)current_dynamic_space_free_pointer | pseudo_atomic_Value))
af867264 91#define clr_pseudo_atomic_atomic() \
e31f8138 92 (current_dynamic_space_free_pointer \
263f0353 93 = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_Value))
e31f8138 94#define get_pseudo_atomic_interrupted() \
263f0353 95 ((unsigned long) current_dynamic_space_free_pointer & pseudo_atomic_InterruptedValue)
af867264 96#define clr_pseudo_atomic_interrupted() \
e31f8138 97 (current_dynamic_space_free_pointer \
263f0353 98 = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_InterruptedValue))
e31f8138 99
723055bb 100#define set_current_region_free(value) \
101 current_dynamic_space_free_pointer = (lispobj*)((value) | ((long)current_dynamic_space_free_pointer & lowtag_Mask))
102
103#define get_current_region_free() \
104 ((long)current_dynamic_space_free_pointer & (~(lowtag_Mask)))
723055bb 105
106#define set_current_region_end(value) \
107 SetSymbolValue(CURRENT_REGION_END_ADDR, (value))
108
555746e0 109#elif defined(DARWIN) && defined(__ppc__)
46a4f482 110#ifndef pseudo_atomic_InterruptedValue
111#define pseudo_atomic_InterruptedValue 1
112#endif
113#ifndef pseudo_atomic_Value
114#define pseudo_atomic_Value 4
115#endif
116
117#define set_alloc_pointer(value)
118#define get_alloc_pointer() \
119 ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)
120#define get_binding_stack_pointer() \
121 (current_binding_stack_pointer)
122#define get_pseudo_atomic_atomic() \
123 ((unsigned long)current_dynamic_space_free_pointer & pseudo_atomic_Value)
124#define set_pseudo_atomic_atomic() \
125 (current_dynamic_space_free_pointer \
126 = (lispobj*) ((unsigned long)current_dynamic_space_free_pointer | pseudo_atomic_Value))
127#define clr_pseudo_atomic_atomic() \
128 (current_dynamic_space_free_pointer \
129 = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_Value))
130#define get_pseudo_atomic_interrupted() \
131 ((unsigned long) current_dynamic_space_free_pointer & pseudo_atomic_InterruptedValue)
132#define clr_pseudo_atomic_interrupted() \
133 (current_dynamic_space_free_pointer \
134 = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_InterruptedValue))
135
136#define set_current_region_free(value) \
137 current_dynamic_space_free_pointer = (lispobj*)((value) | ((long)current_dynamic_space_free_pointer & lowtag_Mask))
138
139#define get_current_region_free() \
140 ((long)current_dynamic_space_free_pointer & (~(lowtag_Mask)))
141
142#define set_current_region_end(value) \
143 SetSymbolValue(CURRENT_REGION_END_ADDR, (value))
144
af867264 145#else
e31f8138 146#error gencgc is not supported on this platform
af867264 147#endif
148
c197af2f 149/* Define for activating assertions. */
150
6438e048 151#if defined(x86) && defined(SOLARIS)
c197af2f 152#define GC_ASSERTIONS 1
153#endif
154
155/* Check for references to stack-allocated objects. */
156
157#ifdef GC_ASSERTIONS
158
159static void *invalid_stack_start, *invalid_stack_end;
160
161static inline void
9a8c1c2f 162check_escaped_stack_object(lispobj * where, lispobj obj)
163{
555746e0 164#if !defined(DARWIN) && !defined(__ppc__)
9a8c1c2f 165 void *p;
166
167 if (Pointerp(obj)
168 && (p = (void *) PTR(obj),
169 (p >= (void *) CONTROL_STACK_START
e7997cb6 170 && p < (void *) control_stack_end))) {
9a8c1c2f 171 char *space;
172
173 if (where >= (lispobj *) DYNAMIC_0_SPACE_START
e7997cb6 174 && where < (lispobj *) (DYNAMIC_0_SPACE_START + dynamic_space_size))
9a8c1c2f 175 space = "dynamic space";
176 else if (where >= (lispobj *) STATIC_SPACE_START
177 && where <
e7997cb6 178 (lispobj *) (STATIC_SPACE_START + static_space_size)) space =
9a8c1c2f 179 "static space";
180 else if (where >= (lispobj *) READ_ONLY_SPACE_START
181 && where <
182 (lispobj *) (READ_ONLY_SPACE_START +
e7997cb6 183 read_only_space_size)) space = "read-only space";
9a8c1c2f 184 else
185 space = NULL;
186
187 /* GC itself uses some stack, so we can't tell exactly where the
188 invalid stack area starts. Usually, it should be an error if a
189 reference to a stack-allocated object is found, although it
190 is valid to store a reference to a stack-allocated object
191 temporarily in another reachable object, as long as the
192 reference goes away at the end of a dynamic extent. */
193
194 if (p >= invalid_stack_start && p < invalid_stack_end)
195 lose("Escaped stack-allocated object 0x%08lx at %p in %s\n",
196 (unsigned long) obj, where, space);
fb64dc30 197#ifndef i386
9a8c1c2f 198 else if ((where >= (lispobj *) CONTROL_STACK_START
e7997cb6 199 && where < (lispobj *) (control_stack_end))
9a8c1c2f 200 || (space == NULL)) {
201 /* Do nothing if it the reference is from the control stack,
202 because that will happen, and that's ok. Or if it's from
203 an unknown space (typically from scavenging an interrupt
204 context. */
205 }
206#endif
207
208 else
209 fprintf(stderr,
210 "Reference to stack-allocated object 0x%08lx at %p in %s\n",
211 (unsigned long) obj, where,
212 space ? space : "Unknown space");
c197af2f 213 }
46a4f482 214#endif
c197af2f 215}
216
217#endif /* GC_ASSERTIONS */
218
219
c197af2f 220#ifdef GC_ASSERTIONS
221#define gc_assert(ex) \
222 do { \
223 if (!(ex)) gc_abort (); \
224 } while (0)
0c41e522 225#else
9e89e4e5 226#define gc_assert(ex) (void) 0
0c41e522 227#endif
0c41e522 228\f
9a8c1c2f 229
2bf0de4c 230/*
231 * The number of generations, an extra is added to this for use as a temp.
232 */
0c41e522 233#define NUM_GENERATIONS 6
234
235/* Debugging variables. */
236
2bf0de4c 237/*
238 * The verbose level. All non-error messages are disabled at level 0;
239 * and only a few rare messages are printed at level 1.
240 */
ac5034a9 241unsigned gencgc_verbose = 0;
65f0bdc0 242unsigned counters_verbose = 0;
0c41e522 243
2bf0de4c 244/*
83376964 245 * If true, then some debugging information is printed when scavenging
246 * static (malloc'ed) arrays.
247 */
248boolean debug_static_array_p = 0;
249
250/*
2bf0de4c 251 * To enable the use of page protection to help avoid the scavenging
252 * of pages that don't have pointers to younger generations.
253 */
9a8c1c2f 254boolean enable_page_protection = TRUE;
65f0bdc0 255
2bf0de4c 256/*
257 * Hunt for pointers to old-space, when GCing generations >= verify_gen.
258 * Set to NUM_GENERATIONS to disable.
259 */
bd46c00c 260int verify_gens = NUM_GENERATIONS;
0c41e522 261
2bf0de4c 262/*
af867264 263 * Enable a pre-scan verify of generation 0 before it's GCed. (This
264 * makes GC very, very slow, so don't enable this unless you really
265 * need it!)
2bf0de4c 266 */
0c41e522 267boolean pre_verify_gen_0 = FALSE;
268
bd46c00c 269/*
2bf0de4c 270 * Enable checking for bad pointers after gc_free_heap called from purify.
bd46c00c 271 */
906452d6 272#if 0 && defined(DARWIN)
46a4f482 273boolean verify_after_free_heap = TRUE;
274#else
bd46c00c 275boolean verify_after_free_heap = FALSE;
46a4f482 276#endif
bd46c00c 277
2bf0de4c 278/*
279 * Enable the printing of a note when code objects are found in the
280 * dynamic space during a heap verify.
281 */
0c41e522 282boolean verify_dynamic_code_check = FALSE;
283
2bf0de4c 284/*
285 * Enable the checking of code objects for fixup errors after they are
af867264 286 * transported. (Only used for x86.)
2bf0de4c 287 */
bd46c00c 288boolean check_code_fixups = FALSE;
0c41e522 289
2bf0de4c 290/*
291 * To enable unmapping of a page and re-mmaping it to have it zero filled.
b39b25d0 292 * Note: this can waste a lot of swap on FreeBSD and Open/NetBSD(?) so
293 * don't unmap.
2bf0de4c 294 */
b39b25d0 295#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__)
0c41e522 296boolean gencgc_unmap_zero = FALSE;
297#else
298boolean gencgc_unmap_zero = TRUE;
299#endif
300
2bf0de4c 301/*
302 * Enable checking that newly allocated regions are zero filled.
303 */
906452d6 304#if 0 && defined(DARWIN)
46a4f482 305boolean gencgc_zero_check = TRUE;
306boolean gencgc_enable_verify_zero_fill = TRUE;
307#else
0c41e522 308boolean gencgc_zero_check = FALSE;
3bf953cb 309boolean gencgc_enable_verify_zero_fill = FALSE;
46a4f482 310#endif
3bf953cb 311
bd46c00c 312/*
313 * Enable checking that free pages are zero filled during gc_free_heap
314 * called after purify.
315 */
906452d6 316#if 0 && defined(DARWIN)
46a4f482 317boolean gencgc_zero_check_during_free_heap = TRUE;
318#else
bd46c00c 319boolean gencgc_zero_check_during_free_heap = FALSE;
46a4f482 320#endif
bd46c00c 321
2bf0de4c 322/*
323 * The minimum size for a large object.
324 */
0b2b8885 325unsigned large_object_size = 4 * GC_PAGE_SIZE;
0c41e522 326
2bf0de4c 327/*
328 * Enable the filtering of stack/register pointers. This could reduce
329 * the number of invalid pointers accepted. It will probably degrades
330 * interrupt safety during object initialisation.
331 */
0c41e522 332boolean enable_pointer_filter = TRUE;
0c41e522 333\f
9a8c1c2f 334
2bf0de4c 335/*
336 * The total bytes allocated. Seen by (dynamic-usage)
337 */
0c41e522 338unsigned long bytes_allocated = 0;
0715274e 339
340/*
65f0bdc0 341 * The total amount of bytes ever allocated. Not decreased by GC.
342 */
343
344volatile unsigned long long bytes_allocated_sum = 0;
345
346/*
0715274e 347 * GC trigger; a value of 0xffffffff represents disabled.
348 */
349unsigned long auto_gc_trigger = 0xffffffff;
0c41e522 350
2bf0de4c 351/*
3e309c44 352 * Number of pages to reserve for heap overflow. We want some space
353 * available on the heap when we are close to a heap overflow, so we
354 * can handle the overflow. But how much do we really need? I (rtoy)
355 * think 256 pages is probably a decent amount. (That's 1 MB for x86,
356 * 2 MB for sparc, which has 8K pages.)
357 */
358
359unsigned long reserved_heap_pages = 256;
360
361/*
2bf0de4c 362 * The src. and dest. generations. Set before a GC starts scavenging.
363 */
0c41e522 364static int from_space;
365static int new_space;
0c41e522 366\f
9a8c1c2f 367
2bf0de4c 368/*
369 * GC structures and variables.
370 */
0c41e522 371
2bf0de4c 372/*
a7070998 373 * Number of pages within the dynamic heap, setup from the size of the
374 * dynamic space.
375 */
376unsigned dynamic_space_pages;
377
378/*
2bf0de4c 379 * An array of page structures is statically allocated.
d54d3cbf 380 * This helps quickly map between an address and its page structure.
2bf0de4c 381 */
a7070998 382struct page *page_table;
0c41e522 383
2bf0de4c 384/*
385 * Heap base, needed for mapping addresses to page structures.
386 */
ae169a66 387static char *heap_base = NULL;
0c41e522 388
2bf0de4c 389/*
390 * Calculate the start address for the given page number.
391 */
97083c55 392static char *
9a8c1c2f 393page_address(int page_num)
0c41e522 394{
0b2b8885 395 return heap_base + GC_PAGE_SIZE * page_num;
0c41e522 396}
397
2bf0de4c 398/*
399 * Find the page index within the page_table for the given address.
400 * Returns -1 on failure.
401 */
97083c55 402int
9a8c1c2f 403find_page_index(void *addr)
0c41e522 404{
9a8c1c2f 405 int index = (char *) addr - heap_base;
0c41e522 406
9a8c1c2f 407 if (index >= 0) {
0b2b8885 408 index = (unsigned int) index / GC_PAGE_SIZE;
9a8c1c2f 409 if (index < dynamic_space_pages)
410 return index;
411 }
0c41e522 412
9a8c1c2f 413 return -1;
0c41e522 414}
415
97083c55 416/*
417 * This routine implements a write barrier used to record stores into
418 * to boxed regions outside of generation 0. When such a store occurs
419 * this routine will be automatically invoked by the page fault
420 * handler. If passed an address outside of the dynamic space, this
421 * routine will return immediately with a value of 0. Otherwise, the
422 * page belonging to the address is made writable, the protection
423 * change is recorded in the garbage collector page table, and a value
424 * of 1 is returned.
425 */
426int
427gc_write_barrier(void *addr)
428{
429 int page_index = find_page_index(addr);
430
431 /* Check if the fault is within the dynamic space. */
432 if (page_index == -1) {
433 return 0;
434 }
435
436 /* The page should have been marked write protected */
437 if (!PAGE_WRITE_PROTECTED(page_index))
438 fprintf(stderr,
439 "*** Page fault in page not marked as write protected\n");
440
441 /* Un-protect the page */
0b2b8885 442 os_protect((os_vm_address_t) page_address(page_index), GC_PAGE_SIZE, OS_VM_PROT_ALL);
97083c55 443 page_table[page_index].flags &= ~PAGE_WRITE_PROTECTED_MASK;
444 page_table[page_index].flags |= PAGE_WRITE_PROTECT_CLEARED_MASK;
445
446 return 1;
447}
0c41e522 448
2bf0de4c 449/*
450 * A structure to hold the state of a generation.
451 */
8a9d1d8d
RT
452#define MEM_AGE_SHIFT 16
453#define MEM_AGE_SCALE (1 << MEM_AGE_SHIFT)
454
0c41e522 455struct generation {
456
9a8c1c2f 457 /* The first page that gc_alloc checks on its next call. */
458 int alloc_start_page;
459
460 /* The first page that gc_alloc_unboxed checks on its next call. */
461 int alloc_unboxed_start_page;
462
463 /*
464 * The first page that gc_alloc_large (boxed) considers on its next call.
465 * Although it always allocates after the boxed_region.
466 */
467 int alloc_large_start_page;
468
469 /*
470 * The first page that gc_alloc_large (unboxed) considers on its next call.
471 * Although it always allocates after the current_unboxed_region.
472 */
473 int alloc_large_unboxed_start_page;
474
475 /* The bytes allocate to this generation. */
476 int bytes_allocated;
477
478 /* The number of bytes at which to trigger a GC */
479 int gc_trigger;
480
481 /* To calculate a new level for gc_trigger */
482 int bytes_consed_between_gc;
483
484 /* The number of GCs since the last raise. */
485 int num_gc;
486
487 /*
488 * The average age at after which a GC will raise objects to the
489 * next generation.
490 */
491 int trigger_age;
492
493 /*
494 * The cumulative sum of the bytes allocated to this generation. It
495 * is cleared after a GC on this generation, and update before new
496 * objects are added from a GC of a younger generation. Dividing by
497 * the bytes_allocated will give the average age of the memory in
498 * this generation since its last GC.
499 */
500 int cum_sum_bytes_allocated;
501
502 /*
503 * A minimum average memory age before a GC will occur helps prevent
504 * a GC when a large number of new live objects have been added, in
505 * which case a GC could be a waste of time.
8a9d1d8d
RT
506 *
507 * The age is represented as an integer between 0 and 32767
508 * corresponding to an age of 0 to (just less than) 1.
9a8c1c2f 509 */
8a9d1d8d 510 int min_av_mem_age;
0c41e522 511};
512
2bf0de4c 513/*
514 * An array of generation structures. There needs to be one more
515 * generation structure than actual generations as the oldest
516 * generations is temporarily raised then lowered.
517 */
2057879e 518static struct generation generations[NUM_GENERATIONS + 1];
0c41e522 519
bf84be07 520/* Statistics about a generation, extracted from the generations
521 array. This gets returned to Lisp.
522*/
523
524struct generation_stats {
9a8c1c2f 525 int bytes_allocated;
526 int gc_trigger;
527 int bytes_consed_between_gc;
528 int num_gc;
529 int trigger_age;
530 int cum_sum_bytes_allocated;
8a9d1d8d 531 int min_av_mem_age;
bf84be07 532};
9a8c1c2f 533
bf84be07 534
2bf0de4c 535/*
536 * The oldest generation that will currently be GCed by default.
537 * Valid values are: 0, 1, ... (NUM_GENERATIONS - 1)
538 *
539 * The default of (NUM_GENERATIONS - 1) enables GC on all generations.
540 *
541 * Setting this to 0 effectively disables the generational nature of
542 * the GC. In some applications generational GC may not be useful
543 * because there are no long-lived objects.
544 *
545 * An intermediate value could be handy after moving long-lived data
546 * into an older generation so an unnecessary GC of this long-lived
547 * data can be avoided.
548 */
9a8c1c2f 549unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS - 1;
0c41e522 550
551
2bf0de4c 552/*
553 * The maximum free page in the heap is maintained and used to update
554 * ALLOCATION_POINTER which is used by the room function to limit its
555 * search of the heap. XX Gencgc obviously needs to be better
556 * integrated with the lisp code.
05747b21 557 *
558 * Except on sparc and ppc, there's no ALLOCATION_POINTER, so it's
559 * never updated. So make this available (non-static).
2bf0de4c 560 */
05747b21 561int last_free_page;
9a8c1c2f 562\f
0c41e522 563
555746e0 564static void scan_weak_tables(void);
565static void scan_weak_objects(void);
0c41e522 566
2bf0de4c 567/*
568 * Misc. heap functions.
569 */
0c41e522 570
2bf0de4c 571/*
572 * Count the number of write protected pages within the given generation.
573 */
9a8c1c2f 574static int
575count_write_protect_generation_pages(int generation)
0c41e522 576{
9a8c1c2f 577 int i;
578 int cnt = 0;
579 int mmask, mflags;
e7e59d7d 580
9a8c1c2f 581 mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
582 | PAGE_GENERATION_MASK;
583 mflags = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK | generation;
2bf0de4c 584
9a8c1c2f 585 for (i = 0; i < last_free_page; i++)
586 if (PAGE_FLAGS(i, mmask) == mflags)
587 cnt++;
588 return cnt;
0c41e522 589}
590
2bf0de4c 591/*
592 * Count the number of pages within the given generation.
593 */
9a8c1c2f 594static int
595count_generation_pages(int generation)
0c41e522 596{
9a8c1c2f 597 int i;
598 int cnt = 0;
599 int mmask, mflags;
e7e59d7d 600
9a8c1c2f 601 mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;
602 mflags = PAGE_ALLOCATED_MASK | generation;
2bf0de4c 603
9a8c1c2f 604 for (i = 0; i < last_free_page; i++)
605 if (PAGE_FLAGS(i, mmask) == mflags)
606 cnt++;
607 return cnt;
0c41e522 608}
609
2bf0de4c 610/*
611 * Count the number of dont_move pages.
612 */
9a8c1c2f 613static int
614count_dont_move_pages(void)
0c41e522 615{
9a8c1c2f 616 int i;
617 int cnt = 0;
618 int mmask;
e7e59d7d 619
9a8c1c2f 620 mmask = PAGE_ALLOCATED_MASK | PAGE_DONT_MOVE_MASK;
2bf0de4c 621
9a8c1c2f 622 for (i = 0; i < last_free_page; i++)
623 if (PAGE_FLAGS(i, mmask) == mmask)
624 cnt++;
625 return cnt;
0c41e522 626}
627
2bf0de4c 628/*
629 * Work through the pages and add up the number of bytes used for the
630 * given generation.
631 */
06354d92 632#ifdef GC_ASSERTIONS
9a8c1c2f 633static int
634generation_bytes_allocated(int generation)
0c41e522 635{
9a8c1c2f 636 int i;
637 int bytes_allocated = 0;
638 int mmask, mflags;
e7e59d7d 639
9a8c1c2f 640 mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;
641 mflags = PAGE_ALLOCATED_MASK | generation;
2bf0de4c 642
9a8c1c2f 643 for (i = 0; i < last_free_page; i++) {
644 if (PAGE_FLAGS(i, mmask) == mflags)
645 bytes_allocated += page_table[i].bytes_used;
646 }
647 return bytes_allocated;
0c41e522 648}
06354d92 649#endif
0c41e522 650
2bf0de4c 651/*
652 * Return the average age of the memory in a generation.
653 */
8a9d1d8d 654static int
9a8c1c2f 655gen_av_mem_age(int gen)
0c41e522 656{
9a8c1c2f 657 if (generations[gen].bytes_allocated == 0)
8a9d1d8d 658 return 0;
2bf0de4c 659
7933ebf6 660 return (((long long) generations[gen].cum_sum_bytes_allocated) << MEM_AGE_SHIFT) /
8a9d1d8d 661 generations[gen].bytes_allocated;
0c41e522 662}
663
2daa0e7c
RT
664
665void
666save_fpu_state(void* state)
667{
668#if defined(i386) || defined(__x86_64)
669 if (fpu_mode == SSE2) {
670 sse_save(state);
671 } else {
672 fpu_save(state);
673 }
674#else
675 fpu_save(state);
676#endif
677}
678
679void
680restore_fpu_state(void* state)
681{
682#if defined(i386) || defined(__x86_64)
683 if (fpu_mode == SSE2) {
684 sse_restore(state);
685 } else {
686 fpu_restore(state);
687 }
688#else
689 fpu_restore(state);
9a8c1c2f 690#endif
2daa0e7c 691}
9a8c1c2f 692
2daa0e7c
RT
693
694/*
695 * The verbose argument controls how much to print out:
696 * 0 for normal level of detail; 1 for debugging.
697 */
698void
699print_generation_stats(int verbose)
700{
701 int i, gens;
702
703 FPU_STATE(fpu_state);
704
9a8c1c2f 705 /*
706 * This code uses the FP instructions which may be setup for Lisp so
707 * they need to the saved and reset for C.
708 */
46a4f482 709
2daa0e7c 710 save_fpu_state(fpu_state);
46a4f482 711
9a8c1c2f 712 /* Number of generations to print out. */
713 if (verbose)
714 gens = NUM_GENERATIONS + 1;
715 else
716 gens = NUM_GENERATIONS;
717
718 /* Print the heap stats */
0b2b8885 719 fprintf(stderr, " Page count (%d KB)\n", GC_PAGE_SIZE / 1024);
9a8c1c2f 720 fprintf(stderr,
721 " Gen Boxed Unboxed LB LUB Alloc Waste Trigger WP GCs Mem-age\n");
722
723 for (i = 0; i < gens; i++) {
724 int j;
725 int boxed_cnt = 0;
726 int unboxed_cnt = 0;
727 int large_boxed_cnt = 0;
728 int large_unboxed_cnt = 0;
729
730 for (j = 0; j < last_free_page; j++) {
731 int flags = page_table[j].flags;
732
733 if ((flags & PAGE_GENERATION_MASK) == i) {
734 if (flags & PAGE_ALLOCATED_MASK) {
735 /*
736 * Count the number of boxed and unboxed pages within the
737 * given generation.
738 */
739 if (flags & PAGE_UNBOXED_MASK)
740 if (flags & PAGE_LARGE_OBJECT_MASK)
741 large_unboxed_cnt++;
742 else
743 unboxed_cnt++;
744 else if (flags & PAGE_LARGE_OBJECT_MASK)
745 large_boxed_cnt++;
746 else
747 boxed_cnt++;
748 }
749 }
e7e59d7d 750 }
2bf0de4c 751
9a8c1c2f 752 gc_assert(generations[i].bytes_allocated ==
753 generation_bytes_allocated(i));
754 fprintf(stderr, " %5d: %5d %5d %5d %5d %10d %6d %10d %4d %3d %7.4f\n",
755 i, boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,
756 generations[i].bytes_allocated,
0b2b8885 757 GC_PAGE_SIZE * count_generation_pages(i) -
9a8c1c2f 758 generations[i].bytes_allocated, generations[i].gc_trigger,
759 count_write_protect_generation_pages(i), generations[i].num_gc,
8a9d1d8d 760 (double)gen_av_mem_age(i) / MEM_AGE_SCALE);
9a8c1c2f 761 }
762 fprintf(stderr, " Total bytes alloc=%ld\n", bytes_allocated);
2d80b863 763
2daa0e7c 764 restore_fpu_state(fpu_state);
0c41e522 765}
766
bf84be07 767/* Get statistics that are kept "on the fly" out of the generation
768 array.
769*/
9a8c1c2f 770void
771get_generation_stats(int gen, struct generation_stats *stats)
772{
773 if (gen <= NUM_GENERATIONS) {
774 stats->bytes_allocated = generations[gen].bytes_allocated;
775 stats->gc_trigger = generations[gen].gc_trigger;
776 stats->bytes_consed_between_gc =
777 generations[gen].bytes_consed_between_gc;
778 stats->num_gc = generations[gen].num_gc;
779 stats->trigger_age = generations[gen].trigger_age;
780 stats->cum_sum_bytes_allocated =
781 generations[gen].cum_sum_bytes_allocated;
782 stats->min_av_mem_age = generations[gen].min_av_mem_age;
783 }
bf84be07 784}
785
9a8c1c2f 786void
787set_gc_trigger(int gen, int trigger)
bf84be07 788{
9a8c1c2f 789 if (gen <= NUM_GENERATIONS) {
790 generations[gen].gc_trigger = trigger;
791 }
bf84be07 792}
0c41e522 793
9a8c1c2f 794void
795set_trigger_age(int gen, int trigger_age)
bf84be07 796{
9a8c1c2f 797 if (gen <= NUM_GENERATIONS) {
798 generations[gen].trigger_age = trigger_age;
799 }
bf84be07 800}
801
9a8c1c2f 802void
803set_min_mem_age(int gen, double min_mem_age)
bf84be07 804{
9a8c1c2f 805 if (gen <= NUM_GENERATIONS) {
8a9d1d8d 806 generations[gen].min_av_mem_age = min_mem_age * MEM_AGE_SCALE;
9a8c1c2f 807 }
bf84be07 808}
0c41e522 809\f
2bf0de4c 810/*
811 * Allocation routines.
812 *
813 *
814 * To support quick and inline allocation, regions of memory can be
815 * allocated and then allocated from with just a free pointer and a
816 * check against an end address.
817 *
818 * Since objects can be allocated to spaces with different properties
819 * e.g. boxed/unboxed, generation, ages; there may need to be many
820 * allocation regions.
821 *
822 * Each allocation region may be start within a partly used page.
823 * Many features of memory use are noted on a page wise basis,
824 * E.g. the generation; so if a region starts within an existing
825 * allocated page it must be consistent with this page.
826 *
827 * During the scavenging of the newspace, objects will be transported
828 * into an allocation region, and pointers updated to point to this
829 * allocation region. It is possible that these pointers will be
830 * scavenged again before the allocation region is closed, E.g. due to
831 * trans_list which jumps all over the place to cleanup the list. It
832 * is important to be able to determine properties of all objects
833 * pointed to when scavenging, E.g to detect pointers to the
834 * oldspace. Thus it's important that the allocation regions have the
835 * correct properties set when allocated, and not just set when
836 * closed. The region allocation routines return regions with the
837 * specified properties, and grab all the pages, setting there
838 * properties appropriately, except that the amount used is not known.
839 *
840 * These regions are used to support quicker allocation using just a
841 * free pointer. The actual space used by the region is not reflected
842 * in the pages tables until it is closed. It can't be scavenged until
843 * closed.
844 *
845 * When finished with the region it should be closed, which will
846 * update the page tables for the actual space used returning unused
847 * space. Further it may be noted in the new regions which is
848 * necessary when scavenging the newspace.
849 *
850 * Large objects may be allocated directly without an allocation
851 * region, the page tables are updated immediately.
852 *
853 * Unboxed objects don't contain points to other objects so don't need
854 * scavenging. Further they can't contain pointers to younger
855 * generations so WP is not needed. By allocating pages to unboxed
856 * objects the whole page never needs scavenging or write protecting.
857 */
0c41e522 858
2bf0de4c 859/*
860 * Only using two regions at present, both are for the current
861 * newspace generation.
862 */
9a8c1c2f 863struct alloc_region boxed_region;
864struct alloc_region unboxed_region;
0c41e522 865
bf84be07 866#if 0
2bf0de4c 867/*
868 * X hack. current lisp code uses the following. Need coping in/out.
869 */
0c41e522 870void *current_region_free_pointer;
871void *current_region_end_addr;
bf84be07 872#endif
0c41e522 873
874/* The generation currently being allocated to. X */
25a69164 875static int gc_alloc_generation = 0;
0c41e522 876
5a1bf534 877extern void do_dynamic_space_overflow_warning(void);
878extern void do_dynamic_space_overflow_error(void);
879
3e309c44 880/* Handle heap overflow here, maybe. */
881static void
9a8c1c2f 882handle_heap_overflow(const char *msg, int size)
3e309c44 883{
9a8c1c2f 884 unsigned long heap_size_mb;
885
886 if (msg) {
887 fprintf(stderr, msg, size);
3e309c44 888 }
889#ifndef SPARSE_BLOCK_SIZE
890#define SPARSE_BLOCK_SIZE (0)
9a8c1c2f 891#endif
892
893 /* Figure out how many MB of heap we have */
894 heap_size_mb = (dynamic_space_size + SPARSE_BLOCK_SIZE) >> 20;
3e309c44 895
9a8c1c2f 896 fprintf(stderr, " CMUCL has run out of dynamic heap space (%lu MB).\n",
897 heap_size_mb);
898 /* Try to handle heap overflow somewhat gracefully if we can. */
3e309c44 899#if defined(trap_DynamicSpaceOverflow) || defined(FEATURE_HEAP_OVERFLOW_CHECK)
9a8c1c2f 900 if (reserved_heap_pages == 0) {
901 fprintf(stderr, "\n Returning to top-level.\n");
902 do_dynamic_space_overflow_error();
903 } else {
904 fprintf(stderr,
905 " You can control heap size with the -dynamic-space-size commandline option.\n");
906 do_dynamic_space_overflow_warning();
3e309c44 907 }
908#else
9a8c1c2f 909 print_generation_stats(1);
3e309c44 910
9a8c1c2f 911 exit(1);
3e309c44 912#endif
913}
914
2bf0de4c 915/*
916 * Find a new region with room for at least the given number of bytes.
917 *
918 * It starts looking at the current generations alloc_start_page. So
919 * may pick up from the previous region if there is enough space. This
920 * keeps the allocation contiguous when scavenging the newspace.
921 *
922 * The alloc_region should have been closed by a call to
923 * gc_alloc_update_page_tables, and will thus be in an empty state.
924 *
925 * To assist the scavenging functions, write protected pages are not
926 * used. Free pages should not be write protected.
927 *
928 * It is critical to the conservative GC that the start of regions be
929 * known. To help achieve this only small regions are allocated at a
930 * time.
931 *
932 * During scavenging, pointers may be found that point within the
933 * current region and the page generation must be set so pointers to
934 * the from space can be recognised. So the generation of pages in
935 * the region are set to gc_alloc_generation. To prevent another
936 * allocation call using the same pages, all the pages in the region
937 * are allocated, although they will initially be empty.
938 */
9a8c1c2f 939static void
940gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
941{
942 int first_page;
943 int last_page;
944 int region_size;
945 int restart_page;
946 int bytes_found;
947 int num_pages;
948 int i;
949 int mmask, mflags;
950
951 /* Shut up some compiler warnings */
952 last_page = bytes_found = 0;
953
2bf0de4c 954#if 0
9a8c1c2f 955 fprintf(stderr, "alloc_new_region for %d bytes from gen %d\n",
956 nbytes, gc_alloc_generation);
2bf0de4c 957#endif
0c41e522 958
9a8c1c2f 959 /* Check that the region is in a reset state. */
960 gc_assert(alloc_region->first_page == 0
961 && alloc_region->last_page == -1
962 && alloc_region->free_pointer == alloc_region->end_addr);
963
964 if (unboxed)
965 restart_page =
966 generations[gc_alloc_generation].alloc_unboxed_start_page;
967 else
968 restart_page = generations[gc_alloc_generation].alloc_start_page;
0c41e522 969
9a8c1c2f 970 /*
971 * Search for a contiguous free region of at least nbytes with the
972 * given properties: boxed/unboxed, generation. First setting up the
973 * mask and matching flags.
974 */
0c41e522 975
9a8c1c2f 976 mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
977 | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK
978 | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;
979 mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
980 | gc_alloc_generation;
e7e59d7d 981
9a8c1c2f 982 do {
983 first_page = restart_page;
e7e59d7d 984
9a8c1c2f 985 /*
986 * First search for a page with at least 32 bytes free, that is
987 * not write protected, or marked dont_move.
988 */
2bf0de4c 989
9a8c1c2f 990 while (first_page < dynamic_space_pages) {
991 int flags = page_table[first_page].flags;
e7e59d7d 992
9a8c1c2f 993 if (!(flags & PAGE_ALLOCATED_MASK)
994 || ((flags & mmask) == mflags &&
0b2b8885 995 page_table[first_page].bytes_used < GC_PAGE_SIZE - 32))
9a8c1c2f 996 break;
997 first_page++;
998 }
e7e59d7d 999
9a8c1c2f 1000 /* Check for a failure */
1001 if (first_page >= dynamic_space_pages - reserved_heap_pages) {
723055bb 1002#if 0
9a8c1c2f 1003 handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n",
1004 nbytes);
723055bb 1005#else
9a8c1c2f 1006 break;
723055bb 1007#endif
9a8c1c2f 1008 }
2bf0de4c 1009
9a8c1c2f 1010 gc_assert(!PAGE_WRITE_PROTECTED(first_page));
2bf0de4c 1011
1012#if 0
9a8c1c2f 1013 fprintf(stderr, " first_page=%d bytes_used=%d\n",
1014 first_page, page_table[first_page].bytes_used);
2bf0de4c 1015#endif
1016
9a8c1c2f 1017 /*
1018 * Now search forward to calculate the available region size. It
1019 * tries to keeps going until nbytes are found and the number of
1020 * pages is greater than some level. This helps keep down the
1021 * number of pages in a region.
1022 */
1023 last_page = first_page;
0b2b8885 1024 bytes_found = GC_PAGE_SIZE - page_table[first_page].bytes_used;
9a8c1c2f 1025 num_pages = 1;
1026 while ((bytes_found < nbytes || num_pages < 2)
1027 && last_page < dynamic_space_pages - 1
1028 && !PAGE_ALLOCATED(last_page + 1)) {
1029 last_page++;
1030 num_pages++;
0b2b8885 1031 bytes_found += GC_PAGE_SIZE;
9a8c1c2f 1032 gc_assert(!PAGE_WRITE_PROTECTED(last_page));
1033 }
2bf0de4c 1034
0b2b8885 1035 region_size = (GC_PAGE_SIZE - page_table[first_page].bytes_used)
1036 + GC_PAGE_SIZE * (last_page - first_page);
2bf0de4c 1037
9a8c1c2f 1038 gc_assert(bytes_found == region_size);
2bf0de4c 1039
1040#if 0
9a8c1c2f 1041 fprintf(stderr, " last_page=%d bytes_found=%d num_pages=%d\n",
1042 last_page, bytes_found, num_pages);
2bf0de4c 1043#endif
1044
9a8c1c2f 1045 restart_page = last_page + 1;
1046 }
1047 while (restart_page < dynamic_space_pages && bytes_found < nbytes);
2bf0de4c 1048
9a8c1c2f 1049 if (first_page >= dynamic_space_pages - reserved_heap_pages) {
1050 handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n",
1051 nbytes);
1052 }
2bf0de4c 1053
9a8c1c2f 1054 /* Check for a failure */
1055 if (restart_page >= (dynamic_space_pages - reserved_heap_pages)
1056 && bytes_found < nbytes) {
1057 handle_heap_overflow("*A1 gc_alloc_new_region failed, nbytes=%d.\n",
1058 nbytes);
1059 }
2bf0de4c 1060#if 0
9a8c1c2f 1061 fprintf(stderr,
1062 "gc_alloc_new_region gen %d: %d bytes: from pages %d to %d: addr=%x\n",
1063 gc_alloc_generation, bytes_found, first_page, last_page,
1064 page_address(first_page));
1065#endif
1066
1067 /* Setup the alloc_region. */
1068 alloc_region->first_page = first_page;
1069 alloc_region->last_page = last_page;
1070 alloc_region->start_addr = page_table[first_page].bytes_used
1071 + page_address(first_page);
1072 alloc_region->free_pointer = alloc_region->start_addr;
1073 alloc_region->end_addr = alloc_region->start_addr + bytes_found;
1074
1075 if (gencgc_zero_check) {
1076 int *p;
1077
1078 for (p = (int *) alloc_region->start_addr;
1079 p < (int *) alloc_region->end_addr; p++)
1080 if (*p != 0)
1081 fprintf(stderr, "** new region not zero @ %lx\n",
1082 (unsigned long) p);
1083 }
0c41e522 1084
9a8c1c2f 1085 /* Setup the pages. */
1086
1087 /* The first page may have already been in use. */
1088 if (page_table[first_page].bytes_used == 0) {
1089 PAGE_FLAGS_UPDATE(first_page, mmask, mflags);
1090 page_table[first_page].first_object_offset = 0;
1091 }
1092
1093 gc_assert(PAGE_ALLOCATED(first_page));
1094 gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
1095 gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
1096 gc_assert(!PAGE_LARGE_OBJECT(first_page));
1097
1098 for (i = first_page + 1; i <= last_page; i++) {
1099 PAGE_FLAGS_UPDATE(i, PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK
1100 | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,
1101 PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
1102 | gc_alloc_generation);
1103 /*
1104 * This may not be necessary for unboxed regions (think it was
1105 * broken before!)
1106 */
1107 page_table[i].first_object_offset =
1108 alloc_region->start_addr - page_address(i);
1109 }
1110
1111 /* Bump up the last_free_page */
1112 if (last_page + 1 > last_free_page) {
1113 last_free_page = last_page + 1;
1114 set_alloc_pointer((lispobj) ((char *) heap_base +
0b2b8885 1115 GC_PAGE_SIZE * last_free_page));
9a8c1c2f 1116
1117 }
0c41e522 1118}
1119
1120
1121
2bf0de4c 1122/*
1123 * If the record_new_objects flag is 2 then all new regions created
1124 * are recorded.
1125 *
d54d3cbf 1126 * If it's 1 then it is only recorded if the first page of the
2bf0de4c 1127 * current region is <= new_areas_ignore_page. This helps avoid
1128 * unnecessary recording when doing full scavenge pass.
1129 *
1130 * The new_object structure holds the page, byte offset, and size of
1131 * new regions of objects. Each new area is placed in the array of
1132 * these structures pointed to by new_areas; new_areas_index holds the
1133 * offset into new_areas.
1134 *
1135 * If new_area overflows NUM_NEW_AREAS then it stops adding them. The
1136 * later code must detect this an handle it, probably by doing a full
1137 * scavenge of a generation.
1138 */
0c41e522 1139
1140#define NUM_NEW_AREAS 512
1141static int record_new_objects = 0;
1142static int new_areas_ignore_page;
1143struct new_area {
9a8c1c2f 1144 int page;
1145 int offset;
1146 int size;
0c41e522 1147};
1148static struct new_area (*new_areas)[];
25a69164 1149static int new_areas_index = 0;
0c41e522 1150int max_new_areas;
1151
1152/* Add a new area to new_areas. */
9a8c1c2f 1153static void
1154add_new_area(int first_page, int offset, int size)
0c41e522 1155{
9a8c1c2f 1156 unsigned new_area_start, c;
1157 int i;
0c41e522 1158
9a8c1c2f 1159 /* Ignore if full */
1160 if (new_areas_index >= NUM_NEW_AREAS)
1161 return;
1162
1163 switch (record_new_objects) {
1164 case 0:
1165 return;
1166 case 1:
1167 if (first_page > new_areas_ignore_page)
1168 return;
1169 break;
1170 case 2:
1171 break;
1172 default:
1173 gc_abort();
1174 }
1175
0b2b8885 1176 new_area_start = GC_PAGE_SIZE * first_page + offset;
9a8c1c2f 1177
1178 /*
1179 * Search backwards for a prior area that this follows from. If
1180 * found this will save adding a new area.
1181 */
1182 for (i = new_areas_index - 1, c = 0; i >= 0 && c < 8; i--, c++) {
0b2b8885 1183 unsigned area_end = GC_PAGE_SIZE * (*new_areas)[i].page
9a8c1c2f 1184 + (*new_areas)[i].offset + (*new_areas)[i].size;
0c41e522 1185
2bf0de4c 1186#if 0
9a8c1c2f 1187 fprintf(stderr, "*S1 %d %d %d %d\n", i, c, new_area_start, area_end);
2bf0de4c 1188#endif
9a8c1c2f 1189 if (new_area_start == area_end) {
2bf0de4c 1190#if 0
9a8c1c2f 1191 fprintf(stderr, "-> Adding to [%d] %d %d %d with %d %d %d:\n",
1192 i, (*new_areas)[i].page, (*new_areas)[i].offset,
1193 (*new_areas)[i].size, first_page, offset, size);
2bf0de4c 1194#endif
9a8c1c2f 1195 (*new_areas)[i].size += size;
1196 return;
1197 }
0c41e522 1198 }
2bf0de4c 1199#if 0
9a8c1c2f 1200 fprintf(stderr, "*S1 %d %d %d\n", i, c, new_area_start);
2bf0de4c 1201#endif
0c41e522 1202
9a8c1c2f 1203 (*new_areas)[new_areas_index].page = first_page;
1204 (*new_areas)[new_areas_index].offset = offset;
1205 (*new_areas)[new_areas_index].size = size;
2bf0de4c 1206#if 0
9a8c1c2f 1207 fprintf(stderr, " new_area %d page %d offset %d size %d\n",
1208 new_areas_index, first_page, offset, size);
2bf0de4c 1209#endif
9a8c1c2f 1210 new_areas_index++;
2bf0de4c 1211
9a8c1c2f 1212 /* Note the max new_areas used. */
1213 if (new_areas_index > max_new_areas)
1214 max_new_areas = new_areas_index;
0c41e522 1215}
1216
1217
2bf0de4c 1218/*
1219 * Update the tables for the alloc_region. The region may be added to
1220 * the new_areas.
1221 *
1222 * When done the alloc_region its setup so that the next quick alloc
1223 * will fail safely and thus a new region will be allocated. Further
1224 * it is safe to try and re-update the page table of this reset
1225 * alloc_region.
1226 */
9a8c1c2f 1227void
1228gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
0c41e522 1229{
9a8c1c2f 1230 int more;
1231 int first_page;
1232 int next_page;
1233 int bytes_used;
1234 int orig_first_page_bytes_used;
1235 int region_size;
1236 int byte_cnt;
0c41e522 1237
2bf0de4c 1238#if 0
9a8c1c2f 1239 fprintf(stderr, "gc_alloc_update_page_tables to gen %d: ",
1240 gc_alloc_generation);
2bf0de4c 1241#endif
0c41e522 1242
9a8c1c2f 1243 first_page = alloc_region->first_page;
0c41e522 1244
9a8c1c2f 1245 /* Catch an unused alloc_region. */
1246 if (first_page == 0 && alloc_region->last_page == -1)
1247 return;
0c41e522 1248
9a8c1c2f 1249 next_page = first_page + 1;
0c41e522 1250
9a8c1c2f 1251 /* Skip if no bytes were allocated */
1252 if (alloc_region->free_pointer != alloc_region->start_addr) {
1253 orig_first_page_bytes_used = page_table[first_page].bytes_used;
2bf0de4c 1254
9a8c1c2f 1255 gc_assert(alloc_region->start_addr == page_address(first_page) +
1256 page_table[first_page].bytes_used);
2bf0de4c 1257
9a8c1c2f 1258 /* All the pages used need to be updated */
2bf0de4c 1259
9a8c1c2f 1260 /* Update the first page. */
2bf0de4c 1261
9a8c1c2f 1262#if 0
1263 fprintf(stderr, "0");
2bf0de4c 1264#endif
1265
9a8c1c2f 1266 /* If the page was free then setup the gen, and first_object_offset. */
1267 if (page_table[first_page].bytes_used == 0)
1268 gc_assert(page_table[first_page].first_object_offset == 0);
2bf0de4c 1269
9a8c1c2f 1270 gc_assert(PAGE_ALLOCATED(first_page));
1271 gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
1272 gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
1273 gc_assert(!PAGE_LARGE_OBJECT(first_page));
2bf0de4c 1274
9a8c1c2f 1275 byte_cnt = 0;
2bf0de4c 1276
9a8c1c2f 1277 /*
1278 * Calc. the number of bytes used in this page. This is not always
1279 * the number of new bytes, unless it was free.
1280 */
1281 more = 0;
1282 bytes_used = alloc_region->free_pointer - page_address(first_page);
0b2b8885 1283 if (bytes_used > GC_PAGE_SIZE) {
1284 bytes_used = GC_PAGE_SIZE;
9a8c1c2f 1285 more = 1;
1286 }
1287 page_table[first_page].bytes_used = bytes_used;
1288 byte_cnt += bytes_used;
2bf0de4c 1289
9a8c1c2f 1290 /*
1291 * All the rest of the pages should be free. Need to set their
1292 * first_object_offset pointer to the start of the region, and set
1293 * the bytes_used.
1294 */
1295 while (more) {
2bf0de4c 1296#if 0
9a8c1c2f 1297 fprintf(stderr, "+");
1298#endif
1299 gc_assert(PAGE_ALLOCATED(next_page));
1300 gc_assert(PAGE_UNBOXED_VAL(next_page) == unboxed);
1301 gc_assert(page_table[next_page].bytes_used == 0);
1302 gc_assert(PAGE_GENERATION(next_page) == gc_alloc_generation);
1303 gc_assert(!PAGE_LARGE_OBJECT(next_page));
1304
1305 gc_assert(page_table[next_page].first_object_offset ==
1306 alloc_region->start_addr - page_address(next_page));
1307
1308 /* Calc. the number of bytes used in this page. */
1309 more = 0;
1310 bytes_used = alloc_region->free_pointer - page_address(next_page);
0b2b8885 1311 if (bytes_used > GC_PAGE_SIZE) {
1312 bytes_used = GC_PAGE_SIZE;
9a8c1c2f 1313 more = 1;
1314 }
1315 page_table[next_page].bytes_used = bytes_used;
1316 byte_cnt += bytes_used;
2bf0de4c 1317
9a8c1c2f 1318 next_page++;
1319 }
2bf0de4c 1320
9a8c1c2f 1321 region_size = alloc_region->free_pointer - alloc_region->start_addr;
1322 bytes_allocated += region_size;
1323 generations[gc_alloc_generation].bytes_allocated += region_size;
2bf0de4c 1324
9a8c1c2f 1325 gc_assert(byte_cnt - orig_first_page_bytes_used == region_size);
2bf0de4c 1326
9a8c1c2f 1327 /*
1328 * Set the generations alloc restart page to the last page of
1329 * the region.
1330 */
1331 if (unboxed)
1332 generations[gc_alloc_generation].alloc_unboxed_start_page =
1333 next_page - 1;
1334 else
1335 generations[gc_alloc_generation].alloc_start_page = next_page - 1;
2bf0de4c 1336
9a8c1c2f 1337 /* Add the region to the new_areas if requested. */
1338 if (!unboxed)
1339 add_new_area(first_page, orig_first_page_bytes_used, region_size);
2bf0de4c 1340
1341#if 0
9a8c1c2f 1342 fprintf(stderr,
1343 " gc_alloc_update_page_tables update %d bytes to gen %d\n",
1344 region_size, gc_alloc_generation);
2bf0de4c 1345#endif
9a8c1c2f 1346 } else
1347 /*
1348 * No bytes allocated. Unallocate the first_page if there are 0 bytes_used.
1349 */
0c41e522 1350 if (page_table[first_page].bytes_used == 0)
9a8c1c2f 1351 page_table[first_page].flags &= ~PAGE_ALLOCATED_MASK;
2bf0de4c 1352
9a8c1c2f 1353 /* Unallocate any unused pages. */
1354 while (next_page <= alloc_region->last_page) {
1355 gc_assert(page_table[next_page].bytes_used == 0);
1356 page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
1357 next_page++;
1358 }
0c41e522 1359
9a8c1c2f 1360 /* Reset the alloc_region. */
1361 alloc_region->first_page = 0;
1362 alloc_region->last_page = -1;
1363 alloc_region->start_addr = page_address(0);
1364 alloc_region->free_pointer = page_address(0);
1365 alloc_region->end_addr = page_address(0);
0c41e522 1366
2bf0de4c 1367#if 0
9a8c1c2f 1368 fprintf(stderr, "\n");
2bf0de4c 1369#endif
0c41e522 1370}
1371
1372
1373
1374static inline void *gc_quick_alloc(int nbytes);
1375
2bf0de4c 1376/*
1377 * Allocate a possibly large object.
1378 */
9a8c1c2f 1379static void *
1380gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
1381{
1382 int first_page;
1383 int last_page;
1384 int region_size;
1385 int restart_page;
1386 int bytes_found;
1387 int num_pages;
1388 int orig_first_page_bytes_used;
1389 int byte_cnt;
1390 int more;
1391 int bytes_used;
1392 int next_page;
1393 int large = (nbytes >= large_object_size);
1394 int mmask, mflags;
0c41e522 1395
2bf0de4c 1396
9a8c1c2f 1397 /* Shut up some compiler warnings */
1398 last_page = bytes_found = 0;
2bf0de4c 1399
723055bb 1400#if 0
9a8c1c2f 1401 if (nbytes > 200000)
1402 fprintf(stderr, "*** alloc_large %d\n", nbytes);
723055bb 1403#endif
2bf0de4c 1404
1405#if 0
9a8c1c2f 1406 fprintf(stderr, "gc_alloc_large for %d bytes from gen %d\n",
1407 nbytes, gc_alloc_generation);
2bf0de4c 1408#endif
1409
9a8c1c2f 1410 /*
1411 * If the object is small, and there is room in the current region
1412 * then allocation it in the current region.
1413 */
1414 if (!large && alloc_region->end_addr - alloc_region->free_pointer >= nbytes)
1415 return gc_quick_alloc(nbytes);
1416
1417 /*
1418 * Search for a contiguous free region of at least nbytes. If it's a
1419 * large object then align it on a page boundary by searching for a
1420 * free page.
1421 */
2bf0de4c 1422
9a8c1c2f 1423 /*
1424 * To allow the allocation of small objects without the danger of
1425 * using a page in the current boxed region, the search starts after
1426 * the current boxed free region. XX could probably keep a page
1427 * index ahead of the current region and bumped up here to save a
1428 * lot of re-scanning.
1429 */
1430 if (unboxed)
1431 restart_page =
1432 generations[gc_alloc_generation].alloc_large_unboxed_start_page;
1433 else
1434 restart_page = generations[gc_alloc_generation].alloc_large_start_page;
1435 if (restart_page <= alloc_region->last_page)
1436 restart_page = alloc_region->last_page + 1;
2bf0de4c 1437
9a8c1c2f 1438 /* Setup the mask and matching flags. */
2bf0de4c 1439
9a8c1c2f 1440 mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
1441 | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK
1442 | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;
1443 mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
1444 | gc_alloc_generation;
2bf0de4c 1445
9a8c1c2f 1446 do {
1447 first_page = restart_page;
0c41e522 1448
9a8c1c2f 1449 if (large)
1450 while (first_page < dynamic_space_pages
1451 && PAGE_ALLOCATED(first_page)) first_page++;
1452 else
1453 while (first_page < dynamic_space_pages) {
1454 int flags = page_table[first_page].flags;
1455
1456 if (!(flags & PAGE_ALLOCATED_MASK)
1457 || ((flags & mmask) == mflags &&
0b2b8885 1458 page_table[first_page].bytes_used < GC_PAGE_SIZE - 32))
9a8c1c2f 1459 break;
1460 first_page++;
1461 }
0c41e522 1462
9a8c1c2f 1463 /* Check for a failure */
1464 if (first_page >= dynamic_space_pages - reserved_heap_pages) {
1465#if 0
1466 handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n",
1467 nbytes);
1468#else
1469 break;
1470#endif
1471 }
1472 gc_assert(!PAGE_WRITE_PROTECTED(first_page));
2bf0de4c 1473
9a8c1c2f 1474#if 0
1475 fprintf(stderr, " first_page=%d bytes_used=%d\n",
1476 first_page, page_table[first_page].bytes_used);
1477#endif
1478
1479 last_page = first_page;
0b2b8885 1480 bytes_found = GC_PAGE_SIZE - page_table[first_page].bytes_used;
9a8c1c2f 1481 num_pages = 1;
1482 while (bytes_found < nbytes
1483 && last_page < dynamic_space_pages - 1
1484 && !PAGE_ALLOCATED(last_page + 1)) {
1485 last_page++;
1486 num_pages++;
0b2b8885 1487 bytes_found += GC_PAGE_SIZE;
9a8c1c2f 1488 gc_assert(!PAGE_WRITE_PROTECTED(last_page));
1489 }
2bf0de4c 1490
0b2b8885 1491 region_size = (GC_PAGE_SIZE - page_table[first_page].bytes_used)
1492 + GC_PAGE_SIZE * (last_page - first_page);
0c41e522 1493
9a8c1c2f 1494 gc_assert(bytes_found == region_size);
0c41e522 1495
2bf0de4c 1496#if 0
9a8c1c2f 1497 fprintf(stderr, " last_page=%d bytes_found=%d num_pages=%d\n",
1498 last_page, bytes_found, num_pages);
2bf0de4c 1499#endif
0c41e522 1500
9a8c1c2f 1501 restart_page = last_page + 1;
1502 }
1503 while ((restart_page < dynamic_space_pages) && (bytes_found < nbytes));
2bf0de4c 1504
9a8c1c2f 1505 if (first_page >= dynamic_space_pages - reserved_heap_pages) {
1506 handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes);
1507 }
1508
1509 /* Check for a failure */
1510 if (restart_page >= (dynamic_space_pages - reserved_heap_pages)
1511 && bytes_found < nbytes) {
1512 handle_heap_overflow("*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes);
1513 }
1514#if 0
1515 if (large)
1516 fprintf(stderr,
1517 "gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
1518 gc_alloc_generation, nbytes, bytes_found, first_page, last_page,
1519 page_address(first_page));
1520#endif
1521
1522 gc_assert(first_page > alloc_region->last_page);
1523 if (unboxed)
1524 generations[gc_alloc_generation].alloc_large_unboxed_start_page =
1525 last_page;
1526 else
1527 generations[gc_alloc_generation].alloc_large_start_page = last_page;
1528
1529 /* Setup the pages. */
1530 orig_first_page_bytes_used = page_table[first_page].bytes_used;
1531
1532 /*
1533 * If the first page was free then setup the gen, and
1534 * first_object_offset.
1535 */
2bf0de4c 1536
9a8c1c2f 1537 if (large)
1538 mflags |= PAGE_LARGE_OBJECT_MASK;
1539 if (page_table[first_page].bytes_used == 0) {
1540 PAGE_FLAGS_UPDATE(first_page, mmask, mflags);
1541 page_table[first_page].first_object_offset = 0;
0c41e522 1542 }
2bf0de4c 1543
9a8c1c2f 1544 gc_assert(PAGE_ALLOCATED(first_page));
1545 gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
1546 gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
1547 gc_assert(PAGE_LARGE_OBJECT_VAL(first_page) == large);
0c41e522 1548
9a8c1c2f 1549 byte_cnt = 0;
0c41e522 1550
9a8c1c2f 1551 /*
1552 * Calc. the number of bytes used in this page. This is not
1553 * always the number of new bytes, unless it was free.
1554 */
1555 more = 0;
1556 bytes_used = nbytes + orig_first_page_bytes_used;
0b2b8885 1557 if (bytes_used > GC_PAGE_SIZE) {
1558 bytes_used = GC_PAGE_SIZE;
9a8c1c2f 1559 more = 1;
1560 }
1561 page_table[first_page].bytes_used = bytes_used;
1562 byte_cnt += bytes_used;
0c41e522 1563
9a8c1c2f 1564 next_page = first_page + 1;
2bf0de4c 1565
9a8c1c2f 1566 /*
1567 * All the rest of the pages should be free. Need to set their
1568 * first_object_offset pointer to the start of the region, and set
1569 * the bytes_used.
1570 */
1571 while (more) {
1572#if 0
1573 fprintf(stderr, "+");
1574#endif
1575
1576 gc_assert(!PAGE_ALLOCATED(next_page));
1577 gc_assert(page_table[next_page].bytes_used == 0);
1578 PAGE_FLAGS_UPDATE(next_page, mmask, mflags);
1579
1580 page_table[next_page].first_object_offset =
0b2b8885 1581 orig_first_page_bytes_used - GC_PAGE_SIZE * (next_page - first_page);
9a8c1c2f 1582
1583 /* Calc. the number of bytes used in this page. */
1584 more = 0;
1585 bytes_used = nbytes + orig_first_page_bytes_used - byte_cnt;
0b2b8885 1586 if (bytes_used > GC_PAGE_SIZE) {
1587 bytes_used = GC_PAGE_SIZE;
9a8c1c2f 1588 more = 1;
1589 }
1590 page_table[next_page].bytes_used = bytes_used;
1591 byte_cnt += bytes_used;
1592
1593 next_page++;
1594 }
1595
1596 gc_assert(byte_cnt - orig_first_page_bytes_used == nbytes);
1597
1598 bytes_allocated += nbytes;
1599 generations[gc_alloc_generation].bytes_allocated += nbytes;
1600
1601 /* Add the region to the new_areas if requested. */
1602 if (!unboxed)
1603 add_new_area(first_page, orig_first_page_bytes_used, nbytes);
1604
1605 /* Bump up the last_free_page */
1606 if (last_page + 1 > last_free_page) {
1607 last_free_page = last_page + 1;
1608 set_alloc_pointer((lispobj) ((char *) heap_base +
0b2b8885 1609 GC_PAGE_SIZE * last_free_page));
9a8c1c2f 1610 }
1611
1612 return (void *) (page_address(first_page) + orig_first_page_bytes_used);
1613}
1614
1615/*
68ac9a3e 1616 * If the current region has more than this much space left, we don't
1617 * want to abandon the region (wasting space), but do a "large" alloc
1618 * to a new region.
9a8c1c2f 1619 */
68ac9a3e 1620
1621int region_empty_threshold = 32;
1622
1623
1624/*
1625 * How many consecutive large alloc we can do before we abandon the
c5b3b076 1626 * current region.
68ac9a3e 1627 */
1628int consecutive_large_alloc_limit = 10;
1629
1630
1631/*
c5b3b076 1632 * Statistics for the current region
68ac9a3e 1633 */
1634struct alloc_stats
9a8c1c2f 1635{
c5b3b076 1636 /*
1637 * How many consecutive allocations we have tried with the current
1638 * region (in saved_region)
1639 */
68ac9a3e 1640 int consecutive_alloc;
c5b3b076 1641 /*
1642 * How many times we tried to allocate to this region but didn't
1643 * because we didn't have enough room and did a large alloc in a
1644 * different region.
1645 */
68ac9a3e 1646 int abandon_region_count;
c5b3b076 1647
1648 /*
1649 * A copy of the current allocation region which we use to compare
1650 * against.
1651 */
68ac9a3e 1652 struct alloc_region saved_region;
1653};
2bf0de4c 1654
c5b3b076 1655/* Statistics for boxed and unboxed regions */
68ac9a3e 1656struct alloc_stats boxed_stats =
c5b3b076 1657{0, 0,
68ac9a3e 1658 {NULL, NULL, -1, -1, NULL}};
1659
1660struct alloc_stats unboxed_stats =
c5b3b076 1661{0, 0,
68ac9a3e 1662 {NULL, NULL, -1, -1, NULL}};
1663
1664/*
1665 * Try to allocate from the current region. If it's possible, do the
1666 * allocation and return the object. If it's not possible, return
1667 * (void*) -1.
1668 */
1669static inline void *
1670gc_alloc_try_current_region(int nbytes, struct alloc_region *region, int unboxed,
1671 struct alloc_stats *stats)
1672{
1673 char *new_free_pointer;
2bf0de4c 1674
9a8c1c2f 1675 /* Check if there is room in the current alloc region. */
68ac9a3e 1676 new_free_pointer = region->free_pointer + nbytes;
2bf0de4c 1677
68ac9a3e 1678 if (new_free_pointer <= region->end_addr) {
9a8c1c2f 1679 /* If so then allocate from the current alloc region. */
68ac9a3e 1680 char *new_obj = region->free_pointer;
0c41e522 1681
68ac9a3e 1682 region->free_pointer = new_free_pointer;
2bf0de4c 1683
9a8c1c2f 1684 /* Check if the alloc region is almost empty. */
c5b3b076 1685 if (region->end_addr - region->free_pointer <= region_empty_threshold) {
9a8c1c2f 1686 /* If so finished with the current region. */
68ac9a3e 1687 gc_alloc_update_page_tables(unboxed, region);
9a8c1c2f 1688 /* Setup a new region. */
c5b3b076 1689 gc_alloc_new_region(region_empty_threshold, unboxed, region);
9a8c1c2f 1690 }
68ac9a3e 1691
1692 stats->consecutive_alloc = 0;
c5b3b076 1693 stats->abandon_region_count = 0;
68ac9a3e 1694 memcpy(&stats->saved_region, region, sizeof(stats->saved_region));
1695
9a8c1c2f 1696 return (void *) new_obj;
68ac9a3e 1697 } else {
1698 return (void *) -1;
1699 }
1700}
1701
1702/*
1703 * Allocate bytes from a boxed or unboxed region. It first checks if
1704 * there is room, if not then it calls gc_alloc_new_region to find a
1705 * new region with enough space. A pointer to the start of the region
1706 * is returned. The parameter "unboxed" should be 0 (boxed) or 1
1707 * (unboxed).
1708 */
1709static void *
1710gc_alloc_region(int nbytes, struct alloc_region *region, int unboxed, struct alloc_stats *stats)
1711{
1712 void *new_obj;
1713
1714#if 0
1715 fprintf(stderr, "gc_alloc %d\n", nbytes);
1716#endif
1717
1718 /* Check if there is room in the current alloc region. */
1719
1720 new_obj = gc_alloc_try_current_region(nbytes, region, unboxed, stats);
1721 if (new_obj != (void *) -1) {
1722 return new_obj;
0c41e522 1723 }
2bf0de4c 1724
9a8c1c2f 1725 /* Else not enough free space in the current region. */
1726
1727 /*
68ac9a3e 1728 * If the allocation is large enough, always do a large alloc This
1729 * helps GC so we don't have to copy this object again.
1730 */
1731
1732 if (nbytes >= large_object_size) {
1733 return gc_alloc_large(nbytes, unboxed, region);
1734 }
1735
1736 /*
9a8c1c2f 1737 * If there is a bit of room left in the current region then
1738 * allocate a large object.
1739 */
68ac9a3e 1740
1741 /*
1742 * This has potentially very bad behavior on sparc if the current
1743 * boxed region is too small for the allocation, but the free
1744 * space is greater than 32 (region_empty_threshold). The
1745 * scenario is where we're always allocating something that won't
1746 * fit in the boxed region, and we keep calling gc_alloc_large.
1747 * Since gc_alloc_large doesn't change the region, the next
1748 * allocation will again be out-of-line and we hit a kernel trap
1749 * again. And so on, so we waste all of our time doing kernel
1750 * traps to allocate small things. This also affects ppc.
1751 *
1752 * X86 has the same issue, but the affect is less because the
1753 * out-of-line allocation is a just a function call, not a kernel
1754 * trap.
1755 *
1756 * Heuristic: If we do too many consecutive large allocations
1757 * because the current region has some space left, we give up and
1758 * abandon the region. This will prevent the bad scenario above
1759 * from killing allocation performance.
1760 *
1761 */
1762
1763 if ((region->end_addr - region->free_pointer > region_empty_threshold)
1764 && (stats->consecutive_alloc < consecutive_large_alloc_limit)) {
1765 /*
1766 * Is the saved region the same as the current region? If so,
1767 * update the counter. If not, that means we did some other
c5b3b076 1768 * (inline) allocation, so reset the counters and region to
1769 * the current region.
68ac9a3e 1770 */
1771 if (memcmp(&stats->saved_region, region, sizeof(stats->saved_region)) == 0) {
1772 ++stats->consecutive_alloc;
1773 } else {
1774 stats->consecutive_alloc = 0;
c5b3b076 1775 stats->abandon_region_count = 0;
68ac9a3e 1776 memcpy(&stats->saved_region, region, sizeof(stats->saved_region));
1777 }
1778
1779 return gc_alloc_large(nbytes, unboxed, region);
1780 }
1781
c5b3b076 1782 /*
1783 * We given up on the current region because the
1784 * consecutive_large_alloc_limit has been reached.
1785 */
68ac9a3e 1786 stats->consecutive_alloc = 0;
1787 ++stats->abandon_region_count;
9a8c1c2f 1788
9a8c1c2f 1789 /* Finished with the current region. */
68ac9a3e 1790 gc_alloc_update_page_tables(unboxed, region);
9a8c1c2f 1791
1792 /* Setup a new region. */
68ac9a3e 1793 gc_alloc_new_region(nbytes, unboxed, region);
9a8c1c2f 1794
1795 /* Should now be enough room. */
1796
68ac9a3e 1797 new_obj = gc_alloc_try_current_region(nbytes, region, unboxed, stats);
1798 if (new_obj != (void *) -1) {
1799 return new_obj;
9a8c1c2f 1800 }
1801
1802 /* Shouldn't happen? */
1803 gc_assert(0);
1804 return 0;
0c41e522 1805}
1806
2bf0de4c 1807/*
68ac9a3e 1808 * Allocate bytes from the boxed_region. It first checks if there is
1809 * room, if not then it calls gc_alloc_new_region to find a new region
1810 * with enough space. A pointer to the start of the region is returned.
1811 */
1812static inline void *
1813gc_alloc(int nbytes)
1814{
1815 void* obj;
1816
1817 obj = gc_alloc_region(nbytes, &boxed_region, 0, &boxed_stats);
1818
1819 return obj;
1820}
1821
1822/*
2bf0de4c 1823 * Allocate space from the boxed_region. If there is not enough free
1824 * space then call gc_alloc to do the job. A pointer to the start of
1825 * the region is returned.
1826 */
9a8c1c2f 1827static inline void *
1828gc_quick_alloc(int nbytes)
0c41e522 1829{
9a8c1c2f 1830 char *new_free_pointer;
0c41e522 1831
9a8c1c2f 1832 /* Check if there is room in the current region. */
1833 new_free_pointer = boxed_region.free_pointer + nbytes;
2bf0de4c 1834
9a8c1c2f 1835 if (new_free_pointer <= boxed_region.end_addr) {
1836 /* If so then allocate from the current region. */
1837 void *new_obj = boxed_region.free_pointer;
1838
1839 boxed_region.free_pointer = new_free_pointer;
1840 return (void *) new_obj;
1841 }
2bf0de4c 1842
9a8c1c2f 1843 /* Else call gc_alloc */
1844 return gc_alloc(nbytes);
0c41e522 1845}
1846
2bf0de4c 1847/*
1848 * Allocate space for the boxed object. If it is a large object then
1849 * do a large alloc else allocate from the current region. If there is
1850 * not enough free space then call gc_alloc to do the job. A pointer
1851 * to the start of the region is returned.
1852 */
9a8c1c2f 1853static inline void *
1854gc_quick_alloc_large(int nbytes)
0c41e522 1855{
9a8c1c2f 1856 char *new_free_pointer;
0c41e522 1857
9a8c1c2f 1858 if (nbytes >= large_object_size)
1859 return gc_alloc_large(nbytes, 0, &boxed_region);
0c41e522 1860
9a8c1c2f 1861 /* Check if there is room in the current region. */
1862 new_free_pointer = boxed_region.free_pointer + nbytes;
2bf0de4c 1863
9a8c1c2f 1864 if (new_free_pointer <= boxed_region.end_addr) {
1865 /* If so then allocate from the current region. */
1866 void *new_obj = boxed_region.free_pointer;
2bf0de4c 1867
9a8c1c2f 1868 boxed_region.free_pointer = new_free_pointer;
1869 return (void *) new_obj;
1870 }
1871
1872 /* Else call gc_alloc */
1873 return gc_alloc(nbytes);
0c41e522 1874}
1875
68ac9a3e 1876static inline void *
9a8c1c2f 1877gc_alloc_unboxed(int nbytes)
0c41e522 1878{
68ac9a3e 1879 void *obj;
0c41e522 1880
68ac9a3e 1881 obj = gc_alloc_region(nbytes, &unboxed_region, 1, &unboxed_stats);
2bf0de4c 1882
68ac9a3e 1883 return obj;
0c41e522 1884}
1885
9a8c1c2f 1886static inline void *
1887gc_quick_alloc_unboxed(int nbytes)
0c41e522 1888{
9a8c1c2f 1889 char *new_free_pointer;
1890
1891 /* Check if there is room in the current region. */
1892 new_free_pointer = unboxed_region.free_pointer + nbytes;
0c41e522 1893
9a8c1c2f 1894 if (new_free_pointer <= unboxed_region.end_addr) {
1895 /* If so then allocate from the current region. */
1896 void *new_obj = unboxed_region.free_pointer;
2bf0de4c 1897
9a8c1c2f 1898 unboxed_region.free_pointer = new_free_pointer;
2bf0de4c 1899
9a8c1c2f 1900 return (void *) new_obj;
0c41e522 1901 }
2bf0de4c 1902
9a8c1c2f 1903 /* Else call gc_alloc */
1904 return gc_alloc_unboxed(nbytes);
0c41e522 1905}
1906
2bf0de4c 1907/*
1908 * Allocate space for the object. If it is a large object then do a
1909 * large alloc else allocate from the current region. If there is not
1910 * enough free space then call gc_alloc to do the job.
1911 *
1912 * A pointer to the start of the region is returned.
1913 */
9a8c1c2f 1914static inline void *
1915gc_quick_alloc_large_unboxed(int nbytes)
0c41e522 1916{
9a8c1c2f 1917 char *new_free_pointer;
0c41e522 1918
9a8c1c2f 1919 if (nbytes >= large_object_size)
1920 return gc_alloc_large(nbytes, 1, &unboxed_region);
0c41e522 1921
9a8c1c2f 1922 /* Check if there is room in the current region. */
1923 new_free_pointer = unboxed_region.free_pointer + nbytes;
2bf0de4c 1924
9a8c1c2f 1925 if (new_free_pointer <= unboxed_region.end_addr) {
1926 /* If so then allocate from the current region. */
1927 void *new_obj = unboxed_region.free_pointer;
2bf0de4c 1928
9a8c1c2f 1929 unboxed_region.free_pointer = new_free_pointer;
1930
1931 return (void *) new_obj;
1932 }
2bf0de4c 1933
9a8c1c2f 1934 /* Else call gc_alloc */
1935 return gc_alloc_unboxed(nbytes);
0c41e522 1936}
1937
1938/***************************************************************************/
0c41e522 1939\f
9a8c1c2f 1940
0c41e522 1941/* Scavenging/transporting routines derived from gc.c */
1942
9a8c1c2f 1943static int (*scavtab[256]) (lispobj * where, lispobj object);
1944static lispobj(*transother[256]) (lispobj object);
1945static int (*sizetab[256]) (lispobj * where);
0c41e522 1946
1947static struct weak_pointer *weak_pointers;
2bf0de4c 1948static struct scavenger_hook *scavenger_hooks = (struct scavenger_hook *) NIL;
0c41e522 1949
68ac9a3e 1950/* Like (ceiling x y), but y is constrained to be a power of two */
0c41e522 1951#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
0c41e522 1952\f
9a8c1c2f 1953
0c41e522 1954/* Predicates */
1955
9a8c1c2f 1956static inline boolean
1957from_space_p(lispobj obj)
0c41e522 1958{
9a8c1c2f 1959 int page_index = (char *) obj - heap_base;
1960
1961 return page_index >= 0
1962 && (page_index =
0b2b8885 1963 (unsigned int) page_index / GC_PAGE_SIZE) < dynamic_space_pages
9a8c1c2f 1964 && PAGE_GENERATION(page_index) == from_space;
0c41e522 1965}
1966
9a8c1c2f 1967static inline boolean
1968new_space_p(lispobj obj)
0c41e522 1969{
9a8c1c2f 1970 int page_index = (char *) obj - heap_base;
0c41e522 1971
9a8c1c2f 1972 return page_index >= 0
1973 && (page_index =
0b2b8885 1974 (unsigned int) page_index / GC_PAGE_SIZE) < dynamic_space_pages
9a8c1c2f 1975 && PAGE_GENERATION(page_index) == new_space;
1976}
45380dbb 1977
1978static inline boolean
1979dynamic_space_p(lispobj obj)
1980{
1981 lispobj end = DYNAMIC_0_SPACE_START + DYNAMIC_SPACE_SIZE;
1982
1983 return (obj >= DYNAMIC_0_SPACE_START) && (obj < end);
1984}
1985
1986static inline boolean
1987static_space_p(lispobj obj)
1988{
1989 lispobj end = SymbolValue(STATIC_SPACE_FREE_POINTER);
1990
1991 return (obj >= STATIC_SPACE_START) && (obj < end);
1992}
1993
1994static inline boolean
1995read_only_space_p(lispobj obj)
1996{
1997 lispobj end = SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1998
1999 return (obj >= READ_ONLY_SPACE_START) && (obj < end);
2000}
2001
2002static inline boolean
2003control_stack_space_p(lispobj obj)
2004{
e7997cb6 2005 lispobj end = CONTROL_STACK_START + control_stack_size;
45380dbb 2006
2007 return (obj >= CONTROL_STACK_START) && (obj < end);
2008}
2009
2010static inline boolean
2011binding_stack_space_p(lispobj obj)
2012{
e7997cb6 2013 lispobj end = BINDING_STACK_START + binding_stack_size;
45380dbb 2014
2015 return (obj >= BINDING_STACK_START) && (obj < end);
2016}
2017
2018static inline boolean
2019signal_space_p(lispobj obj)
2020{
2021#ifdef SIGNAL_STACK_START
2022 lispobj end = SIGNAL_STACK_START + SIGSTKSZ;
2023
2024 return (obj >= SIGNAL_STACK_START) && (obj < end);
2025#else
2026 return FALSE;
2027#endif
2028}
b7271901 2029
30102669 2030#if (defined(DARWIN) && defined(__ppc__))
b7271901 2031/*
2032 * The assembly code defines these as functions, so we make them
2033 * functions. We only care about their addresses anyway.
2034 */
2035extern char closure_tramp();
2036extern char undefined_tramp();
30102669 2037#elif defined(sparc)
2038/* closure tramp and undefined tramp are Lisp assembly routines */
2039#elif (defined(i386) || defined(__x86_64))
2040/* undefined tramp are Lisp assembly routines */
b7271901 2041#else
2042extern int undefined_tramp;
2043#endif
2044
2045/*
2046 * Other random places that can't be in malloc space. Return TRUE if
2047 * obj is in some other known space
2048 */
2049static inline boolean
2050other_space_p(lispobj obj)
2051{
2052 boolean in_space = FALSE;
2053
2054#if defined(sparc)
2055 extern char _end;
2056
2057 /*
2058 * Skip over any objects in the C runtime which includes the
2059 * closure_tramp and undefined_tramp objects. There appears to be
2060 * one other object that points to somewhere in call_into_c, but I
2061 * don't know what that is. I think that's probably all for
2062 * sparc.
2063 */
2064 if ((char*) obj <= &_end) {
2065 in_space = TRUE;
2066 }
f0626999 2067#elif defined(i386)
865ee266 2068#if defined(DARWIN) || defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__)
b7271901 2069 /*
f0626999 2070 * For x86, we see some object at 0xffffffe9. I (rtoy) am not
2071 * sure that is, but it clearly can't be in malloc space so we
2072 * want to skip that (by returning TRUE).
b7271901 2073 *
2074 * Is there anything else?
2075 */
2076 if (obj == (lispobj) 0xffffffe9) {
2077 in_space = TRUE;
2078 }
9dcff02e 2079#elif defined(__ppc__)
e7997cb6
RT
2080 /*
2081 * For ppc, just ignore anything below fpu_restore, which is
2082 * currently at the end of ppc-assem.S.
2083 */
9dcff02e
RT
2084 if (obj <= (lispobj) &fpu_restore) {
2085 in_space = TRUE;
2086 }
f0626999 2087#endif
b7271901 2088#endif
2089
2090 return in_space;
2091}
2092
0c41e522 2093\f
9a8c1c2f 2094
0c41e522 2095/* Copying Objects */
2096
2097
2098/* Copying Boxed Objects */
9a8c1c2f 2099static inline lispobj
2100copy_object(lispobj object, int nwords)
0c41e522 2101{
9a8c1c2f 2102 int tag;
2103 lispobj *new;
2104 lispobj *source, *dest;
2bf0de4c 2105
9a8c1c2f 2106 gc_assert(Pointerp(object));
2107 gc_assert(from_space_p(object));
2108 gc_assert((nwords & 0x01) == 0);
2bf0de4c 2109
9a8c1c2f 2110 /* get tag of object */
2111 tag = LowtagOf(object);
0c41e522 2112
9a8c1c2f 2113 /* allocate space */
2114 new = gc_quick_alloc(nwords * sizeof(lispobj));
2bf0de4c 2115
9a8c1c2f 2116 dest = new;
2117 source = (lispobj *) PTR(object);
2bf0de4c 2118
9a8c1c2f 2119 /* copy the object */
2120 while (nwords > 0) {
2121 dest[0] = source[0];
2122 dest[1] = source[1];
2123 dest += 2;
2124 source += 2;
2125 nwords -= 2;
2126 }
2bf0de4c 2127
9a8c1c2f 2128 /* return lisp pointer of new object */
2129 return (lispobj) new | tag;
0c41e522 2130}
2131
2bf0de4c 2132/*
2133 * Copying Large Boxed Objects. If the object is in a large object
2134 * region then it is simply promoted, else it is copied. If it's large
2135 * enough then it's copied to a large object region.
2136 *
2137 * Vectors may have shrunk. If the object is not copied the space
2138 * needs to be reclaimed, and the page_tables corrected.
2139 */
9a8c1c2f 2140static lispobj
2141copy_large_object(lispobj object, int nwords)
0c41e522 2142{
9a8c1c2f 2143 int tag;
2144 lispobj *new;
2145 lispobj *source, *dest;
2146 int first_page;
2bf0de4c 2147
9a8c1c2f 2148 gc_assert(Pointerp(object));
2149 gc_assert(from_space_p(object));
2150 gc_assert((nwords & 0x01) == 0);
0c41e522 2151
9a8c1c2f 2152 if (gencgc_verbose && nwords > 1024 * 1024)
44e0351e 2153 fprintf(stderr, "** copy_large_object: %lu\n",
2154 (unsigned long) (nwords * sizeof(lispobj)));
0c41e522 2155
9a8c1c2f 2156 /* Check if it's a large object. */
2157 first_page = find_page_index((void *) object);
2158 gc_assert(first_page >= 0);
0c41e522 2159
9a8c1c2f 2160 if (PAGE_LARGE_OBJECT(first_page)) {
2161 /* Promote the object. */
2162 int remaining_bytes;
2163 int next_page;
2164 int bytes_freed;
2165 int old_bytes_used;
2166 int mmask, mflags;
2bf0de4c 2167
9a8c1c2f 2168 /*
2169 * Note: Any page write protection must be removed, else a later
2170 * scavenge_newspace may incorrectly not scavenge these pages.
2171 * This would not be necessary if they are added to the new areas,
2172 * but lets do it for them all (they'll probably be written
2173 * anyway?).
2174 */
0c41e522 2175
9a8c1c2f 2176 gc_assert(page_table[first_page].first_object_offset == 0);
0c41e522 2177
9a8c1c2f 2178 next_page = first_page;
2179 remaining_bytes = nwords * sizeof(lispobj);
0b2b8885 2180 while (remaining_bytes > GC_PAGE_SIZE) {
9a8c1c2f 2181 gc_assert(PAGE_GENERATION(next_page) == from_space);
2182 gc_assert(PAGE_ALLOCATED(next_page));
2183 gc_assert(!PAGE_UNBOXED(next_page));
2184 gc_assert(PAGE_LARGE_OBJECT(next_page));
2185 gc_assert(page_table[next_page].first_object_offset ==
0b2b8885 2186 GC_PAGE_SIZE * (first_page - next_page));
2187 gc_assert(page_table[next_page].bytes_used == GC_PAGE_SIZE);
0c41e522 2188
9a8c1c2f 2189 PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);
2bf0de4c 2190
9a8c1c2f 2191 /*
2192 * Remove any write protection. Should be able to religh on the
2193 * WP flag to avoid redundant calls.
2194 */
2195 if (PAGE_WRITE_PROTECTED(next_page)) {
0b2b8885 2196 os_protect((os_vm_address_t) page_address(next_page), GC_PAGE_SIZE,
9a8c1c2f 2197 OS_VM_PROT_ALL);
2198 page_table[next_page].flags &= ~PAGE_WRITE_PROTECTED_MASK;
2199 }
0b2b8885 2200 remaining_bytes -= GC_PAGE_SIZE;
9a8c1c2f 2201 next_page++;
2202 }
2bf0de4c 2203
9a8c1c2f 2204 /*
2205 * Now only one page remains, but the object may have shrunk so
2206 * there may be more unused pages which will be freed.
2207 */
2bf0de4c 2208
9a8c1c2f 2209 /* Object may have shrunk but shouldn't have grown - check. */
2210 gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
2bf0de4c 2211
9a8c1c2f 2212 PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);
2213 gc_assert(PAGE_ALLOCATED(next_page));
2214 gc_assert(!PAGE_UNBOXED(next_page));
2bf0de4c 2215
9a8c1c2f 2216 /* Adjust the bytes_used. */
2217 old_bytes_used = page_table[next_page].bytes_used;
2218 page_table[next_page].bytes_used = remaining_bytes;
e7e59d7d 2219
9a8c1c2f 2220 bytes_freed = old_bytes_used - remaining_bytes;
2bf0de4c 2221
9a8c1c2f 2222 mmask = PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | PAGE_LARGE_OBJECT_MASK
2223 | PAGE_GENERATION_MASK;
2224 mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;
2bf0de4c 2225
9a8c1c2f 2226 /* Free any remaining pages; needs care. */
2227 next_page++;
0b2b8885 2228 while (old_bytes_used == GC_PAGE_SIZE &&
9a8c1c2f 2229 PAGE_FLAGS(next_page, mmask) == mflags &&
2230 page_table[next_page].first_object_offset ==
0b2b8885 2231 GC_PAGE_SIZE * (first_page - next_page)) {
9a8c1c2f 2232 /*
2233 * Checks out OK, free the page. Don't need to both zeroing
2234 * pages as this should have been done before shrinking the
2235 * object. These pages shouldn't be write protected as they
2236 * should be zero filled.
2237 */
2238 gc_assert(!PAGE_WRITE_PROTECTED(next_page));
2bf0de4c 2239
9a8c1c2f 2240 old_bytes_used = page_table[next_page].bytes_used;
2241 page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
2242 page_table[next_page].bytes_used = 0;
2243 bytes_freed += old_bytes_used;
2244 next_page++;
2245 }
0c41e522 2246
9a8c1c2f 2247 if (gencgc_verbose && bytes_freed > 0)
2248 fprintf(stderr, "* copy_large_boxed bytes_freed %d\n", bytes_freed);
2bf0de4c 2249
9a8c1c2f 2250 generations[from_space].bytes_allocated -=
2251 sizeof(lispobj) * nwords + bytes_freed;
2252 generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;
2253 bytes_allocated -= bytes_freed;
2bf0de4c 2254
9a8c1c2f 2255 /* Add the region to the new_areas if requested. */
2256 add_new_area(first_page, 0, nwords * sizeof(lispobj));
2bf0de4c 2257
9a8c1c2f 2258 return object;
2259 } else {
2260 /* get tag of object */
2261 tag = LowtagOf(object);
2262
2263 /* allocate space */
2264 new = gc_quick_alloc_large(nwords * sizeof(lispobj));
2265
2266 dest = new;
2267 source = (lispobj *) PTR(object);
2268
2269 /* copy the object */
2270 while (nwords > 0) {
2271 dest[0] = source[0];
2272 dest[1] = source[1];
2273 dest += 2;
2274 source += 2;
2275 nwords -= 2;
2276 }
2bf0de4c 2277
9a8c1c2f 2278 /* return lisp pointer of new object */
2279 return (lispobj) new | tag;
2280 }
0c41e522 2281}
2282
2283/* Copying UnBoxed Objects. */
9a8c1c2f 2284static inline lispobj
2285copy_unboxed_object(lispobj object, int nwords)
0c41e522 2286{
9a8c1c2f 2287 int tag;
2288 lispobj *new;
2289 lispobj *source, *dest;
2bf0de4c 2290
9a8c1c2f 2291 gc_assert(Pointerp(object));
2292 gc_assert(from_space_p(object));
2293 gc_assert((nwords & 0x01) == 0);
2bf0de4c 2294
9a8c1c2f 2295 /* get tag of object */
2296 tag = LowtagOf(object);
0c41e522 2297
9a8c1c2f 2298 /* allocate space */
2299 new = gc_quick_alloc_unboxed(nwords * sizeof(lispobj));
2bf0de4c 2300
9a8c1c2f 2301 dest = new;
2302 source = (lispobj *) PTR(object);
2bf0de4c 2303
9a8c1c2f 2304 /* Copy the object */
2305 while (nwords > 0) {
2306 dest[0] = source[0];
2307 dest[1] = source[1];
2308 dest += 2;
2309 source += 2;
2310 nwords -= 2;
2311 }
2bf0de4c 2312
9a8c1c2f 2313 /* Return lisp pointer of new object. */
2314 return (lispobj) new | tag;
0c41e522 2315}
2316
2317
2bf0de4c 2318/*
2319 * Copying Large Unboxed Objects. If the object is in a large object
2320 * region then it is simply promoted, else it is copied. If it's large
2321 * enough then it's copied to a large object region.
2322 *
2323 * Bignums and vectors may have shrunk. If the object is not copied
2324 * the space needs to be reclaimed, and the page_tables corrected.
2325 */
9a8c1c2f 2326static lispobj
2327copy_large_unboxed_object(lispobj object, int nwords)
0c41e522 2328{
9a8c1c2f 2329 int tag;
2330 lispobj *new;
2331 lispobj *source, *dest;
2332 int first_page;
0c41e522 2333
9a8c1c2f 2334 gc_assert(Pointerp(object));
2335 gc_assert(from_space_p(object));
2336 gc_assert((nwords & 0x01) == 0);
0c41e522 2337
9a8c1c2f 2338 if (gencgc_verbose && nwords > 1024 * 1024)
555746e0 2339 fprintf(stderr, "** copy_large_unboxed_object: %lu\n",
44e0351e 2340 (unsigned long) (nwords * sizeof(lispobj)));
0c41e522 2341
9a8c1c2f 2342 /* Check if it's a large object. */
2343 first_page = find_page_index((void *) object);
2344 gc_assert(first_page >= 0);
2bf0de4c 2345
9a8c1c2f 2346 if (PAGE_LARGE_OBJECT(first_page)) {
2347 /*
2348 * Promote the object. Note: Unboxed objects may have been
2349 * allocated to a BOXED region so it may be necessary to change
2350 * the region to UNBOXED.
2351 */
2352 int remaining_bytes;
2353 int next_page;
2354 int bytes_freed;
2355 int old_bytes_used;
2356 int mmask, mflags;
2357
2358 gc_assert(page_table[first_page].first_object_offset == 0);
2359
2360 next_page = first_page;
2361 remaining_bytes = nwords * sizeof(lispobj);
0b2b8885 2362 while (remaining_bytes > GC_PAGE_SIZE) {
9a8c1c2f 2363 gc_assert(PAGE_GENERATION(next_page) == from_space);
2364 gc_assert(PAGE_ALLOCATED(next_page));
2365 gc_assert(PAGE_LARGE_OBJECT(next_page));
2366 gc_assert(page_table[next_page].first_object_offset ==
0b2b8885 2367 GC_PAGE_SIZE * (first_page - next_page));
2368 gc_assert(page_table[next_page].bytes_used == GC_PAGE_SIZE);
9a8c1c2f 2369
2370 PAGE_FLAGS_UPDATE(next_page,
2371 PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,
2372 PAGE_UNBOXED_MASK | new_space);
0b2b8885 2373 remaining_bytes -= GC_PAGE_SIZE;
9a8c1c2f 2374 next_page++;
2375 }
2bf0de4c 2376
9a8c1c2f 2377 /*
2378 * Now only one page remains, but the object may have shrunk so
2379 * there may be more unused pages which will be freed.
2380 */
2bf0de4c 2381
9a8c1c2f 2382 /* Object may have shrunk but shouldn't have grown - check. */
2383 gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
2bf0de4c 2384
9a8c1c2f 2385 PAGE_FLAGS_UPDATE(next_page, PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK
2386 | PAGE_GENERATION_MASK,
2387 PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | new_space);
2bf0de4c 2388
9a8c1c2f 2389 /* Adjust the bytes_used. */
2390 old_bytes_used = page_table[next_page].bytes_used;
2391 page_table[next_page].bytes_used = remaining_bytes;
2bf0de4c 2392
9a8c1c2f 2393 bytes_freed = old_bytes_used - remaining_bytes;
e7e59d7d 2394
9a8c1c2f 2395 mmask = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK
2396 | PAGE_GENERATION_MASK;
2397 mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;
2bf0de4c 2398
9a8c1c2f 2399 /* Free any remaining pages; needs care. */
2400 next_page++;
0b2b8885 2401 while (old_bytes_used == GC_PAGE_SIZE &&
9a8c1c2f 2402 PAGE_FLAGS(next_page, mmask) == mflags &&
2403 page_table[next_page].first_object_offset ==
0b2b8885 2404 GC_PAGE_SIZE * (first_page - next_page)) {
9a8c1c2f 2405 /*
2406 * Checks out OK, free the page. Don't need to both zeroing
2407 * pages as this should have been done before shrinking the
2408 * object. These pages shouldn't be write protected, even if
2409 * boxed they should be zero filled.
2410 */
2411 gc_assert(!PAGE_WRITE_PROTECTED(next_page));
2bf0de4c 2412
9a8c1c2f 2413 old_bytes_used = page_table[next_page].bytes_used;
2414 page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
2415 page_table[next_page].bytes_used = 0;
2416 bytes_freed += old_bytes_used;
2417 next_page++;
2418 }
2bf0de4c 2419
9a8c1c2f 2420 if (gencgc_verbose && bytes_freed > 0)
2421 fprintf(stderr, "* copy_large_unboxed bytes_freed %d\n",
2422 bytes_freed);
2bf0de4c 2423
9a8c1c2f 2424 generations[from_space].bytes_allocated -=
2425 sizeof(lispobj) * nwords + bytes_freed;
2426 generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;
2427 bytes_allocated -= bytes_freed;
2bf0de4c 2428
9a8c1c2f 2429 return object;
2430 } else {
2431 /* get tag of object */
2432 tag = LowtagOf(object);
2433
2434 /* allocate space */
2435 new = gc_quick_alloc_large_unboxed(nwords * sizeof(lispobj));
2436
2437 dest = new;
2438 source = (lispobj *) PTR(object);
2439
2440 /* copy the object */
2441 while (nwords > 0) {
2442 dest[0] = source[0];
2443 dest[1] = source[1];
2444 dest += 2;
2445 source += 2;
2446 nwords -= 2;
2447 }
2bf0de4c 2448
9a8c1c2f 2449 /* return lisp pointer of new object */
2450 return (lispobj) new | tag;
0c41e522 2451 }
0c41e522 2452}
b7271901 2453
2454static inline boolean
2455maybe_static_array_p(lispobj header)
2456{
2457 boolean result;
2458
2459 switch (TypeOf(header)) {
2460 /*
2461 * This needs to be coordinated to the set of allowed
2462 * static vectors in make-array.
2463 */
2464 case type_SimpleString:
2465 case type_SimpleArrayUnsignedByte8:
2466 case type_SimpleArrayUnsignedByte16:
2467 case type_SimpleArrayUnsignedByte32:
2468#ifdef type_SimpleArraySignedByte8
2469 case type_SimpleArraySignedByte8:
2470#endif
2471#ifdef type_SimpleArraySignedByte16
2472 case type_SimpleArraySignedByte16:
2473#endif
2474#ifdef type_SimpleArraySignedByte32
2475 case type_SimpleArraySignedByte32:
2476#endif
2477 case type_SimpleArraySingleFloat:
2478 case type_SimpleArrayDoubleFloat:
2479#ifdef type_SimpleArrayLongFloat
2480 case type_SimpleArrayLongFloat:
2481#endif
2482#ifdef type_SimpleArrayComplexSingleFloat
2483 case type_SimpleArrayComplexSingleFloat:
2484#endif
2485#ifdef type_SimpleArrayComplexDoubleFloat
2486 case type_SimpleArrayComplexDoubleFloat:
2487#endif
2488#ifdef type_SimpleArrayComplexLongFloat
2489 case type_SimpleArrayComplexLongFloat:
2490#endif
2491 result = TRUE;
83376964 2492 break;
b7271901 2493 default:
2494 result = FALSE;
2495 }
2496 return result;
2497}
2498
0c41e522 2499\f
9a8c1c2f 2500
0c41e522 2501/* Scavenging */
2502
0b4f3884 2503/*
2504 * Douglas Crosher says:
2505 *
2506 * There were two different ways in which the scavenger dispatched,
2507 * and DIRECT_SCAV was one option. This code did work at one stage
2508 * but testing showed it to be slower. When DIRECT_SCAV is enabled
2509 * the scavenger dispatches via the scavtab for all objects, and when
2510 * disabled the scavenger firstly detects and handles some common
2511 * cases itself before dispatching.
2512 */
2513
0c41e522 2514#define DIRECT_SCAV 0
2515
c197af2f 2516static void
9a8c1c2f 2517scavenge(void *start_obj, long nwords)
0c41e522 2518{
9a8c1c2f 2519 lispobj *start;
ae169a66 2520
9a8c1c2f 2521 start = (lispobj *) start_obj;
2bf0de4c 2522
9a8c1c2f 2523 while (nwords > 0) {
2524 lispobj object;
2525 int words_scavenged;
2526
2527 object = *start;
2528 /* Not a forwarding pointer. */
2529 gc_assert(object != 0x01);
2bf0de4c 2530
0c41e522 2531#if DIRECT_SCAV
9a8c1c2f 2532 words_scavenged = scavtab[TypeOf(object)] (start, object);
2533#else /* not DIRECT_SCAV */
2534 if (Pointerp(object)) {
c197af2f 2535#ifdef GC_ASSERTIONS
9a8c1c2f 2536 check_escaped_stack_object(start, object);
c197af2f 2537#endif
c197af2f 2538
9a8c1c2f 2539 if (from_space_p(object)) {
2540 lispobj *ptr = (lispobj *) PTR(object);
2541 lispobj first_word = *ptr;
2542
2543 if (first_word == 0x01) {
2544 *start = ptr[1];
2545 words_scavenged = 1;
45380dbb 2546 } else {
9a8c1c2f 2547 words_scavenged = scavtab[TypeOf(object)] (start, object);
45380dbb 2548 }
2549 } else if (dynamic_space_p(object) || new_space_p(object) || static_space_p(object)
2550 || read_only_space_p(object) || control_stack_space_p(object)
b7271901 2551 || binding_stack_space_p(object) || signal_space_p(object)
2552 || other_space_p(object)) {
45380dbb 2553 words_scavenged = 1;
2554 } else {
2555 lispobj *ptr = (lispobj *) PTR(object);
2556 words_scavenged = 1;
83376964 2557 if (debug_static_array_p) {
2558 fprintf(stderr, "Not in Lisp spaces: object = %p, ptr = %p\n",
2559 (void*)object, ptr);
2560 }
2561
f0626999 2562 if (1) {
45380dbb 2563 lispobj header = *ptr;
83376964 2564 if (debug_static_array_p) {
2565 fprintf(stderr, " Header value = 0x%lx\n", (unsigned long) header);
2566 }
2567
b7271901 2568 if (maybe_static_array_p(header)) {
2569 int static_p;
45380dbb 2570
83376964 2571 if (debug_static_array_p) {
2572 fprintf(stderr, "Possible static vector at %p. header = 0x%lx\n",
2573 ptr, (unsigned long) header);
2574 }
45380dbb 2575
b7271901 2576 static_p = (HeaderValue(header) & 1) == 1;
2577 if (static_p) {
2578 /*
2579 * We have a static vector. Mark it as
2580 * reachable by setting the MSB of the header.
2581 */
2582 *ptr = header | 0x80000000;
83376964 2583 if (debug_static_array_p) {
2584 fprintf(stderr, "Scavenged static vector @%p, header = 0x%lx\n",
2585 ptr, (unsigned long) header);
2586 }
b7271901 2587 }
45380dbb 2588 }
2589 }
2590 }
9a8c1c2f 2591 } else if ((object & 3) == 0)
c197af2f 2592 words_scavenged = 1;
9a8c1c2f 2593 else
2594 words_scavenged = scavtab[TypeOf(object)] (start, object);
c197af2f 2595#endif /* not DIRECT_SCAV */
2bf0de4c 2596
9a8c1c2f 2597 start += words_scavenged;
2598 nwords -= words_scavenged;
c197af2f 2599 }
0c41e522 2600
9a8c1c2f 2601 gc_assert(nwords == 0);
2602}
0c41e522 2603\f
9a8c1c2f 2604
3f2ead72 2605#if !(defined(i386) || defined(__x86_64))
af867264 2606/* Scavenging Interrupt Contexts */
2607
2608static int boxed_registers[] = BOXED_REGISTERS;
2609
30102669 2610/* The GC has a notion of an "interior pointer" register, an unboxed
2611 * register that typically contains a pointer to inside an object
2612 * referenced by another pointer. The most obvious of these is the
2613 * program counter, although many compiler backends define a "Lisp
2614 * Interior Pointer" register known as reg_LIP, and various CPU
2615 * architectures have other registers that also partake of the
2616 * interior-pointer nature. As the code for pairing an interior
2617 * pointer value up with its "base" register, and fixing it up after
2618 * scavenging is complete is horribly repetitive, a few macros paper
2619 * over the monotony. --AB, 2010-Jul-14 */
2620
2621#define INTERIOR_POINTER_VARS(name) \
2622 unsigned long name; \
2623 unsigned long name##_offset; \
2624 int name##_register_pair
2625
2626#define PAIR_INTERIOR_POINTER(name, accessor) \
2627 name = accessor; \
2628 pair_interior_pointer(context, name, \
2629 &name##_offset, \
2630 &name##_register_pair)
2631
2632/*
2633 * Do we need to check if the register we're fixing up is in the
2634 * from-space?
2635 */
2636#define FIXUP_INTERIOR_POINTER(name, accessor) \
2637 do { \
2638 if (name##_register_pair >= 0) { \
2639 accessor = \
3adc2c31 2640 PTR(SC_REG(context, name##_register_pair)) \
30102669 2641 + name##_offset; \
2642 } \
2643 } while (0)
2644
2645
2646static void
2647pair_interior_pointer(os_context_t *context, unsigned long pointer,
2648 unsigned long *saved_offset, int *register_pair)
2649{
2650 int i;
2651
2652 /*
2653 * I (RLT) think this is trying to find the boxed register that is
2654 * closest to the LIP address, without going past it. Usually, it's
2655 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
2656 */
2657 *saved_offset = 0x7FFFFFFF;
2658 *register_pair = -1;
2659 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2660 unsigned long reg;
2661 long offset;
2662 int index;
2663
2664 index = boxed_registers[i];
2665 reg = SC_REG(context, index);
2666
2667 /* An interior pointer is never relative to a non-pointer
2668 * register (an oversight in the original implementation).
2669 * The simplest argument for why this is true is to consider
2670 * the fixnum that happens by coincide to be the word-index in
2671 * memory of the header for some object plus two. This is
2672 * happenstance would cause the register containing the fixnum
2673 * to be selected as the register_pair if the interior pointer
2674 * is to anywhere after the first two words of the object.
2675 * The fixnum won't be changed during GC, but the object might
2676 * move, thus destroying the interior pointer. --AB,
2677 * 2010-Jul-14 */
2678
2679 if (Pointerp(reg) && (PTR(reg) <= pointer)) {
3adc2c31 2680 offset = pointer - PTR(reg);
30102669 2681 if (offset < *saved_offset) {
2682 *saved_offset = offset;
2683 *register_pair = index;
2684 }
2685 }
2686 }
2687}
2688
2689
9a8c1c2f 2690static void
2691scavenge_interrupt_context(os_context_t * context)
af867264 2692{
9a8c1c2f 2693 int i;
2694
30102669 2695 INTERIOR_POINTER_VARS(pc);
af867264 2696#ifdef reg_LIP
30102669 2697 INTERIOR_POINTER_VARS(lip);
af867264 2698#endif
87e1c793 2699#ifdef reg_LR
30102669 2700 INTERIOR_POINTER_VARS(lr);
87e1c793 2701#endif
2702#ifdef reg_CTR
30102669 2703 INTERIOR_POINTER_VARS(ctr);
87e1c793 2704#endif
af867264 2705#ifdef SC_NPC
30102669 2706 INTERIOR_POINTER_VARS(npc);
af867264 2707#endif
2708
2709#ifdef reg_LIP
30102669 2710 PAIR_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
af867264 2711#endif /* reg_LIP */
2712
30102669 2713 PAIR_INTERIOR_POINTER(pc, SC_PC(context));
2714
af867264 2715#ifdef SC_NPC
30102669 2716 PAIR_INTERIOR_POINTER(npc, SC_NPC(context));
2717#endif
9a8c1c2f 2718
87e1c793 2719#ifdef reg_LR
9dcff02e 2720 PAIR_INTERIOR_POINTER(lr, SC_REG(context, reg_LR));
30102669 2721#endif
2722
87e1c793 2723#ifdef reg_CTR
9dcff02e 2724 PAIR_INTERIOR_POINTER(ctr, SC_REG(context, reg_CTR));
87e1c793 2725#endif
30102669 2726
9a8c1c2f 2727 /* Scanvenge all boxed registers in the context. */
2728 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2729 int index;
2730 lispobj foo;
2731
2732 index = boxed_registers[i];
2733 foo = SC_REG(context, index);
2734 scavenge(&foo, 1);
2735 SC_REG(context, index) = foo;
2736
2737 scavenge(&(SC_REG(context, index)), 1);
af867264 2738 }
2739
9a8c1c2f 2740 /*
30102669 2741 * Now that the scavenging is done, repair the various interior
2742 * pointers.
9a8c1c2f 2743 */
30102669 2744#ifdef reg_LIP
2745 FIXUP_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
2746#endif
2747
2748 FIXUP_INTERIOR_POINTER(pc, SC_PC(context));
9a8c1c2f 2749
af867264 2750#ifdef SC_NPC
30102669 2751 FIXUP_INTERIOR_POINTER(npc, SC_NPC(context));
2752#endif
87e1c793 2753
2754#ifdef reg_LR
30102669 2755 FIXUP_INTERIOR_POINTER(lr, SC_REG(context, reg_LR));
2756#endif
2757
87e1c793 2758#ifdef reg_CTR
30102669 2759 FIXUP_INTERIOR_POINTER(ctr, SC_REG(context, reg_CTR));
2760#endif
af867264 2761}
2762
9a8c1c2f 2763void
2764scavenge_interrupt_contexts(void)
af867264 2765{
9a8c1c2f 2766 int i, index;
2767 os_context_t *context;
af867264 2768
45de6763 2769#ifdef PRINTNOISE
9a8c1c2f 2770 printf("Scavenging interrupt contexts ...\n");
45de6763 2771#endif
2772
9a8c1c2f 2773 index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
af867264 2774
2775#if defined(DEBUG_PRINT_CONTEXT_INDEX)
9a8c1c2f 2776 printf("Number of active contexts: %d\n", index);
af867264 2777#endif
2778
9a8c1c2f 2779 for (i = 0; i < index; i++) {
2780 context = lisp_interrupt_contexts[i];
2781 scavenge_interrupt_context(context);
af867264 2782 }
2783}
2784#endif
2785\f
0c41e522 2786/* Code and Code-Related Objects */
2787
af867264 2788/*
2789 * Aargh! Why is SPARC so different here? What is the advantage of
2790 * making it different from all the other ports?
2791 */
555746e0 2792#if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
af867264 2793#define RAW_ADDR_OFFSET 0
2794#else
2bf0de4c 2795#define RAW_ADDR_OFFSET (6 * sizeof(lispobj) - type_FunctionPointer)
af867264 2796#endif
0c41e522 2797
2798static lispobj trans_function_header(lispobj object);
2799static lispobj trans_boxed(lispobj object);
2800
2801#if DIRECT_SCAV
9a8c1c2f 2802static int
2803scav_function_pointer(lispobj * where, lispobj object)
0c41e522 2804{
9a8c1c2f 2805 gc_assert(Pointerp(object));
0c41e522 2806
9a8c1c2f 2807 if (from_space_p(object)) {
2808 lispobj first, *first_pointer;
2bf0de4c 2809
9a8c1c2f 2810 /*
2811 * Object is a pointer into from space - check to see if it has
2812 * been forwarded.
2813 */
2814 first_pointer = (lispobj *) PTR(object);
2815 first = *first_pointer;
2bf0de4c 2816
9a8c1c2f 2817 if (first == 0x01) {
2818 /* Forwarded */
2819 *where = first_pointer[1];
2820 return 1;
2821 } else {
2822 int type;
2823 lispobj copy;
2bf0de4c 2824
9a8c1c2f 2825 /*
2826 * Must transport object -- object may point to either a
2827 * function header, a closure function header, or to a closure
2828 * header.
2829 */
2bf0de4c 2830
9a8c1c2f 2831 type = TypeOf(first);
2832 switch (type) {
2833 case type_FunctionHeader:
2834 case type_ClosureFunctionHeader:
2835 copy = trans_function_header(object);
2836 break;
2837 default:
2838 copy = trans_boxed(object);
2839 break;
2840 }
2bf0de4c 2841
9a8c1c2f 2842 if (copy != object) {
2843 /* Set forwarding pointer. */
2844 first_pointer[0] = 0x01;
2845 first_pointer[1] = copy;
2846 }
2bf0de4c 2847
9a8c1c2f 2848 first = copy;
2849 }
2bf0de4c 2850
9a8c1c2f 2851 gc_assert(Pointerp(first));
2852 gc_assert(!from_space_p(first));
2bf0de4c 2853
9a8c1c2f 2854 *where = first;
2855 }
2856 return 1;
0c41e522 2857}
2858#else
9a8c1c2f 2859static int
2860scav_function_pointer(lispobj * where, lispobj object)
0c41e522 2861{
9a8c1c2f 2862 lispobj *first_pointer;
2863 lispobj copy;
0c41e522 2864
9a8c1c2f 2865 gc_assert(Pointerp(object));
2bf0de4c 2866
9a8c1c2f 2867 /* Object is a pointer into from space - no a FP. */
2868 first_pointer = (lispobj *) PTR(object);
2bf0de4c 2869
9a8c1c2f 2870 /*
2871 * Must transport object -- object may point to either a function
2872 * header, a closure function header, or to a closure header.
2873 */
2bf0de4c 2874
9a8c1c2f 2875 switch (TypeOf(*first_pointer)) {
2876 case type_FunctionHeader:
2877 case type_ClosureFunctionHeader:
2878 copy = trans_function_header(object);
2879 break;
2880 default:
2881 copy = trans_boxed(object);
2882 break;
2883 }
2bf0de4c 2884
9a8c1c2f 2885 if (copy != object) {
2886 /* Set forwarding pointer */
2887 first_pointer[0] = 0x01;
2888 first_pointer[1] = copy;
2889 }
2bf0de4c 2890
9a8c1c2f 2891 gc_assert(Pointerp(copy));
2892 gc_assert(!from_space_p(copy));
0c41e522 2893
9a8c1c2f 2894 *where = copy;
2bf0de4c 2895
9a8c1c2f 2896 return 1;
0c41e522 2897}
2898#endif
2899
3f2ead72 2900#if defined(i386) || defined(__x86_64)
2bf0de4c 2901/*
d54d3cbf 2902 * Scan an x86 compiled code object, looking for possible fixups that
2bf0de4c 2903 * have been missed after a move.
2904 *
2905 * Two types of fixups are needed:
2906 * 1. Absolution fixups to within the code object.
2907 * 2. Relative fixups to outside the code object.
2908 *
2909 * Currently only absolution fixups to the constant vector, or to the
2910 * code area are checked.
2911 */
9a8c1c2f 2912void
2913sniff_code_object(struct code *code, unsigned displacement)
0c41e522 2914{
9a8c1c2f 2915 int nheader_words, ncode_words, nwords;
6438e048 2916 char *p;
2917 char *constants_start_addr, *constants_end_addr;
2918 char *code_start_addr, *code_end_addr;
9a8c1c2f 2919 int fixup_found = 0;
2bf0de4c 2920
9a8c1c2f 2921 if (!check_code_fixups)
2922 return;
bd46c00c 2923
9a8c1c2f 2924 /*
2925 * It's ok if it's byte compiled code. The trace table offset will
2926 * be a fixnum if it's x86 compiled code - check.
2927 */
2928 if (code->trace_table_offset & 0x3) {
2bf0de4c 2929#if 0
9a8c1c2f 2930 fprintf(stderr, "*** Sniffing byte compiled code object at %x.\n",
2931 code);
2bf0de4c 2932#endif
9a8c1c2f 2933 return;
2934 }
0c41e522 2935
9a8c1c2f 2936 /* Else it's x86 machine code. */
0c41e522 2937
9a8c1c2f 2938 ncode_words = fixnum_value(code->code_size);
2939 nheader_words = HeaderValue(*(lispobj *) code);
2940 nwords = ncode_words + nheader_words;
0c41e522 2941
6438e048 2942 constants_start_addr = (char *) code + 5 * sizeof(lispobj);
2943 constants_end_addr = (char *) code + nheader_words * sizeof(lispobj);
2944 code_start_addr = (char *) code + nheader_words * sizeof(lispobj);
2945 code_end_addr = (char *) code + nwords * sizeof(lispobj);
0c41e522 2946
9a8c1c2f 2947 /* Work through the unboxed code. */
2948 for (p = code_start_addr; p < code_end_addr; p++) {
6438e048 2949 char *data = *(char **) p;
9a8c1c2f 2950 unsigned d1 = *((unsigned char *) p - 1);
2951 unsigned d2 = *((unsigned char *) p - 2);
2952 unsigned d3 = *((unsigned char *) p - 3);
2953 unsigned d4 = *((unsigned char *) p - 4);
2954 unsigned d5 = *((unsigned char *) p - 5);
2955 unsigned d6 = *((unsigned char *) p - 6);
2bf0de4c 2956
9a8c1c2f 2957 /*
2958 * Check for code references.
2959 *
2960 * Check for a 32 bit word that looks like an absolute reference
2961 * to within the code adea of the code object.
2962 */
2963 if (data >= code_start_addr - displacement
2964 && data < code_end_addr - displacement) {
2965 /* Function header */
2966 if (d4 == 0x5e
2967 && ((unsigned long) p - 4 -
2968 4 * HeaderValue(*((unsigned long *) p - 1))) ==
2969 (unsigned long) code) {
2970 /* Skip the function header */
2971 p += 6 * 4 - 4 - 1;
2972 continue;
2973 }
2974 /* Push imm32 */
2975 if (d1 == 0x68) {
2976 fixup_found = 1;
2977 fprintf(stderr,
2978 "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2979 (unsigned long) p, d6, d5, d4, d3, d2, d1,
2980 (unsigned long) data);
2981 fprintf(stderr, "*** Push $0x%.8lx\n", (unsigned long) data);
2982 }
2983 /* Mov [reg-8],imm32 */
2984 if (d3 == 0xc7
2985 && (d2 == 0x40 || d2 == 0x41 || d2 == 0x42 || d2 == 0x43
2986 || d2 == 0x45 || d2 == 0x46 || d2 == 0x47)
2987 && d1 == 0xf8) {
2988 fixup_found = 1;
2989 fprintf(stderr,
2990 "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2991 (unsigned long) p, d6, d5, d4, d3, d2, d1,
2992 (unsigned long) data);
2993 fprintf(stderr, "*** Mov [reg-8],$0x%.8lx\n",
2994 (unsigned long) data);
2995 }
2996 /* Lea reg, [disp32] */
2997 if (d2 == 0x8d && (d1 & 0xc7) == 5) {
2998 fixup_found = 1;
2999 fprintf(stderr,
3000 "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3001 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3002 (unsigned long) data);
3003 fprintf(stderr, "*** Lea reg,[$0x%.8lx]\n",
3004 (unsigned long) data);
3005 }
3006 }
3007
3008 /*
3009 * Check for constant references.
3010 *
3011 * Check for a 32 bit word that looks like an absolution reference
3012 * to within the constant vector. Constant references will be
3013 * aligned.
3014 */
3015 if (data >= constants_start_addr - displacement
3016 && data < constants_end_addr - displacement
3017 && ((unsigned long) data & 0x3) == 0) {
3018 /* Mov eax,m32 */
3019 if (d1 == 0xa1) {
3020 fixup_found = 1;
3021 fprintf(stderr,
3022 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3023 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3024 (unsigned long) data);
3025 fprintf(stderr, "*** Mov eax,0x%.8lx\n", (unsigned long) data);
3026 }
3027
3028 /* Mov m32,eax */
3029 if (d1 == 0xa3) {
3030 fixup_found = 1;
3031 fprintf(stderr,
3032 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3033 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3034 (unsigned long) data);
3035 fprintf(stderr, "*** Mov 0x%.8lx,eax\n", (unsigned long) data);
3036 }
3037
3038 /* Cmp m32,imm32 */
3039 if (d1 == 0x3d && d2 == 0x81) {
3040 fixup_found = 1;
3041 fprintf(stderr,
3042 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3043 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3044 (unsigned long) data);
3045 /* XX Check this */
3046 fprintf(stderr, "*** Cmp 0x%.8lx,immed32\n",
3047 (unsigned long) data);
3048 }
3049
3050 /* Check for a mod=00, r/m=101 byte. */
3051 if ((d1 & 0xc7) == 5) {
3052 /* Cmp m32,reg */
3053 if (d2 == 0x39) {
3054 fixup_found = 1;
3055 fprintf(stderr,
3056 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3057 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3058 (unsigned long) data);
3059 fprintf(stderr, "*** Cmp 0x%.8lx,reg\n",
3060 (unsigned long) data);
3061 }
3062 /* Cmp reg32,m32 */
3063 if (d2 == 0x3b) {
3064 fixup_found = 1;
3065 fprintf(stderr,
3066 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3067 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3068 (unsigned long) data);
3069 fprintf(stderr, "*** Cmp reg32,0x%.8lx\n",
3070 (unsigned long) data);
3071 }
3072 /* Mov m32,reg32 */
3073 if (d2 == 0x89) {
3074 fixup_found = 1;
3075 fprintf(stderr,
3076 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3077 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3078 (unsigned long) data);
3079 fprintf(stderr, "*** Mov 0x%.8lx,reg32\n",
3080 (unsigned long) data);
3081 }
3082 /* Mov reg32,m32 */
3083 if (d2 == 0x8b) {
3084 fixup_found = 1;
3085 fprintf(stderr,
3086 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3087 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3088 (unsigned long) data);
3089 fprintf(stderr, "*** Mov reg32,0x%.8lx\n",
3090 (unsigned long) data);
3091 }
3092 /* Lea reg32,m32 */
3093 if (d2 == 0x8d) {
3094 fixup_found = 1;
3095 fprintf(stderr,
3096 "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
3097 (unsigned long) p, d6, d5, d4, d3, d2, d1,
3098 (unsigned long) data);
3099 fprintf(stderr, "*** Lea reg32,0x%.8lx\n",
3100 (unsigned long) data);
3101 }
3102 }
3103 }
0c41e522 3104 }
3105
9a8c1c2f 3106 /* If anything was found print out some info. on the code object. */
3107 if (fixup_found) {
3108 fprintf(stderr,
3109 "*** Compiled code object at %lx: header_words=%d code_words=%d .\n",
3110 (unsigned long) code, nheader_words, ncode_words);
3111 fprintf(stderr,
3112 "*** Const. start = %lx; end= %lx; Code start = %lx; end = %lx\n",
3113 (unsigned long) constants_start_addr,
3114 (unsigned long) constants_end_addr,
3115 (unsigned long) code_start_addr, (unsigned long) code_end_addr);
3116 }
3117}
3118
3119static void
3120apply_code_fixups(struct code *old_code, struct code *new_code)
3121{
3122 int nheader_words, ncode_words, nwords;
6438e048 3123 char *constants_start_addr, *constants_end_addr;
3124 char *code_start_addr, *code_end_addr;
9a8c1c2f 3125 lispobj fixups = NIL;
3126 unsigned long displacement =
3127
3128 (unsigned long) new_code - (unsigned long) old_code;
3129 struct vector *fixups_vector;
3130
2bf0de4c 3131 /*
9a8c1c2f 3132 * It's ok if it's byte compiled code. The trace table offset will
3133 * be a fixnum if it's x86 compiled code - check.
2bf0de4c 3134 */
9a8c1c2f 3135 if (new_code->trace_table_offset & 0x3) {
2bf0de4c 3136#if 0
9a8c1c2f 3137 fprintf(stderr, "*** Byte compiled code object at %x.\n", new_code);
2bf0de4c 3138#endif
9a8c1c2f 3139 return;
3140 }
0c41e522 3141
9a8c1c2f 3142 /* Else it's x86 machine code. */
3143 ncode_words = fixnum_value(new_code->code_size);
3144 nheader_words = HeaderValue(*(lispobj *) new_code);
3145 nwords = ncode_words + nheader_words;
2bf0de4c 3146#if 0
9a8c1c2f 3147 fprintf(stderr,
3148 "*** Compiled code object at %x: header_words=%d code_words=%d .\n",
3149 new_code, nheader_words, ncode_words);
2bf0de4c 3150#endif
6438e048 3151 constants_start_addr = (char *) new_code + 5 * sizeof(lispobj);
3152 constants_end_addr = (char *) new_code + nheader_words * sizeof(lispobj);
3153 code_start_addr = (char *) new_code + nheader_words * sizeof(lispobj);
3154 code_end_addr = (char *) new_code + nwords * sizeof(lispobj);
2bf0de4c 3155#if 0
9a8c1c2f 3156 fprintf(stderr,
3157 "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
3158 constants_start_addr, constants_end_addr, code_start_addr,
3159 code_end_addr);
3160#endif
3161
3162 /*
3163 * The first constant should be a pointer to the fixups for this
3164 * code objects - Check.
3165 */
3166 fixups = new_code->constants[0];
3167
3168 /*
3169 * It will be 0 or the unbound-marker if there are no fixups, and
3170 * will be an other pointer if it is valid.
3171 */
3172 if (fixups == 0 || fixups == type_UnboundMarker || !Pointerp(fixups)) {
3173 /* Check for possible errors. */
3174 if (check_code_fixups)
3175 sniff_code_object(new_code, displacement);
2bf0de4c 3176
3177#if 0
9a8c1c2f 3178 fprintf(stderr, "Fixups for code object not found!?\n");
3179 fprintf(stderr,
3180 "*** Compiled code object at %x: header_words=%d code_words=%d .\n",
3181 new_code, nheader_words, ncode_words);
3182 fprintf(stderr,
3183 "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
3184 constants_start_addr, constants_end_addr, code_start_addr,
3185 code_end_addr);
3186#endif
3187 return;
3188 }
0c41e522 3189
9a8c1c2f 3190 fixups_vector = (struct vector *) PTR(fixups);
0c41e522 3191
9a8c1c2f 3192 /* Could be pointing to a forwarding pointer. */
3193 if (Pointerp(fixups) && find_page_index((void *) fixups_vector) != -1
3194 && fixups_vector->header == 0x01) {
2d23e048 3195#if 0
9a8c1c2f 3196 fprintf(stderr, "* FF\n");
2d23e048 3197#endif
9a8c1c2f 3198 /* If so then follow it. */
3199 fixups_vector = (struct vector *) PTR((lispobj) fixups_vector->length);
3200 }
2bf0de4c 3201#if 0
9a8c1c2f 3202 fprintf(stderr, "Got the fixups\n");
2bf0de4c 3203#endif
0c41e522 3204
9a8c1c2f 3205 if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
2bf0de4c 3206 /*
9a8c1c2f 3207 * Got the fixups for the code block. Now work through the
3208 * vector, and apply a fixup at each address.
2bf0de4c 3209 */
9a8c1c2f 3210 int length = fixnum_value(fixups_vector->length);
3211 int i;
3212
3213 for (i = 0; i < length; i++) {
3214 unsigned offset = fixups_vector->data[i];
3215
3216 /* Now check the current value of offset. */
3217 unsigned long old_value =
3218 *(unsigned long *) ((unsigned long) code_start_addr + offset);
3219
3220 /*
3221 * If it's within the old_code object then it must be an
3222 * absolute fixup (relative ones are not saved).
3223 */
3224 if (old_value >= (unsigned long) old_code
3225 && old_value <
3226 (unsigned long) old_code + nwords * sizeof(lispobj))
3227 /* So add the dispacement. */
3228 *(unsigned long *) ((unsigned long) code_start_addr + offset) =
3229 old_value + displacement;
3230 else
3231 /*
3232 * It is outside the old code object so it must be a relative
3233 * fixup (absolute fixups are not saved). So subtract the
3234 * displacement.
3235 */
3236 *(unsigned long *) ((unsigned long) code_start_addr + offset) =
3237 old_value - displacement;
3238 }
0c41e522 3239 }
2bf0de4c 3240
9a8c1c2f 3241 /* Check for possible errors. */
3242 if (check_code_fixups)
3243 sniff_code_object(new_code, displacement);
0c41e522 3244}
af867264 3245#endif
0c41e522 3246
9a8c1c2f 3247static struct code *
3248trans_code(struct code *code)
0c41e522 3249{
9a8c1c2f 3250 struct code *new_code;
3251 lispobj l_code, l_new_code;
3252 int nheader_words, ncode_words, nwords;
3253 unsigned long displacement;
3254 lispobj fheaderl, *prev_pointer;
2bf0de4c 3255
3256#if 0
9a8c1c2f 3257 fprintf(stderr, "\nTransporting code object located at 0x%08x.\n",
3258 (unsigned long) code);
2bf0de4c 3259#endif
3260
9a8c1c2f 3261 /* If object has already been transported, just return pointer */