From: Taylor R Campbell Date: Tue, 10 Aug 2010 18:43:44 +0000 (+0000) Subject: Implement ephemerons. X-Git-Tag: 20101212-Gtk~108 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ebb25823b04a812143fb2b5088fadc7629fb7ad9;p=mit-scheme.git Implement ephemerons. Ephemerons are like weak pairs, except the datum is dropped if the key is dropped, and references to the key through the datum don't count if the only references to the datum are through the ephemeron. In other words, the weak references to the key and datum are dropped iff the key can be proven dead; conversely, the references to the key and datum are preserved iff somebody else cares about the key. --- diff --git a/src/microcode/extern.h b/src/microcode/extern.h index 3f1b84a85..03b79669f 100644 --- a/src/microcode/extern.h +++ b/src/microcode/extern.h @@ -155,6 +155,9 @@ extern SCHEME_OBJECT * constant_end; 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; diff --git a/src/microcode/fasdump.c b/src/microcode/fasdump.c index 8afb3ca0a..c6b004014 100644 --- a/src/microcode/fasdump.c +++ b/src/microcode/fasdump.c @@ -340,6 +340,7 @@ fasdump_table (void) (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; } diff --git a/src/microcode/fasload.c b/src/microcode/fasload.c index faa21b6f6..be871f014 100644 --- a/src/microcode/fasload.c +++ b/src/microcode/fasload.c @@ -471,6 +471,7 @@ relocate_block_table (void) (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; @@ -600,6 +601,7 @@ intern_block_table (void) (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; diff --git a/src/microcode/gccode.h b/src/microcode/gccode.h index 4857ba9c9..cc162f9b8 100644 --- a/src/microcode/gccode.h +++ b/src/microcode/gccode.h @@ -155,6 +155,7 @@ extern gc_handler_t gc_handle_pair; 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; diff --git a/src/microcode/gcloop.c b/src/microcode/gcloop.c index c5103d7bb..695c774e3 100644 --- a/src/microcode/gcloop.c +++ b/src/microcode/gcloop.c @@ -62,6 +62,9 @@ USA. #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; @@ -115,10 +118,32 @@ static SCHEME_OBJECT current_object; ((* ((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; @@ -323,11 +348,9 @@ initialize_gc_table (gc_table_t * table, bool transport_p) 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; @@ -448,12 +471,17 @@ DEFINE_GC_PRECHECK_FROM (gc_precheck_from) 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) @@ -553,6 +581,16 @@ DEFINE_GC_HANDLER (gc_handle_weak_pair) 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); +} + DEFINE_GC_HANDLER (gc_handle_cc_entry) { (*scan) = (GC_HANDLE_CC_ENTRY (object)); @@ -740,36 +778,96 @@ DEFINE_GC_HANDLER (gc_handle_undefined) |_______|_____________| | |_____________________| */ + +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); } +} + +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; + } +} + +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))); @@ -785,17 +883,150 @@ gc_transport_weak_pair (SCHEME_OBJECT pair) 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); +} + +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; +} + 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 @@ -810,40 +1041,19 @@ update_weak_pointers (void) 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 (); +} void std_gc_death (const char * format, ...) @@ -1065,7 +1275,7 @@ gc_type_t gc_type_map [N_TYPE_CODES] = 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 */ diff --git a/src/microcode/memmag.c b/src/microcode/memmag.c index 657f759ec..3c7521c13 100644 --- a/src/microcode/memmag.c +++ b/src/microcode/memmag.c @@ -253,6 +253,7 @@ the primitive GC daemons before returning.") open_tospace (heap_start); initialize_weak_chain (); + ephemeron_count = 0; std_gc_pt1 (); std_gc_pt2 (); @@ -317,6 +318,15 @@ std_gc_pt2 (void) 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); } @@ -329,7 +339,7 @@ save_tospace_copy (SCHEME_OBJECT * start, SCHEME_OBJECT * end, void * p) ((end - start) * SIZEOF_SCHEME_OBJECT)); return (true); } - + void stack_death (const char * name) { @@ -358,3 +368,72 @@ DEFINE_PRIMITIVE ("GC-TRACE-REFERENCES", Prim_gc_trace_references, 2, 2, 0) } PRIMITIVE_RETURN (UNSPECIFIC); } + +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)); + } +} diff --git a/src/microcode/object.h b/src/microcode/object.h index 5a0f42e2f..a33b0ffb4 100644 --- a/src/microcode/object.h +++ b/src/microcode/object.h @@ -192,6 +192,7 @@ extern SCHEME_OBJECT * memory_base; #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) diff --git a/src/microcode/sdata.h b/src/microcode/sdata.h index 873fe8f84..e694d40a4 100644 --- a/src/microcode/sdata.h +++ b/src/microcode/sdata.h @@ -499,4 +499,26 @@ USA. #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 */ diff --git a/src/microcode/storage.c b/src/microcode/storage.c index f72b5e1e4..e28abc6c6 100644 --- a/src/microcode/storage.c +++ b/src/microcode/storage.c @@ -64,6 +64,13 @@ SCHEME_OBJECT * last_return_code; 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; diff --git a/src/microcode/typename.txt b/src/microcode/typename.txt index 34a3e3bbb..fbb6a1a0f 100644 --- a/src/microcode/typename.txt +++ b/src/microcode/typename.txt @@ -39,13 +39,13 @@ 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 diff --git a/src/microcode/types.h b/src/microcode/types.h index 9d3e8584e..f92ddcd43 100644 --- a/src/microcode/types.h +++ b/src/microcode/types.h @@ -68,7 +68,7 @@ USA. #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 */ @@ -146,7 +146,7 @@ USA. /* 0x28 */ "compiled-entry", \ /* 0x29 */ "lexpr", \ /* 0x2a */ "primitive-combination-3", \ - /* 0x2b */ 0, \ + /* 0x2b */ "ephemeron", \ /* 0x2c */ "variable", \ /* 0x2d */ "the-environment", \ /* 0x2e */ 0, \ diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 32189728d..07d9fb92e 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -67,13 +67,17 @@ USA. 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. @@ -89,6 +93,9 @@ USA. ((#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) ;;;; Potpourri @@ -461,4 +468,47 @@ USA. (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))) + +;;;; 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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e34b06044..85fdf32e1 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -315,6 +315,10 @@ USA. default/exit default/quit environment-link-name + ephemeron-broken? + ephemeron-datum + ephemeron-key + ephemeron? eq? error-procedure error:not-hook-list @@ -344,6 +348,7 @@ USA. link-variables local-assignment make-cell + make-ephemeron make-hook-list make-non-pointer-object non-pointer-type-code? @@ -367,6 +372,7 @@ USA. run-hooks-in-list scode-eval set-cell-contents! + set-ephemeron-datum! set-interrupt-enables! show-time system-hunk3-cons diff --git a/tests/runtime/test-ephemeron.scm b/tests/runtime/test-ephemeron.scm new file mode 100644 index 000000000..b396c3ba7 --- /dev/null +++ b/tests/runtime/test-ephemeron.scm @@ -0,0 +1,418 @@ +#| -*-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)) + +;;;; 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)) + +(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))))))) + +(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))))))))) + +(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))) + +(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))))))))) + +(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))))))) + +#| +;;; 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))))) +|# + +(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)))))) +|#