From 0416239a723539ff3e21ffe623a5fb9bf0c21372 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 2 Aug 2001 04:30:16 +0000 Subject: [PATCH] Implement unlink_variable and associated primitive, which is not yet tested. Also, more cleanups to "lookup.c", particularly in code that accesses cache reference lists. Increased abstraction in this area is being prompted by potential design changes to allow linking variables with different names. --- v7/src/microcode/lookprm.c | 71 ++--- v7/src/microcode/lookup.c | 551 +++++++++++++++++++++---------------- v7/src/microcode/lookup.h | 6 +- v7/src/microcode/sdata.h | 33 +-- 4 files changed, 352 insertions(+), 309 deletions(-) diff --git a/v7/src/microcode/lookprm.c b/v7/src/microcode/lookprm.c index a92585813..d98643aec 100644 --- a/v7/src/microcode/lookprm.c +++ b/v7/src/microcode/lookprm.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookprm.c,v 1.13 2001/07/31 03:11:42 cph Exp $ +$Id: lookprm.c,v 1.14 2001/08/02 04:30:03 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -152,64 +152,37 @@ variable lookup error (unbound or unassigned).") PRIMITIVE_HEADER (2); { SCHEME_OBJECT value; - long result = (lookup_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); - switch (result) - { - case ERR_UNASSIGNED_VARIABLE: - case ERR_UNBOUND_VARIABLE: - PRIMITIVE_RETURN(SHARP_T); - - case PRIM_DONE: - PRIMITIVE_RETURN (SHARP_F); - - case PRIM_INTERRUPT: - signal_interrupt_from_primitive (); - - default: - signal_error_from_primitive (result); - } + STD_LOOKUP + (variable_unreferenceable_p ((ARG_REF (1)), (ARG_REF (2)), (&value))); + PRIMITIVE_RETURN (value); } - PRIMITIVE_RETURN (UNSPECIFIC); } -/* This code returns #t if it succeeds, or the following errors - (besides type and range errors) with the following meanings: - - - ERR_UNBOUND_VARIABLE: - is unbound in . - - - ERR_BAD_SET: - is bound locally in . - - - ERR_BAD_FRAME: - Inconsistency in the code. Bad value found. - - - ILLEGAL_REFERENCE_TRAP: - A bad reference trap was found. - - *UNDEFINE*: If undefine is ever implemented, the code below may be - affected. It will have to be rethought. - - NOTE: The following procedure and extract_or_create_cache have NOT - been parallelized. They need thinking. */ - DEFINE_PRIMITIVE ("ENVIRONMENT-LINK-NAME", Prim_environment_link_name, 3, 3, "(ENV1 ENV2 SYMBOL)\n -SYMBOL must be locally undefined in ENV1, and defined in ENV2.\n -It defines SYMBOL in ENV1 and makes it share its value cell with\n -SYMBOL in ENV2.") +SYMBOL must be bound in ENV2. Creates a new binding for SYMBOL in ENV1,\n +such that the bindings in ENV1 and ENV2 share the same value cell.\n +If SYMBOL is already bound in ENV1, the existing binding is modified.") { PRIMITIVE_HEADER (3); CHECK_ARG (1, ENVIRONMENT_P); CHECK_ARG (2, ENVIRONMENT_P); CHECK_ARG (3, SYMBOL_P); + STD_LOOKUP (link_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("UNBIND-VARIABLE", Prim_unbind_variable, 2, 2, + "(ENVIRONMENT SYMBOL)\n +Unbind the variable SYMBOL in ENVIRONMENT.\n +Returns #F if the variable was not previously bound, otherwise #T.") +{ + PRIMITIVE_HEADER (2); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); { - long result - = (link_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)))); - if (result == PRIM_INTERRUPT) - signal_interrupt_from_primitive (); - if (result != PRIM_DONE) - signal_error_from_primitive (result); - PRIMITIVE_RETURN (SHARP_T); + SCHEME_OBJECT value; + STD_LOOKUP (unbind_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); + PRIMITIVE_RETURN (value); } } diff --git a/v7/src/microcode/lookup.c b/v7/src/microcode/lookup.c index 21b20bbaf..c00ab3b09 100644 --- a/v7/src/microcode/lookup.c +++ b/v7/src/microcode/lookup.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookup.c,v 9.60 2001/08/01 02:17:08 cph Exp $ +$Id: lookup.c,v 9.61 2001/08/02 04:30:08 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -97,53 +97,55 @@ static long assign_variable_end (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT *, int); static long assign_variable_cache (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, int); +static long update_uuo_links + (SCHEME_OBJECT, SCHEME_OBJECT); static long allocate_frame_extension (unsigned long, SCHEME_OBJECT, SCHEME_OBJECT *); -static long merge_caches +static int unbind_extension_variable (SCHEME_OBJECT, SCHEME_OBJECT); -static long handle_cache_reference - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int); static long add_cache_reference - (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int); + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int); static long add_reference (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, unsigned long); static long install_cache (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int); static long install_operator_cache (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); -static long update_cache_references +static long update_cache_for_define (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT); -static unsigned long split_cache_references +static long update_cache_for_unbind + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); +static long update_cache_references + (SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT); +static void split_cache_references (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, SCHEME_OBJECT **); static int environment_ancestor_or_self_p (SCHEME_OBJECT, SCHEME_OBJECT); -static void move_cache_references +static long move_cache_references + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT **); +static void move_cache_references_1 (SCHEME_OBJECT, SCHEME_OBJECT **, unsigned int); -static long update_uuo_links - (SCHEME_OBJECT, SCHEME_OBJECT); static SCHEME_OBJECT * find_binding_cell - (SCHEME_OBJECT, SCHEME_OBJECT); + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); static SCHEME_OBJECT * scan_frame - (SCHEME_OBJECT, SCHEME_OBJECT); + (SCHEME_OBJECT, SCHEME_OBJECT, int); static SCHEME_OBJECT * scan_procedure_bindings - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, int); static unsigned long count_references - (SCHEME_OBJECT, unsigned int); + (SCHEME_OBJECT *); static SCHEME_OBJECT * find_tail_holder - (SCHEME_OBJECT, unsigned int); + (SCHEME_OBJECT *); static void update_assignment_references (SCHEME_OBJECT); static long guarantee_cache (SCHEME_OBJECT *, SCHEME_OBJECT); -static long guarantee_clone +static long update_clone (SCHEME_OBJECT); static void flush_clone (SCHEME_OBJECT); static long make_cache (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); -static long make_cache_references - (SCHEME_OBJECT *); static long make_cache_reference (SCHEME_OBJECT, unsigned long, SCHEME_OBJECT *); @@ -163,7 +165,8 @@ lookup_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, = (find_binding_cell (environment, (((OBJECT_TYPE (symbol)) == TC_VARIABLE) ? (GET_VARIABLE_SYMBOL (symbol)) - : symbol))); + : symbol), + 0)); if (cell == 0) return (ERR_UNBOUND_VARIABLE); @@ -264,6 +267,28 @@ variable_unbound_p (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, return (result); } } + +long +variable_unreferenceable_p (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, + SCHEME_OBJECT * value_ret) +{ + SCHEME_OBJECT dummy_value; + long result = (lookup_variable (environment, symbol, (&dummy_value))); + switch (result) + { + case ERR_UNBOUND_VARIABLE: + case ERR_UNASSIGNED_VARIABLE: + (*value_ret) = SHARP_T; + return (PRIM_DONE); + + case PRIM_DONE: + (*value_ret) = SHARP_F; + return (PRIM_DONE); + + default: + return (result); + } +} long assign_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, @@ -276,7 +301,8 @@ assign_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, = (find_binding_cell (environment, (((OBJECT_TYPE (symbol)) == TC_VARIABLE) ? (GET_VARIABLE_SYMBOL (symbol)) - : symbol))); + : symbol), + 0)); if (cell == 0) return (ERR_UNBOUND_VARIABLE); return (assign_variable_end (cell, value, value_ret, 0)); @@ -311,7 +337,7 @@ assign_variable_end (SCHEME_OBJECT * cell, SCHEME_OBJECT value, (*cell) = (MAP_TO_UNASSIGNED (value)); return (PRIM_DONE); } - + static long assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value, SCHEME_OBJECT * value_ret, int force_p) @@ -334,11 +360,33 @@ assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value, (*value_ret) = (MAP_FROM_UNASSIGNED (old_value)); /* Perform the assignment. If there are any operator references to this variable, update their links. */ - if (PAIR_P (GET_CACHE_REFERENCES_OPERATOR (GET_CACHE_REFERENCES (cache)))) + if (PAIR_P (* (GET_CACHE_OPERATOR_REFERENCES (cache)))) return (update_uuo_links (cache, (MAP_TO_UNASSIGNED (value)))); SET_CACHE_VALUE (cache, (MAP_TO_UNASSIGNED (value))); return (PRIM_DONE); } + +static long +update_uuo_links (SCHEME_OBJECT cache, SCHEME_OBJECT new_value) +{ + RETURN_IF_ERROR (update_clone (cache)); + GC_CHECK + ((count_references (GET_CACHE_OPERATOR_REFERENCES (cache))) + * SPACE_PER_UUO_LINK); + SET_CACHE_VALUE (cache, new_value); + { + SCHEME_OBJECT operators = (* (GET_CACHE_OPERATOR_REFERENCES (cache))); + while (PAIR_P (operators)) + { + SCHEME_OBJECT reference = (PAIR_CAR (operators)); + SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference)); + unsigned long offset = (GET_CACHE_REFERENCE_OFFSET (reference)); + DIE_IF_ERROR (install_operator_cache (cache, block, offset)); + operators = (PAIR_CDR (operators)); + } + } + return (PRIM_DONE); +} long define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, @@ -349,7 +397,7 @@ define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, /* If there is already a binding, just assign to it. */ { - SCHEME_OBJECT * cell = (scan_frame (environment, symbol)); + SCHEME_OBJECT * cell = (scan_frame (environment, symbol, 1)); SCHEME_OBJECT old_value; if (cell != 0) return (assign_variable_end (cell, value, (&old_value), 1)); @@ -397,7 +445,9 @@ define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, recache any references to the other binding, because some of them might now refer to the new binding instead. */ return - (update_cache_references ((PAIR_CDR_LOC (pair)), environment, symbol)); + ((PROCEDURE_FRAME_P (environment)) + ? (update_cache_for_define ((PAIR_CDR_LOC (pair)), environment, symbol)) + : PRIM_DONE); } } @@ -409,10 +459,10 @@ allocate_frame_extension (unsigned long length, SCHEME_OBJECT procedure, GC_CHECK (n_words); { SCHEME_OBJECT extension = (make_vector ((n_words - 1), SHARP_F, 0)); - MEMORY_SET (extension, ENV_EXTENSION_PARENT_FRAME, - (GET_PROCEDURE_ENVIRONMENT (procedure))); - MEMORY_SET (extension, ENV_EXTENSION_PROCEDURE, procedure); - MEMORY_SET (extension, ENV_EXTENSION_COUNT, FIXNUM_ZERO); + SET_FRAME_EXTENSION_PARENT_FRAME + (extension, (GET_PROCEDURE_ENVIRONMENT (procedure))); + SET_FRAME_EXTENSION_PROCEDURE (extension, procedure); + SET_FRAME_EXTENSION_LENGTH (extension, 0); (*extension_ret) = extension; return (PRIM_DONE); } @@ -429,7 +479,7 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, if (! ((ENVIRONMENT_P (target)) && (ENVIRONMENT_P (source)))) return (ERR_BAD_FRAME); - source_cell = (find_binding_cell (source, symbol)); + source_cell = (find_binding_cell (source, symbol, 0)); if (source_cell == 0) return (ERR_UNBOUND_VARIABLE); @@ -437,7 +487,7 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, if (source_kind == TRAP_UNBOUND) return (ERR_UNBOUND_VARIABLE); - target_cell = (scan_frame (target, symbol)); + target_cell = (scan_frame (target, symbol, 1)); if ((target_cell != 0) && ((get_trap_kind (*target_cell)) == TRAP_COMPILER_CACHED)) { @@ -445,7 +495,15 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, if (source_kind == TRAP_COMPILER_CACHED) { SCHEME_OBJECT source_cache = (GET_TRAP_CACHE (*source_cell)); - RETURN_IF_ERROR (merge_caches (target_cache, source_cache)); + SCHEME_OBJECT * tail_holders [3]; + (tail_holders[CACHE_REFERENCES_LOOKUP]) + = (GET_CACHE_LOOKUP_REFERENCES (source_cache)); + (tail_holders[CACHE_REFERENCES_ASSIGNMENT]) + = (GET_CACHE_ASSIGNMENT_REFERENCES (source_cache)); + (tail_holders[CACHE_REFERENCES_OPERATOR]) + = (GET_CACHE_OPERATOR_REFERENCES (source_cache)); + RETURN_IF_ERROR + (move_cache_references (source_cache, target_cache, tail_holders)); SET_CACHE_VALUE (target_cache, (GET_CACHE_VALUE (source_cache))); } else @@ -457,43 +515,82 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, RETURN_IF_ERROR (guarantee_cache (source_cell, symbol)); return (define_variable (target, symbol, (*source_cell))); } - -static long -merge_caches (SCHEME_OBJECT target_cache, SCHEME_OBJECT source_cache) + +long +unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, + SCHEME_OBJECT * value_ret) { - SCHEME_OBJECT target_references = (GET_CACHE_REFERENCES (target_cache)); - SCHEME_OBJECT source_references = (GET_CACHE_REFERENCES (source_cache)); - SCHEME_OBJECT * tail_holders [3]; - - if (((PAIR_P (GET_CACHE_REFERENCES_ASSIGNMENT (target_references))) - || (PAIR_P (GET_CACHE_REFERENCES_ASSIGNMENT (source_references)))) - && ((PAIR_P (GET_CACHE_REFERENCES_OPERATOR (target_references))) - || (PAIR_P (GET_CACHE_REFERENCES_OPERATOR (source_references))))) + SCHEME_OBJECT frame; + SCHEME_OBJECT * cell = (find_binding_cell (environment, symbol, (&frame))); + switch ((cell == 0) ? TRAP_UNBOUND : (get_trap_kind (*cell))) { - RETURN_IF_ERROR (guarantee_clone (target_cache)); - } - else - flush_clone (target_cache); + case TRAP_UNBOUND: + (*value_ret) = SHARP_F; + return (PRIM_DONE); - GC_CHECK - ((count_references (source_cache, CACHE_REFERENCES_OPERATOR)) - * SPACE_PER_UUO_LINK); + case NON_TRAP_KIND: + case TRAP_UNASSIGNED: + if (!unbind_extension_variable (frame, symbol)) + (*cell) = UNBOUND_OBJECT; + (*value_ret) = SHARP_T; + return (PRIM_DONE); - (tail_holders[CACHE_REFERENCES_LOOKUP]) - = (MEMORY_LOC (source_references, CACHE_REFERENCES_LOOKUP)); - (tail_holders[CACHE_REFERENCES_ASSIGNMENT]) - = (MEMORY_LOC (source_references, CACHE_REFERENCES_ASSIGNMENT)); - (tail_holders[CACHE_REFERENCES_OPERATOR]) - = (MEMORY_LOC (source_references, CACHE_REFERENCES_OPERATOR)); + case TRAP_COMPILER_CACHED: + { + SCHEME_OBJECT cache = (GET_TRAP_CACHE (*cell)); + switch (get_trap_kind (GET_CACHE_VALUE (cache))) + { + case TRAP_UNBOUND: + (*value_ret) = SHARP_F; + return (PRIM_DONE); + + case NON_TRAP_KIND: + case TRAP_UNASSIGNED: + if (PROCEDURE_FRAME_P (frame)) + { + if (!unbind_extension_variable (frame, symbol)) + (*cell) = UNBOUND_OBJECT; + RETURN_IF_ERROR + (update_cache_for_unbind (cache, frame, symbol)); + } + else + { + SET_CACHE_VALUE (cache, UNBOUND_OBJECT); + } + (*value_ret) = SHARP_T; + return (PRIM_DONE); + + default: + return (ERR_ILLEGAL_REFERENCE_TRAP); + } + } - move_cache_references - (target_cache, tail_holders, CACHE_REFERENCES_LOOKUP); - move_cache_references - (target_cache, tail_holders, CACHE_REFERENCES_ASSIGNMENT); - move_cache_references - (target_cache, tail_holders, CACHE_REFERENCES_OPERATOR); + default: + return (ERR_ILLEGAL_REFERENCE_TRAP); + } +} - return (PRIM_DONE); +static int +unbind_extension_variable (SCHEME_OBJECT frame, SCHEME_OBJECT symbol) +{ + if ((PROCEDURE_FRAME_P (frame)) && (EXTENDED_FRAME_P (frame))) + { + SCHEME_OBJECT * start = (GET_EXTENDED_FRAME_BINDINGS (frame)); + unsigned long length = (GET_EXTENDED_FRAME_LENGTH (frame)); + unsigned long index = 0; + while (index < length) + { + if ((start[index]) == symbol) + { + if (index < (length - 1)) + (start[index]) = (start [length - 1]); + SET_EXTENDED_FRAME_LENGTH (frame, (length - 1)); + return (1); + } + index += 1; + } + } + return (0); } /***** Interface to compiled code. *****/ @@ -503,9 +600,9 @@ compiler_cache_lookup (SCHEME_OBJECT name, SCHEME_OBJECT block, unsigned long offset) { return - (handle_cache_reference ((compiled_block_environment (block)), - name, block, offset, - CACHE_REFERENCES_LOOKUP)); + (add_cache_reference ((compiled_block_environment (block)), + name, block, offset, + CACHE_REFERENCES_LOOKUP)); } long @@ -513,9 +610,9 @@ compiler_cache_assignment (SCHEME_OBJECT name, SCHEME_OBJECT block, unsigned long offset) { return - (handle_cache_reference ((compiled_block_environment (block)), - name, block, offset, - CACHE_REFERENCES_ASSIGNMENT)); + (add_cache_reference ((compiled_block_environment (block)), + name, block, offset, + CACHE_REFERENCES_ASSIGNMENT)); } long @@ -523,9 +620,9 @@ compiler_cache_operator (SCHEME_OBJECT name, SCHEME_OBJECT block, unsigned long offset) { return - (handle_cache_reference ((compiled_block_environment (block)), - name, block, offset, - CACHE_REFERENCES_OPERATOR)); + (add_cache_reference ((compiled_block_environment (block)), + name, block, offset, + CACHE_REFERENCES_OPERATOR)); } long @@ -533,21 +630,9 @@ compiler_cache_global_operator (SCHEME_OBJECT name, SCHEME_OBJECT block, unsigned long offset) { return - (handle_cache_reference (THE_GLOBAL_ENV, - name, block, offset, - CACHE_REFERENCES_OPERATOR)); -} - -static long -handle_cache_reference (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, - SCHEME_OBJECT block, unsigned long offset, - unsigned int reference_kind) -{ - SCHEME_OBJECT * cell = (find_binding_cell (environment, symbol)); - return - ((cell == 0) - ? ERR_UNBOUND_VARIABLE - : (add_cache_reference (cell, symbol, block, offset, reference_kind))); + (add_cache_reference (THE_GLOBAL_ENV, + name, block, offset, + CACHE_REFERENCES_OPERATOR)); } SCHEME_OBJECT @@ -621,9 +706,7 @@ compiler_operator_reference_trap (SCHEME_OBJECT cache, /* add_cache_reference adds a reference to a variable's cache, creating the cache if necessary. It takes the following arguments: - + cell is a variable's value cell. - - + symbol is the variable's name. + + environment and symbol specify the affected variable. + block is a compiled-code block, and offset is an offset into block. Together, these specify the location where the variable @@ -659,12 +742,18 @@ compiler_operator_reference_trap (SCHEME_OBJECT cache, to it. */ static long -add_cache_reference (SCHEME_OBJECT * cell, - SCHEME_OBJECT symbol, - SCHEME_OBJECT block, - unsigned long offset, +add_cache_reference (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, + SCHEME_OBJECT block, unsigned long offset, unsigned int reference_kind) { + SCHEME_OBJECT * cell = (find_binding_cell (environment, symbol, 0)); + SCHEME_OBJECT dummy_cell = UNBOUND_OBJECT; + if (cell == 0) + /* There's no binding for the variable, and we don't have access + to the global environment. The compiled code needs a cache, so + we'll install one, but it won't be attached to any environment + structure. */ + cell = (&dummy_cell); /* This procedure must complete to keep the data structures consistent, so we do a GC check in advance to guarantee that all of the allocations will finish. */ @@ -672,12 +761,8 @@ add_cache_reference (SCHEME_OBJECT * cell, RETURN_IF_ERROR (guarantee_cache (cell, symbol)); { SCHEME_OBJECT cache = (GET_TRAP_CACHE (*cell)); - SCHEME_OBJECT references = (GET_CACHE_REFERENCES (cache)); - RETURN_IF_ERROR - (add_reference (references, reference_kind, block, offset)); - if ((PAIR_P (GET_CACHE_REFERENCES_ASSIGNMENT (references))) - && (PAIR_P (GET_CACHE_REFERENCES_OPERATOR (references)))) - RETURN_IF_ERROR (guarantee_clone (cache)); + RETURN_IF_ERROR (add_reference (cache, reference_kind, block, offset)); + RETURN_IF_ERROR (update_clone (cache)); return (install_cache (cache, block, offset, reference_kind)); } } @@ -687,26 +772,26 @@ add_cache_reference (SCHEME_OBJECT * cell, garbage collector. */ static long -add_reference (SCHEME_OBJECT references, unsigned int reference_kind, +add_reference (SCHEME_OBJECT cache, unsigned int reference_kind, SCHEME_OBJECT block, unsigned long offset) { - SCHEME_OBJECT * slot = (MEMORY_LOC (references, reference_kind)); - while (PAIR_P (*slot)) + SCHEME_OBJECT * holder = (GET_CACHE_REFERENCES (cache, reference_kind)); + while (PAIR_P (*holder)) { - SCHEME_OBJECT reference = (PAIR_CAR (*slot)); + SCHEME_OBJECT reference = (PAIR_CAR (*holder)); if ((GET_CACHE_REFERENCE_BLOCK (reference)) == SHARP_F) { SET_CACHE_REFERENCE_BLOCK (reference, block); SET_CACHE_REFERENCE_OFFSET (reference, offset); return (PRIM_DONE); } - slot = (PAIR_CDR_LOC (*slot)); + holder = (PAIR_CDR_LOC (*holder)); } { SCHEME_OBJECT reference; RETURN_IF_ERROR (make_cache_reference (block, offset, (&reference))); GC_CHECK (2); - (*slot) = (cons (reference, EMPTY_LIST)); + (*holder) = (cons (reference, EMPTY_LIST)); } return (PRIM_DONE); } @@ -751,9 +836,12 @@ install_operator_cache (SCHEME_OBJECT cache, : (make_uuo_link (value, cache, block, offset))); } -/* update_cache_references is invoked when a new binding is created. +/* update_cache_for_define is invoked when a new binding is created. It recaches (at the definition point) all the references that need - to point to the new cell. It does this in two phases: + to point to the new cell. update_cache_for_unbind is called when a + binding is removed. It recaches references from the cache of the + now unbound variable. Both procedures call + update_cache_references, which does the following: First, split_cache_references is called to split all references into those that need to be updated and those that do not. This is @@ -767,72 +855,70 @@ install_operator_cache (SCHEME_OBJECT cache, references are moved to their new locations. */ static long -update_cache_references (SCHEME_OBJECT * new_cell, +update_cache_for_define (SCHEME_OBJECT * new_cell, SCHEME_OBJECT environment, SCHEME_OBJECT symbol) { - SCHEME_OBJECT * shadowed_cell; - SCHEME_OBJECT * tail_holders [3]; - SCHEME_OBJECT new_cache; + SCHEME_OBJECT * shadowed_cell + = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0)); + return + (((shadowed_cell != 0) + && ((get_trap_kind (*shadowed_cell)) == TRAP_COMPILER_CACHED)) + ? (update_cache_references + ((GET_TRAP_CACHE (*shadowed_cell)), new_cell, environment, symbol)) + : PRIM_DONE); +} - if (!PROCEDURE_FRAME_P (environment)) - return (PRIM_DONE); +static long +update_cache_for_unbind (SCHEME_OBJECT old_cache, + SCHEME_OBJECT environment, SCHEME_OBJECT symbol) +{ + SCHEME_OBJECT * shadowed_cell + = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0)); + SCHEME_OBJECT dummy_cell = UNBOUND_OBJECT; - shadowed_cell - = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol)); - if (! ((shadowed_cell != 0) - && ((get_trap_kind (*shadowed_cell)) == TRAP_COMPILER_CACHED))) - return (PRIM_DONE); + return + (update_cache_references (old_cache, + ((shadowed_cell == 0) + ? (&dummy_cell) + : shadowed_cell), + environment, symbol)); +} - RETURN_IF_ERROR (guarantee_cache (new_cell, symbol)); - new_cache = (GET_TRAP_CACHE (*new_cell)); +static long +update_cache_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT * to_cell, + SCHEME_OBJECT environment, SCHEME_OBJECT symbol) +{ + SCHEME_OBJECT * tail_holders [3]; /* Split the references lists. */ - { - SCHEME_OBJECT shadowed_cache = (GET_TRAP_CACHE (*shadowed_cell)); - unsigned long n_lookups - = (split_cache_references - (shadowed_cache, CACHE_REFERENCES_LOOKUP, environment, - tail_holders)); - unsigned long n_assignments - = (split_cache_references - (shadowed_cache, CACHE_REFERENCES_ASSIGNMENT, environment, - tail_holders)); - unsigned long n_operators - = (split_cache_references - (shadowed_cache, CACHE_REFERENCES_OPERATOR, environment, - tail_holders)); - - /* Return if there are no references that need to be updated. */ - if ((n_lookups == 0) && (n_assignments == 0) && (n_operators == 0)) - return (PRIM_DONE); - - /* Make sure the cache has a clone if one will be needed. */ - if ((n_assignments > 0) && (n_operators > 0)) - RETURN_IF_ERROR (guarantee_clone (new_cache)); - - /* Next step must be atomic. In order to guarantee this, we need - enough space to allocate all of the UUO links. */ - GC_CHECK (n_operators * SPACE_PER_UUO_LINK); - } + split_cache_references + (from_cache, CACHE_REFERENCES_LOOKUP, environment, tail_holders); + split_cache_references + (from_cache, CACHE_REFERENCES_ASSIGNMENT, environment, tail_holders); + split_cache_references + (from_cache, CACHE_REFERENCES_OPERATOR, environment, tail_holders); + + /* Return if there are no references that need to be updated. */ + if ((!PAIR_P (* (tail_holders[CACHE_REFERENCES_LOOKUP]))) + && (!PAIR_P (* (tail_holders[CACHE_REFERENCES_ASSIGNMENT]))) + && (!PAIR_P (* (tail_holders[CACHE_REFERENCES_OPERATOR])))) + return (PRIM_DONE); - /* Move all the references. */ - move_cache_references (new_cache, tail_holders, CACHE_REFERENCES_LOOKUP); - move_cache_references (new_cache, tail_holders, CACHE_REFERENCES_ASSIGNMENT); - move_cache_references (new_cache, tail_holders, CACHE_REFERENCES_OPERATOR); + RETURN_IF_ERROR (guarantee_cache (to_cell, symbol)); - return (PRIM_DONE); + return + (move_cache_references + (from_cache, (GET_TRAP_CACHE (*to_cell)), tail_holders)); } -static unsigned long +static void split_cache_references (SCHEME_OBJECT cache, unsigned int reference_kind, SCHEME_OBJECT environment, SCHEME_OBJECT ** tail_holders) { - SCHEME_OBJECT * holder - = (MEMORY_LOC ((GET_CACHE_REFERENCES (cache)), reference_kind)); + SCHEME_OBJECT * holder = (GET_CACHE_REFERENCES (cache, reference_kind)); SCHEME_OBJECT references_to_move = EMPTY_LIST; - unsigned long count = 0; while (PAIR_P (*holder)) { SCHEME_OBJECT p = (*holder); @@ -846,14 +932,12 @@ split_cache_references (SCHEME_OBJECT cache, (*holder) = (PAIR_CDR (p)); SET_PAIR_CDR (p, references_to_move); references_to_move = p; - count += 1; } else holder = (PAIR_CDR_LOC (p)); } (*holder) = references_to_move; (tail_holders[reference_kind]) = holder; - return (count); } static int @@ -869,14 +953,30 @@ environment_ancestor_or_self_p (SCHEME_OBJECT ancestor, return (descendant == ancestor); } +static long +move_cache_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache, + SCHEME_OBJECT ** tail_holders) +{ + GC_CHECK + (((count_references (tail_holders[CACHE_REFERENCES_OPERATOR])) + * SPACE_PER_UUO_LINK) + + (2 * SPACE_PER_CACHE)); + move_cache_references_1 (to_cache, tail_holders, CACHE_REFERENCES_LOOKUP); + move_cache_references_1 + (to_cache, tail_holders, CACHE_REFERENCES_ASSIGNMENT); + move_cache_references_1 (to_cache, tail_holders, CACHE_REFERENCES_OPERATOR); + RETURN_IF_ERROR (update_clone (from_cache)); + RETURN_IF_ERROR (update_clone (to_cache)); + return (PRIM_DONE); +} + static void -move_cache_references (SCHEME_OBJECT cache, SCHEME_OBJECT ** tail_holders, - unsigned int reference_kind) +move_cache_references_1 (SCHEME_OBJECT cache, SCHEME_OBJECT ** tail_holders, + unsigned int reference_kind) { SCHEME_OBJECT tail = (* (tail_holders[reference_kind])); (* (tail_holders[reference_kind])) = EMPTY_LIST; - (* (find_tail_holder ((GET_CACHE_REFERENCES (cache)), reference_kind))) - = tail; + (* (find_tail_holder (GET_CACHE_REFERENCES (cache, reference_kind)))) = tail; while (PAIR_P (tail)) { DIE_IF_ERROR @@ -888,63 +988,28 @@ move_cache_references (SCHEME_OBJECT cache, SCHEME_OBJECT ** tail_holders, } } -/* update_uuo_links is invoked when an assignment occurs to a - variable which has cached operator references (uuo links). - All the operator references must be recached to the new value. - - It currently potentially creates a new uuo link per operator - reference. This may be very expensive in space, but allows a great - deal of flexibility. It is ultimately necessary if there is hidden - information on each call (like arity, types of arguments, etc.). */ - -static long -update_uuo_links (SCHEME_OBJECT cache, SCHEME_OBJECT new_value) -{ - { - unsigned long n_operators - = (count_references (cache, CACHE_REFERENCES_OPERATOR)); - if (n_operators == 0) - { - /* We no longer need a cache clone, so if there is one, delete - it and change any assignment references to refer to the - cache itself. */ - flush_clone (cache); - } - GC_CHECK (n_operators * SPACE_PER_UUO_LINK); - } - SET_CACHE_VALUE (cache, new_value); - { - SCHEME_OBJECT operators - = (GET_CACHE_REFERENCES_OPERATOR (GET_CACHE_REFERENCES (cache))); - while (PAIR_P (operators)) - { - SCHEME_OBJECT reference = (PAIR_CAR (operators)); - SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference)); - unsigned long offset = (GET_CACHE_REFERENCE_OFFSET (reference)); - DIE_IF_ERROR (install_operator_cache (cache, block, offset)); - operators = (PAIR_CDR (operators)); - } - } - return (PRIM_DONE); -} - /***** Utilities *****/ static SCHEME_OBJECT * -find_binding_cell (SCHEME_OBJECT environment, SCHEME_OBJECT symbol) +find_binding_cell (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, + SCHEME_OBJECT * frame_ret) { SCHEME_OBJECT frame = environment; while (1) { - SCHEME_OBJECT * cell = (scan_frame (frame, symbol)); + SCHEME_OBJECT * cell = (scan_frame (frame, symbol, 0)); if ((cell != 0) || (!PROCEDURE_FRAME_P (frame))) - return (cell); + { + if (frame_ret != 0) + (*frame_ret) = frame; + return (cell); + } frame = (GET_FRAME_PARENT (frame)); } } static SCHEME_OBJECT * -scan_frame (SCHEME_OBJECT frame, SCHEME_OBJECT symbol) +scan_frame (SCHEME_OBJECT frame, SCHEME_OBJECT symbol, int find_unbound_p) { if (PROCEDURE_FRAME_P (frame)) { @@ -960,12 +1025,12 @@ scan_frame (SCHEME_OBJECT frame, SCHEME_OBJECT symbol) scan += 1; } return - (scan_procedure_bindings - ((GET_EXTENDED_FRAME_PROCEDURE (frame)), frame, symbol)); + (scan_procedure_bindings ((GET_EXTENDED_FRAME_PROCEDURE (frame)), + frame, symbol, find_unbound_p)); } return - (scan_procedure_bindings - ((GET_FRAME_PROCEDURE (frame)), frame, symbol)); + (scan_procedure_bindings ((GET_FRAME_PROCEDURE (frame)), + frame, symbol, find_unbound_p)); } else if (GLOBAL_FRAME_P (frame)) return (SYMBOL_GLOBAL_VALUE_CELL (symbol)); @@ -975,7 +1040,7 @@ scan_frame (SCHEME_OBJECT frame, SCHEME_OBJECT symbol) static SCHEME_OBJECT * scan_procedure_bindings (SCHEME_OBJECT procedure, SCHEME_OBJECT frame, - SCHEME_OBJECT symbol) + SCHEME_OBJECT symbol, int find_unbound_p) { SCHEME_OBJECT lambda = (GET_PROCEDURE_LAMBDA (procedure)); SCHEME_OBJECT * start = (GET_LAMBDA_PARAMETERS (lambda)); @@ -984,7 +1049,11 @@ scan_procedure_bindings (SCHEME_OBJECT procedure, SCHEME_OBJECT frame, while (scan < end) { if ((*scan) == symbol) - return (GET_FRAME_ARG_CELL (frame, (scan - start))); + { + SCHEME_OBJECT * cell = (GET_FRAME_ARG_CELL (frame, (scan - start))); + if (find_unbound_p || ((*cell) != UNBOUND_OBJECT)) + return (cell); + } scan += 1; } return (0); @@ -1006,10 +1075,8 @@ get_trap_kind (SCHEME_OBJECT object) } static unsigned long -count_references (SCHEME_OBJECT cache, unsigned int references_kind) +count_references (SCHEME_OBJECT * holder) { - SCHEME_OBJECT * holder - = (MEMORY_LOC ((GET_CACHE_REFERENCES (cache)), references_kind)); unsigned long n_references = 0; while (PAIR_P (*holder)) { @@ -1027,9 +1094,8 @@ count_references (SCHEME_OBJECT cache, unsigned int references_kind) } static SCHEME_OBJECT * -find_tail_holder (SCHEME_OBJECT references, unsigned int reference_kind) +find_tail_holder (SCHEME_OBJECT * holder) { - SCHEME_OBJECT * holder = (MEMORY_LOC (references, reference_kind)); while (PAIR_P (*holder)) { SCHEME_OBJECT p = (*holder); @@ -1044,9 +1110,7 @@ find_tail_holder (SCHEME_OBJECT references, unsigned int reference_kind) static void update_assignment_references (SCHEME_OBJECT cache) { - SCHEME_OBJECT * holder - = (MEMORY_LOC ((GET_CACHE_REFERENCES (cache)), - CACHE_REFERENCES_ASSIGNMENT)); + SCHEME_OBJECT * holder = (GET_CACHE_ASSIGNMENT_REFERENCES (cache)); SCHEME_OBJECT reference_cache = (((GET_CACHE_CLONE (cache)) != SHARP_F) ? (GET_CACHE_CLONE (cache)) @@ -1076,7 +1140,12 @@ guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol) if ((get_trap_kind (*cell)) == TRAP_COMPILER_CACHED) return (PRIM_DONE); - RETURN_IF_ERROR (make_cache_references (&references)); + GC_CHECK (3); + references = (MAKE_POINTER_OBJECT (CACHE_REFERENCES_TYPE, Free)); + (*Free++) = EMPTY_LIST; + (*Free++) = EMPTY_LIST; + (*Free++) = EMPTY_LIST; + RETURN_IF_ERROR (make_cache ((*cell), symbol, SHARP_F, references, (&cache))); @@ -1088,20 +1157,27 @@ guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol) } static long -guarantee_clone (SCHEME_OBJECT cache) +update_clone (SCHEME_OBJECT cache) { - if ((GET_CACHE_CLONE (cache)) == SHARP_F) + if ((PAIR_P (* (GET_CACHE_ASSIGNMENT_REFERENCES (cache)))) + && (PAIR_P (* (GET_CACHE_OPERATOR_REFERENCES (cache))))) { - SCHEME_OBJECT clone; - RETURN_IF_ERROR - (make_cache (EXPENSIVE_OBJECT, - (GET_CACHE_NAME (cache)), - cache, - (GET_CACHE_REFERENCES (cache)), - (&clone))); - SET_CACHE_CLONE (cache, clone); - update_assignment_references (cache); + if ((GET_CACHE_CLONE (cache)) == SHARP_F) + { + SCHEME_OBJECT clone; + RETURN_IF_ERROR + (make_cache (EXPENSIVE_OBJECT, + (GET_CACHE_NAME (cache)), + cache, + (GET_CACHE_REFERENCES_OBJECT (cache)), + (&clone))); + SET_CACHE_CLONE (cache, clone); + update_assignment_references (cache); + } + return (PRIM_DONE); } + else + flush_clone (cache); return (PRIM_DONE); } @@ -1128,17 +1204,6 @@ make_cache (SCHEME_OBJECT value, SCHEME_OBJECT symbol, SCHEME_OBJECT clone, return (PRIM_DONE); } -static long -make_cache_references (SCHEME_OBJECT * refs_ret) -{ - GC_CHECK (3); - (*Free++) = EMPTY_LIST; - (*Free++) = EMPTY_LIST; - (*Free++) = EMPTY_LIST; - (*refs_ret) = (MAKE_POINTER_OBJECT (CACHE_REFERENCES_TYPE, (Free - 3))); - return (PRIM_DONE); -} - static long make_cache_reference (SCHEME_OBJECT block, unsigned long offset, SCHEME_OBJECT * ref_ret) diff --git a/v7/src/microcode/lookup.h b/v7/src/microcode/lookup.h index 80b44d29d..bfe034858 100644 --- a/v7/src/microcode/lookup.h +++ b/v7/src/microcode/lookup.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookup.h,v 9.53 2001/07/31 03:11:52 cph Exp $ +$Id: lookup.h,v 9.54 2001/08/02 04:30:12 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -35,12 +35,16 @@ extern long variable_unassigned_p (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); extern long variable_unbound_p (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); +extern long variable_unreferenceable_p + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); extern long assign_variable (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); extern long define_variable (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); extern long link_variable (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); +extern long unbind_variable + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); extern trap_kind_t get_trap_kind (SCHEME_OBJECT); diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h index d0f3957c2..4073e9072 100644 --- a/v7/src/microcode/sdata.h +++ b/v7/src/microcode/sdata.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: sdata.h,v 9.36 2001/08/01 02:17:31 cph Exp $ +$Id: sdata.h,v 9.37 2001/08/02 04:30:16 cph Exp $ Copyright (c) 1987-1989, 1999, 2001 Massachusetts Institute of Technology @@ -282,6 +282,12 @@ USA. #define GET_FRAME_EXTENSION_PROCEDURE(extension) \ (MEMORY_REF ((extension), ENV_EXTENSION_PROCEDURE)) + +#define SET_FRAME_EXTENSION_PROCEDURE(extension, procedure) \ + MEMORY_SET ((extension), ENV_EXTENSION_PROCEDURE, (procedure)) + +#define SET_FRAME_EXTENSION_PARENT_FRAME(extension, frame) \ + MEMORY_SET ((extension), ENV_EXTENSION_PARENT_FRAME, (frame)) /* EXTENDED_FIXNUM * Not used in the C version. On the 68000 this is used for 24-bit @@ -453,27 +459,22 @@ USA. #define SET_CACHE_CLONE(cache, clone) \ MEMORY_SET ((cache), TRAP_EXTENSION_CLONE, (clone)) -#define GET_CACHE_REFERENCES(cache) \ +#define GET_CACHE_REFERENCES_OBJECT(cache) \ (MEMORY_REF ((cache), TRAP_EXTENSION_REFERENCES)) -#define GET_CACHE_REFERENCES_LOOKUP(references) \ - (MEMORY_REF ((references), CACHE_REFERENCES_LOOKUP)) - -#define SET_CACHE_REFERENCES_LOOKUP(references, list) \ - MEMORY_SET ((references), CACHE_REFERENCES_LOOKUP, (list))) - -#define GET_CACHE_REFERENCES_ASSIGNMENT(references) \ - (MEMORY_REF ((references), CACHE_REFERENCES_ASSIGNMENT)) +#define GET_CACHE_REFERENCES(cache, kind) \ + (MEMORY_LOC ((MEMORY_REF ((cache), TRAP_EXTENSION_REFERENCES)), \ + (kind))) -#define SET_CACHE_REFERENCES_ASSIGNMENT(references, list) \ - MEMORY_SET ((references), CACHE_REFERENCES_ASSIGNMENT, (list))) +#define GET_CACHE_LOOKUP_REFERENCES(cache) \ + (GET_CACHE_REFERENCES ((cache), CACHE_REFERENCES_LOOKUP)) -#define GET_CACHE_REFERENCES_OPERATOR(references) \ - (MEMORY_REF ((references), CACHE_REFERENCES_OPERATOR)) +#define GET_CACHE_ASSIGNMENT_REFERENCES(cache) \ + (GET_CACHE_REFERENCES ((cache), CACHE_REFERENCES_ASSIGNMENT)) -#define SET_CACHE_REFERENCES_OPERATOR(references, list) \ - MEMORY_SET ((references), CACHE_REFERENCES_OPERATOR, (list))) +#define GET_CACHE_OPERATOR_REFERENCES(cache) \ + (GET_CACHE_REFERENCES ((cache), CACHE_REFERENCES_OPERATOR)) #define GET_CACHE_REFERENCE_BLOCK(reference) \ -- 2.25.1