/* -*-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
(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 *);
\f
= (find_binding_cell (environment,
(((OBJECT_TYPE (symbol)) == TC_VARIABLE)
? (GET_VARIABLE_SYMBOL (symbol))
- : symbol)));
+ : symbol),
+ 0));
if (cell == 0)
return (ERR_UNBOUND_VARIABLE);
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);
+ }
+}
\f
long
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));
(*cell) = (MAP_TO_UNASSIGNED (value));
return (PRIM_DONE);
}
-
+\f
static long
assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value,
SCHEME_OBJECT * value_ret, int force_p)
(*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);
+}
\f
long
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));
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);
}
}
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);
}
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);
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))
{
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
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)
+\f
+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);
}
\f
/***** Interface to compiled code. *****/
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
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
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
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
/* 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
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. */
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));
}
}
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);
}
: (make_uuo_link (value, cache, block, offset)));
}
\f
-/* 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
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));
}
\f
-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);
(*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
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
}
}
\f
-/* 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);
-}
-\f
/***** 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))
{
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));
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));
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);
}
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))
{
}
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);
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))
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)));
}
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);
}
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)
projects / mit-scheme.git / commitdiff