/* -*-C-*-
-$Id: lookup.c,v 9.58 2000/12/05 21:23:45 cph Exp $
+$Id: lookup.c,v 9.59 2001/07/31 03:11:48 cph Exp $
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
*/
-/*
- * This file contains symbol lookup and modification routines.
- * See a paper by Jim Miller and Bill Rozas in Lisp and Symbolic Computation
- * (4th issue 1990) for a justification of the algorithms.
- */
+/* Environment lookup, modification, and definition. */
#include "scheme.h"
-#include "locks.h"
#include "trap.h"
#include "lookup.h"
-static void EXFUN (fix_references, (SCHEME_OBJECT *, SCHEME_OBJECT));
-static long EXFUN
- (add_reference, (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT));
+extern long make_uuo_link
+ (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+extern long make_fake_uuo_link
+ (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+extern SCHEME_OBJECT extract_uuo_link
+ (SCHEME_OBJECT, unsigned long);
-/* NOTE:
- Although this code has been parallelized, it has not been
- exhaustively tried on a parallel processor. There are probably
- various race conditions/potential deadlocks that have to be thought
- about carefully.
- */
-\f
-/* Useful constants. */
-
-/* This is returned by various procedures to cause a Scheme
- unbound variable error to be signalled.
- */
-
-SCHEME_OBJECT unbound_trap_object[] = { UNBOUND_OBJECT };
-
-/* This is returned by lookup to force a deep lookup when the variable
- needs to be recompiled.
- */
-
-SCHEME_OBJECT uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
-
-/* This is returned by lookup to cause a Scheme broken compiled
- variable error to be signalled.
- */
-
-SCHEME_OBJECT illegal_trap_object[] = { ILLEGAL_OBJECT };
-
-/* This is passed to deep_lookup as the variable to compile when
- we don't really have a variable.
- */
-
-SCHEME_OBJECT fake_variable_object[3];
-\f
-/* scan_frame searches a frame for a given name.
- If it finds the names, it stores into hunk the path by which it was
- found, so that future references do not spend the time to find it
- again. It returns a pointer to the value cell, or a null pointer
- cell if the variable was not found in this frame.
- */
-
-extern SCHEME_OBJECT *
- EXFUN (scan_frame,
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, long, Boolean));
-
-SCHEME_OBJECT *
-DEFUN (scan_frame, (frame, sym, hunk, depth, unbound_valid_p),
- SCHEME_OBJECT frame
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT * hunk
- AND long depth
- AND Boolean unbound_valid_p)
-{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (compile_serializer);
-#endif
- fast SCHEME_OBJECT *scan, temp;
- fast long count;
-
- temp = MEMORY_REF (frame, ENVIRONMENT_FUNCTION);
-
- if (OBJECT_TYPE (temp) == AUX_LIST_TYPE)
- {
- /* Search for an auxiliary binding. */
-
- SCHEME_OBJECT *start;
-
- scan = OBJECT_ADDRESS (temp);
- start = scan;
- count = Lexical_Offset(scan[AUX_LIST_COUNT]);
- scan += AUX_LIST_FIRST;
-
- while (--count >= 0)
- {
- if (FAST_PAIR_CAR (*scan) == sym)
- {
- SCHEME_OBJECT *cell;
-
- cell = PAIR_CDR_LOC (*scan);
- if (MEMORY_FETCH (cell[0]) == DANGEROUS_UNBOUND_OBJECT)
- {
- /* A dangerous unbound object signals that
- a definition here must become dangerous,
- but is not a real bining.
- */
- return (unbound_valid_p ? (cell) : ((SCHEME_OBJECT *) NULL));
- }
- setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (AUX_REF, depth);
- hunk[VARIABLE_OFFSET] = Make_Local_Offset(scan - start);
- remove_lock(compile_serializer);
- return (cell);
- }
- scan += 1;
- }
- temp = MEMORY_REF (temp, ENV_EXTENSION_PROCEDURE);
- }
-\f
- /* Search for a formal parameter. */
-
- temp = (FAST_MEMORY_REF ((FAST_MEMORY_REF (temp, PROCEDURE_LAMBDA_EXPR)),
- LAMBDA_FORMALS));
- for (count = ((VECTOR_LENGTH (temp)) - 1),
- scan = (MEMORY_LOC (temp, VECTOR_DATA + 1));
- count > 0;
- count -= 1,
- scan += 1)
- {
- if (*scan == sym)
- {
- fast long offset;
-
- offset = 1 + VECTOR_LENGTH (temp) - count;
-
- setup_lock(compile_serializer, hunk);
- if (depth != 0)
- {
- hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (FORMAL_REF, depth);
- hunk[VARIABLE_OFFSET] = Make_Local_Offset(offset);
- }
- else
- {
- hunk[VARIABLE_COMPILED_TYPE] = Make_Local_Offset(offset);
- hunk[VARIABLE_OFFSET] = SHARP_F;
- }
- remove_lock(compile_serializer);
-
- return (MEMORY_LOC (frame, offset));
- }
- }
-
- return ((SCHEME_OBJECT *) NULL);
-}
-\f
-/* The lexical lookup procedure.
- deep_lookup searches env for an occurrence of sym. When it finds
- it, it stores into hunk the path by which it was found, so that
- future references do not spend the time to find it again.
- It returns a pointer to the value cell, or a bogus value cell if
- the variable was unbound.
- */
-
-SCHEME_OBJECT *
-DEFUN (deep_lookup, (env, sym, hunk),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT * hunk)
-{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (compile_serializer);
-#endif
- fast SCHEME_OBJECT frame;
- fast long depth;
-
- for (depth = 0, frame = env;
- OBJECT_TYPE (frame) != GLOBAL_ENV;
- depth += 1,
- frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION),
- PROCEDURE_ENVIRONMENT))
- {
- fast SCHEME_OBJECT *cell;
-
- cell = (scan_frame (frame, sym, hunk, depth, false));
- if (cell != ((SCHEME_OBJECT *) NULL))
- {
- return (cell);
- }
- }
-
- /* The reference is global. */
-
- if (OBJECT_DATUM (frame) != GO_TO_GLOBAL)
- {
- return (unbound_trap_object);
- }
-
- setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, sym));
- hunk[VARIABLE_OFFSET] = SHARP_F;
- remove_lock(compile_serializer);
-
- return (MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE));
-}
-\f
-/* Shallow lookup performed "out of line" by various procedures.
- It takes care of invoking deep_lookup when necessary.
- */
-
-extern SCHEME_OBJECT *
- EXFUN (lookup_cell, (SCHEME_OBJECT *, SCHEME_OBJECT));
-
-SCHEME_OBJECT *
-DEFUN (lookup_cell, (hunk, env),
- SCHEME_OBJECT * hunk
- AND SCHEME_OBJECT env)
-{
- SCHEME_OBJECT *cell, value;
- long trap_kind;
-
- lookup(cell, env, hunk, repeat_lookup_cell);
-
- value = MEMORY_FETCH (cell[0]);
-
- if (OBJECT_TYPE (value) != TC_REFERENCE_TRAP)
- {
- return (cell);
- }
-
- get_trap_kind(trap_kind, value);
- switch(trap_kind)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- return (deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk));
-
- case TRAP_COMPILER_CACHED:
- case TRAP_FLUID:
- case TRAP_UNBOUND:
- case TRAP_UNASSIGNED:
- return (cell);
-
- default:
- return (illegal_trap_object);
- }
-}
-\f
-/* Full lookup end code.
- deep_lookup_end handles all the complicated and dangerous cases.
- cell is the value cell (supposedly found by deep_lookup). Hunk is
- the address of the scode variable object which may need to be
- recompiled if the reference is dangerous.
- */
-
-long
-DEFUN (deep_lookup_end, (cell, hunk),
- SCHEME_OBJECT * cell
- AND SCHEME_OBJECT * hunk)
-{
- long trap_kind;
- long return_value = PRIM_DONE;
- Boolean repeat_p;
-
- do {
- repeat_p = false;
- Val = MEMORY_FETCH (cell[0]);
- FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
- if (!(REFERENCE_TRAP_P(Val)))
- {
- return (PRIM_DONE);
- }
-
- /* Remarks:
- In the code below, break means uncompile the variable,
- while continue means do not.
- If repeat_p is set the whole process is redone, but since the
- "danger bit" is kept on the outermost trap, the "uncompilation"
- will not be affected by subsequent iterations.
- */
-
- get_trap_kind(trap_kind, Val);
- switch(trap_kind)
- {
- /* The following cases are divided into pairs:
- the non-dangerous version leaves the compilation alone.
- The dangerous version uncompiles.
- */
-
- case TRAP_UNASSIGNED:
- return (ERR_UNASSIGNED_VARIABLE);
-
- case TRAP_UNASSIGNED_DANGEROUS:
- return_value = ERR_UNASSIGNED_VARIABLE;
- break;
-\f
- case TRAP_DANGEROUS:
- {
- SCHEME_OBJECT trap_value;
-
- trap_value = Val;
- Val = (MEMORY_REF (trap_value, TRAP_EXTRA));
- FUTURE_VARIABLE_SPLICE (trap_value, TRAP_EXTRA, Val);
- return_value = PRIM_DONE;
- break;
- }
-
- case TRAP_FLUID:
- case TRAP_FLUID_DANGEROUS:
- cell = lookup_fluid(Val);
- repeat_p = true;
- if (trap_kind == TRAP_FLUID)
- continue;
- break;
-
- case TRAP_COMPILER_CACHED:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
- repeat_p = true;
- if (trap_kind == TRAP_COMPILER_CACHED)
- continue;
- break;
-
- case TRAP_UNBOUND:
- return (ERR_UNBOUND_VARIABLE);
-
- case TRAP_UNBOUND_DANGEROUS:
- return_value = ERR_UNBOUND_VARIABLE;
- break;
-
- default:
- return_value = ERR_ILLEGAL_REFERENCE_TRAP;
- break;
- }
-
- /* The reference was dangerous, uncompile the variable. */
- {
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (compile_serializer);
-#endif
- setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- hunk[VARIABLE_OFFSET] = SHARP_F;
- remove_lock(compile_serializer);
- }
-
- } while (repeat_p);
-
- return (return_value);
-}
-\f
-/* Simple lookup finalization.
- All the hairy cases are left to deep_lookup_end.
- env is the environment where the reference was supposedly resolved.
- If there is any question about the validity of the resolution (due
- to dangerousness, for example), a deep lookup operation is
- performed, and control is given to deep_lookup_end.
- */
-
-long
-DEFUN (lookup_end, (cell, env, hunk),
- SCHEME_OBJECT * cell
- AND SCHEME_OBJECT env
- AND SCHEME_OBJECT * hunk)
-{
- long trap_kind;
-
-lookup_end_restart:
- Val = MEMORY_FETCH (cell[0]);
- FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
-
- if (!(REFERENCE_TRAP_P(Val)))
- {
- return (PRIM_DONE);
- }
-
- get_trap_kind(trap_kind, Val);
- switch(trap_kind)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- return
- (deep_lookup_end(deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk),
- hunk));
-
- case TRAP_COMPILER_CACHED:
- cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
- goto lookup_end_restart;
-
- case TRAP_FLUID:
- cell = lookup_fluid(Val);
- goto lookup_end_restart;
-
- case TRAP_UNBOUND:
- return (ERR_UNBOUND_VARIABLE);
-
- case TRAP_UNASSIGNED:
- return (ERR_UNASSIGNED_VARIABLE);
-
- default:
- return (ERR_ILLEGAL_REFERENCE_TRAP);
- }
-}
-\f
-/* Complete assignment finalization.
-
- deep_assignment_end handles all dangerous cases, and busts compiled
- code operator reference caches as appropriate. It is similar to
- deep_lookup_end.
- value is the new value for the variable.
- force forces an assignment if the variable is unbound. This is
- used for redefinition in the global environment
-
- Notes on multiprocessor locking:
-
- The lock for assignment is usually in the original value cell in
- the environment structure.
- There are two cases where it is not:
-
- - Deep fluid variables. The lock is in the fluid value cell
- corresponding to this process. The original lock is removed before
- the fluid list is examined.
-
- - Compiler cached variables. The lock is in the new value cell.
- It is here so that compiled code can also lock it, since it does
- not have a pointer to the environment structure at all. The lock
- is moved (updated) from the original location to the new location.
- Ideally the original lock is not released until the new one is
- acquired, but we may not be able to guarantee this.
- The code is carefully written so that a weaker condition makes it
- valid. The condition is that locks should be granted in the order
- of request. The reason for this is that the code which can
- affect an operation must acquire the same locks and in the same
- order, thus if there is no interleaving of these operations, the
- result will be correct.
-
- Important:
-
- A re-definition can take place before the lock is grabbed in this
- code and we will be clobbering the wrong cell. To be paranoid we
- should redo the lookup while we have the cell locked and confirm
- that this is still valid, but this is hard to do here.
- Alternatively the lock could be grabbed by the caller and passed as
- an argument after confirming the correctness of the binding. A
- third option (the one in place now) is not to worry about this,
- saying that there is a race condition in the user code and that the
- definition happened after this assignment. For more precise
- sequencing, the user should synchronize her/his assignments and
- definitions her/himself.
-
- assignment_end suffers from this problem as well.
-
- */
-\f
-#define RESULT(value) \
-{ \
- return_value = (value); \
- break; \
-}
-
-#define UNCOMPILE(value) \
-{ \
- uncompile_p = true; \
- return_value = (value); \
- break; \
-}
-
-#define ABORT(value) \
-{ \
- remove_lock(set_serializer); \
- return (value); \
-}
-
-#define REDO() \
-{ \
- repeat_p = true; \
- break; \
-}
-
-long
-DEFUN (deep_assignment_end, (cell, hunk, value, force),
- fast SCHEME_OBJECT * cell
- AND SCHEME_OBJECT * hunk
- AND SCHEME_OBJECT value
- AND Boolean force)
-{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
- long trap_kind;
- long return_value = PRIM_DONE;
- SCHEME_OBJECT bogus_unassigned, extension, saved_extension;
- SCHEME_OBJECT saved_value = SHARP_F;
- Boolean repeat_p, uncompile_p, fluid_lock_p;
-
- /* State variables */
- saved_extension = SHARP_F;
- uncompile_p = false;
- fluid_lock_p = false;
-\f
- bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
- if (value == bogus_unassigned)
- value = UNASSIGNED_OBJECT;
-
- setup_lock(set_serializer, cell);
-
- do {
-
- repeat_p = false;
- Val = *cell;
-
- if (!(REFERENCE_TRAP_P(Val)))
- {
- *cell = value;
- RESULT(PRIM_DONE);
- }
-
- /* Below, break means uncompile the variable. */
-
- get_trap_kind(trap_kind, Val);
-
- switch(trap_kind)
- {
- case TRAP_DANGEROUS:
- Val = MEMORY_REF (Val, TRAP_EXTRA);
- if (value == UNASSIGNED_OBJECT)
- {
- *cell = DANGEROUS_UNASSIGNED_OBJECT;
- }
- else
- {
- Do_Store_No_Lock ((MEMORY_LOC (*cell, TRAP_EXTRA)), value);
- }
- UNCOMPILE(PRIM_DONE);
-
- case TRAP_UNBOUND:
- if (!force)
- {
- UNCOMPILE(ERR_UNBOUND_VARIABLE)
- }
- /* Fall through */
-
- case TRAP_UNASSIGNED:
- Val = bogus_unassigned;
- *cell = value;
- RESULT(PRIM_DONE);
-\f
- case TRAP_UNBOUND_DANGEROUS:
- if (!force)
- {
- UNCOMPILE(ERR_UNBOUND_VARIABLE);
- }
-
- if (value == UNASSIGNED_OBJECT)
- {
- *cell = DANGEROUS_UNASSIGNED_OBJECT;
- UNCOMPILE(PRIM_DONE);
- }
- /* Fall through */
-
- case TRAP_UNASSIGNED_DANGEROUS:
- Val = bogus_unassigned;
- if (value != UNASSIGNED_OBJECT)
- {
- SCHEME_OBJECT result;
-
- if (GC_allocate_test(2))
- {
- Request_GC(2);
- ABORT(PRIM_INTERRUPT);
- }
- result = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
- *Free++ = DANGEROUS_OBJECT;
- *Free++ = value;
- *cell = result;
- }
- UNCOMPILE(PRIM_DONE);
-
- case TRAP_EXPENSIVE:
- /* This should only happen if we have been invoked by
- compiler_assignment_end invoked by compiler_reference_trap;
- */
- extension = cell[TRAP_EXTENSION_CLONE];
- goto compiler_cache_assignment;
-\f
- case TRAP_COMPILER_CACHED_DANGEROUS:
- uncompile_p = true;
- /* Fall through */
-
- case TRAP_COMPILER_CACHED:
- extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
-
-compiler_cache_assignment:
- {
- SCHEME_OBJECT references;
-
- /* Unlock and lock at the new value cell. */
-
- references = (FAST_MEMORY_REF (extension,
- TRAP_EXTENSION_REFERENCES));
- cell = (MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
- update_lock (set_serializer, cell);
-
- if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
- != SHARP_F)
- {
- if (saved_extension != SHARP_F)
- {
- ABORT(ERR_BROKEN_VARIABLE_CACHE);
- }
- saved_extension = extension;
- saved_value = *cell;
- }
- REDO();
- }
-
- /* Remarks:
- If this is the inner trap of a compiler cache, and there are
- uuo links, there will actually be no recaching, since the old
- contents and the new one will be the fluid trap, and the
- links will already be set up for the fluid trap. Thus we can
- temporarily unlock while the iteration takes place.
- */
- case TRAP_FLUID_DANGEROUS:
- uncompile_p = true;
- /* Fall through */
-
- case TRAP_FLUID:
- fluid_lock_p = true;
- remove_lock(set_serializer);
- cell = lookup_fluid(Val);
- setup_lock(set_serializer, cell);
- REDO();
-
- default:
- UNCOMPILE(ERR_ILLEGAL_REFERENCE_TRAP);
- }
- } while (repeat_p);
-\f
- if (saved_extension != SHARP_F)
- {
- if (fluid_lock_p)
- {
- /* Guarantee that there is a lock on the variable cache around
- the call to recache_uuo_links.
- */
-
- update_lock (set_serializer,
- (MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL)));
- }
-
- /* NOTE:
- recache_uuo_links can take an arbitrary amount of time since
- there may be an internal lock and the code may have to uncache
- arbitrarily many links.
- Deadlock should not occur since both locks are always acquired
- in the same order.
- */
-
- return_value = (recache_uuo_links (saved_extension, saved_value));
- remove_lock (set_serializer);
-
- if (return_value != PRIM_DONE)
- {
- return (return_value);
- }
- }
- else
- {
- remove_lock (set_serializer);
- }
-
- /* This must be done after the assignment lock has been removed,
- to avoid potential deadlock.
- */
-
- if (uncompile_p)
- {
- /* The reference was dangerous, uncompile the variable. */
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (compile_serializer);
-#endif
- setup_lock (compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- hunk[VARIABLE_OFFSET] = SHARP_F;
- remove_lock (compile_serializer);
- }
-
- return (return_value);
-}
-\f
-#undef ABORT
-#undef REDO
-#undef RESULT
-#undef UNCOMPILE
-
-/* Simple assignment end.
- assignment_end lets deep_assignment_end handle all the hairy cases.
- It is similar to lookup_end, but there is some hair for
- unassignedness and compiled code cached references.
- */
-
-long
-DEFUN (assignment_end, (cell, env, hunk, value),
- fast SCHEME_OBJECT * cell
- AND SCHEME_OBJECT env
- AND SCHEME_OBJECT * hunk
- AND SCHEME_OBJECT value)
-{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
- SCHEME_OBJECT bogus_unassigned;
- long temp;
-
- bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
- if (value == bogus_unassigned)
- value = UNASSIGNED_OBJECT;
-
-assignment_end_before_lock:
-
- setup_lock(set_serializer, cell);
-
-assignment_end_after_lock:
-
- Val = *cell;
-
- if (!(REFERENCE_TRAP_P(Val)))
- {
- *cell = value;
- remove_lock(set_serializer);
- return (PRIM_DONE);
- }
-
- get_trap_kind(temp, Val);
- switch(temp)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- remove_lock(set_serializer);
- return
- (deep_assignment_end(deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk),
- hunk,
- value,
- false));
-\f
- case TRAP_COMPILER_CACHED:
- {
- SCHEME_OBJECT extension, references;
-
- extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
- references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
-
- if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
- {
- /* There are uuo links.
- wimp out and let deep_assignment_end handle it.
- */
-
- remove_lock(set_serializer);
- return (deep_assignment_end(cell, hunk, value, false));
- }
- cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
- update_lock(set_serializer, cell);
- goto assignment_end_after_lock;
- }
-
- case TRAP_FLUID:
- remove_lock(set_serializer);
- cell = lookup_fluid(Val);
- goto assignment_end_before_lock;
-
- case TRAP_UNBOUND:
- temp = ERR_UNBOUND_VARIABLE;
- break;
-
- case TRAP_UNASSIGNED:
- Val = bogus_unassigned;
- *cell = value;
- temp = PRIM_DONE;
- break;
-
- default:
- temp = ERR_ILLEGAL_REFERENCE_TRAP;
- break;
- }
- remove_lock(set_serializer);
- return (temp);
-}
-\f
-/* Finds the fluid value cell associated with the reference trap on
- this processor's fluid "binding" list. It is just like ASSQ.
- */
-
-SCHEME_OBJECT *
-DEFUN (lookup_fluid, (trap), fast SCHEME_OBJECT trap)
-{
- fast SCHEME_OBJECT fluids, *this_pair;
-
- fluids = Fluid_Bindings;
-
- if (Fluids_Debug)
- {
- Print_Expression(fluids, "Searching fluid bindings");
- }
-
- while (PAIR_P(fluids))
- {
- this_pair = OBJECT_ADDRESS (FAST_PAIR_CAR (fluids));
-
- if (this_pair[CONS_CAR] == trap)
- {
- if (Fluids_Debug)
- outf_error ("Fluid found.\n");
-
- return (&this_pair[CONS_CDR]);
- }
-
- fluids = FAST_PAIR_CDR (fluids);
- }
-
- /* Not found in fluid binding alist, so use default. */
-
- if (Fluids_Debug)
- outf_error ("Fluid not found, using default.\n");
-
- return (MEMORY_LOC (trap, TRAP_EXTRA));
-}
-\f
-/* Utilities for definition.
-
- redefinition is used when the definition is in fact an assignment.
- A binding already exists in this frame.
-
- dangerize is invoked to guarantee that any variables "compiled" to
- this location are recompiled at the next reference.
- */
-
-#define redefinition(cell, value) \
- (deep_assignment_end (cell, fake_variable_object, value, true))
-
-long
-DEFUN (definition, (cell, value, shadowed_p),
- SCHEME_OBJECT * cell
- AND SCHEME_OBJECT value
- AND Boolean shadowed_p)
-{
- if (shadowed_p)
- return (redefinition (cell, value));
- else
- {
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
- setup_lock (set_serializer, cell);
- if (*cell == DANGEROUS_UNBOUND_OBJECT)
- {
- *cell = value;
- remove_lock (set_serializer);
- return (PRIM_DONE);
- }
- else
- {
- /* Unfortunate fact of life: This binding will be dangerous
- even if there was no need, but this is the only way to
- guarantee consistent values.
- */
- remove_lock (set_serializer);
- return (redefinition (cell, value));
- }
- }
-}
-\f
-long
-DEFUN (dangerize, (cell, sym),
- fast SCHEME_OBJECT * cell
- AND SCHEME_OBJECT sym)
-{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
- fast long temp;
- SCHEME_OBJECT trap;
-
- setup_lock (set_serializer, cell);
- if (!(REFERENCE_TRAP_P (*cell)))
- {
- if (GC_allocate_test (2))
- {
- remove_lock (set_serializer);
- Request_GC (2);
- return (PRIM_INTERRUPT);
- }
- trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
- *Free++ = DANGEROUS_OBJECT;
- *Free++ = *cell;
- *cell = trap;
- remove_lock (set_serializer);
- return (simple_uncache (cell, sym));
- }
-\f
- get_trap_kind (temp, *cell);
- switch (temp)
- {
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- break;
-
- case TRAP_COMPILER_CACHED:
- Do_Store_No_Lock
- ((MEMORY_LOC (*cell, TRAP_TAG)),
- (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED_DANGEROUS)));
- /* Fall through */
-
- case TRAP_COMPILER_CACHED_DANGEROUS:
- {
- remove_lock (set_serializer);
- return (compiler_uncache (cell, sym));
- }
-
- case TRAP_FLUID:
- Do_Store_No_Lock
- ((MEMORY_LOC (*cell, TRAP_TAG)),
- (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID_DANGEROUS)));
- break;
-
- case TRAP_UNBOUND:
- *cell = DANGEROUS_UNBOUND_OBJECT;
- break;
-
- case TRAP_UNASSIGNED:
- *cell = DANGEROUS_UNASSIGNED_OBJECT;
- break;
-
- default:
- remove_lock (set_serializer);
- return (ERR_ILLEGAL_REFERENCE_TRAP);
- }
- remove_lock (set_serializer);
- return (simple_uncache (cell, sym));
-}
-\f
-/* The core of the incremental definition mechanism.
-
- It takes care of dangerizing any bindings being shadowed by this
- definition, extending the frames appropriately, and uncaching or
- recaching (according to the DEFINITION_RECACHES_EAGERLY flag) any
- compiled code reference caches which might be affected by the new
- definition.
-
- *UNDEFINE*: If (local?) undefine is ever implemented, it suffices
- to set the value cell to DANGEROUS_UNBOUND_OBJECT, uncache all the
- compiler cached variables to the location, and rewrite the code
- below slightly as implied by the comments tagged *UNDEFINE*.
- */
-
-long
-DEFUN (extend_frame,
- (env, sym, value, original_frame, recache_p),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT value
- AND SCHEME_OBJECT original_frame
- AND Boolean recache_p)
-{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (extension_serializer);
-#endif
- SCHEME_OBJECT extension, the_procedure;
- fast SCHEME_OBJECT *scan;
- long aux_count;
-
- if ((OBJECT_TYPE (env)) == GLOBAL_ENV)
- {
- /* *UNDEFINE*: If undefine is ever implemented, this code need not
- change: There are no shadowed bindings that need to be
- recached.
- */
- if ((OBJECT_DATUM (env)) != GO_TO_GLOBAL)
- {
- if (env == original_frame)
- {
- return (ERR_BAD_FRAME);
- }
- else
- {
- /* We have a new definition in a chain rooted at the empty
- environment.
- We need not uncache/recache, but we need to set all
- global state accordingly.
- We use a cell which never needs uncacheing/recacheing
- and use the ordinary code otherwise.
-
- This is done only because of compiler cached variables.
- */
- return (compiler_uncache ((unbound_trap_object), sym));
- }
- }
- else if (env == original_frame)
- {
- return (redefinition ((MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE)),
- value));
- }
- else
- {
- return (dangerize ((MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE)), sym));
- }
- }
-\f
- the_procedure = (MEMORY_REF (env, ENVIRONMENT_FUNCTION));
- if ((OBJECT_TYPE (the_procedure)) == AUX_LIST_TYPE)
- the_procedure = (MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE));
-
- /* Search the formals. */
-
- {
- fast long count;
- SCHEME_OBJECT formals;
-
- formals = (FAST_MEMORY_REF ((FAST_MEMORY_REF (the_procedure,
- PROCEDURE_LAMBDA_EXPR)),
- LAMBDA_FORMALS));
- for (count = ((VECTOR_LENGTH (formals)) - 1),
- scan = (MEMORY_LOC (formals, VECTOR_DATA + 1));
- count > 0;
- count -= 1)
- {
- /* *UNDEFINE*: If undefine is ever implemented, this code must
- check whether the value is DANGEROUS_UNBOUND_OBJECT, and if
- so, a search must be done to cause the shadowed compiler
- cached variables to be recached, as in the aux case below.
- */
- if (*scan++ == sym)
- {
- long offset;
-
- offset = (1 + (VECTOR_LENGTH (formals))) - count;
- if (env == original_frame)
- {
- return (redefinition ((MEMORY_LOC (env, offset)), value));
- }
- else
- {
- return (dangerize ((MEMORY_LOC (env, offset)), sym));
- }
- }
- }
- }
-\f
- /* Guarantee that there is an extension slot. */
-
-redo_aux_lookup:
-
- setup_lock (extension_serializer, (OBJECT_ADDRESS (env)));
- extension = (FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION));
- if ((OBJECT_TYPE (extension)) != AUX_LIST_TYPE)
- {
- fast long i;
-
- if (GC_allocate_test (AUX_LIST_INITIAL_SIZE))
- {
- remove_lock (extension_serializer);
- Request_GC (AUX_LIST_INITIAL_SIZE);
- return (PRIM_INTERRUPT);
- }
- scan = Free;
- extension = (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan));
-
- scan[ENV_EXTENSION_HEADER] =
- (MAKE_OBJECT (TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1)));
-
- scan[ENV_EXTENSION_PARENT_FRAME] =
- (MEMORY_REF (the_procedure, PROCEDURE_ENVIRONMENT));
-
- scan[ENV_EXTENSION_PROCEDURE] = the_procedure;
-
- scan[ENV_EXTENSION_COUNT] = (Make_Local_Offset (0));
-
- for (i = AUX_CHUNK_SIZE, scan += AUX_LIST_FIRST;
- --i >= 0;)
- *scan++ = SHARP_F;
-
- Free = scan;
- Do_Store_No_Lock ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)), extension);
- }
- aux_count = (Lexical_Offset (FAST_MEMORY_REF (extension, AUX_LIST_COUNT)));
- remove_lock (extension_serializer);
-\f
- /* Search the aux list. */
-
- {
- fast long count;
-
- scan = (OBJECT_ADDRESS (extension));
- count = aux_count;
- scan += AUX_LIST_FIRST;
-
- while (--count >= 0)
- {
- if ((FAST_PAIR_CAR (*scan)) == sym)
- {
- scan = (PAIR_CDR_LOC (*scan));
-
- /* This is done only because of compiler cached variables.
- In their absence, this conditional is unnecessary.
-
- *UNDEFINE*: This would also have to be done for other kinds
- of bindings if undefine is ever implemented. See the
- comments above.
- */
- if ((MEMORY_FETCH (scan[0])) == DANGEROUS_UNBOUND_OBJECT)
- {
- long temp;
-
- temp =
- (compiler_uncache
- (deep_lookup ((FAST_MEMORY_REF (extension,
- ENV_EXTENSION_PARENT_FRAME)),
- sym,
- fake_variable_object),
- sym));
-
- if ((temp != PRIM_DONE) || (env != original_frame))
- {
- return (temp);
- }
- return (shadowing_recache (scan, env, sym, value, true));
- }
-
- if (env == original_frame)
- {
- return (redefinition (scan, value));
- }
- else
- {
- return (dangerize (scan, sym));
- }
- }
- scan += 1;
- }
- }
-\f
- /* Not found in this frame at all. */
-
- {
- fast long temp;
-
- temp =
- (extend_frame ((FAST_MEMORY_REF (extension, ENV_EXTENSION_PARENT_FRAME)),
- sym, SHARP_F, original_frame, recache_p));
-
- if (temp != PRIM_DONE)
- {
- return (temp);
- }
-
- /* Proceed to extend the frame:
- - If the frame is the one where the definition is occurring,
- put the value in the new value cell.
- - Otherwise, put a dangerous unbound trap there.
- - This code is careful to restart if some other process defines
- something in the meantime in this frame.
- */
-
- setup_lock (extension_serializer, (OBJECT_ADDRESS (env)));
- temp = (Lexical_Offset (FAST_MEMORY_REF (extension, AUX_LIST_COUNT)));
-
- if ((extension != (FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION))) ||
- (temp != aux_count))
- {
- remove_lock (extension_serializer);
- goto redo_aux_lookup;
- }
-\f
- scan = (OBJECT_ADDRESS (extension));
-
- if ((temp + (AUX_LIST_FIRST - 1)) == ((long) (VECTOR_LENGTH (extension))))
- {
- fast long i;
- fast SCHEME_OBJECT *fast_free;
-
- i = ((2 * temp) + AUX_LIST_FIRST);
-
- if (GC_allocate_test (i))
- {
- remove_lock (extension_serializer);
- Request_GC (i);
- return (PRIM_INTERRUPT);
- }
-
- fast_free = Free;
- i -= 1;
-
- scan += 1;
- *fast_free++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, i));
- for (i = (temp + (AUX_LIST_FIRST - 1)); --i >= 0; )
- *fast_free++ = *scan++;
- for (i = temp; --i >= 0; )
- *fast_free++ = SHARP_F;
-
- scan = Free;
- Free = fast_free;
- Do_Store_No_Lock
- ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)),
- (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan)));
- }
-\f
- if (GC_allocate_test (2))
- {
- remove_lock (extension_serializer);
- Request_GC (2);
- return (PRIM_INTERRUPT);
- }
-
- {
- SCHEME_OBJECT result;
-
- result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
- *Free++ = sym;
- *Free++ = DANGEROUS_UNBOUND_OBJECT;
-
- scan[temp + AUX_LIST_FIRST] = result;
- scan[AUX_LIST_COUNT] = (Make_Local_Offset (temp + 1));
-
- remove_lock (extension_serializer);
-
- if ((env != original_frame) || (!recache_p))
- return (PRIM_DONE);
- else
- return (shadowing_recache ((Free - 1), env, sym, value, false));
- }
- }
-}
-\f
-/* Top level of lookup code.
- These are the procedures invoked from outside this file.
- */
-
-long
-DEFUN (Lex_Ref, (env, var),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT var)
-{
- fast SCHEME_OBJECT *cell;
- SCHEME_OBJECT *hunk;
-
- hunk = OBJECT_ADDRESS (var);
- lookup(cell, env, hunk, repeat_lex_ref_lookup);
- return (lookup_end(cell, env, hunk));
-}
-
-long
-DEFUN (Symbol_Lex_Ref, (env, sym),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT sym)
-{
- return (deep_lookup_end(deep_lookup(env, sym, fake_variable_object),
- fake_variable_object));
-}
-
-long
-DEFUN (Lex_Set, (env, var, value),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT var
- AND SCHEME_OBJECT value)
-{
- fast SCHEME_OBJECT *cell;
- SCHEME_OBJECT *hunk;
-
- hunk = OBJECT_ADDRESS (var);
- lookup(cell, env, hunk, repeat_lex_set_lookup);
- return (assignment_end(cell, env, hunk, value));
-}
-
-long
-DEFUN (Symbol_Lex_Set, (env, sym, value),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT value)
-{
- return (deep_assignment_end(deep_lookup(env, sym, fake_variable_object),
- fake_variable_object,
- value,
- false));
-}
-\f
-long
-DEFUN (Local_Set, (env, sym, value),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT value)
-{
- long result;
-
- if (Define_Debug)
- outf_error ("\n;; Local_Set: defining %s.",
- (STRING_LOC ((MEMORY_REF (sym, SYMBOL_NAME)), 0)));
- result = (extend_frame (env, sym, value, env, true));
- Val = sym;
- return (result);
-}
-
-long
-DEFUN (safe_reference_transform, (reference_result), long reference_result)
-{
- if (reference_result == ERR_UNASSIGNED_VARIABLE)
- {
- Val = UNASSIGNED_OBJECT;
- return (PRIM_DONE);
- }
- else
- {
- return (reference_result);
- }
-}
-
-long
-DEFUN (safe_lex_ref, (env, var),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT var)
-{
- return (safe_reference_transform (Lex_Ref (env, var)));
-}
-
-long
-DEFUN (safe_symbol_lex_ref, (env, sym),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT sym)
-{
- return (safe_reference_transform (Symbol_Lex_Ref (env, sym)));
-}
-\f
-long
-DEFUN (unassigned_p_transform, (reference_result), long reference_result)
-{
- switch (reference_result)
- {
- case ERR_UNASSIGNED_VARIABLE:
- Val = SHARP_T;
- return (PRIM_DONE);
-
- case PRIM_DONE:
- Val = SHARP_F;
- return (PRIM_DONE);
-
- case ERR_UNBOUND_VARIABLE:
- default:
- return (reference_result);
- }
-}
-
-extern long
- EXFUN (Symbol_Lex_unassigned_p, (SCHEME_OBJECT, SCHEME_OBJECT)),
- EXFUN (Symbol_Lex_unbound_p, (SCHEME_OBJECT, SCHEME_OBJECT));
-
-long
-DEFUN (Symbol_Lex_unassigned_p, (frame, symbol),
- SCHEME_OBJECT frame
- AND SCHEME_OBJECT symbol)
-{
- return (unassigned_p_transform (Symbol_Lex_Ref (frame, symbol)));
-}
-
-long
-DEFUN (Symbol_Lex_unbound_p, (frame, symbol),
- SCHEME_OBJECT frame
- AND SCHEME_OBJECT symbol)
-{
- long result;
-
- result = (Symbol_Lex_Ref (frame, symbol));
- switch (result)
- {
- case ERR_UNASSIGNED_VARIABLE:
- case PRIM_DONE:
- {
- Val = SHARP_F;
- return (PRIM_DONE);
- }
-
- case ERR_UNBOUND_VARIABLE:
- {
- Val = SHARP_T;
- return (PRIM_DONE);
- }
-
- default:
- return (result);
- }
-}
-\f
-/* force_definition is used when access to the global environment is
- not allowed. It finds the last frame where a definition can occur,
- and performs the definition in this frame. It then returns the
- cell where the value is stored. It's expensive and will hardly be
- used, but is provided for completeness.
-*/
-
-SCHEME_OBJECT *
-DEFUN (force_definition, (env, symbol, message),
- fast SCHEME_OBJECT env
- AND SCHEME_OBJECT symbol
- AND long * message)
-{
- fast SCHEME_OBJECT previous;
-
- if (OBJECT_TYPE (env) == GLOBAL_ENV)
- {
- *message = ERR_BAD_FRAME;
- return ((SCHEME_OBJECT *) NULL);
- }
-
- do
- {
- previous = env;
- env = FAST_MEMORY_REF (MEMORY_REF (env, ENVIRONMENT_FUNCTION),
- PROCEDURE_ENVIRONMENT);
- } while (OBJECT_TYPE (env) != GLOBAL_ENV);
-
- *message = (Local_Set (previous, symbol, UNASSIGNED_OBJECT));
- if (*message != PRIM_DONE)
- {
- return ((SCHEME_OBJECT *) NULL);
- }
- return (deep_lookup(previous, symbol, fake_variable_object));
-}
-\f
-/* Macros to allow multiprocessor interlocking in
- compiler caching and recaching.
+extern SCHEME_OBJECT extract_variable_cache
+ (SCHEME_OBJECT, unsigned long);
+extern void store_variable_cache
+ (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
- The defaults are NOPs, but can be overriden by machine dependent
- include files or config.h
- */
-
-#ifndef update_uuo_prolog
-#define update_uuo_prolog()
-#endif
-
-#ifndef update_uuo_epilog
-#define update_uuo_epilog()
-#endif
-
-#ifndef compiler_cache_prolog
-#define compiler_cache_prolog()
-#endif
-
-#ifndef compiler_cache_epilog
-#define compiler_cache_epilog()
-#endif
-
-#ifndef compiler_trap_prolog
-#define compiler_trap_prolog()
-#endif
-
-#ifndef compiler_trap_epilog
-#define compiler_trap_epilog()
-#endif
-
-#ifndef compiler_uncache_prolog
-#define compiler_uncache_prolog()
-#endif
-
-#ifndef compiler_uncache_epilog
-#define compiler_uncache_epilog()
-#endif
-
-#ifndef compiler_recache_prolog
-#define compiler_recache_prolog()
-#endif
-
-#ifndef compiler_recache_epilog
-#define compiler_recache_epilog()
-#endif
+extern SCHEME_OBJECT compiled_block_environment
+ (SCHEME_OBJECT);
\f
-/* Fast variable reference mechanism for compiled code.
-
- compiler_cache is the core of the variable caching mechanism.
-
- It creates a variable cache for the variable at the specified cell,
- if needed, and stores it or a related object in the location
- specified by (block, offset). It adds this reference to the
- appropriate reference list for further updating.
-
- If the reference is a lookup reference, the cache itself is stored.
-
- If the reference is an assignment reference, there are two possibilities:
- - There are no operator references cached to this location. The
- cache itself is stored.
- - There are operator references. A fake cache (clone) is stored instead.
- This cache will make all assignments trap so that the cached
- operators can be updated.
-
- If the reference is an operator reference, a compiled procedure or a
- "fake" compiled procedure is stored. Furthermore, if there were
- assignment references cached, and no fake cache had been installed,
- a fake cache is created and all the assignment references are
- updated to point to it.
- */
-\f
-#ifndef PARALLEL_PROCESSOR
-
-#define compiler_cache_consistency_check()
-
-#else /* PARALLEL_PROCESSOR */
+/* Hopefully a conservative guesstimate. */
+#ifndef SPACE_PER_UUO_LINK /* So it can be overriden from config.h */
+# define SPACE_PER_UUO_LINK 10
+#endif
-/* The purpose of this code is to avoid a lock gap.
- A re-definition can take place before the lock is grabbed
- and we will be caching to the wrong cell.
- To be paranoid we redo the lookup while we have the
- cell locked and confim that we still have the correct cell.
+/* Cache objects are 4-tuples. */
+#define SPACE_PER_CACHE 4
- Note that this lookup can be "shallow" since the result of
- the previous lookup is saved in my_variable. The "shallow"
- lookup code takes care of performing a deep lookup if the
- cell has been "dangerized".
- */
+/* Each reference uses a pair and a weak pair. */
+#define SPACE_PER_REFERENCE 4
-#define compiler_cache_consistency_check() \
+#define RETURN_IF_ERROR(expression) \
{ \
- SCHEME_OBJECT *new_cell; \
- \
- compiler_cache_variable[VARIABLE_SYMBOL] = name; \
- new_cell = (lookup_cell (compiler_cache_variable, env)); \
- if (cell != new_cell) \
- { \
- remove_lock (set_serializer); \
- cell = new_cell; \
- goto compiler_cache_retry; \
- } \
+ long RIE_result = (expression); \
+ if (RIE_result != PRIM_DONE) \
+ return (RIE_result); \
}
-#endif /* PARALLEL_PROCESSOR */
-
-extern SCHEME_OBJECT compiler_cache_variable[];
-extern long
- EXFUN (compiler_cache,
- (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT,
- SCHEME_OBJECT, long, long, Boolean));
-
-SCHEME_OBJECT compiler_cache_variable[3];
-
-Boolean
-DEFUN (local_reference_p, (env, hunk),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT * hunk)
-{
- SCHEME_OBJECT spec;
-
- spec = (MEMORY_FETCH (hunk [VARIABLE_COMPILED_TYPE]));
- switch (OBJECT_TYPE (spec))
- {
- case GLOBAL_REF:
- return (env == (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)));
+#define DIE_IF_ERROR(expression) \
+{ \
+ if ((expression) != PRIM_DONE) \
+ { \
+ outf_fatal ("\nRan out of guaranteed space!\n"); \
+ Microcode_Termination (TERM_EXIT); \
+ } \
+}
- case LOCAL_REF:
- return (true);
+#define GC_CHECK(n) \
+{ \
+ if (GC_Check (n)) \
+ { \
+ Request_GC (n); \
+ return (PRIM_INTERRUPT); \
+ } \
+}
- case FORMAL_REF:
- case AUX_REF:
- return ((OBJECT_DATUM (spec)) == 0);
+#define MAP_TO_UNASSIGNED(value) \
+ (((value) == EXTERNAL_UNASSIGNED_OBJECT) \
+ ? UNASSIGNED_OBJECT \
+ : (value))
- default:
- return (false);
- }
-}
+#define EXTERNAL_UNASSIGNED_OBJECT (Get_Fixed_Obj_Slot (Non_Object))
\f
+/***** Forward References *****/
+
+static long lookup_variable_cache
+ (SCHEME_OBJECT, SCHEME_OBJECT *);
+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 allocate_frame_extension
+ (unsigned long, SCHEME_OBJECT, SCHEME_OBJECT *);
+static long merge_caches
+ (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);
+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 add_reference
+ (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, unsigned long);
+static long update_cache_references
+ (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
+static unsigned long 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
+ (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);
+static SCHEME_OBJECT * scan_frame
+ (SCHEME_OBJECT, SCHEME_OBJECT);
+static SCHEME_OBJECT * scan_procedure_bindings
+ (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT);
+static unsigned long count_references
+ (SCHEME_OBJECT, unsigned int);
+static SCHEME_OBJECT * find_tail_holder
+ (SCHEME_OBJECT, unsigned int);
+static void update_assignment_references
+ (SCHEME_OBJECT);
+static long guarantee_cache
+ (SCHEME_OBJECT *, SCHEME_OBJECT);
+static long guarantee_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
+/***** Basic environment manipulation (lookup, assign, define). *****/
+
long
-DEFUN (compiler_cache,
- (cell, env, name, block, offset, kind, first_time),
- fast SCHEME_OBJECT * cell
- AND SCHEME_OBJECT env
- AND SCHEME_OBJECT name
- AND SCHEME_OBJECT block
- AND long offset
- AND long kind
- AND Boolean first_time)
+lookup_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT * value_ret)
{
- long EXFUN (cache_reference_end,
- (long, SCHEME_OBJECT, SCHEME_OBJECT,
- SCHEME_OBJECT, long, SCHEME_OBJECT));
-
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
- fast SCHEME_OBJECT trap, references;
- SCHEME_OBJECT extension = SHARP_F;
- SCHEME_OBJECT trap_value, store_trap_tag, store_extension;
- long trap_kind, return_value;
-
- store_trap_tag = SHARP_F;
- store_extension = SHARP_F;
- trap_kind = TRAP_COMPILER_CACHED;
-
-#if 0
-compiler_cache_retry:
-#endif
+ SCHEME_OBJECT * cell;
+ SCHEME_OBJECT value;
- setup_lock (set_serializer, cell);
- compiler_cache_consistency_check ();
- compiler_cache_prolog ();
+ if (!ENVIRONMENT_P (environment))
+ return (ERR_BAD_FRAME);
- trap = *cell;
- trap_value = trap;
-\f
- if (REFERENCE_TRAP_P (trap))
- {
- long old_trap_kind;
+ cell
+ = (find_binding_cell (environment,
+ (((OBJECT_TYPE (symbol)) == TC_VARIABLE)
+ ? (GET_VARIABLE_SYMBOL (symbol))
+ : symbol)));
+ if (cell == 0)
+ return (ERR_UNBOUND_VARIABLE);
- get_trap_kind (old_trap_kind, trap);
- switch (old_trap_kind)
+ value = (*cell);
+ switch (get_trap_kind (value))
{
- case TRAP_UNASSIGNED:
- case TRAP_UNBOUND:
- case TRAP_FLUID:
- break;
-
- case TRAP_DANGEROUS:
- trap_value = (FAST_MEMORY_REF (trap, TRAP_EXTRA));
- trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
- break;
-
- case TRAP_UNASSIGNED_DANGEROUS:
- trap_value = UNASSIGNED_OBJECT;
- trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
- break;
-
- case TRAP_UNBOUND_DANGEROUS:
- trap_value = UNBOUND_OBJECT;
- trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
- break;
-
- case TRAP_FLUID_DANGEROUS:
- store_trap_tag = (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID));
- trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
- break;
-
- case TRAP_COMPILER_CACHED:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- extension = (FAST_MEMORY_REF (trap, TRAP_EXTRA));
- update_lock (set_serializer,
- (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
- trap_value = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL));
- trap_kind = -1;
- break;
-
- default:
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- return (ERR_ILLEGAL_REFERENCE_TRAP);
- }
- }
-\f
-#if TRUE
-
- /* The code below must complete to keep the data structures consistent.
- Thus instead of checking for GC overflow at each allocation, we check
- once at the beginning for the maximum amount of space needed. If we
- cannot do everything, we interrupt now. Otherwise, it is assumed
- that there is enough space available.
-
- MAXIMUM_CACHE_SIZE must accomodate the allocation on either
- branch below, plus potential later allocation (in the form of uuo
- links).
-
- The current value is much larger than what is actually needed, but...
- */
+ case NON_TRAP_KIND:
+ (*value_ret) = value;
+ return (PRIM_DONE);
-#define MAXIMUM_CACHE_SIZE 40
+ case TRAP_UNASSIGNED:
+ return (ERR_UNASSIGNED_VARIABLE);
- if (GC_allocate_test (MAXIMUM_CACHE_SIZE))
- {
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- Request_GC (MAXIMUM_CACHE_SIZE);
- return (PRIM_INTERRUPT);
- }
+ case TRAP_UNBOUND:
+ return (ERR_UNBOUND_VARIABLE);
-#endif
-\f
- /* A new trap is needed.
- This code could add the new reference to the appropriate list,
- but instead leaves it to the shared code below because another
- processor may acquire the lock and change things in the middle
- of update_lock.
- */
-
- if (trap_kind != -1)
- {
- SCHEME_OBJECT new_trap;
+ case TRAP_COMPILER_CACHED:
+ return (lookup_variable_cache ((GET_TRAP_CACHE (value)), value_ret));
-#if FALSE
- /* This is included in the check above. */
- if (GC_allocate_test (9))
- {
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- Request_GC (9);
- return (PRIM_INTERRUPT);
+ default:
+ return (ERR_ILLEGAL_REFERENCE_TRAP);
}
-#endif
-
- new_trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
- *Free++ = (LONG_TO_UNSIGNED_FIXNUM (trap_kind));
- extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, (Free + 1)));
- *Free++ = extension;
-
- *Free++ = trap_value;
- *Free++ = name;
- *Free++ = SHARP_F;
- references = (MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, (Free + 1)));
- *Free++ = references;
-
- *Free++ = EMPTY_LIST;
- *Free++ = EMPTY_LIST;
- *Free++ = EMPTY_LIST;
+}
- *cell = new_trap; /* Do_Store_No_Lock ? */
- if (store_trap_tag != SHARP_F)
+static long
+lookup_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT * value_ret)
+{
+ SCHEME_OBJECT value = (* (GET_CACHE_CELL (cache)));
+ switch (get_trap_kind (value))
{
- /* Do_Store_No_Lock ? */
- FAST_MEMORY_SET (trap, TRAP_TAG, store_trap_tag);
- }
- update_lock (set_serializer,
- (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
- }
+ case NON_TRAP_KIND:
+ (*value_ret) = value;
+ return (PRIM_DONE);
- if (block == SHARP_F)
- {
- /* It is not really from compiled code.
- The environment linking stuff wants a cc cache instead.
- */
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- return (PRIM_DONE);
- }
-\f
- /* There already is a compiled code cache.
- Maybe this should clean up all the cache lists?
- */
+ case TRAP_UNASSIGNED:
+ return (ERR_UNASSIGNED_VARIABLE);
- {
- references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
-
- if (((kind == TRAP_REFERENCES_ASSIGNMENT) &&
- ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
- != EMPTY_LIST)) ||
- ((kind == TRAP_REFERENCES_OPERATOR) &&
- ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
- != EMPTY_LIST)))
- {
- store_extension = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE));
- if (store_extension == SHARP_F)
- {
-#if FALSE
- /* This is included in the check above. */
+ case TRAP_UNBOUND:
+ return (ERR_UNBOUND_VARIABLE);
- if (GC_allocate_test (4))
- {
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- Request_GC (4);
- return (PRIM_INTERRUPT);
- }
-#endif
- store_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
- *Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
- *Free++ = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME));
- *Free++ = extension;
- *Free++ = references;
- FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, store_extension);
-
- if (kind == TRAP_REFERENCES_OPERATOR)
- {
- fix_references ((MEMORY_LOC (references,
- TRAP_REFERENCES_ASSIGNMENT)),
- store_extension);
- }
- }
+ default:
+ return (ERR_ILLEGAL_REFERENCE_TRAP);
}
-
- /* *UNDEFINE*: If undefine is ever implemented, we should re-think
- references by fiat since such references have constraints
- about where they can be linked to.
- For example, if C -> B -> A (-> means descends from)
- and there is a reference by fiat from C to B, and we undefine
- in B, it can go to A, but never to C (or anything between C and B).
- Curently the only references by fiat are those of the form
- ((access foo ()) ...)
- */
-
- return_value =
- (add_reference ((MEMORY_LOC (references, kind)),
- block,
- ((local_reference_p (env, compiler_cache_variable))
- ? (MAKE_OBJECT (TC_CHARACTER, offset))
- : (MAKE_OBJECT (TC_FIXNUM, offset)))));
- if (return_value != PRIM_DONE)
+}
+\f
+long
+safe_lookup_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT * value_ret)
+{
+ long result = (lookup_variable (environment, symbol, value_ret));
+ if (result == ERR_UNASSIGNED_VARIABLE)
{
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- return (return_value);
+ (*value_ret) = EXTERNAL_UNASSIGNED_OBJECT;
+ return (PRIM_DONE);
}
- }
-\f
- /* Install an extension or a uuo link in the cc block. */
-
- return_value = (cache_reference_end (kind, extension, store_extension,
- block, offset, trap_value));
-
- /* Unlock and return */
-
- compiler_cache_epilog ();
- remove_lock (set_serializer);
- return (return_value);
+ return (result);
}
long
-DEFUN (cache_reference_end,
- (kind, extension, store_extension, block, offset, value),
- long kind
- AND SCHEME_OBJECT extension
- AND SCHEME_OBJECT store_extension
- AND SCHEME_OBJECT block
- AND long offset
- AND SCHEME_OBJECT value)
+variable_unassigned_p (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT * value_ret)
{
- extern void
- EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
- extern long
- EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
- EXFUN (make_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
-
- switch(kind)
- {
- default:
- case TRAP_REFERENCES_ASSIGNMENT:
- if (store_extension != SHARP_F)
- {
- store_variable_cache (store_extension, block, offset);
- return (PRIM_DONE);
- }
- /* Fall through */
+ SCHEME_OBJECT dummy_value;
+ long result = (lookup_variable (environment, symbol, (&dummy_value)));
+ switch (result)
+ {
+ case ERR_UNASSIGNED_VARIABLE:
+ (*value_ret) = SHARP_T;
+ return (PRIM_DONE);
- case TRAP_REFERENCES_LOOKUP:
- store_variable_cache (extension, block, offset);
+ case PRIM_DONE:
+ (*value_ret) = SHARP_F;
return (PRIM_DONE);
- case TRAP_REFERENCES_OPERATOR:
- {
- if (REFERENCE_TRAP_P (value))
- {
- return (make_fake_uuo_link (extension, block, offset));
- }
- else
- {
- return (make_uuo_link (value, extension, block, offset));
- }
+ default:
+ return (result);
}
- }
- /*NOTREACHED*/
}
-\f
-/* This procedure invokes compiler_cache after finding the top-level
- value cell associated with (env, name).
- */
long
-DEFUN (compiler_cache_reference,
- (env, name, block, offset, kind, first_time),
- SCHEME_OBJECT env
- AND SCHEME_OBJECT name
- AND SCHEME_OBJECT block
- AND long offset
- AND long kind
- AND Boolean first_time)
+variable_unbound_p (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT * value_ret)
{
- SCHEME_OBJECT *cell;
+ SCHEME_OBJECT dummy_value;
+ long result = (lookup_variable (environment, symbol, (&dummy_value)));
+ switch (result)
+ {
+ case ERR_UNBOUND_VARIABLE:
+ (*value_ret) = SHARP_T;
+ return (PRIM_DONE);
- cell = (deep_lookup (env, name, compiler_cache_variable));
- if (cell == unbound_trap_object)
- {
- long message;
+ case ERR_UNASSIGNED_VARIABLE:
+ case PRIM_DONE:
+ (*value_ret) = SHARP_F;
+ return (PRIM_DONE);
- cell = (force_definition (env, name, &message));
- if (message != PRIM_DONE)
- {
- return (message);
+ default:
+ return (result);
}
- }
- return (compiler_cache (cell, env, name, block, offset, kind, first_time));
}
\f
-/* This procedure updates all the references in the cached reference
- list pointed at by slot to hold value. It also eliminates "empty"
- pairs (pairs whose weakly held block has vanished).
- */
-
-static void
-DEFUN (fix_references, (slot, extension),
- fast SCHEME_OBJECT * slot
- AND fast SCHEME_OBJECT extension)
+long
+assign_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT value, SCHEME_OBJECT * value_ret)
{
- fast SCHEME_OBJECT pair, block;
-
- while (*slot != EMPTY_LIST)
- {
- pair = (FAST_PAIR_CAR (*slot));
- block = (FAST_PAIR_CAR (pair));
- if (block == SHARP_F)
- {
- *slot = (FAST_PAIR_CDR (*slot));
- }
- else
- {
- extern void
- EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
-
- store_variable_cache (extension,
- block,
- (OBJECT_DATUM (FAST_PAIR_CDR (pair))));
- slot = (PAIR_CDR_LOC (*slot));
- }
- }
- return;
+ SCHEME_OBJECT * cell;
+
+ if (!ENVIRONMENT_P (environment))
+ return (ERR_BAD_FRAME);
+ cell
+ = (find_binding_cell (environment,
+ (((OBJECT_TYPE (symbol)) == TC_VARIABLE)
+ ? (GET_VARIABLE_SYMBOL (symbol))
+ : symbol)));
+ if (cell == 0)
+ return (ERR_UNBOUND_VARIABLE);
+
+ return (assign_variable_end (cell, value, value_ret, 0));
}
-\f
-/* This procedures adds a new cached reference to the cached reference
- list pointed at by slot. It attempts to reuse pairs which have been
- "emptied" by the garbage collector.
- */
static long
-DEFUN (add_reference, (slot, block, offset),
- fast SCHEME_OBJECT * slot
- AND SCHEME_OBJECT block
- AND SCHEME_OBJECT offset)
+assign_variable_end (SCHEME_OBJECT * cell, SCHEME_OBJECT value,
+ SCHEME_OBJECT * value_ret, int force_p)
{
- fast SCHEME_OBJECT pair;
-
- while (*slot != EMPTY_LIST)
- {
- pair = (FAST_PAIR_CAR (*slot));
- if ((FAST_PAIR_CAR (pair)) == SHARP_F)
+ SCHEME_OBJECT old_value = (*cell);
+ switch (get_trap_kind (old_value))
{
- FAST_SET_PAIR_CAR (pair, block);
- FAST_SET_PAIR_CDR (pair, offset);
+ case NON_TRAP_KIND:
+ (*cell) = (MAP_TO_UNASSIGNED (value));
+ (*value_ret) = old_value;
return (PRIM_DONE);
- }
- slot = (PAIR_CDR_LOC (*slot));
- }
- if (GC_allocate_test (4))
- {
- Request_GC (4);
- return (PRIM_INTERRUPT);
- }
+ case TRAP_UNBOUND:
+ /* Should only occur in global environment. */
+ if (!force_p)
+ return (ERR_UNBOUND_VARIABLE);
+ /* fall through */
- *slot = (MAKE_POINTER_OBJECT (TC_LIST, Free));
- *Free = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free + 2)));
- Free += 1;
- *Free++ = EMPTY_LIST;
+ case TRAP_UNASSIGNED:
+ (*cell) = (MAP_TO_UNASSIGNED (value));
+ (*value_ret) = EXTERNAL_UNASSIGNED_OBJECT;
+ return (PRIM_DONE);
- *Free++ = block;
- *Free++ = offset;
+ case TRAP_COMPILER_CACHED:
+ return
+ (assign_variable_cache
+ ((GET_TRAP_CACHE (old_value)), value, value_ret, force_p));
- return (PRIM_DONE);
+ default:
+ return (ERR_ILLEGAL_REFERENCE_TRAP);
+ }
}
-\f
-extern SCHEME_OBJECT
- EXFUN (compiled_block_environment, (SCHEME_OBJECT));
static long
- trap_map_table[] = {
- TRAP_REFERENCES_LOOKUP,
- TRAP_REFERENCES_ASSIGNMENT,
- TRAP_REFERENCES_OPERATOR
- };
-
-#define TRAP_MAP_TABLE_SIZE (sizeof(trap_map_table) / sizeof(long))
+assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value,
+ SCHEME_OBJECT * value_ret, int force_p)
+{
+ SCHEME_OBJECT * cell = (GET_CACHE_CELL (cache));
+ SCHEME_OBJECT old_value = (*cell);
+ switch (get_trap_kind (old_value))
+ {
+ case NON_TRAP_KIND:
+ (*value_ret) = old_value;
+ break;
-#ifndef DEFINITION_RECACHES_EAGERLY
+ case TRAP_UNBOUND:
+ /* Should only occur in global environment. */
+ if (!force_p)
+ return (ERR_UNBOUND_VARIABLE);
+ /* fall through */
-/* compiler_uncache_slot uncaches all references in the list pointed
- at by slot, and clears the list. If the references are operator
- references, a fake compiled procedure which will recache when
- invoked is created and installed.
- */
+ case TRAP_UNASSIGNED:
+ (*value_ret) = EXTERNAL_UNASSIGNED_OBJECT;
+ break;
+ default:
+ return (ERR_ILLEGAL_REFERENCE_TRAP);
+ }
+ /* 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))))
+ return (update_uuo_links (cache, (MAP_TO_UNASSIGNED (value))));
+ (*cell) = (MAP_TO_UNASSIGNED (value));
+ return (PRIM_DONE);
+}
+\f
long
-DEFUN (compiler_uncache_slot, (slot, sym, kind),
- fast SCHEME_OBJECT * slot
- AND SCHEME_OBJECT sym
- AND long kind)
+define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT value)
{
- fast SCHEME_OBJECT temp, pair;
- SCHEME_OBJECT block, offset, new_extension;
+ if (!ENVIRONMENT_P (environment))
+ return (ERR_BAD_FRAME);
- for (temp = *slot; temp != EMPTY_LIST; temp = *slot)
+ /* If there is already a binding, just assign to it. */
{
- pair = (FAST_PAIR_CAR (temp));
- block = (FAST_PAIR_CAR (pair));
- if (block != SHARP_F)
- {
- offset = (FAST_PAIR_CDR (pair));
- if (CHARACTER_P (offset))
- {
- /* This reference really belongs here! -- do not uncache.
- Skip to next.
- */
+ SCHEME_OBJECT * cell = (scan_frame (environment, symbol));
+ SCHEME_OBJECT old_value;
+ if (cell != 0)
+ return (assign_variable_end (cell, value, (&old_value), 1));
+ }
- slot = (PAIR_CDR_LOC (temp));
- continue;
- }
- else
- {
- if (GC_allocate_test (4))
+ if (EXTENDED_FRAME_P (environment))
+ /* Guarantee that there is room in the extension for a binding. */
+ {
+ unsigned long length = (GET_EXTENDED_FRAME_LENGTH (environment));
+ if (length == (GET_MAX_EXTENDED_FRAME_LENGTH (environment)))
{
- Request_GC (4);
- return (PRIM_INTERRUPT);
+ SCHEME_OBJECT extension;
+ RETURN_IF_ERROR
+ (allocate_frame_extension
+ ((2 * length),
+ (GET_EXTENDED_FRAME_PROCEDURE (environment)),
+ (&extension)));
+ memcpy ((GET_FRAME_EXTENSION_BINDINGS (extension)),
+ (GET_EXTENDED_FRAME_BINDINGS (environment)),
+ (length * (sizeof (SCHEME_OBJECT))));
+ SET_FRAME_EXTENSION_LENGTH (extension, length);
+ SET_FRAME_EXTENSION (environment, extension);
}
- new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
- *Free++ = REQUEST_RECACHE_OBJECT;
- *Free++ = sym;
- *Free++ = block;
- *Free++ = offset;
+ }
+ else
+ /* There's no extension, so create one. */
+ {
+ SCHEME_OBJECT extension;
+ RETURN_IF_ERROR
+ (allocate_frame_extension (16,
+ (GET_FRAME_PROCEDURE (environment)),
+ (&extension)));
+ SET_FRAME_EXTENSION (environment, extension);
+ }
- if (kind == TRAP_REFERENCES_OPERATOR)
- {
- extern long
- EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long));
- long result;
-
- result = (make_fake_uuo_link (new_extension,
- block,
- (OBJECT_DATUM (offset))));
- if (result != PRIM_DONE)
- return (result);
- }
- else
- {
- extern void
- EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
+ /* Create the binding. */
+ GC_CHECK (2);
+ {
+ SCHEME_OBJECT pair = (cons (symbol, value));
+ unsigned long length = (GET_EXTENDED_FRAME_LENGTH (environment));
+ ((GET_EXTENDED_FRAME_BINDINGS (environment)) [length]) = pair;
+ SET_EXTENDED_FRAME_LENGTH (environment, (length + 1));
- store_variable_cache (new_extension, block, (OBJECT_DATUM (offset)));
- }
- }
- }
- *slot = (FAST_PAIR_CDR (temp));
+ /* If this binding shadows another binding, we'll have to
+ 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));
}
- return (PRIM_DONE);
}
-\f
-/* compiler_uncache is invoked when a redefinition occurs.
- It uncaches all references cached to this value cell, and
- sets the variables up to be recached at the next reference.
- value_cell is the value cell being shadowed.
- sym is the name of the variable.
- */
-long
-DEFUN (compiler_uncache, (value_cell, sym),
- SCHEME_OBJECT * value_cell
- AND SCHEME_OBJECT sym)
+static long
+allocate_frame_extension (unsigned long length, SCHEME_OBJECT procedure,
+ SCHEME_OBJECT * extension_ret)
{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer);
-#endif
- SCHEME_OBJECT val, extension, references;
- long trap_kind, temp, i, index;
-
- setup_lock (set_serializer, value_cell);
-
- val = *value_cell;
-
- if (!(REFERENCE_TRAP_P (val)))
- {
- remove_lock (set_serializer);
+ unsigned long n_words = (ENV_EXTENSION_MIN_SIZE + length);
+ 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);
+ (*extension_ret) = extension;
return (PRIM_DONE);
}
+}
\f
- get_trap_kind (trap_kind, val);
- if ((trap_kind != TRAP_COMPILER_CACHED) &&
- (trap_kind != TRAP_COMPILER_CACHED_DANGEROUS))
- {
- remove_lock (set_serializer);
- return (PRIM_DONE);
- }
+long
+link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source,
+ SCHEME_OBJECT symbol)
+{
+ SCHEME_OBJECT * source_cell;
+ trap_kind_t source_kind;
+ SCHEME_OBJECT * target_cell;
+
+ if (! ((ENVIRONMENT_P (target)) && (ENVIRONMENT_P (source))))
+ return (ERR_BAD_FRAME);
- compiler_uncache_prolog ();
+ source_cell = (find_binding_cell (source, symbol));
+ if (source_cell == 0)
+ return (ERR_UNBOUND_VARIABLE);
- extension = (FAST_MEMORY_REF (val, TRAP_EXTRA));
- references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
- update_lock (set_serializer, (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
+ source_kind = (get_trap_kind (*source_cell));
+ if (source_kind == TRAP_UNBOUND)
+ return (ERR_UNBOUND_VARIABLE);
- /* Uncache all of the lists. */
+ target_cell = (scan_frame (target, symbol));
- for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
- {
- index = trap_map_table[i];
- temp = (compiler_uncache_slot ((MEMORY_LOC (references, index)),
- sym, index));
- if (temp != PRIM_DONE)
+ if ((target_cell != 0)
+ && ((get_trap_kind (*target_cell)) == TRAP_COMPILER_CACHED))
{
- remove_lock (set_serializer);
- compiler_uncache_epilog ();
- return (temp);
+ if (source_kind == TRAP_COMPILER_CACHED)
+ {
+ RETURN_IF_ERROR
+ (merge_caches ((GET_TRAP_CACHE (*target_cell)),
+ (GET_TRAP_CACHE (*source_cell))));
+ (* (GET_CACHE_CELL (GET_TRAP_CACHE (*target_cell))))
+ = (* (GET_CACHE_CELL (GET_TRAP_CACHE (*source_cell))));
+ }
+ else
+ (* (GET_CACHE_CELL (GET_TRAP_CACHE (*target_cell))))
+ = (*source_cell);
+ (*source_cell) = (*target_cell);
+ return (PRIM_DONE);
}
- }
- /* Note that we can only remove the trap if no references remain,
- ie. if there were no hard-wired references to this frame.
- We can test that by checking whether all the slots were set
- to EMPTY_LIST in the preceding loop.
- The current code, however, never removes the trap.
- */
-
- /* Remove the clone extension if there is one and it is no longer needed. */
+ RETURN_IF_ERROR (guarantee_cache (source_cell, symbol));
+ return (define_variable (target, symbol, (*source_cell)));
+}
- if ((FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE)) != SHARP_F)
- {
- if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
- == EMPTY_LIST)
- {
- FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
- }
- else if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
- == EMPTY_LIST)
+static long
+merge_caches (SCHEME_OBJECT target_cache, SCHEME_OBJECT source_cache)
+{
+ 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)))))
{
- /* All operators have disappeared, we can remove the clone,
- but we must update the cells.
- */
- fix_references ((MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT)),
- extension);
- FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
+ RETURN_IF_ERROR (guarantee_clone (target_cache));
}
- }
- compiler_uncache_epilog ();
- remove_lock (set_serializer);
+ else
+ flush_clone (target_cache);
+
+ GC_CHECK
+ ((count_references (source_cache, CACHE_REFERENCES_OPERATOR))
+ * SPACE_PER_UUO_LINK);
+
+ (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));
+
+ 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);
+
return (PRIM_DONE);
}
-
-#endif /* DEFINITION_RECACHES_EAGERLY */
\f
-#ifdef DEFINITION_RECACHES_EAGERLY
-
-/*
- compiler_recache is invoked when a redefinition occurs. It
- recaches (at the definition point) all the references that need to
- point to the new cell.
-
- It does this in two phases:
-
- - First (by means of compiler_recache_split) it splits all
- references into those that need to be updated and those that do
- not. This is done by side-effecting the list so that all those
- that need updating are at the end, and when we actually decide to
- go ahead, we can just clip it and install it in the new location.
- compiler_recache_split also counts how many entries are affected,
- so the total amount of gc space needed can be computed.
-
- - After checking that there is enough space to proceed, (rather
- than aborting) it actually does the recaching. It caches to the
- new location/value by using compiler_recache_slot. Note that the
- eventual trap extension has already been allocated so the recached
- links can point to it.
- */
-
-/* Required by compiler_uncache macro. */
+/***** Interface to compiled code. *****/
-SCHEME_OBJECT *shadowed_value_cell = ((SCHEME_OBJECT *) NULL);
-
-/* Each extension is a hunk4. */
-
-#define SPACE_PER_EXTENSION 4
-
-/* Trap, extension, and one cache-list hunk. */
-
-#define SPACE_PER_TRAP (2 + SPACE_PER_EXTENSION + 3)
-
-/* 1 Pair and 1 Weak pair.
- Not really needed since the pairs and weak pairs are reused.
- */
-
-#define SPACE_PER_ENTRY (2 + 2)
-
-/* Hopefully a conservative guesstimate. */
+long
+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));
+}
-#ifndef SPACE_PER_LINK /* So it can be overriden from config.h */
-#define SPACE_PER_LINK 10
-#endif
-\f
-/* The spaces are 0 because the pairs are reused! If that ever changes,
- they should all become SPACE_PER_ENTRY + curent value.
- */
+long
+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));
+}
-#define SPACE_PER_LOOKUP 0
-#define SPACE_PER_ASSIGNMENT 0
-#define SPACE_PER_OPERATOR (0 + SPACE_PER_LINK)
+long
+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));
+}
-static long
- trap_size_table[TRAP_MAP_TABLE_SIZE] = {
- SPACE_PER_LOOKUP,
- SPACE_PER_ASSIGNMENT,
- SPACE_PER_OPERATOR
- };
+long
+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
- trap_conflict_table[TRAP_MAP_TABLE_SIZE] = {
- 0, /* lookup */
- 1, /* assignment */
- 1 /* operator */
- };
-
-Boolean
-DEFUN (environment_ancestor_or_self_p, (ancestor, descendant),
- fast SCHEME_OBJECT ancestor
- AND fast SCHEME_OBJECT descendant)
+handle_cache_reference (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
+ SCHEME_OBJECT block, unsigned long offset,
+ unsigned int reference_kind)
{
- while ((OBJECT_TYPE (descendant)) != GLOBAL_ENV)
- {
- if (descendant == ancestor)
- return (true);
- descendant = (FAST_MEMORY_REF ((MEMORY_REF (descendant,
- ENVIRONMENT_FUNCTION)),
- PROCEDURE_ENVIRONMENT));
- }
- return (descendant == ancestor);
+ SCHEME_OBJECT * cell = (find_binding_cell (environment, symbol));
+ return
+ ((cell == 0)
+ ? ERR_UNBOUND_VARIABLE
+ : (add_cache_reference (cell, symbol, block, offset, reference_kind)));
}
-\f
-/* This reorders the entries in slot so that the entries that are
- not affected by the redefinition appear first, and the affected
- ones appear last. A pointer to the first affected cell is stored
- in memoize_cell, and this will be given to compiler_recache_slot
- in order to avoid recomputing the division.
-
- Note: There is an implicit assumption throughout that none of the
- pairs (or weak pairs) are in pure space. If they are, they cannot
- be sorted or reused.
- */
+SCHEME_OBJECT
+compiler_var_error (SCHEME_OBJECT cache)
+{
+ return (GET_CACHE_NAME (cache));
+}
+\f
long
-DEFUN (compiler_recache_split,
- (slot, sym, definition_env, memoize_cell, link_p),
- fast SCHEME_OBJECT * slot
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT definition_env
- AND SCHEME_OBJECT ** memoize_cell
- AND Boolean link_p)
+compiler_lookup_trap (SCHEME_OBJECT cache, SCHEME_OBJECT * value_ret)
{
- fast long count;
- SCHEME_OBJECT weak_pair, block, reference_env, invalid_head;
- fast SCHEME_OBJECT *last_invalid;
-
- count = 0;
- last_invalid = &invalid_head;
+ return (lookup_variable_cache (cache, value_ret));
+}
- while (*slot != EMPTY_LIST)
- {
- weak_pair = (FAST_PAIR_CAR (*slot));
- block = (FAST_PAIR_CAR (weak_pair));
- if (block == SHARP_F)
- {
- *slot = (FAST_PAIR_CDR (*slot));
- continue;
- }
- if (!link_p && (CHARACTER_P (FAST_PAIR_CDR (weak_pair))))
- {
- /* The reference really belongs here -- it is not affected by fiat. */
- slot = (PAIR_CDR_LOC (*slot));
- }
- else
+long
+compiler_safe_lookup_trap (SCHEME_OBJECT cache, SCHEME_OBJECT * value_ret)
+{
+ long result = (lookup_variable_cache (cache, value_ret));
+ if (result == ERR_UNASSIGNED_VARIABLE)
{
- reference_env = (compiled_block_environment (block));
- if (!environment_ancestor_or_self_p (definition_env, reference_env))
- {
- slot = (PAIR_CDR_LOC (*slot));
- }
- else
- {
- count += 1;
- *last_invalid = *slot;
- last_invalid = (PAIR_CDR_LOC (*slot));
- *slot = *last_invalid;
- }
+ (*value_ret) = EXTERNAL_UNASSIGNED_OBJECT;
+ return (PRIM_DONE);
}
- }
- *last_invalid = EMPTY_LIST;
- *memoize_cell = slot;
- *slot = invalid_head;
- return (count);
+ return (result);
}
-\f
-/* This recaches the entries pointed out by cell and adds them
- to the list in slot. It also sets to #F the contents
- of cell.
-
- Note that this reuses the pairs and weak pairs that used to be
- in cell.
- */
long
-DEFUN (compiler_recache_slot,
- (extension, sym, kind, slot, cell, value),
- SCHEME_OBJECT extension
- AND SCHEME_OBJECT sym
- AND long kind
- AND fast SCHEME_OBJECT * slot
- AND fast SCHEME_OBJECT * cell
- AND SCHEME_OBJECT value)
+compiler_unassigned_p_trap (SCHEME_OBJECT cache, SCHEME_OBJECT * value_ret)
{
- fast SCHEME_OBJECT pair, weak_pair;
- SCHEME_OBJECT clone, tail;
- long result;
+ SCHEME_OBJECT dummy_value;
+ long result = (lookup_variable_cache (cache, (&dummy_value)));
+ switch (result)
+ {
+ case ERR_UNASSIGNED_VARIABLE:
+ (*value_ret) = SHARP_T;
+ return (PRIM_DONE);
- /* This is #F if there isn't one.
- This makes cache_reference_end do the right thing.
- */
- clone = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE));
- tail = * slot;
+ case PRIM_DONE:
+ (*value_ret) = SHARP_F;
+ return (PRIM_DONE);
- for (pair = (* cell); pair != EMPTY_LIST; pair = (* cell))
- {
- weak_pair = (FAST_PAIR_CAR (pair));
- result = (cache_reference_end (kind, extension, clone,
- (FAST_PAIR_CAR (weak_pair)),
- (OBJECT_DATUM (FAST_PAIR_CDR (weak_pair))),
- value));
- if (result != PRIM_DONE)
- {
- /* We are severely screwed.
- compiler_recache will do the appropriate thing.
- */
- *slot = tail;
+ default:
return (result);
}
-
- * slot = pair;
- slot = (PAIR_CDR_LOC (pair));
- * cell = * slot;
- }
- * slot = tail;
- return (PRIM_DONE);
}
-\f
+
long
-DEFUN (compiler_recache,
- (old_value_cell, new_value_cell, env, sym, value, shadowed_p, link_p),
- SCHEME_OBJECT * old_value_cell
- AND SCHEME_OBJECT * new_value_cell
- AND SCHEME_OBJECT env
- AND SCHEME_OBJECT sym
- AND SCHEME_OBJECT value
- AND Boolean shadowed_p
- AND Boolean link_p)
+compiler_assignment_trap (SCHEME_OBJECT cache, SCHEME_OBJECT value,
+ SCHEME_OBJECT * value_ret)
{
-#ifdef DECLARE_LOCK
- DECLARE_LOCK (set_serializer_1);
- DECLARE_LOCK (set_serializer_2);
-#endif
- SCHEME_OBJECT
- old_value, references, extension, new_extension,
- *trap_info_table[TRAP_MAP_TABLE_SIZE];
- SCHEME_OBJECT new_trap = SHARP_F;
- long
- trap_kind, temp, i, index, total_size, total_count, conflict_count;
-
- setup_locks (set_serializer_1, old_value_cell,
- set_serializer_2, new_value_cell);
+ return
+ (assign_variable_cache
+ ((((* (GET_CACHE_CELL (cache))) == EXPENSIVE_OBJECT)
+ /* The cache is a clone. Get the real cache object. */
+ ? (GET_CACHE_CLONE (cache))
+ : cache),
+ value,
+ value_ret,
+ 0));
+}
- if ((!link_p) && (*new_value_cell != DANGEROUS_UNBOUND_OBJECT))
- {
- /* Another processor has redefined this word in the meantime.
- The other processor must have recached all the compiled code
- caches since it is shadowing the same variable.
- The definition has become a redefinition.
- */
- remove_locks (set_serializer_1, set_serializer_2);
- return (redefinition (new_value_cell, value));
- }
+long
+compiler_operator_reference_trap (SCHEME_OBJECT cache,
+ SCHEME_OBJECT * value_ret)
+{
+ return (lookup_variable_cache (cache, value_ret));
+}
+\f
+/***** Variable-reference cache mechanism. *****/
- old_value = *old_value_cell;
+/* add_cache_reference adds a reference to a variable's cache,
+ creating the cache if necessary. It takes the following arguments:
- if (!(REFERENCE_TRAP_P (old_value)))
- {
- remove_locks (set_serializer_1, set_serializer_2);
- return (link_p ?
- PRIM_DONE :
- (definition (new_value_cell, value, shadowed_p)));
- }
+ + cell is a variable's value cell.
- get_trap_kind (trap_kind, old_value);
- if ((trap_kind != TRAP_COMPILER_CACHED) &&
- (trap_kind != TRAP_COMPILER_CACHED_DANGEROUS))
- {
- remove_locks (set_serializer_1, set_serializer_2);
- return (link_p ?
- PRIM_DONE :
- (definition (new_value_cell, value, shadowed_p)));
- }
+ + symbol is the variable's name.
- compiler_recache_prolog ();
+ + block is a compiled-code block, and offset is an offset into
+ block. Together, these specify the location where the variable
+ cache is to be stored.
- extension = (FAST_MEMORY_REF (old_value, TRAP_EXTRA));
- references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
- update_lock (set_serializer_1,
- (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
-\f
- /*
- Split each slot and compute the amount to allocate.
- */
+ + reference_kind specifies the kind of reference that is being cached.
- conflict_count = 0;
- total_size = (link_p ? 0 : SPACE_PER_TRAP);
- total_count = 0;
+ add_cache_reference creates a variable cache for the specified variable,
+ if needed, and stores it in the location specified by (block,
+ offset). It adds the (block,offset) reference to the appropriate
+ reference list for subsequent updating.
- for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
- {
- index = trap_map_table[i];
- temp = compiler_recache_split ((MEMORY_LOC (references, index)),
- sym, env, &trap_info_table[i], link_p);
+ If the reference is a lookup reference, the cache is directly
+ stored in the block.
- if (temp != 0)
- {
- conflict_count += trap_conflict_table[i];
- total_size += (temp * trap_size_table[i]);
- total_count += temp;
- }
- }
+ If the reference is an assignment reference, and there are no
+ operator references to this variable, the cache is directly stored
+ in the block.
- if (total_count == 0)
- {
- compiler_recache_epilog ();
- remove_locks (set_serializer_1, set_serializer_2);
- return (link_p ?
- PRIM_DONE :
- (definition (new_value_cell, value, shadowed_p)));
- }
+ If the reference is an assignment reference, and there _are_
+ operator references to this variable, a "clone" cache is stored in
+ the block. The "clone" cache has a value of EXPENSIVE_OBJECT,
+ which causes any assignment to this cell to trap out to the
+ microcode, where the expensive process of updating all the related
+ operator references can be performed.
- if ((conflict_count == 2) &&
- ((!link_p) ||
- (new_value_cell[TRAP_EXTENSION_CLONE] == SHARP_F)))
- {
- total_size += SPACE_PER_EXTENSION;
- }
+ If the reference is an operator reference, a "UUO" link is stored
+ in the block. If the variable's value is a compiled procedure, the
+ UUO link is a direct reference to the procedure. In all other
+ cases it is a dummy procedure that redirects as needed. If there
+ are assignment references to this variable but no "clone" cache,
+ one is created and all the assignment references updated to point
+ to it. */
- if (GC_allocate_test (total_size))
- {
- /* Unfortunate fact of life: This binding will be dangerous
- even if there is no need, but this is the only way to
- guarantee consistent values.
- */
- compiler_recache_epilog ();
- remove_locks (set_serializer_1, set_serializer_2);
- Request_GC (total_size);
- return (PRIM_INTERRUPT);
+static long
+add_cache_reference (SCHEME_OBJECT * cell,
+ SCHEME_OBJECT symbol,
+ SCHEME_OBJECT block,
+ unsigned long offset,
+ unsigned int reference_kind)
+{
+ /* 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. */
+ GC_CHECK ((2 * SPACE_PER_CACHE) + SPACE_PER_REFERENCE + SPACE_PER_UUO_LINK);
+ 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 (install_cache (cache, block, offset, reference_kind));
}
-\f
- /*
- Allocate and initialize all the cache structures if necessary.
- */
+}
- if (link_p)
- {
- new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, new_value_cell));
- references = new_value_cell[TRAP_EXTENSION_REFERENCES];
- }
- else
- {
- /* The reference trap is created here, but is not installed in the
- environment structure until the end. The new binding contains
- a DANGEROUS_UNBOUND_OBJECT so that other parallel lookups will
- skip this binding.
- */
-
- references = (MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, Free));
-
- *Free++ = EMPTY_LIST;
- *Free++ = EMPTY_LIST;
- *Free++ = EMPTY_LIST;
-
- new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
-
- *Free++ = value;
- *Free++ = sym;
- *Free++ = SHARP_F;
- *Free++ = references;
-
- new_trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
- *Free++ = (LONG_TO_UNSIGNED_FIXNUM ((shadowed_p ?
- TRAP_COMPILER_CACHED_DANGEROUS :
- TRAP_COMPILER_CACHED)));
- *Free++ = new_extension;
- }
+/* Add a new cached reference to the cached reference list pointed at
+ by slot. Attempt to reuse pairs which have been "emptied" by the
+ garbage collector. */
- if ((conflict_count == 2) &&
- (MEMORY_REF (new_extension, TRAP_EXTENSION_CLONE) == SHARP_F))
+static long
+add_reference (SCHEME_OBJECT references, unsigned int reference_kind,
+ SCHEME_OBJECT block, unsigned long offset)
+{
+ SCHEME_OBJECT * slot = (MEMORY_LOC (references, reference_kind));
+ while (PAIR_P (*slot))
+ {
+ SCHEME_OBJECT reference = (PAIR_CAR (*slot));
+ 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));
+ }
{
- SCHEME_OBJECT clone;
-
- clone = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
-
- *Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
- *Free++ = sym;
- *Free++ = new_extension;
- *Free++ = references;
- FAST_MEMORY_SET (new_extension, TRAP_EXTENSION_CLONE, clone);
+ SCHEME_OBJECT reference;
+ RETURN_IF_ERROR (make_cache_reference (block, offset, (&reference)));
+ GC_CHECK (2);
+ (*slot) = (cons (reference, EMPTY_LIST));
}
-\f
- /*
- Now we actually perform the recaching, allocating freely.
- */
+ return (PRIM_DONE);
+}
- for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
- {
- index = trap_map_table[i];
- temp = (compiler_recache_slot (new_extension, sym, index,
- (MEMORY_LOC (references, index)),
- trap_info_table[i],
- value));
- if (temp != PRIM_DONE)
+static long
+install_cache (SCHEME_OBJECT cache,
+ SCHEME_OBJECT block, unsigned long offset,
+ unsigned int reference_kind)
+{
+ switch (reference_kind)
{
- extern char *Abort_Names[];
+ case CACHE_REFERENCES_LOOKUP:
+ store_variable_cache (cache, block, offset);
+ return (PRIM_DONE);
- /* We've lost BIG. */
+ case CACHE_REFERENCES_ASSIGNMENT:
+ store_variable_cache
+ ((((GET_CACHE_CLONE (cache)) != SHARP_F)
+ ? (GET_CACHE_CLONE (cache))
+ : cache),
+ block,
+ offset);
+ return (PRIM_DONE);
- if (temp == PRIM_INTERRUPT)
- outf_fatal ("\ncompiler_recache: Ran out of guaranteed space!\n");
- else if (temp > 0)
- outf_fatal ("\ncompiler_recache: Unexpected error value %d (%s)\n",
- temp, Abort_Names[temp]);
- else
- outf_fatal ("\ncompiler_recache: Unexpected abort value %d (%s)\n",
- -temp, Abort_Names[(-temp) - 1]);
- Microcode_Termination (TERM_EXIT);
- }
- }
+ case CACHE_REFERENCES_OPERATOR:
+ return (install_operator_cache (cache, block, offset));
- if (!link_p)
- {
- *new_value_cell = new_trap;
- }
- compiler_recache_epilog ();
- remove_locks (set_serializer_1, set_serializer_2);
- return (PRIM_DONE);
+ default:
+ abort ();
+ return (0);
+ }
}
-#endif /* DEFINITION_RECACHES_EAGERLY */
+static long
+install_operator_cache (SCHEME_OBJECT cache,
+ SCHEME_OBJECT block, unsigned long offset)
+{
+ SCHEME_OBJECT value = (* (GET_CACHE_CELL (cache)));
+ return
+ ((REFERENCE_TRAP_P (value))
+ ? (make_fake_uuo_link (cache, block, offset))
+ : (make_uuo_link (value, cache, block, offset)));
+}
\f
-/* recache_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.
+/* update_cache_references 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:
- 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.).
- */
+ First, split_cache_references is called to split all references
+ into those that need to be updated and those that do not. This is
+ done by modifying the references list so that all those that need
+ updating are at the end, so that when we subsequently proceed, we
+ can just clip the list and install the tail in the new location.
+ split_cache_references also counts how many entries are affected,
+ so the total amount of space needed can be computed.
-long
-DEFUN (recache_uuo_links, (extension, old_value),
- SCHEME_OBJECT extension
- AND SCHEME_OBJECT old_value)
+ Second, after checking that there is enough space to proceed, the
+ references are moved to their new locations. */
+
+static long
+update_cache_references (SCHEME_OBJECT * new_cell,
+ SCHEME_OBJECT environment, SCHEME_OBJECT symbol)
{
- long EXFUN (update_uuo_links,
- (SCHEME_OBJECT, SCHEME_OBJECT,
- long ((*)(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long))));
+ SCHEME_OBJECT * shadowed_cell;
+ SCHEME_OBJECT * tail_holders [3];
+ SCHEME_OBJECT new_cache;
- SCHEME_OBJECT value;
- long return_value;
+ if (!PROCEDURE_FRAME_P (environment))
+ return (PRIM_DONE);
- value = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL));
- if (REFERENCE_TRAP_P (value))
- {
- if (REFERENCE_TRAP_P (old_value))
- {
- /* No need to do anything.
- The uuo links are in the correct state.
- */
+ 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_value = PRIM_DONE;
- }
- else
- {
- long EXFUN (make_recache_uuo_link,
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
+ RETURN_IF_ERROR (guarantee_cache (new_cell, symbol));
+ new_cache = (GET_TRAP_CACHE (*new_cell));
+
+ /* 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);
- return_value =
- update_uuo_links (value, extension, make_recache_uuo_link);
- }
- }
- else
- {
- extern long
- EXFUN (make_uuo_link,
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
+ /* 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));
- return_value =
- update_uuo_links (value, extension, make_uuo_link);
+ /* 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);
}
+
+ /* 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 (PRIM_DONE);
+}
\f
- if (return_value != PRIM_DONE)
- {
- /*
- This reverts the variable's value to the original value except
- when the value was fluid bound. In the latter case, it does
- not matter, it should still work: When the assignment is
- restarted, and recache_uuo_links is restarted, the relative
- "trapness" of both old and new values should be unchanged.
-
- Note that recache_uuo_links is invoked with the cell locked,
- so it is safe to "revert" the value.
- */
-
- FAST_MEMORY_SET (extension, TRAP_EXTENSION_CELL, old_value);
- }
- return (return_value);
+static unsigned long
+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 references_to_move = EMPTY_LIST;
+ unsigned long count = 0;
+ while (PAIR_P (*holder))
+ {
+ SCHEME_OBJECT p = (*holder);
+ SCHEME_OBJECT reference = (PAIR_CAR (p));
+ SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference));
+ if (block == SHARP_F)
+ (*holder) = (PAIR_CDR (p));
+ else if (environment_ancestor_or_self_p
+ (environment, (compiled_block_environment (block))))
+ {
+ (*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);
}
-/* This kludge is due to the lack of closures. */
-
-long
-DEFUN (make_recache_uuo_link, (value, extension, block, offset),
- SCHEME_OBJECT value
- AND SCHEME_OBJECT extension
- AND SCHEME_OBJECT block
- AND long offset)
+static int
+environment_ancestor_or_self_p (SCHEME_OBJECT ancestor,
+ SCHEME_OBJECT descendant)
{
- extern long
- EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long));
+ while (PROCEDURE_FRAME_P (descendant))
+ {
+ if (descendant == ancestor)
+ return (1);
+ descendant = (GET_FRAME_PARENT (descendant));
+ }
+ return (descendant == ancestor);
+}
- return (make_fake_uuo_link (extension, block, offset));
+static void
+move_cache_references (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;
+ while (PAIR_P (tail))
+ {
+ DIE_IF_ERROR
+ (install_cache (cache,
+ (GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (tail))),
+ (GET_CACHE_REFERENCE_OFFSET (PAIR_CAR (tail))),
+ reference_kind));
+ tail = (PAIR_CDR (tail));
+ }
}
\f
-long
-DEFUN (update_uuo_links,
- (value, extension, handler),
- SCHEME_OBJECT value
- AND SCHEME_OBJECT extension
- AND long EXFUN ((*handler),
- (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long)))
-{
- SCHEME_OBJECT references, pair, block;
- fast SCHEME_OBJECT *slot;
- long return_value;
+/* 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.
- update_uuo_prolog();
- references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
- slot = (MEMORY_LOC (references, TRAP_REFERENCES_OPERATOR));
+ 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.). */
- while (*slot != EMPTY_LIST)
+static long
+update_uuo_links (SCHEME_OBJECT cache, SCHEME_OBJECT new_value)
+{
{
- pair = (FAST_PAIR_CAR (*slot));
- block = (FAST_PAIR_CAR (pair));
- if (block == SHARP_F)
- {
- *slot = (FAST_PAIR_CDR (*slot));
- }
- else
- {
- return_value =
- (*handler)(value, extension, block,
- (OBJECT_DATUM (FAST_PAIR_CDR (pair))));
- if (return_value != PRIM_DONE)
+ unsigned long n_operators
+ = (count_references (cache, CACHE_REFERENCES_OPERATOR));
+ if (n_operators == 0)
{
- update_uuo_epilog ();
- return (return_value);
+ /* 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);
+ (* (GET_CACHE_CELL (cache))) = new_value;
}
- slot = (PAIR_CDR_LOC (*slot));
- }
+ GC_CHECK (n_operators * SPACE_PER_UUO_LINK);
}
-
- /* If there are no uuo links left, and there is an extension clone,
- remove it, and make assignment references point to the real value
- cell.
- */
-
- if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) == EMPTY_LIST) &&
- (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE) != SHARP_F))
+ (* (GET_CACHE_CELL (cache))) = new_value;
{
- FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
- fix_references ((MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT)),
- extension);
+ 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));
+ }
}
- update_uuo_epilog ();
return (PRIM_DONE);
}
\f
-/* compiler_reference_trap is called when a reference occurs to a compiled
- reference cache which contains a reference trap. If the trap is
- the special REQUEST_RECACHE_OBJECT, the reference is recached.
- Otherwise the reference is done normally, and the process continued.
- */
+/***** Utilities *****/
-long
-DEFUN (compiler_reference_trap, (extension, kind, handler),
- SCHEME_OBJECT extension
- AND long kind
- AND long EXFUN ((*handler),(SCHEME_OBJECT *, SCHEME_OBJECT *)))
+static SCHEME_OBJECT *
+find_binding_cell (SCHEME_OBJECT environment, SCHEME_OBJECT symbol)
{
- long offset, temp;
- SCHEME_OBJECT block;
-
-try_again:
-
- if ((MEMORY_REF (extension, TRAP_EXTENSION_CELL)) != REQUEST_RECACHE_OBJECT)
- {
- return ((*handler) (MEMORY_LOC (extension, TRAP_EXTENSION_CELL),
- fake_variable_object));
- }
-
- block = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_BLOCK));
- offset = (OBJECT_DATUM (FAST_MEMORY_REF (extension, TRAP_EXTENSION_OFFSET)));
-
- compiler_trap_prolog ();
- temp =
- (compiler_cache_reference ((compiled_block_environment (block)),
- (FAST_MEMORY_REF (extension,
- TRAP_EXTENSION_NAME)),
- block, offset, kind, false));
- compiler_trap_epilog ();
- if (temp != PRIM_DONE)
- {
- return (temp);
- }
-\f
- switch (kind)
- {
- case TRAP_REFERENCES_OPERATOR:
+ SCHEME_OBJECT frame = environment;
+ while (1)
{
+ SCHEME_OBJECT * cell = (scan_frame (frame, symbol));
+ if ((cell != 0) || (!PROCEDURE_FRAME_P (frame)))
+ return (cell);
+ frame = (GET_FRAME_PARENT (frame));
+ }
+}
- /* Note that this value may cause another operator trap when
- invoked, since it may be a uuo-link to an interpreted
- procedure, or to a variable with a trap in it. However, it
- should not go into a loop because the reference should be
- cached to the correct place, so the extension will no longer
- have a REQUEST_RECACHE_OBJECT in it. The first branch in
- this procedure will be taken in this case. On a
- multiprocessor it may in fact loop if some other processor
- redefines the variable before we have a chance to invoke the
- value.
- */
-
- extern SCHEME_OBJECT
- EXFUN (extract_uuo_link, (SCHEME_OBJECT, long));
-
- Val = (extract_uuo_link (block, offset));
- return (PRIM_DONE);
+static SCHEME_OBJECT *
+scan_frame (SCHEME_OBJECT frame, SCHEME_OBJECT symbol)
+{
+ if (PROCEDURE_FRAME_P (frame))
+ {
+ if (EXTENDED_FRAME_P (frame))
+ {
+ /* Search for a binding in the extension. */
+ SCHEME_OBJECT * scan = (GET_EXTENDED_FRAME_BINDINGS (frame));
+ SCHEME_OBJECT * end = (scan + (GET_EXTENDED_FRAME_LENGTH (frame)));
+ while (scan < end)
+ {
+ if ((PAIR_CAR (*scan)) == symbol)
+ return (PAIR_CDR_LOC (*scan));
+ scan += 1;
+ }
+ return
+ (scan_procedure_bindings
+ ((GET_EXTENDED_FRAME_PROCEDURE (frame)), frame, symbol));
+ }
+ return
+ (scan_procedure_bindings
+ ((GET_FRAME_PROCEDURE (frame)), frame, symbol));
}
+ else if (GLOBAL_FRAME_P (frame))
+ return (SYMBOL_GLOBAL_VALUE_CELL (symbol));
+ else
+ return (0);
+}
- case TRAP_REFERENCES_ASSIGNMENT:
- case TRAP_REFERENCES_LOOKUP:
- default:
+static SCHEME_OBJECT *
+scan_procedure_bindings (SCHEME_OBJECT procedure, SCHEME_OBJECT frame,
+ SCHEME_OBJECT symbol)
+{
+ SCHEME_OBJECT lambda = (GET_PROCEDURE_LAMBDA (procedure));
+ SCHEME_OBJECT * start = (GET_LAMBDA_PARAMETERS (lambda));
+ SCHEME_OBJECT * scan = start;
+ SCHEME_OBJECT * end = (scan + (GET_LAMBDA_N_PARAMETERS (lambda)));
+ while (scan < end)
{
- extern SCHEME_OBJECT
- EXFUN (extract_variable_cache, (SCHEME_OBJECT, long));
-
- extension = (extract_variable_cache (block, offset));
- /* This is paranoid on a single processor, but it does not hurt.
- On a multiprocessor, we need to do it because some other processor
- may have redefined this variable in the meantime.
- */
- goto try_again;
+ if ((*scan) == symbol)
+ return (GET_FRAME_ARG_CELL (frame, (scan - start)));
+ scan += 1;
}
- }
+ return (0);
}
\f
-/* Procedures invoked from the compiled code interface. */
-
-extern long
- EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
- EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
- EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
- EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long));
-
-long
-DEFUN (compiler_cache_lookup, (name, block, offset),
- SCHEME_OBJECT name
- AND SCHEME_OBJECT block
- AND long offset)
+trap_kind_t
+get_trap_kind (SCHEME_OBJECT object)
{
- return (compiler_cache_reference ((compiled_block_environment (block)),
- name, block, offset,
- TRAP_REFERENCES_LOOKUP, true));
+ if (REFERENCE_TRAP_P (object))
+ {
+ unsigned long datum = (OBJECT_DATUM (object));
+ return
+ ((datum <= TRAP_MAX_IMMEDIATE)
+ ? datum
+ : (OBJECT_DATUM (GET_TRAP_TAG (object))));
+ }
+ else
+ return (NON_TRAP_KIND);
}
-long
-DEFUN (compiler_cache_assignment, (name, block, offset),
- SCHEME_OBJECT name
- AND SCHEME_OBJECT block
- AND long offset)
+static unsigned long
+count_references (SCHEME_OBJECT cache, unsigned int references_kind)
{
- return (compiler_cache_reference ((compiled_block_environment (block)),
- name, block, offset,
- TRAP_REFERENCES_ASSIGNMENT, true));
+ SCHEME_OBJECT * holder
+ = (MEMORY_LOC ((GET_CACHE_REFERENCES (cache)), references_kind));
+ unsigned long n_references = 0;
+ while (PAIR_P (*holder))
+ {
+ SCHEME_OBJECT reference = (PAIR_CAR (*holder));
+ SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference));
+ if (block == SHARP_F)
+ (*holder) = (PAIR_CDR (*holder));
+ else
+ {
+ n_references += 1;
+ holder = (PAIR_CDR_LOC (*holder));
+ }
+ }
+ return (n_references);
}
-long
-DEFUN (compiler_cache_operator, (name, block, offset),
- SCHEME_OBJECT name
- AND SCHEME_OBJECT block
- AND long offset)
+static SCHEME_OBJECT *
+find_tail_holder (SCHEME_OBJECT references, unsigned int reference_kind)
{
- return (compiler_cache_reference ((compiled_block_environment (block)),
- name, block, offset,
- TRAP_REFERENCES_OPERATOR, true));
+ SCHEME_OBJECT * holder = (MEMORY_LOC (references, reference_kind));
+ while (PAIR_P (*holder))
+ {
+ SCHEME_OBJECT p = (*holder);
+ if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (p))) == SHARP_F)
+ (*holder) = (PAIR_CDR (p));
+ else
+ holder = (PAIR_CDR_LOC (p));
+ }
+ return (holder);
}
-long
-DEFUN (compiler_cache_global_operator, (name, block, offset),
- SCHEME_OBJECT name
- AND SCHEME_OBJECT block
- AND long offset)
+static void
+update_assignment_references (SCHEME_OBJECT cache)
{
- return (compiler_cache_reference ((MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)),
- name, block, offset,
- TRAP_REFERENCES_OPERATOR, true));
+ SCHEME_OBJECT * holder
+ = (MEMORY_LOC ((GET_CACHE_REFERENCES (cache)),
+ CACHE_REFERENCES_ASSIGNMENT));
+ SCHEME_OBJECT reference_cache
+ = (((GET_CACHE_CLONE (cache)) != SHARP_F)
+ ? (GET_CACHE_CLONE (cache))
+ : cache);
+ while (PAIR_P (*holder))
+ {
+ SCHEME_OBJECT reference = (PAIR_CAR (*holder));
+ if ((GET_CACHE_REFERENCE_BLOCK (reference)) == SHARP_F)
+ (*holder) = (PAIR_CDR (*holder));
+ else
+ {
+ store_variable_cache
+ (reference_cache,
+ (GET_CACHE_REFERENCE_BLOCK (reference)),
+ (GET_CACHE_REFERENCE_OFFSET (reference)));
+ holder = (PAIR_CDR_LOC (*holder));
+ }
+ }
}
\f
-extern long
- EXFUN (complr_operator_reference_trap, (SCHEME_OBJECT *, SCHEME_OBJECT));
+static long
+guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol)
+{
+ SCHEME_OBJECT references;
+ SCHEME_OBJECT cache;
-extern SCHEME_OBJECT
- EXFUN (compiler_var_error, (SCHEME_OBJECT, SCHEME_OBJECT));
+ if ((get_trap_kind (*cell)) == TRAP_COMPILER_CACHED)
+ return (PRIM_DONE);
-long
-DEFUN (complr_operator_reference_trap, (frame_slot, extension),
- SCHEME_OBJECT * frame_slot
- AND SCHEME_OBJECT extension)
-{
- long temp;
+ RETURN_IF_ERROR (make_cache_references (&references));
+ RETURN_IF_ERROR
+ (make_cache ((*cell), symbol, SHARP_F, references, (&cache)));
- temp = (compiler_reference_trap (extension,
- TRAP_REFERENCES_OPERATOR,
- deep_lookup_end));
- if (temp != PRIM_DONE)
- {
- return temp;
- }
- *frame_slot = Val;
+ GC_CHECK (2);
+ (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED));
+ (*Free++) = cache;
+ (*cell) = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, (Free - 2)));
return (PRIM_DONE);
}
-SCHEME_OBJECT
-DEFUN (compiler_var_error, (extension, environment),
- SCHEME_OBJECT extension
- AND SCHEME_OBJECT environment)
-{
- return (MEMORY_REF (extension, TRAP_EXTENSION_NAME));
-}
-
-/* Utility for compiler_assignment_trap, below.
- Necessary because C lacks lambda. Argh!
- */
-
-static SCHEME_OBJECT saved_compiler_assignment_value;
-
-long
-DEFUN (compiler_assignment_end, (cell, hunk),
- SCHEME_OBJECT * cell
- AND SCHEME_OBJECT * hunk)
+static long
+guarantee_clone (SCHEME_OBJECT cache)
{
- return (deep_assignment_end (cell, hunk,
- saved_compiler_assignment_value, false));
+ 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 (cache)),
+ (&clone)));
+ SET_CACHE_CLONE (cache, clone);
+ update_assignment_references (cache);
+ }
+ return (PRIM_DONE);
}
-\f
-/* More compiled code interface procedures */
-extern long
- EXFUN (compiler_lookup_trap, (SCHEME_OBJECT)),
- EXFUN (compiler_safe_lookup_trap, (SCHEME_OBJECT)),
- EXFUN (compiler_unassigned_p_trap, (SCHEME_OBJECT)),
- EXFUN (compiler_assignment_trap, (SCHEME_OBJECT, SCHEME_OBJECT));
-
-long
-DEFUN (compiler_lookup_trap, (extension), SCHEME_OBJECT extension)
+static void
+flush_clone (SCHEME_OBJECT cache)
{
- return (compiler_reference_trap (extension,
- TRAP_REFERENCES_LOOKUP,
- deep_lookup_end));
+ if ((GET_CACHE_CLONE (cache)) != SHARP_F)
+ {
+ SET_CACHE_CLONE (cache, SHARP_F);
+ update_assignment_references (cache);
+ }
}
-long
-DEFUN (compiler_safe_lookup_trap, (extension), SCHEME_OBJECT extension)
+static long
+make_cache (SCHEME_OBJECT value, SCHEME_OBJECT symbol, SCHEME_OBJECT clone,
+ SCHEME_OBJECT references, SCHEME_OBJECT * cache_ret)
{
- return (safe_reference_transform (compiler_lookup_trap (extension)));
+ GC_CHECK (4);
+ (*Free++) = value;
+ (*Free++) = symbol;
+ (*Free++) = clone;
+ (*Free++) = references;
+ (*cache_ret) = (MAKE_POINTER_OBJECT (CACHE_TYPE, (Free - 4)));
+ return (PRIM_DONE);
}
-long
-DEFUN (compiler_unassigned_p_trap, (extension), SCHEME_OBJECT extension)
+static long
+make_cache_references (SCHEME_OBJECT * refs_ret)
{
- return (unassigned_p_transform (compiler_lookup_trap (extension)));
+ 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);
}
-long
-DEFUN (compiler_assignment_trap, (extension, value),
- SCHEME_OBJECT extension
- AND SCHEME_OBJECT value)
+static long
+make_cache_reference (SCHEME_OBJECT block, unsigned long offset,
+ SCHEME_OBJECT * ref_ret)
{
- saved_compiler_assignment_value = value;
- return (compiler_reference_trap (extension,
- TRAP_REFERENCES_ASSIGNMENT,
- compiler_assignment_end));
+ GC_CHECK (2);
+ (*Free++) = block;
+ (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (offset));
+ (*ref_ret) = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free - 2)));
+ return (PRIM_DONE);
}
projects / mit-scheme.git / commitdiff