From: Chris Hanson Date: Tue, 31 Jul 2001 03:12:15 +0000 (+0000) Subject: Completely rewrite the variable-reference code. New design is X-Git-Tag: 20090517-FFI~2624 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=84a3db4469e127771008514b7025c833ee83f4f9;p=mit-scheme.git Completely rewrite the variable-reference code. New design is considerably simpler, having discarded all the legacy code from the Butterfly. Furthermore, two hacks to speed up the interpreter, caching of variable locations and in-line variable reference, have been removed. This makes the interpreter slower, but has no effect on compiled code, and has several important benefits. One benefit is that we can now implement undefine. New design allows ENVIRONMENT-LINK-NAME to link to a variable that is already bound (previous signalled an error in this case). Eliminate "in-line" variable references in the interpreter. All reference machinery is now defined in "lookup.c". Define THE_GLOBAL_ENV and THE_NULL_ENV, and predicates to detect them. Eliminate GO_TO_GLOBAL and END_OF_CHAIN definitions. Latter was a name conflict under OS/2. Change definition of ENVIRONMENT_P so that it is false for THE_NULL_ENV. Define lots of macros to provide abstract access to the data structures used for variable references. Change terminology, so that instead of "trap extension" we now use "cache", and so on for the substructures of the cache. Add "guards" to allow .h files to be loaded more than once. Remove variable-access procedures from "extern.h"; new procedures are now defined in "lookup.h". Eliminate all unused trap kinds. --- diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 0d3bc6379..4d493e768 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: boot.c,v 9.104 2000/12/05 21:23:43 cph Exp $ +$Id: boot.c,v 9.105 2001/07/31 03:10:57 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 @@ -16,7 +16,8 @@ General Public License for more details. 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 `main' and associated startup code. */ @@ -411,7 +412,7 @@ DEFUN (Start_Scheme, (Start_Prim, File_Name), expr = MAKE_POINTER_OBJECT (TC_PCOMB2, Free); *Free++ = prim; *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); - *Free++ = MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL); + *Free++ = THE_GLOBAL_ENV; break; case BOOT_LOAD_BAND: /* (LOAD-BAND ) */ @@ -444,7 +445,7 @@ DEFUN (Start_Scheme, (Start_Prim, File_Name), expr = (MAKE_POINTER_OBJECT (TC_PCOMB2, Free)); *Free++ = prim; *Free++ = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg)); - *Free++ = (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)); + *Free++ = THE_GLOBAL_ENV; break; @@ -457,7 +458,7 @@ DEFUN (Start_Scheme, (Start_Prim, File_Name), /* Setup registers */ INITIALIZE_INTERRUPTS (); SET_INTERRUPT_MASK (0); - Env = (MAKE_OBJECT (GLOBAL_ENV, 0)); + Env = THE_GLOBAL_ENV; Trapping = false; Return_Hook_Address = NULL; diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 252c923ba..8f9bc5838 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: cmpint.c,v 1.92 2000/12/05 21:23:43 cph Exp $ +$Id: cmpint.c,v 1.93 2001/07/31 03:11:12 cph Exp $ -Copyright (c) 1989-2000 Massachusetts Institute of Technology +Copyright (c) 1989-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 @@ -16,7 +16,8 @@ General Public License for more details. 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. */ /* @@ -81,7 +82,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #include "interp.h" /* Interpreter state and primitive destructuring */ #include "default.h" /* various definitions */ #include "extern.h" /* External decls (missing Cont_Debug, etc.) */ -#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */ +#include "trap.h" /* UNASSIGNED_OBJECT, CACHE_TYPE */ #include "prims.h" /* LEXPR */ #include "prim.h" /* Primitive_Procedure_Table, etc. */ @@ -91,6 +92,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define IN_CMPINT_C #include "cmpgc.h" /* Compiled code object relocation */ +#include "lookup.h" + #ifdef HAS_COMPILER_SUPPORT /* ASM_ENTRY_POINT, EXFNX, and DEFNX are for OS/2. The IBM C Set++/2 @@ -247,12 +250,6 @@ typedef utility_result EXFUN (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr)) /* Imports from the rest of the "microcode" */ - -extern long - EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)), - EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)), - EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)), - EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)); /* Exports to the rest of the "microcode" */ @@ -996,7 +993,9 @@ DEFNX (comutil_lexpr_apply, static long DEFUN (compiler_link_closure_pattern, (distance, block, offset), - SCHEME_OBJECT distance AND SCHEME_OBJECT block AND long offset) + SCHEME_OBJECT distance AND + SCHEME_OBJECT block AND + unsigned long offset) { long objdist = (FIXNUM_TO_LONG (distance)); long nmv_length = (OBJECT_DATUM (MEMORY_REF (block, 1))); @@ -1047,9 +1046,9 @@ static long DEFUN (link_cc_block, (block_address, offset, last_header_offset, sections, original_count, ret_add), - register SCHEME_OBJECT * block_address AND - register long offset AND - long last_header_offset AND + SCHEME_OBJECT * block_address AND + unsigned long offset AND + unsigned long last_header_offset AND long sections AND long original_count AND instruction * ret_add) @@ -1059,7 +1058,7 @@ DEFUN (link_cc_block, SCHEME_OBJECT block; SCHEME_OBJECT header; long result, kind, total_count; - long EXFUN ((* cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, long)); + long EXFUN ((*cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long)); transaction_begin (); { @@ -1146,7 +1145,7 @@ DEFUN (link_cc_block, else EXTRACT_EXECUTE_CACHE_SYMBOL (info, &(block_address[offset])); - result = ((* cache_handler) (info, block, offset)); + result = ((*cache_handler) (info, block, offset)); if (result != PRIM_DONE) { /* Save enough state to continue. @@ -1238,7 +1237,7 @@ DEFNX (comutil_link, = (SCHEME_ADDR_TO_ADDR (block_address_raw)); SCHEME_OBJECT * constant_address = (SCHEME_ADDR_TO_ADDR (constant_address_raw)); - long offset; + unsigned long offset; #ifdef AUTOCLOBBER_BUG block_address[OBJECT_DATUM (* block_address)] = Regs[REGBLOCK_ENV]; @@ -1266,7 +1265,9 @@ C_TO_SCHEME long DEFUN_VOID (comp_link_caches_restart) { SCHEME_OBJECT block, environment; - long original_count, offset, last_header_offset, sections, code; + long original_count, sections, code; + unsigned long offset; + unsigned long last_header_offset; instruction * ret_add; original_count = (OBJECT_DATUM (STACK_POP())); @@ -1404,9 +1405,6 @@ DEFNX (comutil_operator_primitive_trap, return (comutil_primitive_apply ((tramp_data[0]), 0, 0, 0)); } - -extern SCHEME_OBJECT EXFUN (compiler_var_error, - (SCHEME_OBJECT, SCHEME_OBJECT)); /* The linker either couldn't find a binding or the binding was unassigned, unbound, or a deep-bound (parallel processor) fluid. @@ -1423,36 +1421,34 @@ extern SCHEME_OBJECT EXFUN (compiler_var_error, SCHEME_UTILITY utility_result DEFNX (comutil_operator_lookup_trap, (tramp_data_raw, ignore_2, ignore_3, ignore_4), - SCHEME_ADDR tramp_data_raw - AND long ignore_2 AND long ignore_3 AND long ignore_4) + SCHEME_ADDR tramp_data_raw AND + long ignore_2 AND + long ignore_3 AND + long ignore_4) { - extern long EXFUN (complr_operator_reference_trap, - (SCHEME_OBJECT *, SCHEME_OBJECT)); SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - SCHEME_OBJECT true_operator, * cache_cell; - long code, nargs; + SCHEME_OBJECT true_operator; + long code + = (compiler_operator_reference_trap ((tramp_data[0]), (&true_operator))); + SCHEME_OBJECT * cache_cell + = (MEMORY_LOC ((tramp_data[1]), (OBJECT_DATUM (tramp_data[2])))); + long nargs; - code = (complr_operator_reference_trap (&true_operator, (tramp_data[0]))); - cache_cell = (MEMORY_LOC ((tramp_data[1]), - (OBJECT_DATUM (tramp_data[2])))); EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell); if (code == PRIM_DONE) return (comutil_apply (true_operator, nargs, 0, 0)); - else /* Error or interrupt */ + /* Error or interrupt */ { - SCHEME_OBJECT trampoline, environment, name; + SCHEME_OBJECT trampoline; - /* This could be done by bumpint tramp_data to the entry point. - It would probably be better. - */ + /* This could be done by bumping tramp_data to the entry point. + It would probably be better. */ EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell); - environment = (compiled_block_environment (tramp_data[1])); - name = (compiler_var_error ((tramp_data[0]), environment)); - STACK_PUSH (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (trampoline))); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs)); /* For debugger */ - STACK_PUSH (environment); /* For debugger */ - STACK_PUSH (name); /* For debugger */ + /* Next three for debugger. */ + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs)); + STACK_PUSH (compiled_block_environment (tramp_data[1])); + STACK_PUSH (compiler_var_error (tramp_data[0])); Store_Expression (SHARP_F); Store_Return (RC_COMP_OP_REF_TRAP_RESTART); Save_Cont (); @@ -1768,9 +1764,7 @@ DEFNX (comutil_interrupt_continuation_2, C_TO_SCHEME long DEFUN_VOID (comp_interrupt_restart) { - SCHEME_OBJECT state; - - state = (STACK_POP ()); + SCHEME_OBJECT state = (STACK_POP ()); Store_Env (state); Val = state; ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); @@ -1783,95 +1777,77 @@ DEFUN_VOID (comp_interrupt_restart) SCHEME_UTILITY utility_result DEFNX (comutil_assignment_trap, (return_address_raw, extension_addr_raw, value, ignore_4), - SCHEME_ADDR return_address_raw - AND SCHEME_ADDR extension_addr_raw - AND SCHEME_OBJECT value - AND long ignore_4) + SCHEME_ADDR return_address_raw AND + SCHEME_ADDR extension_addr_raw AND + SCHEME_OBJECT value AND + long ignore_4) { - extern long EXFUN (compiler_assignment_trap, (SCHEME_OBJECT, SCHEME_OBJECT)); instruction * return_address = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); - SCHEME_OBJECT * extension_addr = (SCHEME_ADDR_TO_ADDR (extension_addr_raw)); - SCHEME_OBJECT extension; - long code; - - extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr)); - code = (compiler_assignment_trap (extension, value)); + SCHEME_OBJECT extension + = (MAKE_POINTER_OBJECT + (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw)))); + long code = (compiler_assignment_trap (extension, value, (&Val))); if (code == PRIM_DONE) RETURN_TO_SCHEME (return_address); else - { - SCHEME_OBJECT block, environment, name, sra; - - sra = (ENTRY_TO_OBJECT (return_address)); - STACK_PUSH (sra); - STACK_PUSH (value); - block = (compiled_entry_to_block (sra)); - environment = (compiled_block_environment (block)); - STACK_PUSH (environment); - name = (compiler_var_error (extension, environment)); - STACK_PUSH (name); - Store_Expression (SHARP_F); - Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); - Save_Cont (); - RETURN_TO_C (code); - } + { + SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); + STACK_PUSH (sra); + STACK_PUSH (value); + STACK_PUSH (compiled_block_environment (compiled_entry_to_block (sra))); + STACK_PUSH (compiler_var_error (extension)); + Store_Expression (SHARP_F); + Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); + Save_Cont (); + RETURN_TO_C (code); + } } C_TO_SCHEME long DEFUN_VOID (comp_assignment_trap_restart) { - extern long EXFUN (Symbol_Lex_Set, - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT)); - SCHEME_OBJECT name, environment, value; - long code; - - name = (STACK_POP ()); - environment = (STACK_POP ()); - value = (STACK_POP ()); - code = (Symbol_Lex_Set (environment, name, value)); + SCHEME_OBJECT name = (STACK_POP ()); + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT value = (STACK_POP ()); + long code = (assign_variable (environment, name, value, (&Val))); if (code == PRIM_DONE) ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); else - { - STACK_PUSH (value); - STACK_PUSH (environment); - STACK_PUSH (name); - Store_Expression (SHARP_F); - Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); - Save_Cont (); - return (code); - } + { + STACK_PUSH (value); + STACK_PUSH (environment); + STACK_PUSH (name); + Store_Expression (SHARP_F); + Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); + Save_Cont (); + return (code); + } } SCHEME_UTILITY utility_result DEFNX (comutil_cache_lookup_apply, (extension_addr_raw, block_address_raw, nactuals, ignore_4), - SCHEME_ADDR extension_addr_raw - AND SCHEME_ADDR block_address_raw - AND long nactuals - AND long ignore_4) + SCHEME_ADDR extension_addr_raw AND + SCHEME_ADDR block_address_raw AND + long nactuals AND + long ignore_4) { - extern long EXFUN (compiler_lookup_trap, (SCHEME_OBJECT)); - SCHEME_OBJECT * extension_addr = (SCHEME_ADDR_TO_ADDR (extension_addr_raw)); - SCHEME_OBJECT * block_address = (SCHEME_ADDR_TO_ADDR (block_address_raw)); - SCHEME_OBJECT extension; - long code; - - extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr)); - code = (compiler_lookup_trap (extension)); + SCHEME_OBJECT extension + = (MAKE_POINTER_OBJECT + (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw)))); + SCHEME_OBJECT value; + long code = (compiler_lookup_trap (extension, (&value))); if (code == PRIM_DONE) - return (comutil_apply (Val, nactuals, 0, 0)); - else + return (comutil_apply (value, nactuals, 0, 0)); { - SCHEME_OBJECT block, environment, name; - - block = (MAKE_CC_BLOCK (block_address)); + SCHEME_OBJECT block + = (MAKE_CC_BLOCK (SCHEME_ADDR_TO_ADDR (block_address_raw))); + SCHEME_OBJECT environment = (compiled_block_environment (block)); + SCHEME_OBJECT name = (compiler_var_error (extension)); STACK_PUSH (block); STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - environment = (compiled_block_environment (block)); STACK_PUSH (environment); - name = (compiler_var_error (extension, environment)); STACK_PUSH (name); Store_Expression (SHARP_F); Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART); @@ -1883,97 +1859,83 @@ DEFNX (comutil_cache_lookup_apply, C_TO_SCHEME long DEFUN_VOID (comp_cache_lookup_apply_restart) { - extern long EXFUN (Symbol_Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT)); - SCHEME_OBJECT name, environment; - long code; - - name = (STACK_POP ()); - environment = (STACK_POP ()); - code = (Symbol_Lex_Ref (environment, name)); + SCHEME_OBJECT name = (STACK_POP ()); + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT value; + long code = (lookup_variable (environment, name, (&value))); if (code == PRIM_DONE) - { - /* Replace block with actual operator */ - (* (STACK_LOC (1))) = Val; - if (COMPILED_CODE_ADDRESS_P (Val)) - return (apply_compiled_procedure ()); - else - return (PRIM_APPLY); - } + { + /* Replace block with actual operator */ + (* (STACK_LOC (1))) = value; + if (COMPILED_CODE_ADDRESS_P (value)) + return (apply_compiled_procedure ()); + else + return (PRIM_APPLY); + } else - { - STACK_PUSH (environment); - STACK_PUSH (name); - Store_Expression (SHARP_F); - Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART); - Save_Cont (); - return (code); - } + { + STACK_PUSH (environment); + STACK_PUSH (name); + Store_Expression (SHARP_F); + Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART); + Save_Cont (); + return (code); + } } /* Variable reference traps: Reference to a free variable that has a reference trap -- either a - fluid or an error (unassigned / unbound) - */ + fluid or an error (unassigned / unbound). */ #define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup) \ SCHEME_UTILITY utility_result \ DEFNX (name, \ (return_address_raw, extension_addr_raw, ignore_3, ignore_4), \ - SCHEME_ADDR return_address_raw \ - AND SCHEME_ADDR extension_addr_raw \ - AND long ignore_3 AND long ignore_4) \ + SCHEME_ADDR return_address_raw AND \ + SCHEME_ADDR extension_addr_raw AND \ + long ignore_3 AND \ + long ignore_4) \ { \ - extern long EXFUN (c_trap, (SCHEME_OBJECT)); \ instruction * return_address \ = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); \ - SCHEME_OBJECT * extension_addr \ - = (SCHEME_ADDR_TO_ADDR (extension_addr_raw)); \ - SCHEME_OBJECT extension; \ - long code; \ - \ - extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr)); \ - code = c_trap (extension); \ + SCHEME_OBJECT extension \ + = (MAKE_POINTER_OBJECT \ + (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw)))); \ + long code = (c_trap (extension, (&Val))); \ if (code == PRIM_DONE) \ RETURN_TO_SCHEME (return_address); \ else \ - { \ - SCHEME_OBJECT block, environment, name, sra; \ - \ - sra = (ENTRY_TO_OBJECT (return_address)); \ - STACK_PUSH (sra); \ - block = (compiled_entry_to_block (sra)); \ - environment = (compiled_block_environment (block)); \ - STACK_PUSH (environment); \ - name = (compiler_var_error (extension, environment)); \ - STACK_PUSH (name); \ - Store_Expression (SHARP_F); \ - Store_Return (ret_code); \ - Save_Cont (); \ - RETURN_TO_C (code); \ - } \ + { \ + SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); \ + STACK_PUSH (sra); \ + STACK_PUSH \ + (compiled_block_environment \ + (compiled_entry_to_block (sra))); \ + STACK_PUSH (compiler_var_error (extension)); \ + Store_Expression (SHARP_F); \ + Store_Return (ret_code); \ + Save_Cont (); \ + RETURN_TO_C (code); \ + } \ } \ \ C_TO_SCHEME long \ DEFUN_VOID (restart) \ { \ - extern long EXFUN (c_lookup, (SCHEME_OBJECT, SCHEME_OBJECT)); \ - SCHEME_OBJECT name, environment; \ - long code; \ - \ - name = (Fetch_Expression ()); \ - environment = (STACK_POP ()); \ - code = (c_lookup (environment, name)); \ + SCHEME_OBJECT name = (Fetch_Expression ()); \ + SCHEME_OBJECT environment = (STACK_POP ()); \ + long code = (c_lookup (environment, name, (&Val))); \ if (code == PRIM_DONE) \ ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \ else \ - { \ - STACK_PUSH (environment); \ - STACK_PUSH (name); \ - Store_Expression (SHARP_F); \ - Store_Return (ret_code); \ - Save_Cont (); \ - return (code); \ - } \ + { \ + STACK_PUSH (environment); \ + STACK_PUSH (name); \ + Store_Expression (SHARP_F); \ + Store_Return (ret_code); \ + Save_Cont (); \ + return (code); \ + } \ } /* Actual traps */ @@ -1982,19 +1944,19 @@ CMPLR_REF_TRAP(comutil_lookup_trap, compiler_lookup_trap, RC_COMP_LOOKUP_TRAP_RESTART, comp_lookup_trap_restart, - Symbol_Lex_Ref) + lookup_variable) CMPLR_REF_TRAP(comutil_safe_lookup_trap, compiler_safe_lookup_trap, RC_COMP_SAFE_REF_TRAP_RESTART, comp_safe_lookup_trap_restart, - safe_symbol_lex_ref) + safe_lookup_variable) CMPLR_REF_TRAP(comutil_unassigned_p_trap, compiler_unassigned_p_trap, RC_COMP_UNASSIGNED_TRAP_RESTART, comp_unassigned_p_trap_restart, - Symbol_Lex_unassigned_p) + variable_unassigned_p) /* NUMERIC ROUTINES @@ -2047,12 +2009,11 @@ DEFNX (util_name, \ AND SCHEME_OBJECT environment AND SCHEME_OBJECT variable \ AND long ignore_4) \ { \ - extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT)); \ instruction * ret_add \ = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \ long code; \ \ - code = (c_proc (environment, variable)); \ + code = (c_proc (environment, variable, (&Val))); \ if (code == PRIM_DONE) \ { \ RETURN_TO_SCHEME (ret_add); \ @@ -2072,13 +2033,12 @@ DEFNX (util_name, \ C_TO_SCHEME long \ DEFUN_VOID (restart_name) \ { \ - extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT)); \ SCHEME_OBJECT environment, variable; \ long code; \ \ environment = (STACK_POP ()); \ variable = (STACK_POP ()); \ - code = (c_proc (environment, variable)); \ + code = (c_proc (environment, variable, (&Val))); \ if (code == PRIM_DONE) \ { \ Regs[REGBLOCK_ENV] = environment; \ @@ -2104,8 +2064,6 @@ DEFNX (util_name, \ AND SCHEME_OBJECT variable \ AND SCHEME_OBJECT value) \ { \ - extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT, \ - SCHEME_OBJECT)); \ instruction * ret_add \ = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \ long code; \ @@ -2129,8 +2087,6 @@ DEFNX (util_name, \ C_TO_SCHEME long \ DEFUN_VOID (restart_name) \ { \ - extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT, \ - SCHEME_OBJECT)); \ SCHEME_OBJECT environment, variable, value; \ long code; \ \ @@ -2156,37 +2112,54 @@ DEFUN_VOID (restart_name) \ } CMPLR_REFERENCE(comutil_access, - Symbol_Lex_Ref, + lookup_variable, RC_COMP_ACCESS_RESTART, comp_access_restart) CMPLR_REFERENCE(comutil_reference, - Lex_Ref, + lookup_variable, RC_COMP_REFERENCE_RESTART, comp_reference_restart) CMPLR_REFERENCE(comutil_safe_reference, - safe_lex_ref, + safe_lookup_variable, RC_COMP_SAFE_REFERENCE_RESTART, comp_safe_reference_restart) CMPLR_REFERENCE(comutil_unassigned_p, - Symbol_Lex_unassigned_p, + variable_unassigned_p, RC_COMP_UNASSIGNED_P_RESTART, comp_unassigned_p_restart) CMPLR_REFERENCE(comutil_unbound_p, - Symbol_Lex_unbound_p, + variable_unbound_p, RC_COMP_UNBOUND_P_RESTART, comp_unbound_p_restart) +static long +compiler_assign_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, + SCHEME_OBJECT value) +{ + return (assign_variable (environment, symbol, value, (&Val))); +} + CMPLR_ASSIGNMENT(comutil_assignment, - Lex_Set, + compiler_assign_variable, RC_COMP_ASSIGNMENT_RESTART, comp_assignment_restart) +static long +compiler_define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, + SCHEME_OBJECT value) +{ + long result = (define_variable (environment, symbol, value)); + if (result == PRIM_DONE) + Val = symbol; + return (result); +} + CMPLR_ASSIGNMENT(comutil_definition, - Local_Set, + compiler_define_variable, RC_COMP_DEFINITION_RESTART, comp_definition_restart) @@ -2196,13 +2169,9 @@ DEFNX (comutil_lookup_apply, SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND long nactuals AND long ignore_4) { - extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT)); - long code; - - code = (Lex_Ref (environment, variable)); + long code = (lookup_variable (environment, variable, (&Val))); if (code == PRIM_DONE) return (comutil_apply (Val, nactuals, 0, 0)); - else { STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); STACK_PUSH (variable); @@ -2217,34 +2186,29 @@ DEFNX (comutil_lookup_apply, C_TO_SCHEME long DEFUN_VOID (comp_lookup_apply_restart) { - extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT)); - SCHEME_OBJECT environment, variable; - long code; - - environment = (STACK_POP ()); - variable = (STACK_POP ()); - code = (Lex_Ref (environment, variable)); + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT variable = (STACK_POP ()); + SCHEME_OBJECT value; + long code = (lookup_variable (environment, variable, (&value))); if (code == PRIM_DONE) - { - SCHEME_OBJECT nactuals; - - nactuals = (STACK_POP ()); - STACK_PUSH (Val); - STACK_PUSH (nactuals); - if (COMPILED_CODE_ADDRESS_P (Val)) - return (apply_compiled_procedure ()); - else - return (PRIM_APPLY); - } + { + SCHEME_OBJECT nactuals = (STACK_POP ()); + STACK_PUSH (value); + STACK_PUSH (nactuals); + if (COMPILED_CODE_ADDRESS_P (value)) + return (apply_compiled_procedure ()); + else + return (PRIM_APPLY); + } else - { - STACK_PUSH (variable); - STACK_PUSH (environment); - Store_Expression (SHARP_F); - Store_Return (RC_COMP_LOOKUP_APPLY_RESTART); - Save_Cont (); - return (code); - } + { + STACK_PUSH (variable); + STACK_PUSH (environment); + Store_Expression (SHARP_F); + Store_Return (RC_COMP_LOOKUP_APPLY_RESTART); + Save_Cont (); + return (code); + } } SCHEME_UTILITY utility_result @@ -2539,7 +2503,7 @@ DEFUN (extract_variable_cache, (block, offset), SCHEME_OBJECT block AND long offset) { - return (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, + return (MAKE_POINTER_OBJECT (CACHE_TYPE, ((SCHEME_OBJECT *) (SCHEME_ADDR_TO_ADDR (FAST_MEMORY_REF (block, offset)))))); diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index 198def32c..7ad67ab7c 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: debug.c,v 9.52 2001/03/08 18:00:18 cph Exp $ +$Id: debug.c,v 9.53 2001/07/31 03:11:17 cph Exp $ -Copyright (c) 1987-2000 Massachusetts Institute of Technology +Copyright (c) 1987-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 @@ -16,7 +16,8 @@ General Public License for more details. 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. */ /* Utilities to help with debugging */ @@ -171,7 +172,7 @@ DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) procedure = MEMORY_REF (The_Env, ENVIRONMENT_FUNCTION); value_ptr = MEMORY_LOC (The_Env, ENVIRONMENT_FIRST_ARG); - if (OBJECT_TYPE (procedure) == AUX_LIST_TYPE) + if (FRAME_EXTENSION_P (procedure)) { extension = procedure; procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE); @@ -198,9 +199,9 @@ DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) } if (extension != SHARP_F) { - outf_console ("Auxilliary Variables\n"); - count = OBJECT_DATUM (MEMORY_REF (extension, AUX_LIST_COUNT)); - for (i = 0, name_ptr = MEMORY_LOC (extension, AUX_LIST_FIRST); + outf_console ("Auxiliary Variables\n"); + count = (GET_FRAME_EXTENSION_LENGTH (extension)); + for (i = 0, name_ptr = (GET_FRAME_EXTENSION_BINDINGS (extension)); i < count; i++, name_ptr++) { diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h index eeb4bedcb..264115a96 100644 --- a/v7/src/microcode/extern.h +++ b/v7/src/microcode/extern.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: extern.h,v 9.59 2001/03/08 17:12:50 cph Exp $ +$Id: extern.h,v 9.60 2001/07/31 03:11:21 cph Exp $ Copyright (c) 1987-2001 Massachusetts Institute of Technology @@ -16,10 +16,14 @@ General Public License for more details. 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. */ /* External Declarations */ + +#ifndef SCM_EXTERN_H +#define SCM_EXTERN_H #ifdef ENABLE_DEBUGGING_TOOLS @@ -143,14 +147,6 @@ extern long Constant_Size; extern long Stack_Size; extern SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address; -/* Environment lookup utilities. */ -extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern long EXFUN (Local_Set, (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT)); -extern long EXFUN (Lex_Set, (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT)); -extern long EXFUN (Symbol_Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern long EXFUN (Symbol_Lex_Set, - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT)); - /* Arithmetic utilities */ extern long EXFUN (fixnum_to_long, (SCHEME_OBJECT)); extern SCHEME_OBJECT EXFUN (double_to_fixnum, (double)); @@ -276,3 +272,5 @@ extern void EXFUN (Allocate_New_Stacklet, (long)); #if FALSE extern void EXFUN (Clear_Perfinfo_Data, (void)); #endif + +#endif /* not SCM_EXTERN_H */ diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index c5d7ea9d0..9cf356dd1 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: fasload.c,v 9.88 2000/12/05 21:23:44 cph Exp $ +$Id: fasload.c,v 9.89 2001/07/31 03:11:26 cph Exp $ -Copyright (c) 1987-2000 Massachusetts Institute of Technology +Copyright (c) 1987-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 @@ -16,7 +16,8 @@ General Public License for more details. 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. */ /* The "fast loader" which reads in and relocates binary files and then @@ -1059,7 +1060,7 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) Store_Expression (SHARP_F); Save_Cont (); Store_Expression (MEMORY_REF (result, 0)); - Store_Env (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)); + Store_Env (THE_GLOBAL_ENV); /* Clear various interpreter state parameters. */ Trapping = false; Return_Hook_Address = 0; diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index 169679d6b..da60169a0 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: hooks.c,v 9.59 2000/12/05 21:23:44 cph Exp $ +$Id: hooks.c,v 9.60 2001/07/31 03:11:31 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 @@ -16,7 +16,8 @@ General Public License for more details. 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 various hooks and handles that connect the @@ -738,7 +739,7 @@ identified by the continuation parser.") { SCHEME_OBJECT thunk = (STACK_POP ()); STACK_PUSH (STACK_FRAME_HEADER + (nargs - 2)); - Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN)); + Store_Env (THE_NULL_ENV); Store_Expression (SHARP_F); Store_Return (RC_INTERNAL_APPLY); Save_Cont (); diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index 591904fb5..2a2edfddd 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: interp.c,v 9.90 2000/12/05 21:23:44 cph Exp $ +$Id: interp.c,v 9.91 2001/07/31 03:11:39 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 @@ -16,7 +16,8 @@ General Public License for more details. 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 the heart of the SCode interpreter. */ @@ -843,75 +844,13 @@ Eval_Non_Trapping: { long temp; -#ifndef No_In_Line_Lookup - - fast SCHEME_OBJECT *cell; - Set_Time_Zone(Zone_Lookup); - cell = OBJECT_ADDRESS (Fetch_Expression()); - lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); - - lookup_end_restart: - - Val = MEMORY_FETCH (cell[0]); - if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP) - { - Set_Time_Zone(Zone_Working); - goto Pop_Return; - } - - 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: - cell = OBJECT_ADDRESS (Fetch_Expression()); - temp = - deep_lookup_end(deep_lookup(Fetch_Env(), - cell[VARIABLE_SYMBOL], - cell), - cell); - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - goto Pop_Return; - - case TRAP_COMPILER_CACHED: - cell = MEMORY_LOC (FAST_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: - temp = ERR_UNBOUND_VARIABLE; - break; - - case TRAP_UNASSIGNED: - temp = ERR_UNASSIGNED_VARIABLE; - break; - - default: - temp = ERR_ILLEGAL_REFERENCE_TRAP; - break; - } - -#else /* No_In_Line_Lookup */ - - Set_Time_Zone(Zone_Lookup); - temp = Lex_Ref(Fetch_Env(), Fetch_Expression()); + temp + = (lookup_variable ((Fetch_Env ()), (Fetch_Expression ()), (&Val))); Import_Val(); if (temp == PRIM_DONE) goto Pop_Return; -#endif /* No_In_Line_Lookup */ - /* Back out of the evaluation. */ Set_Time_Zone(Zone_Working); @@ -1134,9 +1073,11 @@ Pop_Return_Non_Trapping: if (ENVIRONMENT_P (Val)) { - Result = Symbol_Lex_Ref(value, - FAST_MEMORY_REF (Fetch_Expression(), - ACCESS_NAME)); + Result + = (lookup_variable (value, + (FAST_MEMORY_REF ((Fetch_Expression ()), + ACCESS_NAME)), + (&Val))); Import_Val(); if (Result == PRIM_DONE) { @@ -1163,124 +1104,15 @@ Pop_Return_Non_Trapping: DECLARE_LOCK (set_serializer); #endif -#ifndef No_In_Line_Lookup - - SCHEME_OBJECT bogus_unassigned; - fast SCHEME_OBJECT *cell; - - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME)); - lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); - - value = Val; - 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 (OBJECT_TYPE (*cell) != TC_REFERENCE_TRAP) - { - normal_assignment_done: - *cell = value; - remove_lock(set_serializer); - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - } - - get_trap_kind(temp, *cell); - 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); - cell - = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME)); - temp - = deep_assignment_end(deep_lookup(Fetch_Env(), - cell[VARIABLE_SYMBOL], - cell), - cell, - value, - false); - external_assignment_return: - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - - 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); - temp = deep_assignment_end(cell, - fake_variable_object, - value, - false); - goto external_assignment_return; - } - 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: - remove_lock(set_serializer); - temp = ERR_UNBOUND_VARIABLE; - break; - - case TRAP_UNASSIGNED: - Val = bogus_unassigned; - goto normal_assignment_done; - - default: - remove_lock(set_serializer); - temp = ERR_ILLEGAL_REFERENCE_TRAP; - break; - } - - if (value == UNASSIGNED_OBJECT) - value = bogus_unassigned; - -#else /* No_In_Line_Lookup */ - value = Val; Set_Time_Zone(Zone_Lookup); Restore_Env(); - temp = Lex_Set(Fetch_Env(), - MEMORY_REF (Fetch_Expression(), ASSIGN_NAME), - value); + temp + = (assign_variable + ((Fetch_Env ()), + (MEMORY_REF ((Fetch_Expression ()), ASSIGN_NAME)), + value, + (&Val))); Import_Val(); if (temp == PRIM_DONE) { @@ -1289,8 +1121,6 @@ Pop_Return_Non_Trapping: break; } -#endif /* No_In_Line_Lookup */ - Set_Time_Zone(Zone_Working); Save_Env(); if (temp != PRIM_INTERRUPT) @@ -1312,9 +1142,11 @@ Pop_Return_Non_Trapping: value = Val; Restore_Env(); Export_Registers(); - result = Local_Set(Fetch_Env(), - FAST_MEMORY_REF (Fetch_Expression(), DEFINE_NAME), - Val); + result + = (define_variable + ((Fetch_Env ()), + (FAST_MEMORY_REF ((Fetch_Expression ()), DEFINE_NAME)), + Val)); Import_Registers(); if (result == PRIM_DONE) { diff --git a/v7/src/microcode/lookprm.c b/v7/src/microcode/lookprm.c index 02c54bd05..a92585813 100644 --- a/v7/src/microcode/lookprm.c +++ b/v7/src/microcode/lookprm.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: lookprm.c,v 1.12 2000/12/05 21:23:45 cph Exp $ +$Id: lookprm.c,v 1.13 2001/07/31 03:11:42 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 @@ -16,7 +16,8 @@ General Public License for more details. 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 environment manipulation primitives. @@ -28,239 +29,150 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #include "trap.h" #include "lookup.h" -/* NOTE: - Although this code has been parallelized, it has not been - exhaustively tried on a parallel processor. There are probably - various race conditions that have to be thought about carefully. - */ - -/* Utility macros */ - -#define VALID_ENVIRONMENT_P(env) \ - ((OBJECT_TYPE (env) == TC_ENVIRONMENT) || \ - ((OBJECT_TYPE (env) == GLOBAL_ENV) && \ - (OBJECT_DATUM (env) == GO_TO_GLOBAL))) - -/* This used to be more paranoid, and check for interned symbols, - rather than normal symbols. Does it matter? - */ - -#define lookup_primitive_type_test() \ -do \ -{ \ - CHECK_ARG(1, ENVIRONMENT_P); \ - CHECK_ARG(2, SYMBOL_P); \ -} while (0) - -#define lookup_primitive_action(action) \ -{ \ - long result; \ - \ - result = (action); \ - if (result != PRIM_DONE) \ - { \ - if (result == PRIM_INTERRUPT) \ - signal_interrupt_from_primitive(); \ - else \ - signal_error_from_primitive(result); \ - } \ -} - -#define lookup_primitive_end(value, action) \ +#define STD_LOOKUP(expression) \ { \ - lookup_primitive_action(action); \ - PRIMITIVE_RETURN(value); \ -} - -#define standard_lookup_primitive(action) \ -{ \ - lookup_primitive_type_test(); \ - lookup_primitive_end(Val, action); \ - /*NOTREACHED*/ \ + long SL_result = (expression); \ + if (SL_result != PRIM_DONE) \ + { \ + if (SL_result == PRIM_INTERRUPT) \ + signal_interrupt_from_primitive (); \ + else \ + signal_error_from_primitive (SL_result); \ + } \ } -/* (LEXICAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE) - Sets the value of the variable with the name given in SYMBOL, as - seen in the lexical ENVIRONMENT, to the specified VALUE. - Returns the previous value. - - It's indistinguishable from evaluating - (set! ) in . -*/ - -DEFINE_PRIMITIVE ("LEXICAL-ASSIGNMENT", Prim_lexical_assignment, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - - standard_lookup_primitive(Symbol_Lex_Set(ARG_REF (1), - ARG_REF (2), ARG_REF (3))); -} - -/* (LEXICAL-REFERENCE ENVIRONMENT SYMBOL) - Returns the value of the variable with the name given in SYMBOL, - as seen in the lexical ENVIRONMENT. - - Indistinguishable from evaluating in . -*/ - -DEFINE_PRIMITIVE ("LEXICAL-REFERENCE", Prim_lexical_reference, 2, 2, 0) +DEFINE_PRIMITIVE ("LEXICAL-REFERENCE", Prim_lexical_reference, 2, 2, + "(ENVIRONMENT SYMBOL)\n +Returns the value of the variable in ENVIRONMENT named SYMBOL.\n +\n +Indistinguishable from evaluating SYMBOL in ENVIRONMENT.") { PRIMITIVE_HEADER (2); - - standard_lookup_primitive(Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2))); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + { + SCHEME_OBJECT value; + STD_LOOKUP (lookup_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); + PRIMITIVE_RETURN (value); + } } -/* (LOCAL-REFERENCE ENVIRONMENT SYMBOL) - Identical to LEXICAL_REFERENCE, here for histerical reasons. -*/ - -DEFINE_PRIMITIVE ("LOCAL-REFERENCE", Prim_local_reference, 2, 2, 0) +DEFINE_PRIMITIVE ("LOCAL-REFERENCE", Prim_local_reference, 2, 2, + "(REFERENCE ENVIRONMENT SYMBOL)\n +Identical to LEXICAL_REFERENCE, here for hysterical reasons.") { PRIMITIVE_HEADER (2); - - standard_lookup_primitive(Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2))); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + { + SCHEME_OBJECT value; + STD_LOOKUP (lookup_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); + PRIMITIVE_RETURN (value); + } } - -/* (LOCAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE) - Should be called LEXICAL-DEFINE. - If the variable specified by SYMBOL already exists in the - lexical ENVIRONMENT, then its value there is changed to VALUE. - Otherwise a new binding is created in that environment linking - the specified variable to the value. Returns SYMBOL. - - Indistinguishable from evaluating - (define ) in . */ - -DEFINE_PRIMITIVE ("LOCAL-ASSIGNMENT", Prim_local_assignment, 3, 3, 0) +DEFINE_PRIMITIVE ("LEXICAL-ASSIGNMENT", Prim_lexical_assignment, 3, 3, + "(ASSIGNMENT ENVIRONMENT SYMBOL VALUE)\n +Sets the value of the variable in ENVIRONMENT named SYMBOL to VALUE.\n +Returns the previous value.\n +\n +Indistinguishable from evaluating (set! SYMBOL VALUE) in ENVIRONMENT.") { PRIMITIVE_HEADER (3); - standard_lookup_primitive - (Local_Set ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)))); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + { + SCHEME_OBJECT value; + STD_LOOKUP + (assign_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)), + (&value))); + PRIMITIVE_RETURN (value); + } } -/* (LEXICAL-UNASSIGNED? ENVIRONMENT SYMBOL) - Returns #T if the variable corresponding to SYMBOL is bound - but has the special UNASSIGNED value in ENVIRONMENT. Returns - #F otherwise. Does a complete lexical search for SYMBOL - starting in ENVIRONMENT. - The special form (unassigned? ) is built on top of this. */ - -DEFINE_PRIMITIVE ("LEXICAL-UNASSIGNED?", Prim_unassigned_test, 2, 2, 0) +DEFINE_PRIMITIVE ("LOCAL-ASSIGNMENT", Prim_local_assignment, 3, 3, + "(ENVIRONMENT SYMBOL VALUE)\n + [Should be called LEXICAL-DEFINE.]\n +\n +If the variable specified by SYMBOL already exists in the\n +lexical ENVIRONMENT, then its value there is changed to VALUE.\n +Otherwise a new binding is created in that environment linking\n +the specified variable to the value. Returns SYMBOL.\n +\n +Indistinguishable from evaluating (define SYMBOL VALUE) in ENVIRONMENT.") { - extern long EXFUN (Symbol_Lex_unassigned_p, (SCHEME_OBJECT, SCHEME_OBJECT)); - PRIMITIVE_HEADER (2); - standard_lookup_primitive - (Symbol_Lex_unassigned_p ((ARG_REF (1)), (ARG_REF (2)))); + PRIMITIVE_HEADER (3); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + STD_LOOKUP (define_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)))); + PRIMITIVE_RETURN (ARG_REF (2)); } -/* (LEXICAL-UNBOUND? ENVIRONMENT SYMBOL) - Returns #T if the variable corresponding to SYMBOL has no - binding in ENVIRONMENT. Returns #F otherwise. Does a complete - lexical search for SYMBOL starting in ENVIRONMENT. - The special form (unbound? ) is built on top of this. */ - -DEFINE_PRIMITIVE ("LEXICAL-UNBOUND?", Prim_unbound_test, 2, 2, 0) +DEFINE_PRIMITIVE ("LEXICAL-UNASSIGNED?", Prim_unassigned_test, 2, 2, + "(ENVIRONMENT SYMBOL)\n +Returns #T if the variable corresponding to SYMBOL is bound\n +but has the special UNASSIGNED value in ENVIRONMENT. Returns\n +#F otherwise. Does a complete lexical search for SYMBOL\n +starting in ENVIRONMENT.\n +The special form (unassigned? ) is built on top of this.") { - extern long EXFUN (Symbol_Lex_unbound_p, (SCHEME_OBJECT, SCHEME_OBJECT)); PRIMITIVE_HEADER (2); - standard_lookup_primitive - (Symbol_Lex_unbound_p ((ARG_REF (1)), (ARG_REF (2)))); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + { + SCHEME_OBJECT value; + STD_LOOKUP + (variable_unassigned_p ((ARG_REF (1)), (ARG_REF (2)), (&value))); + PRIMITIVE_RETURN (value); + } } - -/* (LEXICAL-UNREFERENCEABLE? ENVIRONMENT SYMBOL) - Returns #T if evaluating in would cause - a variable lookup error (unbound or unassigned). -*/ -DEFINE_PRIMITIVE ("LEXICAL-UNREFERENCEABLE?", Prim_unreferenceable_test, 2, 2, 0) +DEFINE_PRIMITIVE ("LEXICAL-UNBOUND?", Prim_unbound_test, 2, 2, + "(ENVIRONMENT SYMBOL)\n +Returns #T if the variable corresponding to SYMBOL has no binding in\n +ENVIRONMENT. Returns #F otherwise. Does a complete lexical search\n +for SYMBOL starting in ENVIRONMENT. The special form (unbound?\n +) is built on top of this.") { - long Result; PRIMITIVE_HEADER (2); - - lookup_primitive_type_test(); - Result = Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2)); - switch (Result) + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); { - case PRIM_DONE: - PRIMITIVE_RETURN (SHARP_F); - - case PRIM_INTERRUPT: - signal_interrupt_from_primitive(); - /*NOTREACHED*/ - - case ERR_UNASSIGNED_VARIABLE: - case ERR_UNBOUND_VARIABLE: - PRIMITIVE_RETURN(SHARP_T); - - default: - signal_error_from_primitive(Result); + SCHEME_OBJECT value; + STD_LOOKUP (variable_unbound_p ((ARG_REF (1)), (ARG_REF (2)), (&value))); + PRIMITIVE_RETURN (value); } - /*NOTREACHED*/ - return (0); } - -SCHEME_OBJECT -DEFUN (extract_or_create_cache, (frame, sym), - SCHEME_OBJECT frame - AND SCHEME_OBJECT sym) -{ - extern SCHEME_OBJECT compiler_cache_variable[]; - extern long EXFUN (compiler_cache, - (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, - SCHEME_OBJECT, long, long, Boolean)); - SCHEME_OBJECT *cell, value; - long trap_kind, result; - cell = deep_lookup(frame, sym, compiler_cache_variable); - value = MEMORY_FETCH (cell[0]); - if (REFERENCE_TRAP_P(value)) +DEFINE_PRIMITIVE ("LEXICAL-UNREFERENCEABLE?", Prim_unreferenceable_test, 2, 2, + "(ENVIRONMENT SYMBOL)\n +Returns #T if evaluating SYMBOL in ENVIRONMENT would cause a\n +variable lookup error (unbound or unassigned).") +{ + PRIMITIVE_HEADER (2); { - get_trap_kind(trap_kind, value); - switch (trap_kind) - { - case TRAP_UNBOUND: - case TRAP_UNBOUND_DANGEROUS: - signal_error_from_primitive(ERR_UNBOUND_VARIABLE); + SCHEME_OBJECT value; + long result = (lookup_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); + switch (result) + { + case ERR_UNASSIGNED_VARIABLE: + case ERR_UNBOUND_VARIABLE: + PRIMITIVE_RETURN(SHARP_T); - case TRAP_COMPILER_CACHED: - case TRAP_COMPILER_CACHED_DANGEROUS: - return (FAST_MEMORY_REF (value, TRAP_EXTRA)); + case PRIM_DONE: + PRIMITIVE_RETURN (SHARP_F); + + case PRIM_INTERRUPT: + signal_interrupt_from_primitive (); - /* This should list the traps explicitely */ default: - break; - } - } - result = compiler_cache(cell, frame, sym, SHARP_F, 0, - TRAP_REFERENCES_LOOKUP, true); - if (result != PRIM_DONE) - { - if (result == PRIM_INTERRUPT) - signal_interrupt_from_primitive(); - else - signal_error_from_primitive(result); + signal_error_from_primitive (result); + } } - value = MEMORY_FETCH (cell[0]); - return (FAST_MEMORY_REF (value, TRAP_EXTRA)); -} - -void -DEFUN (error_bad_environment, (arg), long arg) -{ - if (OBJECT_TYPE (ARG_REF(arg)) == GLOBAL_ENV) - error_bad_range_arg(arg); - else - error_wrong_type_arg(arg); - /*NOTREACHED*/ + PRIMITIVE_RETURN (UNSPECIFIC); } - -/* (ENVIRONMENT-LINK-NAME ) - must be locally undefined in , and defined in . - It defines in and makes it share its value cell with - in . - This code returns #t if it succeeds, or the following errors +/* This code returns #t if it succeeds, or the following errors (besides type and range errors) with the following meanings: - ERR_UNBOUND_VARIABLE: @@ -279,142 +191,25 @@ DEFUN (error_bad_environment, (arg), long arg) affected. It will have to be rethought. NOTE: The following procedure and extract_or_create_cache have NOT - been parallelized. They need thinking. -*/ + been parallelized. They need thinking. */ -DEFINE_PRIMITIVE ("ENVIRONMENT-LINK-NAME", Prim_environment_link_name, 3, 3, 0) +DEFINE_PRIMITIVE ("ENVIRONMENT-LINK-NAME", Prim_environment_link_name, 3, 3, + "(ENV1 ENV2 SYMBOL)\n +SYMBOL must be locally undefined in ENV1, and defined in ENV2.\n +It defines SYMBOL in ENV1 and makes it share its value cell with\n +SYMBOL in ENV2.") { - extern SCHEME_OBJECT * EXFUN (scan_frame, - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, - long, Boolean)); - SCHEME_OBJECT target, source, sym; - SCHEME_OBJECT cache, *cell, *value_cell; PRIMITIVE_HEADER (3); - - target = ARG_REF (1); - source = ARG_REF (2); - sym = ARG_REF (3); - - if (!SYMBOL_P(sym)) - error_wrong_type_arg(3); - - if (!VALID_ENVIRONMENT_P(source)) - error_bad_environment(2); - - if (!VALID_ENVIRONMENT_P(target)) - error_bad_environment(1); - - cache = extract_or_create_cache(source, sym); - - if (OBJECT_TYPE (target) == GLOBAL_ENV) - { - long trap_kind; - SCHEME_OBJECT value; - - cell = MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE); - value = MEMORY_FETCH (cell[0]); - - if (!REFERENCE_TRAP_P(value)) - /* The variable is bound! */ - signal_error_from_primitive(ERR_BAD_SET); - - get_trap_kind(trap_kind, value); - switch(trap_kind) - { - case TRAP_UNBOUND: - case TRAP_UNBOUND_DANGEROUS: - { - /* Allocate new trap object. */ - fast SCHEME_OBJECT *trap; - - Primitive_GC_If_Needed(2); - trap = Free; - Free += 2; - trap[0] = LONG_TO_UNSIGNED_FIXNUM((trap_kind == TRAP_UNBOUND) ? - TRAP_COMPILER_CACHED : - TRAP_COMPILER_CACHED_DANGEROUS); - trap[1] = cache; - MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap)); - PRIMITIVE_RETURN(SHARP_T); - } - - case TRAP_COMPILER_CACHED: - case TRAP_COMPILER_CACHED_DANGEROUS: - { - if (MEMORY_REF (MEMORY_REF (value, TRAP_EXTRA), TRAP_EXTENSION_CELL) != - UNBOUND_OBJECT) - { - /* It is bound */ - - signal_error_from_primitive(ERR_BAD_SET); - } - lookup_primitive_action(compiler_uncache(cell, sym)); - value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL); - lookup_primitive_action - (compiler_recache(shadowed_value_cell, value_cell, target, - sym, (MEMORY_FETCH (value_cell[0])), false, true)); - MEMORY_SET (value, TRAP_EXTRA, cache); - PRIMITIVE_RETURN(SHARP_T); - } - - case TRAP_DANGEROUS: - case TRAP_UNASSIGNED: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID: - case TRAP_FLUID_DANGEROUS: - /* The variable is bound! */ - signal_error_from_primitive(ERR_BAD_SET); - - default: - signal_error_from_primitive(ERR_ILLEGAL_REFERENCE_TRAP); - } - } - - else + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, ENVIRONMENT_P); + CHECK_ARG (3, SYMBOL_P); { - SCHEME_OBJECT *trap; - - cell = scan_frame(target, sym, fake_variable_object, 0, true); - - /* Is it bound? */ - - if ((cell != ((SCHEME_OBJECT *) NULL)) && - (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT)) - { - signal_error_from_primitive(ERR_BAD_SET); - } - - /* Allocate new trap object. */ - - Primitive_GC_If_Needed(2); - trap = Free; - Free += 2; - trap[1] = cache; - - lookup_primitive_action(extend_frame(target, sym, SHARP_F, target, false)); - - if (cell == ((SCHEME_OBJECT *) NULL)) - { - trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED); - cell = scan_frame(target, sym, fake_variable_object, 0, true); - if (cell == ((SCHEME_OBJECT *) NULL)) - signal_error_from_primitive(ERR_BAD_FRAME); - } - else - { - trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED_DANGEROUS); - } - - if (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT) - signal_error_from_primitive(ERR_BAD_FRAME); - - value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL); - lookup_primitive_action - (compiler_recache(shadowed_value_cell, value_cell, target, - sym, MEMORY_FETCH (value_cell[0]), false, true)); - MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap)); - PRIMITIVE_RETURN(SHARP_T); + long result + = (link_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)))); + if (result == PRIM_INTERRUPT) + signal_interrupt_from_primitive (); + if (result != PRIM_DONE) + signal_error_from_primitive (result); + PRIMITIVE_RETURN (SHARP_T); } - /*NOTREACHED*/ - return (0); } diff --git a/v7/src/microcode/lookup.c b/v7/src/microcode/lookup.c index 803f68049..6a172a751 100644 --- a/v7/src/microcode/lookup.c +++ b/v7/src/microcode/lookup.c @@ -1,8 +1,8 @@ /* -*-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 @@ -16,2912 +16,1145 @@ General Public License for more details. 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. - */ - -/* 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]; - -/* 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); - } - - /* 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); -} - -/* 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)); -} - -/* 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); - } -} - -/* 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; - - 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); -} - -/* 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); - } -} - -/* 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. - - */ - -#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; - - 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); - - 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; - - 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); - - 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); -} - -#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)); - - 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); -} - -/* 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)); -} - -/* 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)); - } - } -} - -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)); - } - - 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)); -} - -/* 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)); - } - } - - 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)); - } - } - } - } - - /* 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); - - /* 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; - } - } - - /* 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; - } - - 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))); - } - - 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)); - } - } -} - -/* 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)); -} - -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))); -} - -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); - } -} - -/* 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)); -} - -/* 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); -/* 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. - */ - -#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)) +/***** 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 *); + +/***** 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; - - 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); - } - } - -#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 - - /* 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); - } - - /* 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) +} + +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); } - } - - /* 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*/ } - -/* 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)); } -/* 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)); } - -/* 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); + } } - -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); +} + 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); } - -/* 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); } +} - 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 */ -#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 - -/* 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))); } - -/* 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)); +} + 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); } - -/* 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); } - + 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)); +} + +/***** 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))); - - /* - 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)); } - - /* - 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)); } - - /* - 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))); +} -/* 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); +} - 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)); + } } -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); } -/* 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); - } - - 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); } -/* 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)); + } + } } -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); } - -/* 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); } diff --git a/v7/src/microcode/lookup.h b/v7/src/microcode/lookup.h index 2852559f2..80b44d29d 100644 --- a/v7/src/microcode/lookup.h +++ b/v7/src/microcode/lookup.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: lookup.h,v 9.52 2000/12/05 21:23:45 cph Exp $ +$Id: lookup.h,v 9.53 2001/07/31 03:11:52 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 @@ -16,302 +16,56 @@ General Public License for more details. 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. */ /* Macros and declarations for the variable lookup code. */ -extern SCHEME_OBJECT - * EXFUN (deep_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *)), - * EXFUN (lookup_fluid, (SCHEME_OBJECT)), - * EXFUN (force_definition, (SCHEME_OBJECT, SCHEME_OBJECT, long *)); - -extern long - EXFUN (deep_lookup_end, (SCHEME_OBJECT *, SCHEME_OBJECT *)), - EXFUN (deep_assignment_end, - (SCHEME_OBJECT *, SCHEME_OBJECT *, SCHEME_OBJECT, Boolean)); - -extern long EXFUN (recache_uuo_links, (SCHEME_OBJECT, SCHEME_OBJECT)); - -extern SCHEME_OBJECT - unbound_trap_object[], - uncompiled_trap_object[], - illegal_trap_object[], - fake_variable_object[]; - -#define GC_allocate_test(N) GC_Check(N) - -#define AUX_LIST_TYPE TC_VECTOR - -#define AUX_CHUNK_SIZE 20 -#define AUX_LIST_COUNT ENV_EXTENSION_COUNT -#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE -#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE) - -/* Variable compilation types. */ - -#define LOCAL_REF TC_NULL -#define GLOBAL_REF TC_UNINTERNED_SYMBOL -#define FORMAL_REF TC_CHARACTER -#define AUX_REF TC_FIXNUM -#define UNCOMPILED_REF TC_CONSTANT - -/* Common constants. */ - -#if (SIZEOF_UNSIGNED_LONG == 4) /* 32 bit objects */ -# if (TYPE_CODE_LENGTH == 8) -# define UNCOMPILED_VARIABLE 0x08000000 -# endif -# if (TYPE_CODE_LENGTH == 6) -# define UNCOMPILED_VARIABLE 0x20000000 -# endif -# if (TC_CONSTANT != 0x08) -# include "error:lookup.h and types.h are inconsistent" -# endif -#endif - -#ifndef UNCOMPILED_VARIABLE /* Safe version */ -#define UNCOMPILED_VARIABLE MAKE_OBJECT (UNCOMPILED_REF, 0) -#endif - -/* Macros for speedy variable reference. */ - -#if (LOCAL_REF == 0) - -#define Lexical_Offset(Ind) ((long) (Ind)) -#define Make_Local_Offset(Ind) ((SCHEME_OBJECT) (Ind)) - -#else - -#define Lexical_Offset(Ind) OBJECT_DATUM (Ind) -#define Make_Local_Offset(Ind) MAKE_OBJECT (LOCAL_REF, Ind) - -#endif - -/* The code below depends on the following. */ - -/* Done as follows because of VMS. */ - -#define lookup_inconsistency_p \ - ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \ - (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE)) - -#if (lookup_inconsistency_p) -#include "error: lookup.h inconsistency detected." -#endif - -#define get_offset(hunk) Lexical_Offset(MEMORY_FETCH (hunk[VARIABLE_OFFSET])) - -#ifdef PARALLEL_PROCESSOR - -#define verify(type_code, variable, code, label) \ -{ \ - variable = code; \ - if (OBJECT_TYPE (MEMORY_FETCH (hunk[VARIABLE_COMPILED_TYPE])) != \ - type_code) \ - goto label; \ -} - -#define verified_offset(variable, code) variable - -/* Unlike Lock_Cell, cell must be (SCHEME_OBJECT *). This currently does - not matter, but might on a machine with address mapping. - */ - -#define DECLARE_LOCK(name) Lock_Handle name -#define setup_lock(handle, cell) handle = Lock_Cell(cell) -#define remove_lock(handle) Unlock_Cell(handle) - -/* This should prevent a deadly embrace if whole contiguous - regions are locked, rather than individual words. - */ - -#define setup_locks(hand1, cel1, hand2, cel2) \ -{ \ - if (LOCK_FIRST(cel1, cel2)) \ - { \ - setup_lock(hand1, cel1); \ - setup_lock(hand2, cel2); \ - } \ - else \ - { \ - setup_lock(hand2, cel2); \ - setup_lock(hand1, cel1); \ - } \ -} - -#define remove_locks(hand1, hand2) \ -{ \ - remove_lock(hand2); \ - remove_lock(hand1); \ -} - -#else /* not PARALLEL_PROCESSOR */ - -#define verify(type_code, variable, code, label) -#define verified_offset(variable, code) code -/* #undef DECLARE_LOCK */ -#define setup_lock(handle, cell) -#define remove_lock(ignore) -#define setup_locks(hand1, cel1, hand2, cel2) -#define remove_locks(ign1, ign2) - -#endif /* PARALLEL_PROCESSOR */ - -/* This is provided as a separate macro so that it can be made - atomic if necessary. - */ - -#define update_lock(handle, cell) \ -{ \ - remove_lock(handle); \ - setup_lock(handle, cell); \ -} - -#ifndef Future_Variable_Splice -/* Parameter list (Vbl, Ofs, Value) displeased some compilers */ -#define Future_Variable_Splice(a, b, c) -#endif - -/* SCHEME_OBJECT *cell, env, *hunk; */ - -#define lookup(cell, env, hunk, label) \ -{ \ - fast SCHEME_OBJECT frame; \ - \ -/* Deleted this label to eliminate compiler warnings: */ \ -/* label: */ \ - \ - frame = (MEMORY_FETCH (hunk [VARIABLE_COMPILED_TYPE])); \ - \ - switch (OBJECT_TYPE (frame)) \ - { \ - case GLOBAL_REF: \ - /* frame is a pointer to the same symbol. */ \ - cell = MEMORY_LOC (frame, SYMBOL_GLOBAL_VALUE); \ - break; \ - \ - case LOCAL_REF: \ - cell = MEMORY_LOC (env, Lexical_Offset(frame)); \ - break; \ - \ - case FORMAL_REF: \ - lookup_formal(cell, env, hunk, label); \ - \ - case AUX_REF: \ - lookup_aux(cell, env, hunk, label); \ - \ - default: \ - /* Done here rather than in a separate case because of \ - peculiarities of the bobcat compiler. \ - */ \ - cell = ((OBJECT_TYPE (frame) == UNCOMPILED_REF) ? \ - uncompiled_trap_object : \ - illegal_trap_object); \ - break; \ - } \ -} - -#define lookup_formal(cell, env, hunk, label) \ -{ \ - fast long depth; \ - \ - verify(FORMAL_REF, offset, get_offset(hunk), label); \ - depth = (OBJECT_DATUM (frame)); \ - frame = env; \ - while(--depth >= 0) \ - { \ - frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION), \ - PROCEDURE_ENVIRONMENT); \ - } \ - \ - cell = MEMORY_LOC (frame, \ - verified_offset(offset, get_offset(hunk))); \ - \ - break; \ -} - -#define lookup_aux(cell, env, hunk, label) \ -{ \ - fast long depth; \ - \ - verify(AUX_REF, offset, get_offset(hunk), label); \ - depth = (OBJECT_DATUM (frame)); \ - frame = env; \ - while(--depth >= 0) \ - { \ - frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION), \ - PROCEDURE_ENVIRONMENT); \ - } \ - \ - frame = MEMORY_REF (frame, ENVIRONMENT_FUNCTION); \ - if (OBJECT_TYPE (frame) != AUX_LIST_TYPE) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - depth = verified_offset(offset, get_offset(hunk)); \ - if (depth > ((long) (VECTOR_LENGTH (frame)))) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - frame = MEMORY_REF (frame, depth); \ - if ((frame == SHARP_F) || \ - (FAST_PAIR_CAR (frame) != hunk[VARIABLE_SYMBOL])) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - cell = PAIR_CDR_LOC (frame); \ - break; \ -} - -/* Macros and exports for incremental definition and hooks. */ - -extern long - EXFUN (extend_frame, - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, - SCHEME_OBJECT, Boolean)); - -/* Definition recaches eagerly by default. */ - -#ifndef DEFINITION_RECACHES_LAZILY -# ifndef DEFINITION_RECACHES_EAGERLY -# define DEFINITION_RECACHES_EAGERLY -# endif -#endif - -#ifndef DEFINITION_RECACHES_EAGERLY - -extern long - EXFUN (compiler_uncache, (SCHEME_OBJECT *, SCHEME_OBJECT)); - -#define simple_uncache(cell, sym) PRIM_DONE - -#define shadowing_recache(cell, env, sym, value, shadowed_p) \ - definition(cell, value, shadowed_p) - -#define compiler_recache(old, new, env, sym, val, shadowed_p, link_p) \ - PRIM_DONE - -#else /* DEFINITION_RECACHES_EAGERLY */ - -extern long - EXFUN (compiler_recache, - (SCHEME_OBJECT *, SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, - SCHEME_OBJECT, Boolean, Boolean)); - -extern SCHEME_OBJECT * shadowed_value_cell; - -#define compiler_uncache(cell, sym) \ - (shadowed_value_cell = cell, PRIM_DONE) - -#define simple_uncache(cell, sym) \ - compiler_uncache(cell, sym) - -#define shadowing_recache(cell, env, sym, value, shadowed_p) \ - compiler_recache(shadowed_value_cell, cell, env, sym, value, \ - shadowed_p, false) - -#endif /* DEFINITION_RECACHES_EAGERLY */ +#ifndef SCM_LOOKUP_H +#define SCM_LOOKUP_H + +#include "trap.h" + +extern long lookup_variable + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); +extern long safe_lookup_variable + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); +extern long variable_unassigned_p + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); +extern long variable_unbound_p + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); +extern long assign_variable + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); +extern long define_variable + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); +extern long link_variable + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); + +extern trap_kind_t get_trap_kind (SCHEME_OBJECT); + +extern long compiler_cache_lookup + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); +extern long compiler_cache_assignment + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); +extern long compiler_cache_operator + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); +extern long compiler_cache_global_operator + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); + +extern SCHEME_OBJECT compiler_var_error (SCHEME_OBJECT); + +extern long compiler_lookup_trap + (SCHEME_OBJECT, SCHEME_OBJECT *); +extern long compiler_operator_reference_trap + (SCHEME_OBJECT, SCHEME_OBJECT *); +extern long compiler_safe_lookup_trap + (SCHEME_OBJECT, SCHEME_OBJECT *); +extern long compiler_unassigned_p_trap + (SCHEME_OBJECT, SCHEME_OBJECT *); +extern long compiler_assignment_trap + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); + +#define UNCOMPILED_VARIABLE (MAKE_OBJECT (TC_CONSTANT, 0)) + +#endif /* not SCM_LOOKUP_H */ diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index 2d8d2888a..883cc30aa 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: object.h,v 9.50 2000/12/05 21:23:46 cph Exp $ +$Id: object.h,v 9.51 2001/07/31 03:11:56 cph Exp $ -Copyright (c) 1987-2000 Massachusetts Institute of Technology +Copyright (c) 1987-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 @@ -16,7 +16,8 @@ General Public License for more details. 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 defines the macros which define and manipulate Scheme @@ -237,8 +238,7 @@ extern SCHEME_OBJECT * memory_base; #define INTERPRETER_APPLICABLE_P interpreter_applicable_p #define ENVIRONMENT_P(env) \ - ((OBJECT_TYPE (env) == TC_ENVIRONMENT) || \ - (OBJECT_TYPE (env) == GLOBAL_ENV)) + (((OBJECT_TYPE (env)) == TC_ENVIRONMENT) || (GLOBAL_FRAME_P (env))) /* Memory Operations */ diff --git a/v7/src/microcode/os2.h b/v7/src/microcode/os2.h index 193ab67f3..6344b8db8 100644 --- a/v7/src/microcode/os2.h +++ b/v7/src/microcode/os2.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: os2.h,v 1.7 2000/12/05 21:23:46 cph Exp $ +$Id: os2.h,v 1.8 2001/07/31 03:11:59 cph Exp $ -Copyright (c) 1994-2000 Massachusetts Institute of Technology +Copyright (c) 1994-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 @@ -16,7 +16,8 @@ General Public License for more details. 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. */ /* OS/2 system include file */ @@ -29,12 +30,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #include "osscheme.h" #include "syscall.h" -/* Defined by "scheme.h" and conflicts with definition in . - Scheme's definition not needed in OS/2 files. */ -#ifdef END_OF_CHAIN -# undef END_OF_CHAIN -#endif - #define INCL_BASE #define INCL_PM #include diff --git a/v7/src/microcode/scode.h b/v7/src/microcode/scode.h index fd4ca45f9..56db6efb5 100644 --- a/v7/src/microcode/scode.h +++ b/v7/src/microcode/scode.h @@ -1,6 +1,8 @@ /* -*-C-*- -Copyright (c) 1987, 1988, 1989, 1999 Massachusetts Institute of Technology +$Id: scode.h,v 9.27 2001/07/31 03:12:03 cph Exp $ + +Copyright (c) 1987-1989, 1999, 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 @@ -14,15 +16,15 @@ General Public License for more details. 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. */ -/* $Id: scode.h,v 9.26 1999/01/02 06:11:34 cph Exp $ - * - * Format of the SCode representation of programs. Each of these - * is described in terms of the slots in the data structure. - * - */ +/* Format of the SCode representation of programs. Each of these is + described in terms of the slots in the data structure. */ + +#ifndef SCM_SCODE_H +#define SCM_SCODE_H /* Here are the definitions of the the executable operations for the interpreter. This file should parallel the file SCODE.SCM in the @@ -130,6 +132,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define LAMBDA_SCODE 0 #define LAMBDA_FORMALS 1 +#define GET_LAMBDA_FORMALS(lambda) \ + (MEMORY_REF ((lambda), LAMBDA_FORMALS)) + +#define GET_LAMBDA_PARAMETERS(lambda) \ + (MEMORY_LOC ((GET_LAMBDA_FORMALS (lambda)), (VECTOR_DATA + 1))) + +#define GET_LAMBDA_N_PARAMETERS(lambda) \ + ((VECTOR_LENGTH (GET_LAMBDA_FORMALS (lambda))) - 1) + /* LEXPR * Same as LAMBDA (q.v.) except additional arguments are permitted * beyond those indicated in the LAMBDA_FORMALS list. @@ -174,3 +185,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define VARIABLE_FRAME_NO 1 #define VARIABLE_OFFSET 2 #define VARIABLE_COMPILED_TYPE 1 + +#define GET_VARIABLE_SYMBOL(variable) \ + (MEMORY_REF ((variable), VARIABLE_SYMBOL)) + +#endif /* not SCM_SCODE_H */ diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h index f94b98a21..33e850670 100644 --- a/v7/src/microcode/sdata.h +++ b/v7/src/microcode/sdata.h @@ -1,6 +1,8 @@ /* -*-C-*- -Copyright (c) 1987, 1988, 1989, 1999 Massachusetts Institute of Technology +$Id: sdata.h,v 9.35 2001/07/31 03:12:08 cph Exp $ + +Copyright (c) 1987-1989, 1999, 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 @@ -14,15 +16,15 @@ General Public License for more details. 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. */ -/* $Id: sdata.h,v 9.34 1999/01/02 06:11:34 cph Exp $ - * - * Description of the user data objects. This should parallel the - * file SDATA.SCM in the runtime system. - * - */ +/* Description of the user data objects. This should parallel the + file SDATA.SCM in the runtime system. */ + +#ifndef SCM_SDATA_H +#define SCM_SDATA_H /* Alphabetical order. Every type of object is described either with a comment or with offsets describing locations of various parts. */ @@ -153,7 +155,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define ENTITY_OPERATOR 0 #define ENTITY_DATA 1 - + /* ENVIRONMENT * Associates identifiers with values. * The identifiers are either from a lambda-binding (as in a procedure @@ -183,7 +185,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. * associations between names and values. It is the final stage, and * corresponds to the structure described above. */ - + #define ENVIRONMENT_HEADER 0 #define ENVIRONMENT_FUNCTION 1 #define ENVIRONMENT_FIRST_ARG 2 @@ -202,12 +204,27 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. true global environment, or terminate at this frame. We arrange for the global environment to be the same as #F, and the - end chain to be different by toggling the lowest bit: - */ + end chain to be different by toggling the lowest bit: */ + +#define GLOBAL_ENV (OBJECT_TYPE (SHARP_F)) +#define THE_GLOBAL_ENV (MAKE_OBJECT (GLOBAL_ENV, (OBJECT_DATUM (SHARP_F)))) +#define THE_NULL_ENV (MAKE_OBJECT (GLOBAL_ENV, ((OBJECT_DATUM (SHARP_F)) ^ 1))) + +#define GLOBAL_FRAME_P(frame) ((frame) == THE_GLOBAL_ENV) +#define NULL_FRAME_P(frame) ((frame) == THE_NULL_ENV) +#define PROCEDURE_FRAME_P(frame) ((OBJECT_TYPE (frame)) == TC_ENVIRONMENT) + +#define GET_FRAME_PARENT(frame) \ + (GET_PROCEDURE_ENVIRONMENT (GET_FRAME_PROCEDURE (frame))) + +#define GET_FRAME_PROCEDURE(frame) \ + (MEMORY_REF ((frame), ENVIRONMENT_FUNCTION)) -#define GLOBAL_ENV (OBJECT_TYPE(SHARP_F)) -#define GO_TO_GLOBAL (OBJECT_DATUM(SHARP_F)) -#define END_OF_CHAIN ((GO_TO_GLOBAL) ^ 1) +#define SET_FRAME_EXTENSION(frame, extension) \ + MEMORY_SET ((frame), ENVIRONMENT_FUNCTION, (extension)) + +#define GET_FRAME_ARG_CELL(frame, index) \ + (MEMORY_LOC ((frame), (ENVIRONMENT_FIRST_ARG + (index)))) /* Environment extension objects: @@ -228,6 +245,43 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define ENV_EXTENSION_PROCEDURE 2 #define ENV_EXTENSION_COUNT 3 #define ENV_EXTENSION_MIN_SIZE 4 + +#define EXTENDED_FRAME_P(frame) \ + (FRAME_EXTENSION_P (GET_FRAME_PROCEDURE (frame))) + +#define FRAME_EXTENSION_P VECTOR_P + +#define GET_EXTENDED_FRAME_BINDINGS(frame) \ + (GET_FRAME_EXTENSION_BINDINGS (GET_FRAME_PROCEDURE (frame))) + +#define GET_FRAME_EXTENSION_BINDINGS(extension) \ + ((OBJECT_ADDRESS (extension)) + ENV_EXTENSION_MIN_SIZE) + +#define GET_EXTENDED_FRAME_LENGTH(frame) \ + (GET_FRAME_EXTENSION_LENGTH (GET_FRAME_PROCEDURE (frame))) + +#define GET_FRAME_EXTENSION_LENGTH(extension) \ + (UNSIGNED_FIXNUM_TO_LONG \ + ((OBJECT_ADDRESS (extension)) [ENV_EXTENSION_COUNT])) + +#define SET_EXTENDED_FRAME_LENGTH(frame, length) \ + (SET_FRAME_EXTENSION_LENGTH ((GET_FRAME_PROCEDURE (frame)), (length))) + +#define SET_FRAME_EXTENSION_LENGTH(extension, length) \ + (((OBJECT_ADDRESS (extension)) [ENV_EXTENSION_COUNT]) \ + = (LONG_TO_UNSIGNED_FIXNUM (length))) + +#define GET_MAX_EXTENDED_FRAME_LENGTH(frame) \ + (GET_MAX_FRAME_EXTENSION_LENGTH (GET_FRAME_PROCEDURE (frame))) + +#define GET_MAX_FRAME_EXTENSION_LENGTH(extension) \ + ((VECTOR_LENGTH (extension)) - (ENV_EXTENSION_MIN_SIZE - 1)) + +#define GET_EXTENDED_FRAME_PROCEDURE(frame) \ + (GET_FRAME_EXTENSION_PROCEDURE (GET_FRAME_PROCEDURE (frame))) + +#define GET_FRAME_EXTENSION_PROCEDURE(extension) \ + (MEMORY_REF ((extension), ENV_EXTENSION_PROCEDURE)) /* EXTENDED_FIXNUM * Not used in the C version. On the 68000 this is used for 24-bit @@ -272,6 +326,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define SYMBOL_NAME 0 #define SYMBOL_GLOBAL_VALUE 1 +#define SYMBOL_GLOBAL_VALUE_CELL(symbol) \ + (MEMORY_LOC ((symbol), SYMBOL_GLOBAL_VALUE)) + +#define GET_SYMBOL_GLOBAL_VALUE(symbol) \ + (* (SYMBOL_GLOBAL_VALUE_CELL (symbol))) + +#define SET_SYMBOL_GLOBAL_VALUE(symbol, value) \ + ((* (SYMBOL_GLOBAL_VALUE_CELL (symbol))) = (value)) + /* LIST * Ordinary CONS cell as supplied to a user. Perhaps this data type is * misnamed ... CONS or PAIR would be better. @@ -326,6 +389,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ #define PROCEDURE_LAMBDA_EXPR 0 #define PROCEDURE_ENVIRONMENT 1 + +#define GET_PROCEDURE_LAMBDA(procedure) \ + (MEMORY_REF ((procedure), PROCEDURE_LAMBDA_EXPR)) + +#define GET_PROCEDURE_ENVIRONMENT(procedure) \ + (MEMORY_REF ((procedure), PROCEDURE_ENVIRONMENT)) /* QUAD or HUNK4 * Like a pair but with 4 components. @@ -339,31 +408,82 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. /* REFERENCE_TRAP * Causes the variable lookup code to trap. * Used to implement a variety of features. - * This type code is really the collection of two, done this way for efficiency. - * Traps whose datum is less than TRAP_MAX_IMMEDIATE are immediate (not pointers). - * The rest are pairs. The garbage collector deals with them specially. - */ + * This type code is really the collection of two, done this way for + * efficiency. Traps whose datum is less than TRAP_MAX_IMMEDIATE are + * immediate (not pointers). The rest are pairs. The garbage + * collector deals with them specially. */ #define TRAP_TAG 0 #define TRAP_EXTRA 1 -/* Traps can be extended for the use of the fast variable reference mechanism in - * compiled code. The following is the format of a trap extension object. - */ +#define GET_TRAP_TAG(object) \ + (MEMORY_REF ((object), TRAP_TAG)) + +#define GET_TRAP_EXTENSION(object) \ + (MEMORY_REF ((object), TRAP_EXTRA)) + +/* Traps can be extended for the use of the fast variable reference + mechanism in compiled code. The following is the format of a trap + extension object. */ #define TRAP_EXTENSION_CELL HUNK4_CXR0 #define TRAP_EXTENSION_NAME HUNK4_CXR1 #define TRAP_EXTENSION_CLONE HUNK4_CXR2 #define TRAP_EXTENSION_REFERENCES HUNK4_CXR3 -/* Aliases */ +#define CACHE_REFERENCES_LOOKUP HUNK3_CXR0 +#define CACHE_REFERENCES_ASSIGNMENT HUNK3_CXR1 +#define CACHE_REFERENCES_OPERATOR HUNK3_CXR2 + +#define GET_TRAP_CACHE GET_TRAP_EXTENSION + + +#define GET_CACHE_CELL(extension) \ + (MEMORY_LOC ((extension), TRAP_EXTENSION_CELL)) + +#define GET_CACHE_NAME(extension) \ + (MEMORY_REF ((extension), TRAP_EXTENSION_NAME)) + +#define GET_CACHE_CLONE(extension) \ + (MEMORY_REF ((extension), TRAP_EXTENSION_CLONE)) -#define TRAP_EXTENSION_BLOCK TRAP_EXTENSION_CLONE -#define TRAP_EXTENSION_OFFSET TRAP_EXTENSION_REFERENCES +#define SET_CACHE_CLONE(extension, clone) \ + MEMORY_SET ((extension), TRAP_EXTENSION_CLONE, (clone)) -#define TRAP_REFERENCES_LOOKUP HUNK3_CXR0 -#define TRAP_REFERENCES_ASSIGNMENT HUNK3_CXR1 -#define TRAP_REFERENCES_OPERATOR HUNK3_CXR2 +#define GET_CACHE_REFERENCES(extension) \ + (MEMORY_REF ((extension), TRAP_EXTENSION_REFERENCES)) + + +#define GET_CACHE_REFERENCES_LOOKUP(references) \ + (MEMORY_REF ((references), CACHE_REFERENCES_LOOKUP)) + +#define SET_CACHE_REFERENCES_LOOKUP(references, list) \ + MEMORY_SET ((references), CACHE_REFERENCES_LOOKUP, (list))) + +#define GET_CACHE_REFERENCES_ASSIGNMENT(references) \ + (MEMORY_REF ((references), CACHE_REFERENCES_ASSIGNMENT)) + +#define SET_CACHE_REFERENCES_ASSIGNMENT(references, list) \ + MEMORY_SET ((references), CACHE_REFERENCES_ASSIGNMENT, (list))) + +#define GET_CACHE_REFERENCES_OPERATOR(references) \ + (MEMORY_REF ((references), CACHE_REFERENCES_OPERATOR)) + +#define SET_CACHE_REFERENCES_OPERATOR(references, list) \ + MEMORY_SET ((references), CACHE_REFERENCES_OPERATOR, (list))) + + +#define GET_CACHE_REFERENCE_BLOCK(reference) \ + (PAIR_CAR (reference)) + +#define SET_CACHE_REFERENCE_BLOCK(reference, block) \ + SET_PAIR_CAR (reference, block) + +#define GET_CACHE_REFERENCE_OFFSET(reference) \ + (OBJECT_DATUM (PAIR_CDR (reference))) + +#define SET_CACHE_REFERENCE_OFFSET(reference, offset) \ + (SET_PAIR_CDR ((reference), (LONG_TO_UNSIGNED_FIXNUM (offset)))) /* RETURN_CODE * Represents an address where computation is to continue. These can be @@ -422,3 +542,5 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define COMPLEX_REAL 0 #define COMPLEX_IMAG 1 + +#endif /* not SCM_SDATA_H */ diff --git a/v7/src/microcode/trap.h b/v7/src/microcode/trap.h index 4182deedd..87fd306ea 100644 --- a/v7/src/microcode/trap.h +++ b/v7/src/microcode/trap.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: trap.h,v 9.45 2000/12/05 21:23:48 cph Exp $ +$Id: trap.h,v 9.46 2001/07/31 03:12:11 cph Exp $ -Copyright (c) 1987, 1988, 1989, 1999, 2000 Massachusetts Institute of Technology +Copyright (c) 1987-1989, 1999-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 @@ -16,96 +16,80 @@ General Public License for more details. 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. */ + +#ifndef SCM_TRAP_H +#define SCM_TRAP_H /* Kinds of traps: - Note that for every trap there is a dangerous version. - The danger bit is the bottom bit of the trap number, - thus all dangerous traps are odd and viceversa. - For efficiency, some traps are immediate, while some are pointer objects. The type code is multiplexed, and the garbage collector handles it specially. - */ -/* The following are immediate traps: */ + The odd-numbered traps used to be "dangerous" versions of the + even-numbered ones, but all that complexity has been flushed. */ +typedef unsigned long trap_kind_t; + +/* The following are immediate traps: */ #define TRAP_UNASSIGNED 0 -#define TRAP_UNASSIGNED_DANGEROUS 1 #define TRAP_UNBOUND 2 -#define TRAP_UNBOUND_DANGEROUS 3 -#define TRAP_ILLEGAL 4 -#define TRAP_ILLEGAL_DANGEROUS 5 +#define TRAP_RECACHE 4 #define TRAP_EXPENSIVE 6 -#define TRAP_EXPENSIVE_DANGEROUS 7 - /* TRAP_MAX_IMMEDIATE is defined in const.h */ -/* The following are not: */ - -#define TRAP_NOP 10 -#define TRAP_DANGEROUS 11 -#define TRAP_FLUID 12 -#define TRAP_FLUID_DANGEROUS 13 +/* The following are non-immediate traps: */ #define TRAP_COMPILER_CACHED 14 -#define TRAP_COMPILER_CACHED_DANGEROUS 15 - -/* These MUST be distinct */ -#define TRAP_EXTENSION_TYPE TC_QUAD -#define TRAP_REFERENCES_TYPE TC_HUNK3 +/* Usages of the above traps: + TRAP_UNASSIGNED can appear in a value cell or a cache. + TRAP_UNBOUND can appear in a value cell or a cache, but only when + the associated variable is in the global environment. This is + the only way to indicate that a variable is unbound in the + global environment. + TRAP_RECACHE can only appear in a cache. Its presence requests + that the reference be recached. + TRAP_EXPENSIVE can only appear in a "clone" cache. This causes + assignments to this cache to trap out to the microcode, where the + updating of the variable's associated UUO links can be performed. + TRAP_COMPILER_CACHED can only appear in a value cell. It is used + to associate a cache with the variable. */ + +/* The following never appear in value cells. */ +/* NON_TRAP_KIND is returned by get_trap_kind when its argument is not + a reference trap object. */ +#define NON_TRAP_KIND 32 -/* Trap utilities */ - -#define get_trap_kind(variable, what) \ -{ \ - variable = OBJECT_DATUM (what); \ - if (variable > TRAP_MAX_IMMEDIATE) \ - variable = OBJECT_DATUM (MEMORY_REF (what, TRAP_TAG)); \ -} - -/* Common constants */ +/* These MUST be distinct */ +#define CACHE_TYPE TC_QUAD +#define CACHE_REFERENCES_TYPE TC_HUNK3 #if (SIZEOF_UNSIGNED_LONG == 4) /* 32 bit objects */ # if (TYPE_CODE_LENGTH == 8) -# define UNASSIGNED_OBJECT 0x32000000 -# define DANGEROUS_UNASSIGNED_OBJECT 0x32000001 -# define UNBOUND_OBJECT 0x32000002 -# define DANGEROUS_UNBOUND_OBJECT 0x32000003 -# define ILLEGAL_OBJECT 0x32000004 -# define DANGEROUS_ILLEGAL_OBJECT 0x32000005 -# define EXPENSIVE_OBJECT 0x32000006 -# define DANGEROUS_EXPENSIVE_OBJECT 0x32000007 +# define UNASSIGNED_OBJECT 0x32000000 +# define UNBOUND_OBJECT 0x32000002 +# define RECACHE_OBJECT 0x32000004 +# define EXPENSIVE_OBJECT 0x32000006 # endif # if (TYPE_CODE_LENGTH == 6) -# define UNASSIGNED_OBJECT 0xc8000000 -# define DANGEROUS_UNASSIGNED_OBJECT 0xc8000001 -# define UNBOUND_OBJECT 0xc8000002 -# define DANGEROUS_UNBOUND_OBJECT 0xc8000003 -# define ILLEGAL_OBJECT 0xc8000004 -# define DANGEROUS_ILLEGAL_OBJECT 0xc8000005 -# define EXPENSIVE_OBJECT 0xc8000006 -# define DANGEROUS_EXPENSIVE_OBJECT 0xc8000007 +# define UNASSIGNED_OBJECT 0xc8000000 +# define UNBOUND_OBJECT 0xc8000002 +# define RECACHE_OBJECT 0xc8000004 +# define EXPENSIVE_OBJECT 0xc8000006 # endif # if (TC_REFERENCE_TRAP != 0x32) # include "error: trap.h and types.h are inconsistent" # endif #endif -#ifndef UNASSIGNED_OBJECT /* Safe version */ -# define UNASSIGNED_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED) -# define DANGEROUS_UNASSIGNED_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS) -# define UNBOUND_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND) -# define DANGEROUS_UNBOUND_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS) -# define ILLEGAL_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_ILLEGAL) -# define DANGEROUS_ILLEGAL_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS) -# define EXPENSIVE_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE) -# define DANGEROUS_EXPENSIVE_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE_DANGEROUS) +#ifndef UNASSIGNED_OBJECT /* Safe version */ +# define UNASSIGNED_OBJECT (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED)) +# define UNBOUND_OBJECT (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND)) +# define RECACHE_OBJECT (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_RECACHE)) +# define EXPENSIVE_OBJECT (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE)) #endif -#define NOP_OBJECT (LONG_TO_UNSIGNED_FIXNUM (TRAP_NOP)) -#define DANGEROUS_OBJECT (LONG_TO_UNSIGNED_FIXNUM (TRAP_DANGEROUS)) -#define REQUEST_RECACHE_OBJECT DANGEROUS_ILLEGAL_OBJECT -#define EXPENSIVE_ASSIGNMENT_OBJECT EXPENSIVE_OBJECT +#endif /* not SCM_TRAP_H */ diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 9b8f968f7..272db039b 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: utils.c,v 9.78 2001/03/08 18:24:30 cph Exp $ +$Id: utils.c,v 9.79 2001/07/31 03:12:15 cph Exp $ Copyright (c) 1987-2001 Massachusetts Institute of Technology @@ -16,7 +16,8 @@ General Public License for more details. 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 utilities for interrupts, errors, etc. */ @@ -250,7 +251,7 @@ DEFUN_VOID (back_out_of_primitive_internal) compiler_apply_procedure (nargs); STACK_PUSH (primitive); STACK_PUSH (STACK_FRAME_HEADER + nargs); - Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN)); + Store_Env (THE_NULL_ENV); Val = SHARP_F; Store_Return (RC_INTERNAL_APPLY); Store_Expression (SHARP_F);