extern SCHEME_OBJECT * last_return_code;
extern SCHEME_OBJECT fixed_objects;
+extern SCHEME_OBJECT ephemeron_array;
+extern unsigned long ephemeron_count;
+
extern char * CONT_PRINT_RETURN_MESSAGE;
extern char * CONT_PRINT_EXPR_MESSAGE;
extern char * RESTORE_CONT_RETURN_MESSAGE;
(GCT_ENTRY ((&table), TC_VARIABLE)) = handle_variable;
(GCT_ENTRY ((&table), TC_ENVIRONMENT)) = handle_environment;
(GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
+ (GCT_ENTRY ((&table), TC_EPHEMERON)) = gc_handle_unaligned_vector;
initialized_p = true;
}
(GCT_RAW_ADDRESS_TO_CC_ENTRY (&table)) = fasload_raw_address_to_cc_entry;
(GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
+ (GCT_ENTRY ((&table), TC_EPHEMERON)) = gc_handle_unaligned_vector;
(GCT_ENTRY ((&table), TC_PRIMITIVE)) = handle_primitive;
(GCT_ENTRY ((&table), TC_PCOMB0)) = handle_primitive;
(GCT_ENTRY ((&table), TC_BROKEN_HEART)) = gc_handle_non_pointer;
(GCT_CC_ENTRY (&table)) = intern_cc_entry;
(GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
+ (GCT_ENTRY ((&table), TC_EPHEMERON)) = gc_handle_unaligned_vector;
(GCT_ENTRY ((&table), TC_INTERNED_SYMBOL)) = intern_handle_symbol;
(GCT_ENTRY ((&table), TC_BROKEN_HEART)) = gc_handle_non_pointer;
extern gc_handler_t gc_handle_triple;
extern gc_handler_t gc_handle_quadruple;
extern gc_handler_t gc_handle_weak_pair;
+extern gc_handler_t gc_handle_ephemeron;
extern gc_handler_t gc_handle_cc_entry;
extern gc_handler_t gc_handle_aligned_vector;
extern gc_handler_t gc_handle_unaligned_vector;
#include "outf.h"
#include "gccode.h"
+/* For ephemeron layout. */
+#include "sdata.h"
+
static SCHEME_OBJECT ** p_fromspace_start;
static SCHEME_OBJECT ** p_fromspace_end;
static gc_tospace_allocator_t * gc_tospace_allocator;
((* ((SCHEME_OBJECT **) (addr))) = (ref))
#endif
+/* The weak chain is a linked list of all the live weak pairs whose
+ cars are not GC-invariant, described below.
+
+ The ephemeron list is a linked list of all the live ephemerons whose
+ cars are not GC-invariant. The ephemeron queue is a queue of all
+ the live ephemerons whose keys have been proven live but whose data
+ slots have not yet been scanned. The ephemeron hash table is a map
+ from fromspace addresses to lists of ephemerons, in which an
+ association between a fromspace address and a list of ephemerons
+ indicates that if the object stored at that fromspace address is
+ proven live, those ephemerons must not be broken, and consequently
+ their data must be live too. */
+
static SCHEME_OBJECT * weak_chain;
+static SCHEME_OBJECT ephemeron_list = SHARP_F;
+static SCHEME_OBJECT ephemeron_queue = SHARP_F;
+static bool scanning_ephemerons_p = false;
-static void run_gc_loop (SCHEME_OBJECT * , SCHEME_OBJECT **);
+extern SCHEME_OBJECT ephemeron_array;
+extern unsigned long ephemeron_count;
+
+static void queue_ephemerons_for_key (SCHEME_OBJECT *);
static SCHEME_OBJECT gc_transport_weak_pair (SCHEME_OBJECT);
+static SCHEME_OBJECT gc_transport_ephemeron (SCHEME_OBJECT);
+
+static void run_gc_loop (SCHEME_OBJECT * , SCHEME_OBJECT **);
static void tospace_closed (void) NORETURN;
static void tospace_open (void) NORETURN;
break;
}
(GCT_ENTRY (table, TC_WEAK_CONS)) = gc_handle_weak_pair;
+ (GCT_ENTRY (table, TC_EPHEMERON)) = gc_handle_ephemeron;
(GCT_ENTRY (table, TC_BIG_FLONUM)) = gc_handle_aligned_vector;
(GCT_ENTRY (table, TC_COMPILED_CODE_BLOCK)) = gc_handle_aligned_vector;
- /* The next is for backwards compatibility with older bands.
- This type used to be TC_MANIFEST_SPECIAL_NM_VECTOR. */
- (GCT_ENTRY (table, 0x2B)) = gc_handle_non_pointer;
(GCT_TUPLE (table)) = gc_tuple;
(GCT_VECTOR (table)) = gc_vector;
(GCT_CC_ENTRY (table)) = gc_cc_entry;
std_gc_death ("out of range pointer: %#lx", ((unsigned long) from));
#endif
#endif
- return
- ((ADDRESS_IN_FROMSPACE_P (from))
- ? ((BROKEN_HEART_P (*from))
- ? (OBJECT_ADDRESS (*from))
- : 0)
- : from);
+ if (!ADDRESS_IN_FROMSPACE_P (from))
+ return (from);
+ if (BROKEN_HEART_P (*from))
+ return (OBJECT_ADDRESS (*from));
+ if (scanning_ephemerons_p)
+ /* It would be nice if we had the new address, too; that way we
+ could eliminate a post-processing loop over the list of all
+ ephemerons. However, the GC abstraction doesn't have a nice way
+ to do that. */
+ queue_ephemerons_for_key (from);
+ return (0);
}
DEFINE_GC_PRECHECK_FROM (gc_precheck_from_no_transport)
return (scan + 1);
}
+DEFINE_GC_HANDLER (gc_handle_ephemeron)
+{
+ SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (OBJECT_ADDRESS (object)));
+ (*scan)
+ = ((new_address != 0)
+ ? (OBJECT_NEW_ADDRESS (object, new_address))
+ : (gc_transport_ephemeron (object)));
+ return (scan + 1);
+}
+\f
DEFINE_GC_HANDLER (gc_handle_cc_entry)
{
(*scan) = (GC_HANDLE_CC_ENTRY (object));
|_______|_____________| | |_____________________|
*/
+\f
+static SCHEME_OBJECT *
+weak_referent_address (SCHEME_OBJECT object)
+{
+ switch (gc_ptr_type (object))
+ {
+ case GC_POINTER_NORMAL:
+ return (OBJECT_ADDRESS (object));
+
+ case GC_POINTER_COMPILED:
+#ifdef CC_SUPPORT_P
+ return (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (object)));
+#else
+ gc_no_cc_support ();
+#endif
+
+ default:
+ return (0);
+ }
+}
static SCHEME_OBJECT
-gc_transport_weak_pair (SCHEME_OBJECT pair)
+weak_referent_forward (SCHEME_OBJECT object)
{
- SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (pair));
- SCHEME_OBJECT * new_addr = (GC_TRANSPORT_WORDS (old_addr, 2, false));
- SCHEME_OBJECT old_car = (READ_TOSPACE (new_addr));
- SCHEME_OBJECT * caddr;
-
- /* Don't add pair to chain unless old_car is a pointer into old
- space. */
+ SCHEME_OBJECT * addr;
- switch (gc_ptr_type (old_car))
+ switch (gc_ptr_type (object))
{
case GC_POINTER_NORMAL:
- caddr = (OBJECT_ADDRESS (old_car));
- break;
+ addr = (OBJECT_ADDRESS (object));
+ if (BROKEN_HEART_P (*addr))
+ return (MAKE_OBJECT_FROM_OBJECTS (object, (*addr)));
+ return (SHARP_F);
case GC_POINTER_COMPILED:
#ifdef CC_SUPPORT_P
- caddr = (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (old_car)));
+ addr = (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (object)));
+ if (BROKEN_HEART_P (*addr))
+ return (CC_ENTRY_NEW_BLOCK (object, (OBJECT_ADDRESS (*addr)), addr));
#else
gc_no_cc_support ();
#endif
- break;
+ return (SHARP_F);
- default:
- caddr = 0;
- break;
+ case GC_POINTER_NOT:
+ default: /* suppress bogus GCC warning */
+ std_gc_death ("Non-pointer cannot be a weak reference.");
+ return (SHARP_F);
}
+}
+\f
+static void
+queue_ephemerons_for_key (SCHEME_OBJECT * addr)
+{
+ SCHEME_OBJECT ht = ephemeron_array;
+ unsigned long index = (((unsigned long) addr) % (VECTOR_LENGTH (ht)));
+ SCHEME_OBJECT * entry_loc = (VECTOR_LOC (ht, index));
+ SCHEME_OBJECT entry;
+
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ if (!scanning_ephemerons_p)
+ std_gc_death ("queue_ephemerons_for_key while not scanning ephemerons");
+
+ if (!ADDRESS_IN_FROMSPACE_P (addr))
+ std_gc_death ("Queueing ephemerons for key with non-fromspace address.");
+#endif
+
+ while (EPHEMERON_P (entry = (*entry_loc)))
+ {
+ SCHEME_OBJECT * entry_addr = (OBJECT_ADDRESS (entry));
+ SCHEME_OBJECT * next_loc
+ = (NEWSPACE_TO_TOSPACE (entry_addr + EPHEMERON_NEXT));
+ if (addr == (OBJECT_ADDRESS (READ_TOSPACE (entry_addr + EPHEMERON_KEY))))
+ {
+ (*entry_loc) = (*next_loc);
+ (*next_loc) = ephemeron_queue;
+ ephemeron_queue = entry;
+ }
+ entry_loc = next_loc;
+ }
+}
+\f
+static SCHEME_OBJECT
+gc_transport_weak_pair (SCHEME_OBJECT pair)
+{
+ SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (pair));
+ SCHEME_OBJECT * new_addr = (GC_TRANSPORT_WORDS (old_addr, 2, false));
+ SCHEME_OBJECT old_car = (READ_TOSPACE (new_addr));
+ SCHEME_OBJECT * caddr = (weak_referent_address (old_car));
+
if ((caddr != 0) && (ADDRESS_IN_FROMSPACE_P (caddr)))
{
WRITE_TOSPACE (new_addr, (OBJECT_NEW_TYPE (TC_NULL, old_car)));
return (OBJECT_NEW_ADDRESS (pair, new_addr));
}
+static SCHEME_OBJECT
+gc_transport_ephemeron (SCHEME_OBJECT old_ephemeron)
+{
+ SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (old_ephemeron));
+ SCHEME_OBJECT * new_addr
+ = (GC_TRANSPORT_WORDS (old_addr, EPHEMERON_SIZE, false));
+ SCHEME_OBJECT new_ephemeron = (OBJECT_NEW_ADDRESS (old_ephemeron, new_addr));
+ SCHEME_OBJECT old_key = (READ_TOSPACE (new_addr + EPHEMERON_KEY));
+ SCHEME_OBJECT * old_key_addr = (weak_referent_address (old_key));
+ SCHEME_OBJECT index;
+ SCHEME_OBJECT ht = ephemeron_array;
+
+ ephemeron_count += 1;
+
+ /* If the key is GC-invariant or live, the ephemeron will not be
+ broken, so leave a marked vector manifest to make the GC will scan
+ its contents, including the datum. */
+ if ((old_key_addr == 0)
+ || (!ADDRESS_IN_FROMSPACE_P (old_key_addr))
+ || (SHARP_F != (weak_referent_forward (old_key))))
+ {
+ WRITE_TOSPACE (new_addr, MARKED_EPHEMERON_MANIFEST);
+ return (new_ephemeron);
+ }
+
+ /* Write a manifest that makes the GC skip over the ephemeron. */
+ WRITE_TOSPACE (new_addr, UNMARKED_EPHEMERON_MANIFEST);
+
+ /* Map its key back to it. */
+ index = (((unsigned long) old_key_addr) % (VECTOR_LENGTH (ht)));
+ WRITE_TOSPACE ((new_addr + EPHEMERON_NEXT), (VECTOR_REF (ht, index)));
+ VECTOR_SET (ht, index, new_ephemeron);
+
+ /* Link it up in the ephemeron list. */
+ WRITE_TOSPACE ((new_addr + EPHEMERON_LIST), ephemeron_list);
+ ephemeron_list = new_ephemeron;
+
+ return (new_ephemeron);
+}
+\f
+static void
+scan_newspace_addr (SCHEME_OBJECT * addr)
+{
+ gc_ignore_object_p_t * ignore_object_p
+ = (GCT_IGNORE_OBJECT_P (current_gc_table));
+ SCHEME_OBJECT * scan;
+ SCHEME_OBJECT object;
+
+ addr = (NEWSPACE_TO_TOSPACE (addr));
+ scan = addr;
+
+ INITIALIZE_GC_HISTORY ();
+ object = (*scan);
+ HANDLE_GC_TRAP (scan, object);
+ if ((ignore_object_p != 0) && ((*ignore_object_p) (object)))
+ return;
+
+ current_scan = scan;
+ current_object = object;
+ scan = ((* (GCT_ENTRY (current_gc_table, (OBJECT_TYPE (object)))))
+ (scan, object));
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ if (scan != (addr + 1))
+ std_gc_death ("scan_newspace_addr overflowed");
+#endif
+}
+
+static void
+scan_ephemerons (void)
+{
+ SCHEME_OBJECT ephemeron = ephemeron_list;
+ SCHEME_OBJECT * saved_newspace_next = newspace_next;
+ scanning_ephemerons_p = true;
+ while (EPHEMERON_P (ephemeron))
+ {
+ SCHEME_OBJECT * ephemeron_addr = (OBJECT_ADDRESS (ephemeron));
+ SCHEME_OBJECT old_key = (READ_TOSPACE (ephemeron_addr + EPHEMERON_KEY));
+ ephemeron = (READ_TOSPACE (ephemeron_addr + EPHEMERON_LIST));
+ /* It is tempting to scan the ephemeron's datum right here and
+ now, but we can't do that because it may already be in the
+ queue, and the assumption is that for each ephemeron in the
+ queue, its key has been proven live but its datum has not yet
+ been scanned. It is tempting to link this up in the queue
+ right here and now, but we can't do that, because we must also
+ delete it from the hash table so that nothing else will put it
+ in the queue again. */
+ if (SHARP_F != (weak_referent_forward (old_key)))
+ queue_ephemerons_for_key (weak_referent_address (old_key));
+ }
+ while (EPHEMERON_P (ephemeron = ephemeron_queue))
+ {
+ SCHEME_OBJECT * ephemeron_addr = (OBJECT_ADDRESS (ephemeron));
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ {
+ SCHEME_OBJECT key = (READ_TOSPACE (ephemeron_addr + EPHEMERON_KEY));
+ if (! (weak_referent_forward (key)))
+ std_gc_death
+ ("Ephemeron queued whose key has not been forwarded: %lx", key);
+ }
+#endif
+ ephemeron_queue = (READ_TOSPACE (ephemeron_addr + EPHEMERON_NEXT));
+ saved_newspace_next = newspace_next;
+ scan_newspace_addr (ephemeron_addr + EPHEMERON_DATUM);
+ gc_scan_tospace (saved_newspace_next, 0);
+ }
+ scanning_ephemerons_p = false;
+}
+\f
void
initialize_weak_chain (void)
{
weak_chain = 0;
#ifdef ENABLE_GC_DEBUGGING_TOOLS
weak_chain_length = 0;
+ if (ephemeron_list != SHARP_F) std_gc_death ("Bad ephemeron list.");
+ if (ephemeron_queue != SHARP_F) std_gc_death ("Bad ephemeron queue.");
+ if (scanning_ephemerons_p != SHARP_F) std_gc_death ("Bad ephemeron state.");
#endif
}
-void
-update_weak_pointers (void)
+static void
+update_ephemerons (void)
+{
+ SCHEME_OBJECT ephemeron = ephemeron_list;
+ while (EPHEMERON_P (ephemeron))
+ {
+ SCHEME_OBJECT * ephemeron_addr = (OBJECT_ADDRESS (ephemeron));
+ SCHEME_OBJECT * key_loc = (ephemeron_addr + EPHEMERON_KEY);
+ SCHEME_OBJECT old_key = (READ_TOSPACE (key_loc));
+ SCHEME_OBJECT new_key = (weak_referent_forward (old_key));
+ WRITE_TOSPACE (ephemeron_addr, MARKED_EPHEMERON_MANIFEST);
+ WRITE_TOSPACE (key_loc, new_key);
+ /* Advance before we clobber the list pointer. */
+ ephemeron = (READ_TOSPACE (ephemeron_addr + EPHEMERON_LIST));
+ WRITE_TOSPACE ((ephemeron_addr + EPHEMERON_LIST), SHARP_F);
+ WRITE_TOSPACE ((ephemeron_addr + EPHEMERON_NEXT), SHARP_F);
+ if (new_key == SHARP_F)
+ WRITE_TOSPACE ((ephemeron_addr + EPHEMERON_DATUM), SHARP_F);
+ }
+ ephemeron_list = SHARP_F;
+}
+
+static void
+update_weak_pairs (void)
{
#if 0
#ifdef ENABLE_GC_DEBUGGING_TOOLS
SCHEME_OBJECT old_car
= (OBJECT_NEW_TYPE ((OBJECT_TYPE (obj)),
(READ_TOSPACE (new_addr))));
- SCHEME_OBJECT * addr;
-
- switch (gc_ptr_type (old_car))
- {
- case GC_POINTER_NORMAL:
- addr = (OBJECT_ADDRESS (old_car));
- WRITE_TOSPACE (new_addr,
- ((BROKEN_HEART_P (*addr))
- ? (MAKE_OBJECT_FROM_OBJECTS (old_car, (*addr)))
- : SHARP_F));
- break;
-
- case GC_POINTER_COMPILED:
-#ifdef CC_SUPPORT_P
- addr = (cc_entry_address_to_block_address
- (CC_ENTRY_ADDRESS (old_car)));
- WRITE_TOSPACE (new_addr,
- ((BROKEN_HEART_P (*addr))
- ? (CC_ENTRY_NEW_BLOCK (old_car,
- (OBJECT_ADDRESS (*addr)),
- addr))
- : SHARP_F));
-#else
- std_gc_death (0, "update_weak_pointers: unsupported compiled code");
-#endif
- break;
- case GC_POINTER_NOT:
- std_gc_death ("update_weak_pointers: non-pointer found");
- break;
- }
+ WRITE_TOSPACE (new_addr, (weak_referent_forward (old_car)));
weak_chain = (((OBJECT_DATUM (obj)) == 0) ? 0 : (OBJECT_ADDRESS (obj)));
}
}
+
+void
+update_weak_pointers (void)
+{
+ scan_ephemerons ();
+ update_ephemerons ();
+ update_weak_pairs ();
+}
\f
void
std_gc_death (const char * format, ...)
GC_COMPILED, /* TC_COMPILED_ENTRY */
GC_PAIR, /* TC_LEXPR */
GC_VECTOR, /* TC_PCOMB3 */
- GC_UNDEFINED, /* 0x2B */
+ GC_VECTOR, /* TC_EPHEMERON */
GC_TRIPLE, /* TC_VARIABLE */
GC_NON_POINTER, /* TC_THE_ENVIRONMENT */
GC_UNDEFINED, /* 0x2E */
open_tospace (heap_start);
initialize_weak_chain ();
+ ephemeron_count = 0;
std_gc_pt1 ();
std_gc_pt2 ();
history_register = (OBJECT_ADDRESS (*saved_to++));
saved_to = 0;
+#ifdef ENABLE_GC_DEBUGGING_TOOLS
+ /* This should never trigger, because we discard the previous
+ ephemeron array, which always has at least as many slots as there
+ are live ephemerons. Add one for the vector's manifest. */
+ if (GC_NEEDED_P (ephemeron_count + 1))
+ std_gc_death ("No room for ephemeron array");
+#endif
+ ephemeron_array = (make_vector (ephemeron_count, SHARP_F, false));
+
CC_TRANSPORT_END ();
CLEAR_INTERRUPT (INT_GC);
}
((end - start) * SIZEOF_SCHEME_OBJECT));
return (true);
}
-
+\f
void
stack_death (const char * name)
{
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
+\f
+static unsigned long primes [] =
+ {
+ /* A list of primes that approximately doubles, up to near 2^32.
+ If you have that many ephemerons, collisions in the ephemeron
+ hash table are the least of your worries. */
+ 11, 23, 53, 97, 193, 389, 769, 1543, 3079, 6151, 12289, 24593, 49157,
+ 98317, 196613, 393241, 786433, 1572869, 3145739, 6291469, 12582917,
+ 25165843, 50331653, 100663319, 201326611, 402653189, 805306457,
+ 1610612741,
+ };
+
+static unsigned long
+compute_ephemeron_array_length (void)
+{
+ unsigned int start = 0, end = ((sizeof primes) / (sizeof (*primes)));
+ unsigned int index;
+
+ if ((primes [end - 1]) < ephemeron_count)
+ return (primes [end - 1]);
+
+ do {
+ index = (start + ((end - start) / 2));
+ if ((primes [index]) < ephemeron_count)
+ start = (index + 1);
+ else if (ephemeron_count < (primes [index]))
+ end = index;
+ else
+ return (primes [index]);
+ } while (start < end);
+
+ return (primes [start]);
+}
+
+static void
+guarantee_ephemeron_space (void)
+{
+ /* Guarantee space after Free and in the ephemeron array for one
+ ephemeron. */
+ if ((VECTOR_P (ephemeron_array))
+ && (ephemeron_count <= (VECTOR_LENGTH (ephemeron_array))))
+ Primitive_GC_If_Needed (EPHEMERON_SIZE);
+ else
+ {
+ unsigned long length = (compute_ephemeron_array_length ());
+ /* We could be cleverer about expanding the ephemeron array, and
+ tell the GC (above) that we really want an ephemeron array
+ that is one slot larger. */
+ Primitive_GC_If_Needed (EPHEMERON_SIZE + VECTOR_DATA + length);
+ ephemeron_array = (make_vector (length, SHARP_F, false));
+ }
+}
+
+DEFINE_PRIMITIVE ("MAKE-EPHEMERON", Prim_make_ephemeron, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ ephemeron_count += 1;
+ guarantee_ephemeron_space ();
+ {
+ SCHEME_OBJECT * addr = Free;
+ (*Free++) = MARKED_EPHEMERON_MANIFEST;
+ (*Free++) = (ARG_REF (1)); /* key */
+ (*Free++) = (ARG_REF (2)); /* datum */
+ (*Free++) = SHARP_F; /* list */
+ (*Free++) = SHARP_F; /* queue */
+ assert ((Free - addr) == EPHEMERON_SIZE);
+ PRIMITIVE_RETURN (MAKE_POINTER_OBJECT (TC_EPHEMERON, addr));
+ }
+}
#define CONTROL_POINT_P(object) ((OBJECT_TYPE (object)) == TC_CONTROL_POINT)
#define BROKEN_HEART_P(object) ((OBJECT_TYPE (object)) == TC_BROKEN_HEART)
#define RETURN_CODE_P(object) ((OBJECT_TYPE (object)) == TC_RETURN_CODE)
+#define EPHEMERON_P(object) ((OBJECT_TYPE (object)) == TC_EPHEMERON)
#define NON_MARKED_VECTOR_P(object) \
((OBJECT_TYPE (object)) == TC_NON_MARKED_VECTOR)
#define COMPLEX_REAL 0
#define COMPLEX_IMAG 1
+/* EPHEMERON
+ * Similar to a weak pair, but the datum is weakly referenced too. The
+ * key and datum are simultaneously dropped iff the only references to
+ * the key go through the datum. Every ephemeron has extra slots for
+ * data structures that the garbage collector needs to implement this,
+ * so that the garbage collector need not allocate auxiliary storage.
+ */
+
+#define EPHEMERON_MANIFEST 0
+#define EPHEMERON_KEY 1
+#define EPHEMERON_DATUM 2
+#define EPHEMERON_LIST 3
+#define EPHEMERON_NEXT 4
+
+#define EPHEMERON_SIZE 5
+
+#define MARKED_EPHEMERON_MANIFEST \
+ (MAKE_OBJECT (TC_MANIFEST_VECTOR, (EPHEMERON_SIZE - 1)))
+
+#define UNMARKED_EPHEMERON_MANIFEST \
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (EPHEMERON_SIZE - 1)))
+
#endif /* not SCM_SDATA_H */
SCHEME_OBJECT fixed_objects;
+/* Array of contiguous auxiliary storage, one entry per ephemeron, for
+ the sake of the garbage collector, which can use the array however
+ it pleases -- as a hash table, binary tree, &c. */
+
+SCHEME_OBJECT ephemeron_array = SHARP_F;
+unsigned long ephemeron_count = 0;
+
bool trapping;
unsigned long n_heap_blocks;
22 88 BROKEN-HEART 01 04 LIST
23 8C ASSIGNMENT 0D 34 MANIFEST-CLOSURE
24 90 HUNK3-B 27 9C MANIFEST-NM-VECTOR
-25 94 IN-PACKAGE 2B AC MANIFEST-SPECIAL-NM-VECTOR
+25 94 IN-PACKAGE 2B AC EPHEMERON
26 98 COMBINATION 16 58 NON-MARKED-VECTOR
27 9C MANIFEST-NM-VECTOR 00 00 NULL
28 A0 COMPILED-ENTRY 30 C0 PCOMB0
29 A4 LEXPR 1B 6C PCOMB1
2A A8 PCOMB3 04 10 PCOMB2
-2B AC MANIFEST-SPECIAL-NM-VECTOR 2A A8 PCOMB3
+2B AC EPHEMERON 2A A8 PCOMB3
2C B0 VARIABLE 18 60 PRIMITIVE
2D B4 THE-ENVIRONMENT 0F 3C PROCEDURE
2E B8 FUTURE 38 E0 QUAD
#define TC_COMPILED_ENTRY 0x28
#define TC_LEXPR 0x29
#define TC_PCOMB3 0x2A
-/* #define TC_UNUSED 0x2B */
+#define TC_EPHEMERON 0x2B
#define TC_VARIABLE 0x2C
#define TC_THE_ENVIRONMENT 0x2D
/* #define TC_UNUSED 0x2E */
/* 0x28 */ "compiled-entry", \
/* 0x29 */ "lexpr", \
/* 0x2a */ "primitive-combination-3", \
- /* 0x2b */ 0, \
+ /* 0x2b */ "ephemeron", \
/* 0x2c */ "variable", \
/* 0x2d */ "the-environment", \
/* 0x2e */ 0, \
system-vector?
(system-vector-length system-vector-size)
system-vector-ref
- system-vector-set!)
+ system-vector-set!
+
+ primitive-object-ref primitive-object-set!)
(define (host-big-endian?)
host-big-endian?-saved)
(define host-big-endian?-saved)
+(define ephemeron-type)
+
(define (initialize-package!)
;; Assumptions:
;; * Word length is 32 or 64 bits.
((#x00020100 #x0004030000020100) #f)
(else (error "Unable to determine endianness of host."))))
(add-secondary-gc-daemon! clean-obarray)
+ ;; Kludge until the next released version, to avoid a bootstrapping
+ ;; failure.
+ (set! ephemeron-type (microcode-type 'EPHEMERON))
unspecific)
\f
;;;; Potpourri
(guarantee-hook-list hook-list 'RUN-HOOKS-IN-LIST)
(for-each (lambda (p)
(apply (cdr p) arguments))
- (hook-list-hooks hook-list)))
\ No newline at end of file
+ (hook-list-hooks hook-list)))
+\f
+;;;; Ephemerons
+
+(define canonical-false (list 'FALSE))
+
+(define (canonicalize object)
+ (if (eq? object #f)
+ canonical-false
+ object))
+
+(define (decanonicalize object)
+ (if (eq? object canonical-false)
+ #f
+ object))
+
+(define (make-ephemeron key datum)
+ ((ucode-primitive MAKE-EPHEMERON 2) (canonicalize key) (canonicalize datum)))
+
+(define (ephemeron? object)
+ (object-type? ephemeron-type object))
+
+(define-guarantee ephemeron "ephemeron")
+
+(define (ephemeron-key ephemeron)
+ (guarantee-ephemeron ephemeron 'EPHEMERON-KEY)
+ (decanonicalize (primitive-object-ref ephemeron 1)))
+
+(define (ephemeron-datum ephemeron)
+ (guarantee-ephemeron ephemeron 'EPHEMERON-DATUM)
+ (decanonicalize (primitive-object-ref ephemeron 2)))
+
+(define (set-ephemeron-datum! ephemeron datum)
+ (guarantee-ephemeron ephemeron 'SET-EPHEMERON-DATUM!)
+ (let ((key (primitive-object-ref ephemeron 1)))
+ (if key (primitive-object-set! ephemeron 2 (canonicalize datum)))
+ ;; Guarantee that the key is referenced until this procedure
+ ;; returns.
+ (identity-procedure key))
+ unspecific)
+
+(define (ephemeron-broken? ephemeron)
+ (guarantee-ephemeron ephemeron 'EPHEMERON-BROKEN?)
+ (not (primitive-object-ref ephemeron 1)))
\ No newline at end of file
default/exit
default/quit
environment-link-name
+ ephemeron-broken?
+ ephemeron-datum
+ ephemeron-key
+ ephemeron?
eq?
error-procedure
error:not-hook-list
link-variables
local-assignment
make-cell
+ make-ephemeron
make-hook-list
make-non-pointer-object
non-pointer-type-code?
run-hooks-in-list
scode-eval
set-cell-contents!
+ set-ephemeron-datum!
set-interrupt-enables!
show-time
system-hunk3-cons
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test of ephemerons
+
+(declare (usual-integrations))
+\f
+;;;; Utilities
+
+;;; REFERENCE-BARRIER guarantees that OBJECT will be considered live at
+;;; least until the call to REFERENCE-BARRIER, by forcing the compiler
+;;; to assume that it passes out.
+
+(define (reference-barrier object)
+ (identity-procedure object))
+
+(define (assert-unbroken ephemeron key datum)
+ (assert-equal (ephemeron-key ephemeron) key)
+ (assert-equal (ephemeron-datum ephemeron) datum)
+ (assert-false (ephemeron-broken? ephemeron)))
+
+(define (assert-broken ephemeron)
+ (assert-eqv (ephemeron-key ephemeron) #f)
+ (assert-eqv (ephemeron-datum ephemeron) #f)
+ (assert-true (ephemeron-broken? ephemeron)))
+
+(define (repeat procedure)
+ (gc-flip)
+ (procedure)
+ (gc-flip)
+ (procedure)
+ (gc-flip)
+ (procedure))
+
+(define (finally procedure)
+ (gc-flip)
+ (procedure))
+\f
+(define-test 'NO-GC
+ ;; Not really no GC; it's just that the ephemeron is never broken
+ ;; because its key is never GC'd.
+ (lambda ()
+ (let ((key (list 'KEY)) (datum (list 'DATUM)))
+ (let ((ephemeron (make-ephemeron key datum)))
+ (define (check) (assert-unbroken ephemeron '(KEY) '(DATUM)))
+ (repeat check)
+ (finally check)
+ (reference-barrier (list key datum))))))
+
+(define-test 'GC-KEY
+ (lambda ()
+ (let ((key (list 'KEY)) (datum (list 'DATUM)))
+ (let ((ephemeron (make-ephemeron key datum)))
+ (repeat (lambda () (assert-unbroken ephemeron '(KEY) '(DATUM))))
+ (reference-barrier key)
+ (set! key 0)
+ (finally (lambda () (assert-broken ephemeron)))
+ (reference-barrier datum)))))
+
+(define-test 'GC-DATUM
+ (lambda ()
+ (let ((key (list 'KEY)) (datum (list 'DATUM)))
+ (let ((ephemeron (make-ephemeron key datum)))
+ (repeat (lambda () (assert-unbroken ephemeron '(KEY) '(DATUM))))
+ (reference-barrier datum)
+ (set! datum 0)
+ (finally (lambda () (assert-unbroken ephemeron '(KEY) '(DATUM))))
+ (reference-barrier key)))))
+
+(define-test 'GC-KEY-AND-DATUM
+ (lambda ()
+ (let ((key (list 'KEY)) (datum (list 'DATUM)))
+ (let ((ephemeron (make-ephemeron key datum)))
+ (repeat (lambda () (assert-unbroken ephemeron '(KEY) '(DATUM))))
+ (reference-barrier (list key datum))
+ (set! key 0)
+ (set! datum 0)
+ (finally (lambda () (assert-broken ephemeron)))))))
+\f
+(define-test 'EPHEMERON-AND-WEAK-PAIR
+ (lambda ()
+ (let ((key (list 'KEY)) (datum (list 'DATUM)))
+ (let ((ephemeron (make-ephemeron key datum))
+ (weak-pair (weak-cons datum 0)))
+ (define (check)
+ (assert-unbroken ephemeron '(KEY) '(DATUM))
+ (assert-equal (weak-car weak-pair) '(DATUM))
+ (assert-eqv (weak-car weak-pair) (ephemeron-datum ephemeron)))
+ (repeat check)
+ (reference-barrier datum)
+ (set! datum 0)
+ (repeat check)
+ (reference-barrier key)
+ (set! key 0)
+ (finally (lambda ()
+ (assert-broken ephemeron)
+ (assert-false (weak-pair/car? weak-pair))))))))
+
+(define-test 'MANY-EPHEMERONS
+ (lambda ()
+ (let ((n 100))
+ (let* ((frobs (make-initialized-vector n (lambda (i) (cons i i))))
+ (ephemerons
+ (make-initialized-vector n
+ (lambda (i) (make-ephemeron (vector-ref frobs i) i)))))
+ (define (frob i) (vector-ref frobs i))
+ (define (ephemeron i) (vector-ref ephemerons i))
+ (define (unbroken i) (assert-unbroken (ephemeron i) (frob i) i))
+ (define (broken i) (assert-broken (ephemeron i)))
+ (repeat (lambda () (do ((i 0 (+ i 1))) ((= i n)) (unbroken i))))
+ (do ((i 0 (+ i 2))) ((>= i n)) (vector-set! frobs i #f))
+ (finally (lambda ()
+ (do ((i 0 (+ i 1))) ((= i n))
+ (if (even? i) (broken i) (unbroken i)))))))))
+\f
+(define-test 'SIMPLE-EPHEMERON-CYCLE
+ (lambda ()
+ (let ((p (list 'P)) (q (list 'Q)))
+ (let ((a (make-ephemeron p q))
+ (b (make-ephemeron q p)))
+ (define (check)
+ (assert-unbroken a '(P) '(Q))
+ (assert-unbroken b '(Q) '(P)))
+ (repeat check)
+ (reference-barrier p)
+ (set! p 0)
+ (repeat check)
+ (reference-barrier q)
+ (set! q 0)
+ (finally (lambda () (assert-broken a) (assert-broken b)))))))
+
+(define (random-cyclic-permutation n)
+ (let ((permutation (make-initialized-vector n identity-procedure)))
+ ;; Does this give a uniform distribution?
+ (let loop ((i n))
+ (if (< 1 i)
+ (let ((i* (- i 1)))
+ (vector-exchange! permutation i* (random-integer i*))
+ (loop i*))))
+ permutation))
+
+(define (cyclic-permutation? object)
+ (and (vector? object)
+ (let loop ((i 0))
+ (or (>= i (vector-length object))
+ (and (let ((vi (vector-ref object i)))
+ (and (integer? vi)
+ (exact? vi)
+ (<= 0 vi)
+ (< vi (vector-length object))
+ (not (= vi (vector-ref object vi)))))
+ (loop (+ i 1)))))))
+
+(define (vector-exchange! v i j)
+ (let ((t (vector-ref v i)))
+ (vector-set! v i (vector-ref v j))
+ (vector-set! v j t)))
+\f
+(define-test 'RANDOM-EPHEMERON-CYCLES
+ (lambda ()
+ (let ((n 10))
+ (do ((i 0 (+ i 1))) ((= i n))
+ (let ((permutation (random-cyclic-permutation n))
+ (frobs (make-initialized-vector n list)))
+ (define (permute i) (vector-ref permutation i))
+ (define (frob i) (vector-ref frobs i))
+ (let ((ephemerons
+ (make-initialized-vector n
+ (lambda (i) (make-ephemeron (frob i) (frob (permute i)))))))
+ (define (ephemeron i) (vector-ref ephemerons i))
+ (define (check)
+ (do ((i 0 (+ i 1))) ((= i n))
+ (assert-unbroken (ephemeron i) (list i) (list (permute i)))))
+ (repeat check)
+ (do ((i 1 (+ i 1))) ((= i n)) (vector-set! frobs (permute i) #f))
+ (repeat check)
+ (reference-barrier frobs)
+ (set! frobs 0)
+ (finally (lambda ()
+ (do ((i 0 (+ i 1))) ((= i n))
+ (assert-broken (ephemeron i)))))))))))
+
+(define-test 'TWO-RANDOM-EPHEMERON-CYCLES
+ (lambda ()
+ (let* ((n 10) (n/2 (quotient n 2)))
+ (do ((i 0 (+ i 1))) ((= i n))
+ (let ((permutation-a (random-cyclic-permutation n/2))
+ (permutation-b (random-cyclic-permutation (- n n/2)))
+ (frobs (make-initialized-vector n list)))
+ (define (permute i)
+ (if (< i n/2)
+ (vector-ref permutation-a i)
+ (+ n/2 (vector-ref permutation-b (- i n/2)))))
+ (define (frob i) (vector-ref frobs i))
+ (let ((ephemerons
+ (make-initialized-vector n
+ (lambda (i) (make-ephemeron (frob i) (frob (permute i)))))))
+ (define (ephemeron i) (vector-ref ephemerons i))
+ (define (unbroken start end)
+ (do ((i start (+ i 1))) ((= i end))
+ (assert-unbroken (ephemeron i) (list i) (list (permute i)))))
+ (define (unbroken-a) (unbroken 0 n/2))
+ (define (unbroken-b) (unbroken n/2 n))
+ (define (broken start end)
+ (do ((i start (+ i 1))) ((= i end))
+ (assert-broken (ephemeron i))))
+ (define (broken-a) (broken 0 n/2))
+ (define (broken-b) (broken n/2 n))
+ (repeat (lambda () (unbroken-a) (unbroken-b)))
+ (reference-barrier frobs)
+ (do ((i 1 (+ i 1))) ((= i n/2)) (vector-set! frobs (permute i) #f))
+ (repeat (lambda () (unbroken-a) (unbroken-b)))
+ (reference-barrier frobs)
+ (do ((i (+ n/2 1) (+ i 1))) ((= i n))
+ (vector-set! frobs (permute i) #f))
+ (repeat (lambda () (unbroken-a) (unbroken-b)))
+ (reference-barrier frobs)
+ (vector-set! frobs (permute 0) #f)
+ (repeat (lambda () (broken-a) (unbroken-b)))
+ (reference-barrier frobs)
+ (vector-set! frobs (permute n/2) #f)
+ (repeat (lambda () (broken-a) (broken-b)))))))))
+\f
+(define-test 'FORCE-EPHEMERON-QUEUE
+ ;; This test forces the garbage-collector to discover an ephemeron
+ ;; during the ephemeron-scanning phase, whose key it can't prove live
+ ;; upon discovery. Assumes the garbage-collector processes earlier
+ ;; elements in vectors before later ones.
+ (lambda ()
+ (let ((p (list 'P)) (q (list 'Q)) (r (list 'R)))
+ (let ((e (make-ephemeron p (vector (make-ephemeron q r) (list q))))
+ (wp (weak-cons r '())))
+ (define (check)
+ (assert-equal '(R) (weak-car wp))
+ (assert-equal '(P) (ephemeron-key e))
+ (let ((datum (ephemeron-datum e)))
+ (define (v i) (vector-ref datum i))
+ (assert-true (vector? datum))
+ (assert-true (ephemeron? (v 0)))
+ (assert-unbroken (v 0) '(Q) '(R))
+ (assert-eqv (ephemeron-datum (v 0)) (weak-car wp))
+ (assert-equal (v 1) '((Q))))
+ (assert-true (weak-pair/car? wp))
+ (assert-false (ephemeron-broken? e)))
+ (repeat check)
+ (reference-barrier r)
+ (set! r 0)
+ (repeat check)
+ (reference-barrier q)
+ (set! q 0)
+ (repeat check)
+ (reference-barrier p)
+ (set! p 0)
+ (finally (lambda ()
+ (assert-broken e)
+ (assert-false (weak-pair/car? wp))))))))
+
+(define-test 'SET-EPHEMERON-DATUM-WITHOUT-GC
+ (lambda ()
+ (let ((p (list 'P)) (q (list 'Q)) (r (list 'R)))
+ (let ((e (make-ephemeron p q)))
+ (repeat (lambda () (assert-unbroken e '(P) '(Q))))
+ (set-ephemeron-datum! e r)
+ (finally (lambda () (assert-unbroken e '(P) '(R))))
+ (reference-barrier (list p q r))))))
+
+(define-test 'SET-EPHEMERON-DATUM-BEFORE-GC
+ (lambda ()
+ (let ((p (list 'P)) (q (list 'Q)) (r (list 'R)))
+ (let ((e (make-ephemeron p q)))
+ (repeat (lambda () (assert-unbroken e '(P) '(Q))))
+ (set-ephemeron-datum! e r)
+ (repeat (lambda () (assert-unbroken e '(P) '(R))))
+ (reference-barrier p)
+ (set! p 0)
+ (finally (lambda () (assert-broken e)))))))
+
+(define-test 'SET-EPHEMERON-DATUM-AFTER-GC
+ (lambda ()
+ (let ((p (list 'P)) (q (list 'Q)) (r (list 'R)))
+ (let ((e (make-ephemeron p q)))
+ (repeat (lambda () (assert-unbroken e '(P) '(Q))))
+ (set! p 0)
+ (reference-barrier p)
+ (repeat (lambda () (assert-broken e)))
+ (set-ephemeron-datum! e r)
+ (assert-equal (ephemeron-datum e) #f)
+ (finally (lambda () (assert-broken e)))))))
+\f
+#|
+;;; Cute idea, but doesn't work very well -- the timings are too
+;;; imprecise and noisy.
+
+(define (check-time-complexity ephemerons key datum)
+ (define (initialize i)
+ (vector-set! ephemerons i (make-ephemeron (key i) (datum i))))
+ (define (measure-time i)
+ ;; Don't let other threads interfere with our timing by consing.
+ (with-thread-timer-stopped
+ (lambda ()
+ (gc-flip)
+ ;; It's tempting to time the initialization too, but
+ ;; MAKE-EPHEMERON runs in constant amortized time, not constant
+ ;; worst-case time, so timing individual runs does no good.
+ (initialize i)
+ (gc-flip)
+ (let ((start-time (real-time-clock)))
+ (gc-flip)
+ (- (real-time-clock) start-time)))))
+ (let loop ((i 0) (times '()))
+ (if (< i (vector-length ephemerons))
+ (loop (+ i 1)
+ (if (zero? (modulo i 100))
+ (cons (measure-time i) times)
+ (begin (initialize i) times)))
+ (begin
+ ;; (assert-false (fits-to-parabola? times))
+ (assert-true (fits-to-line? times))))))
+
+(define (fits-to-line? times)
+ (define (sum data) (reduce + 0 data))
+ (define (dot u v) (sum (map * u v)))
+ (define (distance^2 a b) (square (- a b)))
+ (define (mean data) (/ (sum data) (length data)))
+ (define (normalize data)
+ (let ((mean (mean data)))
+ (map (lambda (datum) (- datum mean)) data)))
+ (let ((n (length times)))
+ (let ((times (normalize times))
+ (indices (normalize (iota n))))
+ (let ((slope (/ (dot indices times) (dot indices indices))))
+ (let ((times* (map (lambda (i) (* slope i)) indices)))
+ (>= 1 (mean (map distance^2 times times*))))))))
+
+(define-test 'LINEAR-TIME-COMPLEXITY-WITHOUT-REFERENCES
+ (lambda ()
+ (let* ((n 10000) (ephemerons (make-vector n #f)))
+ (check-time-complexity ephemerons (lambda (i) i 0) (lambda (i) i 0)))))
+
+(define-test 'LINEAR-TIME-COMPLEXITY-WITH-KEYS
+ (lambda ()
+ (let ((n 10000))
+ (let ((cells (make-initialized-vector n make-cell))
+ (ephemerons (make-vector n #f)))
+ (check-time-complexity ephemerons
+ (lambda (i) (vector-ref cells i))
+ (lambda (i) i 0))))))
+
+(define-test 'LINEAR-TIME-COMPLEXITY-WITH-SOME-KEYS
+ (lambda ()
+ (let ((n 10000))
+ (define (make-even-cell i) (and (even? i) (make-cell i)))
+ (let ((cells (make-initialized-vector n make-even-cell))
+ (ephemerons (make-vector n #f)))
+ (check-time-complexity ephemerons
+ (lambda (i) (vector-ref cells i))
+ (lambda (i) i 0))))))
+
+(define-test 'LINEAR-TIME-COMPLEXITY-WITH-EPHEMERON-KEYS
+ (lambda ()
+ (let* ((n 10000) (ephemerons (make-vector n #f)))
+ (check-time-complexity ephemerons
+ (lambda (i) (if (zero? i) 0 (vector-ref ephemerons (- i 1))))
+ (lambda (i) i 0)))))
+|#
+\f
+(define-test 'FASL-PRESERVES-EPHEMERONS
+ (lambda ()
+ (call-with-temporary-file-pathname
+ (lambda (pathname)
+ (let* ((pair (cons 0 0))
+ (ephemeron (make-ephemeron pair 0)))
+ (fasdump (vector ephemeron pair) pathname))
+ (let ((object (fasload pathname)))
+ (assert-true (vector? object))
+ (assert-eqv (vector-length object) 2)
+ (let ((ephemeron (vector-ref object 0))
+ (pair (vector-ref object 1)))
+ (assert-equal pair '(0 . 0))
+ (assert-true (ephemeron? ephemeron))
+ (assert-unbroken ephemeron pair 0)
+ (assert-eqv (ephemeron-key ephemeron) pair)))))))
+
+;;; Commented out because the fasdumper does not, in fact, break
+;;; ephemerons whose keys are not strongly referenced in the fasl.
+
+#|
+(define-test 'FASL-BREAKS-EPHEMERONS
+ (lambda ()
+ (call-with-temporary-file-pathname
+ (lambda (pathname)
+ (fasdump (make-ephemeron (cons 0 0) 0) pathname)
+ (let ((ephemeron (fasload pathname)))
+ (assert-true (ephemeron? ephemeron))
+ (assert-broken ephemeron))))))
+|#
projects / mit-scheme.git / commitdiff