1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Garbage collector core
28
29 This is a one-space copying garbage collector. It's like a
30 two-space collector, except that the heap is copied to temporary
31 memory ("tospace"), then copied back at the end. This design is
32 more complex and slower than a two-space collector, but it has the
33 advantage that tospace can be allocated anywhere in the virtual
34 address space. This matters because our tagging scheme limits the
35 number of address bits we can use (26 on a 32-bit machine), and
36 with this design tospace can be located outside of the addressable
37 range, thus maximizing the usage of addressable memory. This
38 design is similar to that of the older "bchscheme" GC, except that
39 bchscheme allocated its tospace in a file.
40
41 Some terminology:
42
43 "Fromspace" is the allocated portion of the heap that we copy
44 objects from.
45
46 "Tospace" is the temporary memory that we copy objects to.
47
48 "Newspace" is the region of memory into which tospace will be
49 copied after the GC is complete. During the GC we copy objects
50 into tospace, but update pointers to refer to locations in
51 newspace. Since there's a simple relationship between pointers in
52 newspace and pointers in tospace, it's easy to convert between
53 them.
54
55 "Oldspace" is the addressable region of memory. This includes
56 fromspace, and also the stack and constant areas. It is
57 distinguished from fromspace because we can scan anywhere in
58 oldspace, but we copy only from fromspace.
59
60 */
61
62 #include "object.h"
63 #include "outf.h"
64 #include "gccode.h"
65
66 /* For ephemeron layout. */
67 #include "sdata.h"
68
69 /* For memory advice. */
70 #include "ostop.h"
71
72 static SCHEME_OBJECT ** p_fromspace_start;
73 static SCHEME_OBJECT ** p_fromspace_end;
74 static gc_tospace_allocator_t * gc_tospace_allocator;
75 static gc_abort_handler_t * gc_abort_handler NORETURN;
76
77 static SCHEME_OBJECT * tospace_start;
78 static SCHEME_OBJECT * tospace_next;
79 static SCHEME_OBJECT * tospace_end;
80 static SCHEME_OBJECT * newspace_start;
81 static SCHEME_OBJECT * newspace_next;
82 static SCHEME_OBJECT * newspace_end;
83
84 gc_table_t * current_gc_table;
85 static SCHEME_OBJECT * current_scan;
86 static SCHEME_OBJECT current_object;
87
88 #define ADDRESS_IN_FROMSPACE_P(addr) \
89 ((((void *) (addr)) >= ((void *) (*p_fromspace_start))) \
90 && (((void *) (addr)) < ((void *) (*p_fromspace_end))))
91
92 #define TOSPACE_TO_NEWSPACE(p) (((p) - tospace_start) + newspace_start)
93 #define NEWSPACE_TO_TOSPACE(p) (((p) - newspace_start) + tospace_start)
94
95 #define READ_TOSPACE(addr) (* (NEWSPACE_TO_TOSPACE (addr)))
96 #define WRITE_TOSPACE(addr, obj) ((* (NEWSPACE_TO_TOSPACE (addr))) = (obj))
97
98 #define CLOSE_TOSPACE() do \
99 { \
100 tospace_next = 0; \
101 newspace_start = 0; \
102 newspace_next = 0; \
103 newspace_end = 0; \
104 } while (false)
105
106 #define GUARANTEE_TOSPACE_OPEN() do \
107 { \
108 if (tospace_next == 0) \
109 tospace_closed (); \
110 } while (false)
111
112 #define GUARANTEE_TOSPACE_CLOSED() do \
113 { \
114 if (tospace_next != 0) \
115 tospace_open (); \
116 } while (false)
117
118 #ifndef READ_REFERENCE_ADDRESS
119 # define READ_REFERENCE_ADDRESS(addr) \
120 (* ((SCHEME_OBJECT **) (addr)))
121 # define WRITE_REFERENCE_ADDRESS(ref, addr) \
122 ((* ((SCHEME_OBJECT **) (addr))) = (ref))
123 #endif
124
125 /* The weak chain is a linked list of all the live weak pairs whose
126 cars are not GC-invariant, described below.
127
128 The ephemeron list is a linked list of all the live ephemerons whose
129 cars are not GC-invariant. The ephemeron queue is a queue of all
130 the live ephemerons whose keys have been proven live but whose data
131 slots have not yet been scanned. The ephemeron hash table is a map
132 from fromspace addresses to lists of ephemerons, in which an
133 association between a fromspace address and a list of ephemerons
134 indicates that if the object stored at that fromspace address is
135 proven live, those ephemerons must not be broken, and consequently
136 their data must be live too. */
137
138 static SCHEME_OBJECT * weak_chain;
139 static SCHEME_OBJECT ephemeron_list = SHARP_F;
140 static SCHEME_OBJECT ephemeron_queue = SHARP_F;
141 static bool scanning_ephemerons_p = false;
142
143 extern SCHEME_OBJECT ephemeron_array;
144 extern unsigned long ephemeron_count;
145
146 static void queue_ephemerons_for_key (SCHEME_OBJECT *);
147 static SCHEME_OBJECT gc_transport_weak_pair (SCHEME_OBJECT);
148 static SCHEME_OBJECT gc_transport_ephemeron (SCHEME_OBJECT);
149
150 static void run_gc_loop (SCHEME_OBJECT * , SCHEME_OBJECT **);
151 static void tospace_closed (void) NORETURN;
152 static void tospace_open (void) NORETURN;
153
154 #ifdef ENABLE_GC_DEBUGGING_TOOLS
155 # ifndef GC_SCAN_HISTORY_SIZE
156 # define GC_SCAN_HISTORY_SIZE 1024
157 # endif
158 # define INITIALIZE_GC_HISTORY initialize_gc_history
159 # define HANDLE_GC_TRAP handle_gc_trap
160 # define CHECK_NEWSPACE_SYNC check_newspace_sync
161 # define DEBUG_TRANSPORT_ONE_WORD debug_transport_one_word
162
163 static unsigned int gc_scan_history_index;
164 static SCHEME_OBJECT * gc_scan_history [GC_SCAN_HISTORY_SIZE];
165 static SCHEME_OBJECT * gc_to_history [GC_SCAN_HISTORY_SIZE];
166
167 static SCHEME_OBJECT gc_trap
168 = (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE));
169 static SCHEME_OBJECT * gc_scan_trap = 0;
170 static SCHEME_OBJECT * gc_to_trap = 0;
171
172 static SCHEME_OBJECT gc_object_referenced = SHARP_F;
173 static SCHEME_OBJECT gc_object_references = SHARP_F;
174 static unsigned long gc_object_references_count;
175 static SCHEME_OBJECT * gc_object_references_scan;
176 static SCHEME_OBJECT * gc_object_references_end;
177
178 static unsigned long weak_chain_length;
179
180 static void initialize_gc_history (void);
181 static void handle_gc_trap (SCHEME_OBJECT *, SCHEME_OBJECT);
182 static void check_newspace_sync (void);
183 static void debug_transport_one_word (SCHEME_OBJECT, SCHEME_OBJECT *);
184 #else
185 # define INITIALIZE_GC_HISTORY() do {} while (false)
186 # define HANDLE_GC_TRAP(scan, object) do {} while (false)
187 # define CHECK_NEWSPACE_SYNC() do {} while (false)
188 # define DEBUG_TRANSPORT_ONE_WORD(object, from) do {} while (false)
189 #endif
190
191 void
initialize_gc(unsigned long n_words,SCHEME_OBJECT ** pf_start,SCHEME_OBJECT ** pf_end,gc_tospace_allocator_t * allocator,gc_abort_handler_t * abort_handler NORETURN)192 initialize_gc (unsigned long n_words,
193 SCHEME_OBJECT ** pf_start,
194 SCHEME_OBJECT ** pf_end,
195 gc_tospace_allocator_t * allocator,
196 gc_abort_handler_t * abort_handler NORETURN)
197 {
198 p_fromspace_start = pf_start;
199 p_fromspace_end = pf_end;
200 gc_tospace_allocator = allocator;
201 gc_abort_handler = abort_handler;
202 CLOSE_TOSPACE ();
203 tospace_start = 0;
204 tospace_end = 0;
205 (*gc_tospace_allocator) (n_words, (&tospace_start), (&tospace_end));
206 }
207
208 void
resize_tospace(unsigned long n_words)209 resize_tospace (unsigned long n_words)
210 {
211 GUARANTEE_TOSPACE_CLOSED ();
212 (*gc_tospace_allocator) (n_words, (&tospace_start), (&tospace_end));
213 }
214
215 void
open_tospace(SCHEME_OBJECT * start)216 open_tospace (SCHEME_OBJECT * start)
217 {
218 GUARANTEE_TOSPACE_CLOSED ();
219 tospace_next = tospace_start;
220 newspace_start = start;
221 newspace_next = start;
222 newspace_end = (start + (tospace_end - tospace_start));
223 }
224
225 bool
save_tospace(gc_walk_proc_t * proc,void * ctx)226 save_tospace (gc_walk_proc_t * proc, void * ctx)
227 {
228 bool ok;
229
230 GUARANTEE_TOSPACE_OPEN ();
231 CHECK_NEWSPACE_SYNC ();
232 ok = (proc (tospace_start, tospace_next, ctx));
233 OS_free_pages (tospace_start, tospace_end);
234 CLOSE_TOSPACE ();
235 return (ok);
236 }
237
238 void
discard_tospace(void)239 discard_tospace (void)
240 {
241 GUARANTEE_TOSPACE_OPEN ();
242 CHECK_NEWSPACE_SYNC ();
243 OS_free_pages (tospace_start, tospace_end);
244 CLOSE_TOSPACE ();
245 }
246
247 bool
tospace_available_p(unsigned long n_words)248 tospace_available_p (unsigned long n_words)
249 {
250 GUARANTEE_TOSPACE_OPEN ();
251 return ((tospace_end - tospace_next) >= n_words);
252 }
253
254 void
add_to_tospace(SCHEME_OBJECT object)255 add_to_tospace (SCHEME_OBJECT object)
256 {
257 GUARANTEE_TOSPACE_OPEN ();
258 (*tospace_next++) = object;
259 newspace_next += 1;
260 }
261
262 SCHEME_OBJECT
read_tospace(SCHEME_OBJECT * addr)263 read_tospace (SCHEME_OBJECT * addr)
264 {
265 GUARANTEE_TOSPACE_OPEN ();
266 return (READ_TOSPACE (addr));
267 }
268
269 void
write_tospace(SCHEME_OBJECT * addr,SCHEME_OBJECT object)270 write_tospace (SCHEME_OBJECT * addr, SCHEME_OBJECT object)
271 {
272 GUARANTEE_TOSPACE_OPEN ();
273 WRITE_TOSPACE (addr, object);
274 }
275
276 void
increment_tospace_ptr(unsigned long n_words)277 increment_tospace_ptr (unsigned long n_words)
278 {
279 GUARANTEE_TOSPACE_OPEN ();
280 tospace_next += n_words;
281 newspace_next += n_words;
282 }
283
284 SCHEME_OBJECT *
get_newspace_ptr(void)285 get_newspace_ptr (void)
286 {
287 return (newspace_next);
288 }
289
290 void *
tospace_to_newspace(void * addr)291 tospace_to_newspace (void * addr)
292 {
293 return
294 (((addr >= ((void *) tospace_start))
295 && (addr <= ((void *) tospace_end)))
296 ? ((((byte_t *) addr) - ((byte_t *) tospace_start))
297 + ((byte_t *) newspace_start))
298 : addr);
299 }
300
301 void *
newspace_to_tospace(void * addr)302 newspace_to_tospace (void * addr)
303 {
304 return
305 (((addr >= ((void *) newspace_start))
306 && (addr <= ((void *) newspace_end)))
307 ? ((((byte_t *) addr) - ((byte_t *) newspace_start))
308 + ((byte_t *) tospace_start))
309 : addr);
310 }
311
312 #define SIMPLE_HANDLER(name) \
313 (GCT_ENTRY (table, i)) = name; \
314 break
315
316 void
initialize_gc_table(gc_table_t * table,bool transport_p)317 initialize_gc_table (gc_table_t * table, bool transport_p)
318 {
319 unsigned int i;
320 for (i = 0; (i < N_TYPE_CODES); i += 1)
321 switch (gc_type_map[i])
322 {
323 case GC_NON_POINTER: SIMPLE_HANDLER (gc_handle_non_pointer);
324 case GC_CELL: SIMPLE_HANDLER (gc_handle_cell);
325 case GC_PAIR: SIMPLE_HANDLER (gc_handle_pair);
326 case GC_TRIPLE: SIMPLE_HANDLER (gc_handle_triple);
327 case GC_QUADRUPLE: SIMPLE_HANDLER (gc_handle_quadruple);
328 case GC_VECTOR: SIMPLE_HANDLER (gc_handle_unaligned_vector);
329 case GC_COMPILED: SIMPLE_HANDLER (gc_handle_cc_entry);
330 case GC_UNDEFINED: SIMPLE_HANDLER (gc_handle_undefined);
331
332 case GC_SPECIAL:
333 switch (i)
334 {
335 case TC_BROKEN_HEART:
336 SIMPLE_HANDLER (gc_handle_broken_heart);
337
338 case TC_REFERENCE_TRAP:
339 SIMPLE_HANDLER (gc_handle_reference_trap);
340
341 case TC_LINKAGE_SECTION:
342 SIMPLE_HANDLER (gc_handle_linkage_section);
343
344 case TC_MANIFEST_CLOSURE:
345 SIMPLE_HANDLER (gc_handle_manifest_closure);
346
347 case TC_MANIFEST_NM_VECTOR:
348 SIMPLE_HANDLER (gc_handle_nmv);
349
350 default:
351 std_gc_death ("unknown GC special type: %#02x\n", i);
352 break;
353 }
354 break;
355 }
356 (GCT_ENTRY (table, TC_WEAK_CONS)) = gc_handle_weak_pair;
357 (GCT_ENTRY (table, TC_EPHEMERON)) = gc_handle_ephemeron;
358 (GCT_ENTRY (table, TC_BIG_FLONUM)) = gc_handle_aligned_vector;
359 (GCT_ENTRY (table, TC_COMPILED_CODE_BLOCK)) = gc_handle_aligned_vector;
360 (GCT_TUPLE (table)) = gc_tuple;
361 (GCT_VECTOR (table)) = gc_vector;
362 (GCT_CC_ENTRY (table)) = gc_cc_entry;
363 if (transport_p)
364 {
365 (GCT_PRECHECK_FROM (table)) = gc_precheck_from;
366 (GCT_TRANSPORT_WORDS (table)) = gc_transport_words;
367 }
368 else
369 {
370 (GCT_PRECHECK_FROM (table)) = gc_precheck_from_no_transport;
371 (GCT_TRANSPORT_WORDS (table)) = gc_no_transport_words;
372 }
373 (GCT_IGNORE_OBJECT_P (table)) = 0;
374 (GCT_RAW_ADDRESS_TO_OBJECT (table)) = gc_raw_address_to_object;
375 (GCT_OBJECT_TO_RAW_ADDRESS (table)) = gc_object_to_raw_address;
376 (GCT_RAW_ADDRESS_TO_CC_ENTRY (table)) = gc_raw_address_to_cc_entry;
377 (GCT_CC_ENTRY_TO_RAW_ADDRESS (table)) = gc_cc_entry_to_raw_address;
378 }
379
380 gc_table_t *
std_gc_table(void)381 std_gc_table (void)
382 {
383 static bool initialized_p = false;
384 static gc_table_t table;
385 if (!initialized_p)
386 {
387 initialize_gc_table ((&table), true);
388 initialized_p = true;
389 }
390 return (&table);
391 }
392
393 void
gc_scan_oldspace(SCHEME_OBJECT * scan,SCHEME_OBJECT * end)394 gc_scan_oldspace (SCHEME_OBJECT * scan, SCHEME_OBJECT * end)
395 {
396 OS_expect_sequential_access (scan, end);
397 run_gc_loop (scan, (&end));
398 /* FIXME: This doesn't actually revert the expectation for [scan,
399 end). However, Unix has no way to query the madvice, or to
400 dynamically scope it, so this is the best we can do. Fortunately,
401 at the moment, none of the system uses any special madvice, so it
402 doesn't matter for now. */
403 OS_expect_normal_access (scan, end);
404 }
405
406 void
gc_scan_tospace(SCHEME_OBJECT * scan,SCHEME_OBJECT * end)407 gc_scan_tospace (SCHEME_OBJECT * scan, SCHEME_OBJECT * end)
408 {
409 if (end == 0)
410 run_gc_loop ((NEWSPACE_TO_TOSPACE (scan)), (&tospace_next));
411 else
412 {
413 SCHEME_OBJECT * tend = (NEWSPACE_TO_TOSPACE (end));
414 run_gc_loop ((NEWSPACE_TO_TOSPACE (scan)), (&tend));
415 }
416 }
417
418 static void
run_gc_loop(SCHEME_OBJECT * scan,SCHEME_OBJECT ** pend)419 run_gc_loop (SCHEME_OBJECT * scan, SCHEME_OBJECT ** pend)
420 {
421 gc_ignore_object_p_t * ignore_object_p
422 = (GCT_IGNORE_OBJECT_P (current_gc_table));
423 INITIALIZE_GC_HISTORY ();
424 while (scan < (*pend))
425 {
426 SCHEME_OBJECT object = (*scan);
427 HANDLE_GC_TRAP (scan, object);
428 if ((ignore_object_p != 0) && ((*ignore_object_p) (object)))
429 scan += 1;
430 else
431 {
432 current_scan = scan;
433 current_object = object;
434 scan
435 = ((* (GCT_ENTRY (current_gc_table, (OBJECT_TYPE (object)))))
436 (scan, object));
437 }
438 }
439 }
440
DEFINE_GC_TUPLE_HANDLER(gc_tuple)441 DEFINE_GC_TUPLE_HANDLER (gc_tuple)
442 {
443 SCHEME_OBJECT * from = (OBJECT_ADDRESS (tuple));
444 SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
445 return
446 (OBJECT_NEW_ADDRESS (tuple,
447 ((new_address != 0)
448 ? new_address
449 : (GC_TRANSPORT_WORDS (from, n_words, false)))));
450 }
451
DEFINE_GC_VECTOR_HANDLER(gc_vector)452 DEFINE_GC_VECTOR_HANDLER (gc_vector)
453 {
454 SCHEME_OBJECT * from = (OBJECT_ADDRESS (vector));
455 SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
456 return
457 (OBJECT_NEW_ADDRESS (vector,
458 ((new_address != 0)
459 ? new_address
460 : (GC_TRANSPORT_WORDS (from,
461 (1 + (OBJECT_DATUM (*from))),
462 align_p)))));
463 }
464
DEFINE_GC_OBJECT_HANDLER(gc_cc_entry)465 DEFINE_GC_OBJECT_HANDLER (gc_cc_entry)
466 {
467 #ifdef CC_SUPPORT_P
468 SCHEME_OBJECT old_block = (cc_entry_to_block (object));
469 SCHEME_OBJECT new_block = (GC_HANDLE_VECTOR (old_block, true));
470 return (CC_ENTRY_NEW_BLOCK (object,
471 (OBJECT_ADDRESS (new_block)),
472 (OBJECT_ADDRESS (old_block))));
473 #else
474 gc_no_cc_support ();
475 return (object);
476 #endif
477 }
478
DEFINE_GC_PRECHECK_FROM(gc_precheck_from)479 DEFINE_GC_PRECHECK_FROM (gc_precheck_from)
480 {
481 #if 0
482 #ifdef ENABLE_GC_DEBUGGING_TOOLS
483 if (!ADDRESS_IN_MEMORY_BLOCK_P (from))
484 std_gc_death ("out of range pointer: %#lx", ((unsigned long) from));
485 #endif
486 #endif
487 if (!ADDRESS_IN_FROMSPACE_P (from))
488 return (from);
489 if (BROKEN_HEART_P (*from))
490 return (OBJECT_ADDRESS (*from));
491 if (scanning_ephemerons_p)
492 /* It would be nice if we had the new address, too; that way we
493 could eliminate a post-processing loop over the list of all
494 ephemerons. However, the GC abstraction doesn't have a nice way
495 to do that. */
496 queue_ephemerons_for_key (from);
497 return (0);
498 }
499
DEFINE_GC_PRECHECK_FROM(gc_precheck_from_no_transport)500 DEFINE_GC_PRECHECK_FROM (gc_precheck_from_no_transport)
501 {
502 #if 0
503 #ifdef ENABLE_GC_DEBUGGING_TOOLS
504 if (!ADDRESS_IN_MEMORY_BLOCK_P (from))
505 std_gc_death ("out of range pointer: %#lx", ((unsigned long) from));
506 #endif
507 #endif
508 return (from);
509 }
510
DEFINE_GC_TRANSPORT_WORDS(gc_transport_words)511 DEFINE_GC_TRANSPORT_WORDS (gc_transport_words)
512 {
513 SCHEME_OBJECT * from_start = from;
514 SCHEME_OBJECT * from_end = (from_start + n_words);
515 SCHEME_OBJECT * new_address;
516
517 GUARANTEE_TOSPACE_OPEN ();
518 if (align_p)
519 while (!FLOATING_ALIGNED_P (newspace_next))
520 {
521 (*tospace_next++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
522 newspace_next += 1;
523 }
524 #ifdef ENABLE_GC_DEBUGGING_TOOLS
525 if (tospace_next >= tospace_end)
526 std_gc_death ("tospace completely filled");
527 {
528 SCHEME_OBJECT * end = (tospace_next + n_words);
529 if (end > tospace_end)
530 std_gc_death ("block overflows tospace: %#lx",
531 ((unsigned long) end));
532 }
533 if (n_words == 0)
534 std_gc_death ("gc_transport_words: attempt to transfer zero words.");
535 if (n_words > 0x10000)
536 {
537 outf_error ("\nWarning: copying large block: %lu\n", n_words);
538 outf_flush_error ();
539 }
540 #endif
541 new_address = newspace_next;
542 while (from < from_end)
543 {
544 DEBUG_TRANSPORT_ONE_WORD (current_object, from);
545 (*tospace_next++) = (*from++);
546 newspace_next += 1;
547 }
548 (*from_start) = (MAKE_BROKEN_HEART (new_address));
549 return (new_address);
550 }
551
DEFINE_GC_TRANSPORT_WORDS(gc_no_transport_words)552 DEFINE_GC_TRANSPORT_WORDS (gc_no_transport_words)
553 {
554 tospace_closed ();
555 return (from);
556 }
557
DEFINE_GC_HANDLER(gc_handle_non_pointer)558 DEFINE_GC_HANDLER (gc_handle_non_pointer)
559 {
560 return (scan + 1);
561 }
562
DEFINE_GC_HANDLER(gc_handle_cell)563 DEFINE_GC_HANDLER (gc_handle_cell)
564 {
565 (*scan) = (GC_HANDLE_TUPLE (object, 1));
566 return (scan + 1);
567 }
568
DEFINE_GC_HANDLER(gc_handle_pair)569 DEFINE_GC_HANDLER (gc_handle_pair)
570 {
571 (*scan) = (GC_HANDLE_TUPLE (object, 2));
572 return (scan + 1);
573 }
574
DEFINE_GC_HANDLER(gc_handle_triple)575 DEFINE_GC_HANDLER (gc_handle_triple)
576 {
577 (*scan) = (GC_HANDLE_TUPLE (object, 3));
578 return (scan + 1);
579 }
580
DEFINE_GC_HANDLER(gc_handle_quadruple)581 DEFINE_GC_HANDLER (gc_handle_quadruple)
582 {
583 (*scan) = (GC_HANDLE_TUPLE (object, 4));
584 return (scan + 1);
585 }
586
DEFINE_GC_HANDLER(gc_handle_weak_pair)587 DEFINE_GC_HANDLER (gc_handle_weak_pair)
588 {
589 SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (OBJECT_ADDRESS (object)));
590 (*scan)
591 = ((new_address != 0)
592 ? (OBJECT_NEW_ADDRESS (object, new_address))
593 : (gc_transport_weak_pair (object)));
594 return (scan + 1);
595 }
596
DEFINE_GC_HANDLER(gc_handle_ephemeron)597 DEFINE_GC_HANDLER (gc_handle_ephemeron)
598 {
599 SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (OBJECT_ADDRESS (object)));
600 (*scan)
601 = ((new_address != 0)
602 ? (OBJECT_NEW_ADDRESS (object, new_address))
603 : (gc_transport_ephemeron (object)));
604 return (scan + 1);
605 }
606
DEFINE_GC_HANDLER(gc_handle_cc_entry)607 DEFINE_GC_HANDLER (gc_handle_cc_entry)
608 {
609 (*scan) = (GC_HANDLE_CC_ENTRY (object));
610 return (scan + 1);
611 }
612
DEFINE_GC_HANDLER(gc_handle_aligned_vector)613 DEFINE_GC_HANDLER (gc_handle_aligned_vector)
614 {
615 (*scan) = (GC_HANDLE_VECTOR (object, true));
616 return (scan + 1);
617 }
618
DEFINE_GC_HANDLER(gc_handle_unaligned_vector)619 DEFINE_GC_HANDLER (gc_handle_unaligned_vector)
620 {
621 (*scan) = (GC_HANDLE_VECTOR (object, false));
622 return (scan + 1);
623 }
624
DEFINE_GC_HANDLER(gc_handle_broken_heart)625 DEFINE_GC_HANDLER (gc_handle_broken_heart)
626 {
627 std_gc_death ("broken heart in scan: %#lx", object);
628 return (scan);
629 }
630
DEFINE_GC_HANDLER(gc_handle_nmv)631 DEFINE_GC_HANDLER (gc_handle_nmv)
632 {
633 return (scan + 1 + (OBJECT_DATUM (object)));
634 }
635
DEFINE_GC_HANDLER(gc_handle_reference_trap)636 DEFINE_GC_HANDLER (gc_handle_reference_trap)
637 {
638 (*scan) = (((OBJECT_DATUM (object)) <= TRAP_MAX_IMMEDIATE)
639 ? object
640 : (GC_HANDLE_TUPLE (object, 2)));
641 return (scan + 1);
642 }
643
644 SCHEME_OBJECT
gc_raw_address_to_object(unsigned int type,SCHEME_OBJECT * address)645 gc_raw_address_to_object (unsigned int type, SCHEME_OBJECT * address)
646 {
647 return (MAKE_POINTER_OBJECT (type, address));
648 }
649
650 SCHEME_OBJECT *
gc_object_to_raw_address(SCHEME_OBJECT object)651 gc_object_to_raw_address (SCHEME_OBJECT object)
652 {
653 return (OBJECT_ADDRESS (object));
654 }
655
656 SCHEME_OBJECT
gc_raw_address_to_cc_entry(insn_t * address)657 gc_raw_address_to_cc_entry (insn_t * address)
658 {
659 return (MAKE_CC_ENTRY (address));
660 }
661
662 insn_t *
gc_cc_entry_to_raw_address(SCHEME_OBJECT entry)663 gc_cc_entry_to_raw_address (SCHEME_OBJECT entry)
664 {
665 return (CC_ENTRY_ADDRESS (entry));
666 }
667
DEFINE_GC_HANDLER(gc_handle_linkage_section)668 DEFINE_GC_HANDLER (gc_handle_linkage_section)
669 {
670 #ifdef CC_SUPPORT_P
671 unsigned long count = (linkage_section_count (object));
672 scan += 1;
673 switch (linkage_section_type (object))
674 {
675 case LINKAGE_SECTION_TYPE_REFERENCE:
676 case LINKAGE_SECTION_TYPE_ASSIGNMENT:
677 while (count > 0)
678 {
679 WRITE_REFERENCE_ADDRESS
680 ((GC_OBJECT_TO_RAW_ADDRESS
681 (GC_HANDLE_TUPLE
682 ((GC_RAW_ADDRESS_TO_OBJECT
683 (TC_HUNK3,
684 (READ_REFERENCE_ADDRESS (scan)))),
685 3))),
686 scan);
687 scan += 1;
688 count -= 1;
689 }
690 break;
691
692 case LINKAGE_SECTION_TYPE_OPERATOR:
693 case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
694 {
695 DECLARE_RELOCATION_REFERENCE (ref);
696 START_OPERATOR_RELOCATION (scan, ref);
697 while (count > 0)
698 {
699 write_uuo_target
700 ((GC_CC_ENTRY_TO_RAW_ADDRESS
701 (GC_HANDLE_CC_ENTRY
702 (GC_RAW_ADDRESS_TO_CC_ENTRY
703 (READ_UUO_TARGET (scan, ref))))),
704 scan);
705 scan += UUO_LINK_SIZE;
706 count -= 1;
707 }
708 }
709 break;
710
711 default:
712 std_gc_death ("Unknown linkage-section type.");
713 break;
714 }
715 return (scan);
716 #else
717 gc_no_cc_support ();
718 return (scan);
719 #endif
720 }
721
DEFINE_GC_HANDLER(gc_handle_manifest_closure)722 DEFINE_GC_HANDLER (gc_handle_manifest_closure)
723 {
724 #ifdef CC_SUPPORT_P
725 #ifdef EMBEDDED_CLOSURE_ADDRS_P
726 DECLARE_RELOCATION_REFERENCE (ref);
727 START_CLOSURE_RELOCATION (scan, ref);
728 scan += 1;
729 {
730 insn_t * start = (compiled_closure_start (scan));
731 unsigned long count = (compiled_closure_count (scan));
732 while (count > 0)
733 {
734 write_compiled_closure_target
735 ((GC_CC_ENTRY_TO_RAW_ADDRESS
736 (GC_HANDLE_CC_ENTRY
737 (GC_RAW_ADDRESS_TO_CC_ENTRY
738 (READ_COMPILED_CLOSURE_TARGET (start, ref))))),
739 start);
740 start = (compiled_closure_next (start));
741 count -= 1;
742 }
743 scan = (skip_compiled_closure_padding (start));
744 }
745 return (scan);
746 #else
747 return (compiled_closure_objects (scan + 1));
748 #endif
749 #else
750 gc_no_cc_support ();
751 return (scan);
752 #endif
753 }
754
DEFINE_GC_HANDLER(gc_handle_undefined)755 DEFINE_GC_HANDLER (gc_handle_undefined)
756 {
757 gc_bad_type (object);
758 return (scan + 1);
759 }
760
761 /* Weak pairs are supported by adding an extra pass to the GC. During
762 the normal pass, a weak pair is transported to new space, but the
763 car of the pair is marked as a non-pointer so it won't be traced.
764 Then the original weak pair in old space is chained into a list.
765 This work is performed by 'gc_transport_weak_pair'.
766
767 At the end of this pass, we have a list of all of the old weak
768 pairs. Since each weak pair in old space has a broken-heart
769 pointer to the corresponding weak pair in new space, we also have a
770 list of all of the new weak pairs.
771
772 The extra pass then traverses this list, restoring the original
773 type of the object in the car of each pair. Then, if the car is a
774 pointer that hasn't been copied to new space, it is replaced by #F.
775 This work is performed by 'update_weak_pointers'.
776
777 Here is a diagram showing the layout of a weak pair immediately
778 after it is transported to new space. After the normal pass is
779 complete, the only thing that will have changed is that the "old
780 CDR object" will have been updated to point to new space, if it is
781 a pointer object.
782
783
784 weak_chain old space | new space
785 | _______________________ | _______________________
786 | |broken | new | | | | |
787 +=====>|heart | location ======|==>| NULL | old CAR data |
788 |_______|_____________| | |______|______________|
789 |old car| next in | | | |
790 | type | chain | | | old CDR object |
791 |_______|_____________| | |_____________________|
792
793 */
794
795 static SCHEME_OBJECT *
weak_referent_address(SCHEME_OBJECT object)796 weak_referent_address (SCHEME_OBJECT object)
797 {
798 switch (gc_ptr_type (object))
799 {
800 case GC_POINTER_NORMAL:
801 return (OBJECT_ADDRESS (object));
802
803 case GC_POINTER_COMPILED:
804 #ifdef CC_SUPPORT_P
805 return (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (object)));
806 #else
807 gc_no_cc_support ();
808 #endif
809
810 default:
811 return (0);
812 }
813 }
814
815 static SCHEME_OBJECT
weak_referent_forward(SCHEME_OBJECT object)816 weak_referent_forward (SCHEME_OBJECT object)
817 {
818 SCHEME_OBJECT * addr;
819
820 switch (gc_ptr_type (object))
821 {
822 case GC_POINTER_NORMAL:
823 addr = (OBJECT_ADDRESS (object));
824 if (BROKEN_HEART_P (*addr))
825 return (MAKE_OBJECT_FROM_OBJECTS (object, (*addr)));
826 return (SHARP_F);
827
828 case GC_POINTER_COMPILED:
829 #ifdef CC_SUPPORT_P
830 addr = (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (object)));
831 if (BROKEN_HEART_P (*addr))
832 return (CC_ENTRY_NEW_BLOCK (object, (OBJECT_ADDRESS (*addr)), addr));
833 #else
834 gc_no_cc_support ();
835 #endif
836 return (SHARP_F);
837
838 case GC_POINTER_NOT:
839 default: /* suppress bogus GCC warning */
840 std_gc_death ("Non-pointer cannot be a weak reference.");
841 return (SHARP_F);
842 }
843 }
844
845 static void
queue_ephemerons_for_key(SCHEME_OBJECT * addr)846 queue_ephemerons_for_key (SCHEME_OBJECT * addr)
847 {
848 SCHEME_OBJECT ht = ephemeron_array;
849 unsigned long index = (((unsigned long) addr) % (VECTOR_LENGTH (ht)));
850 SCHEME_OBJECT * entry_loc = (VECTOR_LOC (ht, index));
851 SCHEME_OBJECT entry;
852
853 #ifdef ENABLE_GC_DEBUGGING_TOOLS
854 if (!scanning_ephemerons_p)
855 std_gc_death ("queue_ephemerons_for_key while not scanning ephemerons");
856
857 if (!ADDRESS_IN_FROMSPACE_P (addr))
858 std_gc_death ("Queueing ephemerons for key with non-fromspace address.");
859 #endif
860
861 while (EPHEMERON_P (entry = (*entry_loc)))
862 {
863 SCHEME_OBJECT * entry_addr = (OBJECT_ADDRESS (entry));
864 SCHEME_OBJECT * next_loc
865 = (NEWSPACE_TO_TOSPACE (entry_addr + EPHEMERON_NEXT));
866 SCHEME_OBJECT * key_addr
867 = (weak_referent_address (READ_TOSPACE (entry_addr + EPHEMERON_KEY)));
868 if (addr == key_addr)
869 {
870 (*entry_loc) = (*next_loc);
871 (*next_loc) = ephemeron_queue;
872 ephemeron_queue = entry;
873 }
874 entry_loc = next_loc;
875 }
876 }
877
878 static SCHEME_OBJECT
gc_transport_weak_pair(SCHEME_OBJECT pair)879 gc_transport_weak_pair (SCHEME_OBJECT pair)
880 {
881 SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (pair));
882 SCHEME_OBJECT * new_addr = (GC_TRANSPORT_WORDS (old_addr, 2, false));
883 SCHEME_OBJECT old_car = (READ_TOSPACE (new_addr));
884 SCHEME_OBJECT * caddr = (weak_referent_address (old_car));
885
886 if ((caddr != 0) && (ADDRESS_IN_FROMSPACE_P (caddr)))
887 {
888 WRITE_TOSPACE (new_addr, (OBJECT_NEW_TYPE (TC_NULL, old_car)));
889 (old_addr[1])
890 = ((weak_chain == 0)
891 ? (MAKE_OBJECT ((OBJECT_TYPE (old_car)), 0))
892 : (MAKE_POINTER_OBJECT ((OBJECT_TYPE (old_car)), weak_chain)));
893 weak_chain = old_addr;
894 #ifdef ENABLE_GC_DEBUGGING_TOOLS
895 weak_chain_length += 1;
896 #endif
897 }
898 return (OBJECT_NEW_ADDRESS (pair, new_addr));
899 }
900
901 static SCHEME_OBJECT
gc_transport_ephemeron(SCHEME_OBJECT old_ephemeron)902 gc_transport_ephemeron (SCHEME_OBJECT old_ephemeron)
903 {
904 SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (old_ephemeron));
905 SCHEME_OBJECT * new_addr
906 = (GC_TRANSPORT_WORDS (old_addr, EPHEMERON_SIZE, false));
907 SCHEME_OBJECT new_ephemeron = (OBJECT_NEW_ADDRESS (old_ephemeron, new_addr));
908 SCHEME_OBJECT old_key = (READ_TOSPACE (new_addr + EPHEMERON_KEY));
909 SCHEME_OBJECT * old_key_addr = (weak_referent_address (old_key));
910 SCHEME_OBJECT index;
911 SCHEME_OBJECT ht = ephemeron_array;
912
913 ephemeron_count += 1;
914
915 /* If the key is GC-invariant or live, the ephemeron will not be
916 broken, so leave a marked vector manifest to make the GC will scan
917 its contents, including the datum. */
918 if ((old_key_addr == 0)
919 || (!ADDRESS_IN_FROMSPACE_P (old_key_addr))
920 || (SHARP_F != (weak_referent_forward (old_key))))
921 {
922 WRITE_TOSPACE (new_addr, MARKED_EPHEMERON_MANIFEST);
923 return (new_ephemeron);
924 }
925
926 /* Write a manifest that makes the GC skip over the ephemeron. */
927 WRITE_TOSPACE (new_addr, UNMARKED_EPHEMERON_MANIFEST);
928
929 /* Map its key back to it. */
930 index = (((unsigned long) old_key_addr) % (VECTOR_LENGTH (ht)));
931 WRITE_TOSPACE ((new_addr + EPHEMERON_NEXT), (VECTOR_REF (ht, index)));
932 VECTOR_SET (ht, index, new_ephemeron);
933
934 /* Link it up in the ephemeron list. */
935 WRITE_TOSPACE ((new_addr + EPHEMERON_LIST), ephemeron_list);
936 ephemeron_list = new_ephemeron;
937
938 return (new_ephemeron);
939 }
940
941 static void
scan_newspace_addr(SCHEME_OBJECT * addr)942 scan_newspace_addr (SCHEME_OBJECT * addr)
943 {
944 gc_ignore_object_p_t * ignore_object_p
945 = (GCT_IGNORE_OBJECT_P (current_gc_table));
946 SCHEME_OBJECT * scan;
947 SCHEME_OBJECT object;
948
949 addr = (NEWSPACE_TO_TOSPACE (addr));
950 scan = addr;
951
952 INITIALIZE_GC_HISTORY ();
953 object = (*scan);
954 HANDLE_GC_TRAP (scan, object);
955 if ((ignore_object_p != 0) && ((*ignore_object_p) (object)))
956 return;
957
958 current_scan = scan;
959 current_object = object;
960 scan = ((* (GCT_ENTRY (current_gc_table, (OBJECT_TYPE (object)))))
961 (scan, object));
962 #ifdef ENABLE_GC_DEBUGGING_TOOLS
963 if (scan != (addr + 1))
964 std_gc_death ("scan_newspace_addr overflowed");
965 #else
966 (void) scan; /* ignore */
967 #endif
968 }
969
970 static void
scan_ephemerons(void)971 scan_ephemerons (void)
972 {
973 SCHEME_OBJECT ephemeron = ephemeron_list;
974 SCHEME_OBJECT * saved_newspace_next;
975 scanning_ephemerons_p = true;
976 while (EPHEMERON_P (ephemeron))
977 {
978 SCHEME_OBJECT * ephemeron_addr = (OBJECT_ADDRESS (ephemeron));
979 SCHEME_OBJECT old_key = (READ_TOSPACE (ephemeron_addr + EPHEMERON_KEY));
980 ephemeron = (READ_TOSPACE (ephemeron_addr + EPHEMERON_LIST));
981 /* It is tempting to scan the ephemeron's datum right here and
982 now, but we can't do that because it may already be in the
983 queue, and the assumption is that for each ephemeron in the
984 queue, its key has been proven live but its datum has not yet
985 been scanned. It is tempting to link this up in the queue
986 right here and now, but we can't do that, because we must also
987 delete it from the hash table so that nothing else will put it
988 in the queue again. */
989 if (SHARP_F != (weak_referent_forward (old_key)))
990 queue_ephemerons_for_key (weak_referent_address (old_key));
991 }
992 while (EPHEMERON_P (ephemeron = ephemeron_queue))
993 {
994 SCHEME_OBJECT * ephemeron_addr = (OBJECT_ADDRESS (ephemeron));
995 #ifdef ENABLE_GC_DEBUGGING_TOOLS
996 {
997 SCHEME_OBJECT key = (READ_TOSPACE (ephemeron_addr + EPHEMERON_KEY));
998 if (! (weak_referent_forward (key)))
999 std_gc_death
1000 ("Ephemeron queued whose key has not been forwarded: %lx", key);
1001 }
1002 #endif
1003 ephemeron_queue = (READ_TOSPACE (ephemeron_addr + EPHEMERON_NEXT));
1004 saved_newspace_next = newspace_next;
1005 scan_newspace_addr (ephemeron_addr + EPHEMERON_DATUM);
1006 gc_scan_tospace (saved_newspace_next, 0);
1007 }
1008 scanning_ephemerons_p = false;
1009 }
1010
1011 void
initialize_weak_chain(void)1012 initialize_weak_chain (void)
1013 {
1014 weak_chain = 0;
1015 #ifdef ENABLE_GC_DEBUGGING_TOOLS
1016 weak_chain_length = 0;
1017 if (ephemeron_list != SHARP_F) std_gc_death ("Bad ephemeron list.");
1018 if (ephemeron_queue != SHARP_F) std_gc_death ("Bad ephemeron queue.");
1019 if (scanning_ephemerons_p != SHARP_F) std_gc_death ("Bad ephemeron state.");
1020 #endif
1021 }
1022
1023 static void
update_ephemerons(void)1024 update_ephemerons (void)
1025 {
1026 SCHEME_OBJECT ephemeron = ephemeron_list;
1027 while (EPHEMERON_P (ephemeron))
1028 {
1029 SCHEME_OBJECT * ephemeron_addr = (OBJECT_ADDRESS (ephemeron));
1030 SCHEME_OBJECT * key_loc = (ephemeron_addr + EPHEMERON_KEY);
1031 SCHEME_OBJECT old_key = (READ_TOSPACE (key_loc));
1032 SCHEME_OBJECT new_key = (weak_referent_forward (old_key));
1033 WRITE_TOSPACE (ephemeron_addr, MARKED_EPHEMERON_MANIFEST);
1034 WRITE_TOSPACE (key_loc, new_key);
1035 /* Advance before we clobber the list pointer. */
1036 ephemeron = (READ_TOSPACE (ephemeron_addr + EPHEMERON_LIST));
1037 WRITE_TOSPACE ((ephemeron_addr + EPHEMERON_LIST), SHARP_F);
1038 WRITE_TOSPACE ((ephemeron_addr + EPHEMERON_NEXT), SHARP_F);
1039 if (new_key == SHARP_F)
1040 WRITE_TOSPACE ((ephemeron_addr + EPHEMERON_DATUM), SHARP_F);
1041 }
1042 ephemeron_list = SHARP_F;
1043 }
1044
1045 static void
update_weak_pairs(void)1046 update_weak_pairs (void)
1047 {
1048 #if 0
1049 #ifdef ENABLE_GC_DEBUGGING_TOOLS
1050 outf_console ("; **** Weak chain length = %lu\n", weak_chain_length);
1051 outf_flush_console ();
1052 #endif
1053 #endif
1054 while (weak_chain != 0)
1055 {
1056 SCHEME_OBJECT * new_addr = (OBJECT_ADDRESS (weak_chain[0]));
1057 SCHEME_OBJECT obj = (weak_chain[1]);
1058 SCHEME_OBJECT old_car
1059 = (OBJECT_NEW_TYPE ((OBJECT_TYPE (obj)),
1060 (READ_TOSPACE (new_addr))));
1061
1062 WRITE_TOSPACE (new_addr, (weak_referent_forward (old_car)));
1063 weak_chain = (((OBJECT_DATUM (obj)) == 0) ? 0 : (OBJECT_ADDRESS (obj)));
1064 }
1065 }
1066
1067 void
update_weak_pointers(void)1068 update_weak_pointers (void)
1069 {
1070 scan_ephemerons ();
1071 update_ephemerons ();
1072 update_weak_pairs ();
1073 }
1074
1075 void
std_gc_death(const char * format,...)1076 std_gc_death (const char * format, ...)
1077 {
1078 va_list ap;
1079
1080 va_start (ap, format);
1081 outf_fatal ("\n");
1082 voutf_fatal (format, ap);
1083 outf_fatal ("\n");
1084 if (current_scan != 0)
1085 {
1086 outf_fatal ("scan = 0x%lx", ((unsigned long) current_scan));
1087 if (tospace_next != 0)
1088 outf_fatal ("; to = 0x%lx", ((unsigned long) tospace_next));
1089 outf_fatal ("\n");
1090 }
1091 va_end (ap);
1092 if (gc_abort_handler != 0)
1093 (*gc_abort_handler) ();
1094 exit (1);
1095 }
1096
1097 static void
tospace_closed(void)1098 tospace_closed (void)
1099 {
1100 std_gc_death ("GC transport not allowed here");
1101 }
1102
1103 static void
tospace_open(void)1104 tospace_open (void)
1105 {
1106 std_gc_death ("tospace is open, should be closed");
1107 }
1108
1109 void
gc_no_cc_support(void)1110 gc_no_cc_support (void)
1111 {
1112 std_gc_death ("No compiled-code support.");
1113 }
1114
1115 void
gc_bad_type(SCHEME_OBJECT object)1116 gc_bad_type (SCHEME_OBJECT object)
1117 {
1118 std_gc_death ("bad type code: %#02lx %#lx",
1119 (OBJECT_TYPE (object)),
1120 object);
1121 }
1122
1123 #ifdef ENABLE_GC_DEBUGGING_TOOLS
1124
1125 static void
initialize_gc_history(void)1126 initialize_gc_history (void)
1127 {
1128 gc_scan_history_index = 0;
1129 memset (gc_scan_history, 0, (sizeof (gc_scan_history)));
1130 memset (gc_to_history, 0, (sizeof (gc_to_history)));
1131 }
1132
1133 static void
handle_gc_trap(SCHEME_OBJECT * scan,SCHEME_OBJECT object)1134 handle_gc_trap (SCHEME_OBJECT * scan, SCHEME_OBJECT object)
1135 {
1136 (gc_scan_history[gc_scan_history_index]) = scan;
1137 (gc_to_history[gc_scan_history_index]) = newspace_next;
1138 gc_scan_history_index += 1;
1139 if (gc_scan_history_index == GC_SCAN_HISTORY_SIZE)
1140 gc_scan_history_index = 0;
1141 if ((object == gc_trap)
1142 || ((gc_scan_trap != 0)
1143 && (scan >= gc_scan_trap))
1144 || ((gc_to_trap != 0)
1145 && (newspace_next != 0)
1146 && (newspace_next >= gc_to_trap)))
1147 {
1148 outf_error ("\nhandle_gc_trap: trap.\n");
1149 abort ();
1150 }
1151 }
1152
1153 static void
check_newspace_sync(void)1154 check_newspace_sync (void)
1155 {
1156 if ((newspace_next - newspace_start)
1157 != (tospace_next - tospace_start))
1158 std_gc_death ("mismatch between newspace and tospace ptrs: %ld/%ld",
1159 ((long) (newspace_next - newspace_start)),
1160 ((long) (tospace_next - tospace_start)));
1161 }
1162
1163 void
collect_gc_object_references(SCHEME_OBJECT object,SCHEME_OBJECT collector)1164 collect_gc_object_references (SCHEME_OBJECT object, SCHEME_OBJECT collector)
1165 {
1166 gc_object_referenced = object;
1167 gc_object_references = collector;
1168 }
1169
1170 static void
debug_transport_one_word(SCHEME_OBJECT object,SCHEME_OBJECT * from)1171 debug_transport_one_word (SCHEME_OBJECT object, SCHEME_OBJECT * from)
1172 {
1173 if ((gc_object_references != SHARP_F)
1174 && (gc_object_referenced == (*from)))
1175 {
1176 gc_object_references_count += 1;
1177 if (gc_object_references_scan < gc_object_references_end)
1178 (*gc_object_references_scan++) = object;
1179 }
1180 }
1181
1182 void
initialize_gc_object_references(void)1183 initialize_gc_object_references (void)
1184 {
1185 if (gc_object_references != SHARP_F)
1186 {
1187 /* Temporarily change to non-marked vector. */
1188 MEMORY_SET
1189 (gc_object_references, 0,
1190 (MAKE_OBJECT
1191 (TC_MANIFEST_NM_VECTOR,
1192 (OBJECT_DATUM (MEMORY_REF (gc_object_references, 0))))));
1193 gc_object_references_count = 0;
1194 gc_object_references_scan = (VECTOR_LOC (gc_object_references, 1));
1195 gc_object_references_end
1196 = (VECTOR_LOC (gc_object_references,
1197 (VECTOR_LENGTH (gc_object_references))));
1198 /* Wipe the table. */
1199 VECTOR_SET (gc_object_references, 0, FIXNUM_ZERO);
1200 {
1201 SCHEME_OBJECT * scan = gc_object_references_scan;
1202 while (scan < gc_object_references_end)
1203 (*scan++) = SHARP_F;
1204 }
1205 (*tospace_next++) = gc_object_references;
1206 newspace_next += 1;
1207 }
1208 }
1209
1210 void
finalize_gc_object_references(void)1211 finalize_gc_object_references (void)
1212 {
1213 if (gc_object_references != SHARP_F)
1214 {
1215 SCHEME_OBJECT header = (MEMORY_REF (gc_object_references, 0));
1216 if (BROKEN_HEART_P (header))
1217 {
1218 SCHEME_OBJECT * to_addr
1219 = (NEWSPACE_TO_TOSPACE (OBJECT_ADDRESS (header)));
1220 SCHEME_OBJECT * scan_to = to_addr;
1221 SCHEME_OBJECT * scan_from = (VECTOR_LOC (gc_object_references, 0));
1222
1223 /* Change back to marked vector. */
1224 (*scan_to++)
1225 = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (OBJECT_DATUM (*to_addr))));
1226
1227 /* Store the count in the table. */
1228 VECTOR_SET (gc_object_references, 0,
1229 (ULONG_TO_FIXNUM (gc_object_references_count)));
1230
1231 /* Make sure tospace copy is up to date. */
1232 while (scan_from < gc_object_references_scan)
1233 (*scan_to++) = (*scan_from++);
1234
1235 /* No need to scan the vector's contents, since anything
1236 here has already been transported. */
1237 }
1238 gc_object_references = SHARP_F;
1239 gc_object_referenced = SHARP_F;
1240 }
1241 }
1242
1243 #endif /* ENABLE_GC_DEBUGGING_TOOLS */
1244
1245 gc_type_t gc_type_map [N_TYPE_CODES] =
1246 {
1247 GC_NON_POINTER, /* TC_NULL,etc */
1248 GC_PAIR, /* TC_LIST */
1249 GC_NON_POINTER, /* TC_CHARACTER */
1250 GC_PAIR, /* TC_SCODE_QUOTE */
1251 GC_TRIPLE, /* TC_PCOMB2 */
1252 GC_PAIR, /* TC_UNINTERNED_SYMBOL */
1253 GC_VECTOR, /* TC_BIG_FLONUM */
1254 GC_PAIR, /* TC_COMBINATION_1 */
1255 GC_NON_POINTER, /* TC_CONSTANT */
1256 GC_PAIR, /* TC_EXTENDED_PROCEDURE */
1257 GC_VECTOR, /* TC_VECTOR */
1258 GC_NON_POINTER, /* TC_RETURN_CODE */
1259 GC_TRIPLE, /* TC_COMBINATION_2 */
1260 GC_SPECIAL, /* TC_MANIFEST_CLOSURE */
1261 GC_VECTOR, /* TC_BIG_FIXNUM */
1262 GC_PAIR, /* TC_PROCEDURE */
1263 GC_PAIR, /* TC_ENTITY */
1264 GC_PAIR, /* TC_DELAY */
1265 GC_VECTOR, /* TC_ENVIRONMENT */
1266 GC_PAIR, /* TC_DELAYED */
1267 GC_TRIPLE, /* TC_EXTENDED_LAMBDA */
1268 GC_PAIR, /* TC_COMMENT */
1269 GC_VECTOR, /* TC_NON_MARKED_VECTOR */
1270 GC_PAIR, /* TC_LAMBDA */
1271 GC_NON_POINTER, /* TC_PRIMITIVE */
1272 GC_PAIR, /* TC_SEQUENCE */
1273 GC_NON_POINTER, /* TC_FIXNUM */
1274 GC_PAIR, /* TC_PCOMB1 */
1275 GC_VECTOR, /* TC_CONTROL_POINT */
1276 GC_PAIR, /* TC_INTERNED_SYMBOL */
1277 GC_VECTOR, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
1278 GC_PAIR, /* TC_ACCESS */
1279 GC_TRIPLE, /* TC_HUNK3_A */
1280 GC_PAIR, /* TC_DEFINITION */
1281 GC_SPECIAL, /* TC_BROKEN_HEART */
1282 GC_PAIR, /* TC_ASSIGNMENT */
1283 GC_TRIPLE, /* TC_HUNK3_B */
1284 GC_UNDEFINED, /* unused */
1285 GC_VECTOR, /* TC_COMBINATION */
1286 GC_SPECIAL, /* TC_MANIFEST_NM_VECTOR */
1287 GC_COMPILED, /* TC_COMPILED_ENTRY */
1288 GC_PAIR, /* TC_LEXPR */
1289 GC_VECTOR, /* TC_PCOMB3 */
1290 GC_VECTOR, /* TC_EPHEMERON */
1291 GC_TRIPLE, /* TC_VARIABLE */
1292 GC_NON_POINTER, /* TC_THE_ENVIRONMENT */
1293 GC_PAIR, /* TC_SYNTAX_ERROR */
1294 GC_VECTOR, /* TC_VECTOR_1B,TC_BIT_STRING */
1295 GC_NON_POINTER, /* TC_PCOMB0 */
1296 GC_VECTOR, /* TC_VECTOR_16B */
1297 GC_SPECIAL, /* TC_REFERENCE_TRAP */
1298 GC_UNDEFINED, /* 0x33 */
1299 GC_TRIPLE, /* TC_CONDITIONAL */
1300 GC_PAIR, /* TC_DISJUNCTION */
1301 GC_CELL, /* TC_CELL */
1302 GC_PAIR, /* TC_WEAK_CONS */
1303 GC_QUADRUPLE, /* TC_QUAD */
1304 GC_SPECIAL, /* TC_LINKAGE_SECTION */
1305 GC_PAIR, /* TC_RATNUM */
1306 GC_NON_POINTER, /* TC_STACK_ENVIRONMENT */
1307 GC_PAIR, /* TC_COMPLEX */
1308 GC_VECTOR, /* TC_COMPILED_CODE_BLOCK */
1309 GC_VECTOR, /* TC_RECORD */
1310 GC_UNDEFINED /* 0x3F */
1311 };
1312
1313 #if (N_TYPE_CODES != 0x40)
1314 # include "gcloop.c and object.h inconsistent -- gc_type_map"
1315 #endif
1316
1317 gc_type_t
gc_type_code(unsigned int type_code)1318 gc_type_code (unsigned int type_code)
1319 {
1320 return (gc_type_map[type_code]);
1321 }
1322
1323 gc_ptr_type_t
gc_ptr_type(SCHEME_OBJECT object)1324 gc_ptr_type (SCHEME_OBJECT object)
1325 {
1326 switch (GC_TYPE (object))
1327 {
1328 case GC_SPECIAL:
1329 return
1330 (((REFERENCE_TRAP_P (object))
1331 && ((OBJECT_DATUM (object)) >= TRAP_MAX_IMMEDIATE))
1332 ? GC_POINTER_NORMAL
1333 : GC_POINTER_NOT);
1334
1335 case GC_CELL:
1336 case GC_PAIR:
1337 case GC_TRIPLE:
1338 case GC_QUADRUPLE:
1339 case GC_VECTOR:
1340 return (GC_POINTER_NORMAL);
1341
1342 case GC_COMPILED:
1343 return (GC_POINTER_COMPILED);
1344 break;
1345
1346 default:
1347 return (GC_POINTER_NOT);
1348 }
1349 }
1350
1351 SCHEME_OBJECT *
get_object_address(SCHEME_OBJECT object)1352 get_object_address (SCHEME_OBJECT object)
1353 {
1354 switch (gc_ptr_type (object))
1355 {
1356 case GC_POINTER_NORMAL:
1357 return (OBJECT_ADDRESS (object));
1358
1359 case GC_POINTER_COMPILED:
1360 #ifdef CC_SUPPORT_P
1361 return (cc_entry_to_block_address (object));
1362 #endif
1363
1364 default:
1365 return (0);
1366 }
1367 }
1368