From 6f60945a6b97a46f88bb79d85c6e719d3bd972bb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 7 Aug 2001 01:27:17 +0000 Subject: [PATCH] Implement primitive to allow linking variables that have different names. (Previously, linked variables were required to have the same name.) This requires a major redesign of the cache data structures, and since the garbage collector knows about these structures, all of the garbage-collector files are affected too. The new data structures have slightly different space requirements: a cache with no references uses one word less than previously, while a cache with references uses three words more than previously (independent of the number of references). This change requires Runtime 14.190 or later. --- v7/src/microcode/bchdmp.c | 10 +- v7/src/microcode/bchgcl.c | 10 +- v7/src/microcode/bintopsb.c | 18 +- v7/src/microcode/cmpint.c | 66 ++-- v7/src/microcode/fasdump.c | 9 +- v7/src/microcode/fasload.c | 7 +- v7/src/microcode/gccode.h | 22 +- v7/src/microcode/gcloop.c | 9 +- v7/src/microcode/lookprm.c | 23 +- v7/src/microcode/lookup.c | 643 ++++++++++++++++++++---------------- v7/src/microcode/lookup.h | 9 +- v7/src/microcode/psbmap.h | 11 +- v7/src/microcode/psbtobin.c | 17 +- v7/src/microcode/purify.c | 9 +- v7/src/microcode/sdata.h | 33 +- v7/src/microcode/trap.h | 9 +- v7/src/microcode/types.h | 9 +- 17 files changed, 502 insertions(+), 412 deletions(-) diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index de44a953c..6a7b45de9 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchdmp.c,v 9.88 2001/02/12 22:32:32 cph Exp $ +$Id: bchdmp.c,v 9.89 2001/08/07 01:25:20 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. */ /* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag, @@ -840,7 +841,7 @@ DEFUN (dump_loop, (scan, free_ptr, new_address_ptr), case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: { - /* `count' typeless pointers to quads follow. */ + /* `count' typeless pointers to hunk3s follow. */ unsigned long count = (READ_CACHE_LINKAGE_COUNT (object)); scan += 1; while (count > 0) @@ -857,11 +858,10 @@ DEFUN (dump_loop, (scan, free_ptr, new_address_ptr), (*free++) = (old_start[0]); (*free++) = (old_start[1]); (*free++) = (old_start[2]); - (*free++) = (old_start[3]); MAYBE_DUMP_FREE (free); (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address)); (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 4; + new_address += 3; } count -= 1; } diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c index 2e7bbb342..71f662061 100644 --- a/v7/src/microcode/bchgcl.c +++ b/v7/src/microcode/bchgcl.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchgcl.c,v 9.52 2001/02/12 22:32:20 cph Exp $ +$Id: bchgcl.c,v 9.53 2001/08/07 01:25:26 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 is the main GC loop for bchscheme. */ @@ -460,7 +461,7 @@ DEFUN (gc_loop, case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: { - /* `count' typeless pointers to quads follow. */ + /* `count' typeless pointers to hunk3s follow. */ unsigned long count = (READ_CACHE_LINKAGE_COUNT (object)); scan += 1; while (count > 0) @@ -478,11 +479,10 @@ DEFUN (gc_loop, (*free++) = (old_start[0]); (*free++) = (old_start[1]); (*free++) = (old_start[2]); - (*free++) = (old_start[3]); MAYBE_DUMP_FREE (free); (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address)); (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 4; + new_address += 3; } count -= 1; } diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index 1b0415f37..a119d0dc8 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: bintopsb.c,v 9.72 2000/12/05 21:23:43 cph Exp $ +$Id: bintopsb.c,v 9.73 2001/08/07 01:25:37 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 contains the code to translate internal format binary @@ -718,7 +719,7 @@ DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src) } \ } while (0) -#define DO_RAW_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \ +#define DO_RAW_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \ { \ Old_Address += (Rel); \ Old_Contents = (* Old_Address); \ @@ -731,7 +732,6 @@ DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src) (Mem_Base [(Fre)++]) = Old_Contents; \ (Mem_Base [(Fre)++]) = (*Old_Address++); \ (Mem_Base [(Fre)++]) = (*Old_Address++); \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ } \ } while (0) @@ -1312,7 +1312,7 @@ DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj), *Area += 1; while (--count >= 0) { - DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_QUAD); + DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_TRIPLE); *Area += 1; } break; @@ -1701,12 +1701,12 @@ DEFUN (print_objects, (from, to), ((long) count)); while (--count >= 0) { - unsigned long the_quad = ((unsigned long) *from++); + unsigned long the_triple = ((unsigned long) *from++); fprintf (portable_file, "%02x %lx %lx\n", TC_C_COMPILED_TAG, - ((long) C_COMPILED_RAW_QUAD), - the_quad); + ((long) C_COMPILED_RAW_TRIPLE), + the_triple); } break; } diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 8f9bc5838..f9d7650ca 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.93 2001/07/31 03:11:12 cph Exp $ +$Id: cmpint.c,v 1.94 2001/08/07 01:25:51 cph Exp $ Copyright (c) 1989-2001 Massachusetts Institute of Technology @@ -1427,11 +1427,13 @@ DEFNX (comutil_operator_lookup_trap, long ignore_4) { SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); + SCHEME_OBJECT cache = (tramp_data[0]); + SCHEME_OBJECT block = (tramp_data[1]); + unsigned long offset = (OBJECT_DATUM (tramp_data[2])); 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])))); + = (compiler_operator_reference_trap (cache, (&true_operator))); + SCHEME_OBJECT * cache_cell = (MEMORY_LOC (block, offset)); long nargs; EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell); @@ -1442,13 +1444,13 @@ DEFNX (comutil_operator_lookup_trap, SCHEME_OBJECT trampoline; /* This could be done by bumping tramp_data to the entry point. - It would probably be better. */ + It would probably be better. */ EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell); STACK_PUSH (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (trampoline))); /* 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])); + STACK_PUSH (compiled_block_environment (block)); + STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR)); Store_Expression (SHARP_F); Store_Return (RC_COMP_OP_REF_TRAP_RESTART); Save_Cont (); @@ -1776,27 +1778,29 @@ DEFUN_VOID (comp_interrupt_restart) SCHEME_UTILITY utility_result DEFNX (comutil_assignment_trap, - (return_address_raw, extension_addr_raw, value, ignore_4), + (return_address_raw, cache_addr_raw, value, ignore_4), SCHEME_ADDR return_address_raw AND - SCHEME_ADDR extension_addr_raw AND + SCHEME_ADDR cache_addr_raw AND SCHEME_OBJECT value AND long ignore_4) { instruction * return_address = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); - SCHEME_OBJECT extension + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT - (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw)))); - long code = (compiler_assignment_trap (extension, value, (&Val))); + (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); + long code = (compiler_assignment_trap (cache, value, (&Val))); if (code == PRIM_DONE) RETURN_TO_SCHEME (return_address); else { SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); + SCHEME_OBJECT block = (compiled_entry_to_block (sra)); STACK_PUSH (sra); STACK_PUSH (value); - STACK_PUSH (compiled_block_environment (compiled_entry_to_block (sra))); - STACK_PUSH (compiler_var_error (extension)); + STACK_PUSH (compiled_block_environment (block)); + STACK_PUSH + (compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT)); Store_Expression (SHARP_F); Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); Save_Cont (); @@ -1827,28 +1831,27 @@ DEFUN_VOID (comp_assignment_trap_restart) SCHEME_UTILITY utility_result DEFNX (comutil_cache_lookup_apply, - (extension_addr_raw, block_address_raw, nactuals, ignore_4), - SCHEME_ADDR extension_addr_raw AND + (cache_addr_raw, block_address_raw, nactuals, ignore_4), + SCHEME_ADDR cache_addr_raw AND SCHEME_ADDR block_address_raw AND long nactuals AND long ignore_4) { - SCHEME_OBJECT extension + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT - (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw)))); + (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); SCHEME_OBJECT value; - long code = (compiler_lookup_trap (extension, (&value))); + long code = (compiler_lookup_trap (cache, (&value))); if (code == PRIM_DONE) return (comutil_apply (value, nactuals, 0, 0)); { 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)); - STACK_PUSH (environment); - STACK_PUSH (name); + STACK_PUSH (compiled_block_environment (block)); + STACK_PUSH + (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR)); Store_Expression (SHARP_F); Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART); Save_Cont (); @@ -1890,28 +1893,29 @@ DEFUN_VOID (comp_cache_lookup_apply_restart) #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), \ + (return_address_raw, cache_addr_raw, ignore_3, ignore_4), \ SCHEME_ADDR return_address_raw AND \ - SCHEME_ADDR extension_addr_raw AND \ + SCHEME_ADDR cache_addr_raw AND \ long ignore_3 AND \ long ignore_4) \ { \ instruction * return_address \ = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); \ - SCHEME_OBJECT extension \ + SCHEME_OBJECT cache \ = (MAKE_POINTER_OBJECT \ - (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw)))); \ - long code = (c_trap (extension, (&Val))); \ + (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); \ + long code = (c_trap (cache, (&Val))); \ if (code == PRIM_DONE) \ RETURN_TO_SCHEME (return_address); \ else \ { \ SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); \ + SCHEME_OBJECT block = (compiled_entry_to_block (sra)); \ STACK_PUSH (sra); \ + STACK_PUSH (compiled_block_environment (block)); \ STACK_PUSH \ - (compiled_block_environment \ - (compiled_entry_to_block (sra))); \ - STACK_PUSH (compiler_var_error (extension)); \ + (compiler_var_error \ + (cache, block, CACHE_REFERENCES_LOOKUP)); \ Store_Expression (SHARP_F); \ Store_Return (ret_code); \ Save_Cont (); \ diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 70402768d..d1b14c0ca 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: fasdump.c,v 9.64 2000/12/05 21:23:44 cph Exp $ +$Id: fasdump.c,v 9.65 2001/08/07 01:25:59 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 contains code for fasdump and dump-band. */ @@ -236,7 +237,7 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode) { Temp = (* Scan); DUMP_RAW_POINTER (Fasdump_Setup_Pointer - (TRANSPORT_RAW_QUADRUPLE (), + (TRANSPORT_RAW_TRIPLE (), RAW_BH (false, continue))); } Scan -= 1; diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 9cf356dd1..4d40fba68 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasload.c,v 9.89 2001/07/31 03:11:26 cph Exp $ +$Id: fasload.c,v 9.90 2001/08/07 01:26:05 cph Exp $ Copyright (c) 1987-2001 Massachusetts Institute of Technology @@ -465,9 +465,8 @@ DEFUN (Relocate_Block, (Scan, Stop_At), case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: { - /* Assumes that all others are objects of type TC_QUAD without - their type codes. - */ + /* Assumes that all others are objects of type TC_HUNK3 + without their type codes. */ fast long count; diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index f48920f61..840271110 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: gccode.h,v 9.57 2000/12/05 21:23:44 cph Exp $ +$Id: gccode.h,v 9.58 2001/08/07 01:26:09 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 contains the macros for use in code which does GC-like @@ -351,25 +352,22 @@ extern SCHEME_OBJECT * gc_objects_referencing_end; Pointer_End (); \ } -#define TRANSPORT_QUADRUPLE_INTERNAL() \ +#define TRANSPORT_RAW_TRIPLE() \ { \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ TRANSPORT_ONE_THING ((*To++) = (*Old)); \ + RAW_POINTER_END (); \ } #define Transport_Quadruple() \ { \ - TRANSPORT_QUADRUPLE_INTERNAL (); \ + TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ + TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ + TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ + TRANSPORT_ONE_THING ((*To++) = (*Old)); \ Pointer_End (); \ } - -#define TRANSPORT_RAW_QUADRUPLE() \ -{ \ - TRANSPORT_QUADRUPLE_INTERNAL (); \ - RAW_POINTER_END (); \ -} #ifndef In_Fasdump diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c index 7b73df934..6e2a11abe 100644 --- a/v7/src/microcode/gcloop.c +++ b/v7/src/microcode/gcloop.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: gcloop.c,v 9.47 2000/12/05 21:23:44 cph Exp $ +$Id: gcloop.c,v 9.48 2001/08/07 01:26:14 cph Exp $ -Copyright (c) 1987-1999 Massachusetts Institute of Technology +Copyright (c) 1987-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,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. */ /* @@ -175,7 +176,7 @@ DEFUN (GCLoop, { Temp = (* Scan); GC_RAW_POINTER (Setup_Internal (true, - TRANSPORT_RAW_QUADRUPLE (), + TRANSPORT_RAW_TRIPLE (), RAW_BH (true, continue))); } Scan -= 1; diff --git a/v7/src/microcode/lookprm.c b/v7/src/microcode/lookprm.c index d98643aec..9a40a66bf 100644 --- a/v7/src/microcode/lookprm.c +++ b/v7/src/microcode/lookprm.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookprm.c,v 1.14 2001/08/02 04:30:03 cph Exp $ +$Id: lookprm.c,v 1.15 2001/08/07 01:26:22 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -168,7 +168,26 @@ If SYMBOL is already bound in ENV1, the existing binding is modified.") CHECK_ARG (1, ENVIRONMENT_P); CHECK_ARG (2, ENVIRONMENT_P); CHECK_ARG (3, SYMBOL_P); - STD_LOOKUP (link_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3)))); + STD_LOOKUP + (link_variables ((ARG_REF (1)), (ARG_REF (3)), + (ARG_REF (2)), (ARG_REF (3)))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("LINK-VARIABLES", Prim_link_variables, 4, 4, + "(TARGET-ENV TARGET-NAME SOURCE-ENV SOURCE-NAME)\n +Define a new binding for TARGET-NAME in TARGET-ENV, which shares its\n +value cell with the binding for SOURCE-NAME in SOURCE-ENV.\n +SOURCE-NAME must be bound in SOURCE-ENV.") +{ + PRIMITIVE_HEADER (4); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + CHECK_ARG (3, ENVIRONMENT_P); + CHECK_ARG (4, SYMBOL_P); + STD_LOOKUP + (link_variables ((ARG_REF (1)), (ARG_REF (2)), + (ARG_REF (3)), (ARG_REF (4)))); PRIMITIVE_RETURN (UNSPECIFIC); } diff --git a/v7/src/microcode/lookup.c b/v7/src/microcode/lookup.c index e5b208be0..3710a9397 100644 --- a/v7/src/microcode/lookup.c +++ b/v7/src/microcode/lookup.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookup.c,v 9.63 2001/08/04 02:46:14 cph Exp $ +$Id: lookup.c,v 9.64 2001/08/07 01:26:29 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -46,11 +46,12 @@ extern SCHEME_OBJECT compiled_block_environment # define SPACE_PER_UUO_LINK 10 #endif -/* Cache objects are 4-tuples. */ -#define SPACE_PER_CACHE 4 +/* Cache objects are 3-tuples. */ +#define SPACE_PER_CACHE 3 -/* Each reference uses a pair and a weak pair. */ -#define SPACE_PER_REFERENCE 4 +/* Each reference uses a pair and a weak pair, and potentially two + more pairs if the reference introduces a new name. */ +#define SPACE_PER_REFERENCE 8 #define RETURN_IF_ERROR(expression) \ { \ @@ -88,6 +89,32 @@ extern SCHEME_OBJECT compiled_block_environment : (value)) #define EXTERNAL_UNASSIGNED_OBJECT (Get_Fixed_Obj_Slot (Non_Object)) + +#define WALK_REFERENCES(refs_pointer, ref_var, body) \ +{ \ + SCHEME_OBJECT * WR_palist = (refs_pointer); \ + while (PAIR_P (*WR_palist)) \ + { \ + SCHEME_OBJECT * WR_prefs \ + = (PAIR_CDR_LOC (PAIR_CAR (*WR_palist))); \ + while (PAIR_P (*WR_prefs)) \ + { \ + SCHEME_OBJECT ref_var = (PAIR_CAR (*WR_prefs)); \ + if ((GET_CACHE_REFERENCE_BLOCK (ref_var)) \ + == SHARP_F) \ + (*WR_prefs) = (PAIR_CDR (*WR_prefs)); \ + else \ + { \ + body; \ + WR_prefs = (PAIR_CDR_LOC (*WR_prefs)); \ + } \ + } \ + if (PAIR_P (PAIR_CDR (PAIR_CAR (*WR_palist)))) \ + WR_palist = (PAIR_CDR_LOC (*WR_palist)); \ + else \ + (*WR_palist) = (PAIR_CDR (*WR_palist)); \ + } \ +} /***** Forward References *****/ @@ -99,32 +126,34 @@ static long assign_variable_cache (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, int); static long update_uuo_links (SCHEME_OBJECT, SCHEME_OBJECT); +static long guarantee_extension_space + (SCHEME_OBJECT); static long allocate_frame_extension (unsigned long, SCHEME_OBJECT, SCHEME_OBJECT *); -static int unbind_extension_variable - (SCHEME_OBJECT, SCHEME_OBJECT); +static void move_all_references + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int); +static long unbind_cached_variable + (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT); +static void unbind_variable_1 + (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT); static long add_cache_reference (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int); -static long add_reference - (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, unsigned long); -static long install_cache +static void add_reference + (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); +static void install_cache (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int); -static long install_operator_cache +static void install_operator_cache (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); -static long update_cache_for_define - (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT); -static long update_cache_for_unbind - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); +static unsigned long update_cache_refs_space + (SCHEME_OBJECT, SCHEME_OBJECT); static long update_cache_references - (SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT); -static void split_cache_references - (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, SCHEME_OBJECT **); -static int environment_ancestor_or_self_p + (SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT); +static unsigned long ref_pairs_to_move + (SCHEME_OBJECT *, SCHEME_OBJECT, unsigned long *); +static void move_ref_pairs + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int, SCHEME_OBJECT); +static int move_ref_pair_p (SCHEME_OBJECT, SCHEME_OBJECT); -static long move_cache_references - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT **); -static void move_cache_references_1 - (SCHEME_OBJECT, SCHEME_OBJECT **, unsigned int); static SCHEME_OBJECT * find_binding_cell (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); static SCHEME_OBJECT * scan_frame @@ -133,17 +162,16 @@ static SCHEME_OBJECT * scan_procedure_bindings (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, int); static unsigned long count_references (SCHEME_OBJECT *); -static SCHEME_OBJECT * find_tail_holder - (SCHEME_OBJECT *); +static SCHEME_OBJECT * find_references_named + (SCHEME_OBJECT *, SCHEME_OBJECT); static void update_assignment_references (SCHEME_OBJECT); static long guarantee_cache - (SCHEME_OBJECT *, SCHEME_OBJECT); -static long update_clone + (SCHEME_OBJECT *); +static void update_clone (SCHEME_OBJECT); static long make_cache - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, - SCHEME_OBJECT *); + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); static long make_cache_reference (SCHEME_OBJECT, unsigned long, SCHEME_OBJECT *); @@ -367,22 +395,20 @@ assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value, static long update_uuo_links (SCHEME_OBJECT cache, SCHEME_OBJECT new_value) { - RETURN_IF_ERROR (update_clone (cache)); GC_CHECK - ((count_references (GET_CACHE_OPERATOR_REFERENCES (cache))) - * SPACE_PER_UUO_LINK); + (((count_references (GET_CACHE_OPERATOR_REFERENCES (cache))) + * SPACE_PER_UUO_LINK) + + SPACE_PER_CACHE); SET_CACHE_VALUE (cache, new_value); - { - SCHEME_OBJECT operators = (* (GET_CACHE_OPERATOR_REFERENCES (cache))); - while (PAIR_P (operators)) - { - SCHEME_OBJECT reference = (PAIR_CAR (operators)); - SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference)); - unsigned long offset = (GET_CACHE_REFERENCE_OFFSET (reference)); - DIE_IF_ERROR (install_operator_cache (cache, block, offset)); - operators = (PAIR_CDR (operators)); - } - } + update_clone (cache); + WALK_REFERENCES + ((GET_CACHE_OPERATOR_REFERENCES (cache)), + reference, + { + install_operator_cache (cache, + (GET_CACHE_REFERENCE_BLOCK (reference)), + (GET_CACHE_REFERENCE_OFFSET (reference))); + }); return (PRIM_DONE); } @@ -401,6 +427,51 @@ define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, return (assign_variable_end (cell, value, (&old_value), 1)); } + /* At this point, we know that environment can't be the global + environment, because scan_frame would have returned a non-null + pointer for the global environment. */ + + RETURN_IF_ERROR (guarantee_extension_space (environment)); + + /* 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. */ + { + SCHEME_OBJECT * shadowed_cell + = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0)); + SCHEME_OBJECT old_cache + = (((shadowed_cell != 0) + && ((get_trap_kind (*shadowed_cell)) == TRAP_COMPILER_CACHED)) + ? (GET_TRAP_CACHE (*shadowed_cell)) + : SHARP_F); + unsigned long length = (GET_EXTENDED_FRAME_LENGTH (environment)); + SCHEME_OBJECT pair; + + /* Make sure there is enough space available to move any + references that need moving. */ + GC_CHECK + (2 + + ((old_cache != SHARP_F) + ? (update_cache_refs_space (old_cache, environment)) + : 0)); + + /* Create the binding. */ + pair = (cons (symbol, value)); + ((GET_EXTENDED_FRAME_BINDINGS (environment)) [length]) = pair; + SET_EXTENDED_FRAME_LENGTH (environment, (length + 1)); + + /* Move any references that need moving. */ + return + ((old_cache != SHARP_F) + ? (update_cache_references + (old_cache, (PAIR_CDR_LOC (pair)), environment)) + : PRIM_DONE); + } +} + +static long +guarantee_extension_space (SCHEME_OBJECT environment) +{ if (EXTENDED_FRAME_P (environment)) /* Guarantee that there is room in the extension for a binding. */ { @@ -430,23 +501,7 @@ define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, (&extension))); SET_FRAME_EXTENSION (environment, extension); } - - /* 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)); - - /* 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 - ((PROCEDURE_FRAME_P (environment)) - ? (update_cache_for_define ((PAIR_CDR_LOC (pair)), environment, symbol)) - : PRIM_DONE); - } + return (PRIM_DONE); } static long @@ -467,17 +522,18 @@ allocate_frame_extension (unsigned long length, SCHEME_OBJECT procedure, } long -link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, - SCHEME_OBJECT symbol) +link_variables (SCHEME_OBJECT target_environment, SCHEME_OBJECT target_symbol, + SCHEME_OBJECT source_environment, SCHEME_OBJECT source_symbol) { SCHEME_OBJECT * source_cell; trap_kind_t source_kind; SCHEME_OBJECT * target_cell; - if (! ((ENVIRONMENT_P (target)) && (ENVIRONMENT_P (source)))) + if (! ((ENVIRONMENT_P (target_environment)) + && (ENVIRONMENT_P (source_environment)))) return (ERR_BAD_FRAME); - source_cell = (find_binding_cell (source, symbol, 0)); + source_cell = (find_binding_cell (source_environment, source_symbol, 0)); if (source_cell == 0) return (ERR_UNBOUND_VARIABLE); @@ -485,7 +541,7 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, if (source_kind == TRAP_UNBOUND) return (ERR_UNBOUND_VARIABLE); - target_cell = (scan_frame (target, symbol, 1)); + target_cell = (scan_frame (target_environment, target_symbol, 1)); if ((target_cell != 0) && ((get_trap_kind (*target_cell)) == TRAP_COMPILER_CACHED)) { @@ -493,16 +549,19 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, if (source_kind == TRAP_COMPILER_CACHED) { SCHEME_OBJECT source_cache = (GET_TRAP_CACHE (*source_cell)); - SCHEME_OBJECT * tail_holders [3]; - (tail_holders[CACHE_REFERENCES_LOOKUP]) - = (GET_CACHE_LOOKUP_REFERENCES (source_cache)); - (tail_holders[CACHE_REFERENCES_ASSIGNMENT]) - = (GET_CACHE_ASSIGNMENT_REFERENCES (source_cache)); - (tail_holders[CACHE_REFERENCES_OPERATOR]) - = (GET_CACHE_OPERATOR_REFERENCES (source_cache)); - RETURN_IF_ERROR - (move_cache_references (source_cache, target_cache, tail_holders)); + GC_CHECK + (((count_references (GET_CACHE_OPERATOR_REFERENCES (target_cache))) + * SPACE_PER_UUO_LINK) + + (2 * SPACE_PER_CACHE)); SET_CACHE_VALUE (target_cache, (GET_CACHE_VALUE (source_cache))); + move_all_references + (source_cache, target_cache, CACHE_REFERENCES_LOOKUP); + move_all_references + (source_cache, target_cache, CACHE_REFERENCES_ASSIGNMENT); + move_all_references + (source_cache, target_cache, CACHE_REFERENCES_OPERATOR); + update_clone (source_cache); + update_clone (target_cache); } else SET_CACHE_VALUE (target_cache, (*source_cell)); @@ -510,8 +569,29 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source, return (PRIM_DONE); } - RETURN_IF_ERROR (guarantee_cache (source_cell, symbol)); - return (define_variable (target, symbol, (*source_cell))); + RETURN_IF_ERROR (guarantee_cache (source_cell)); + return (define_variable (target_environment, target_symbol, (*source_cell))); +} + +static void +move_all_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache, + unsigned int reference_kind) +{ + SCHEME_OBJECT * palist = (GET_CACHE_REFERENCES (to_cache, reference_kind)); + { + SCHEME_OBJECT * pf = (GET_CACHE_REFERENCES (from_cache, reference_kind)); + (*palist) = (*pf); + (*pf) = EMPTY_LIST; + } + WALK_REFERENCES + (palist, + reference, + { + install_cache (to_cache, + (GET_CACHE_REFERENCE_BLOCK (reference)), + (GET_CACHE_REFERENCE_OFFSET (reference)), + reference_kind); + }); } long @@ -528,8 +608,7 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, case NON_TRAP_KIND: case TRAP_UNASSIGNED: - if (!unbind_extension_variable (frame, symbol)) - (*cell) = UNBOUND_OBJECT; + unbind_variable_1 (cell, frame, symbol); (*value_ret) = SHARP_T; return (PRIM_DONE); @@ -546,10 +625,8 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, case TRAP_UNASSIGNED: if (PROCEDURE_FRAME_P (frame)) { - if (!unbind_extension_variable (frame, symbol)) - (*cell) = UNBOUND_OBJECT; RETURN_IF_ERROR - (update_cache_for_unbind (cache, frame, symbol)); + (unbind_cached_variable (cell, frame, symbol)); } else { @@ -567,9 +644,27 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, return (ERR_ILLEGAL_REFERENCE_TRAP); } } + +static long +unbind_cached_variable (SCHEME_OBJECT * cell, SCHEME_OBJECT frame, + SCHEME_OBJECT symbol) +{ + SCHEME_OBJECT cache = (GET_TRAP_CACHE (*cell)); + SCHEME_OBJECT * shadowed_cell + = (find_binding_cell ((GET_FRAME_PARENT (frame)), symbol, 0)); + SCHEME_OBJECT dummy_cell = UNBOUND_OBJECT; + GC_CHECK (update_cache_refs_space (cache, frame)); + unbind_variable_1 (cell, frame, symbol); + return + (update_cache_references + (cache, + ((shadowed_cell == 0) ? (&dummy_cell) : shadowed_cell), + frame)); +} -static int -unbind_extension_variable (SCHEME_OBJECT frame, SCHEME_OBJECT symbol) +static void +unbind_variable_1 (SCHEME_OBJECT * cell, + SCHEME_OBJECT frame, SCHEME_OBJECT symbol) { if ((PROCEDURE_FRAME_P (frame)) && (EXTENDED_FRAME_P (frame))) { @@ -584,12 +679,12 @@ unbind_extension_variable (SCHEME_OBJECT frame, SCHEME_OBJECT symbol) (start[index]) = (start [length - 1]); SET_EXTENDED_FRAME_LENGTH (frame, (length - 1)); (start [length - 1]) = SHARP_F; - return (1); + return; } index += 1; } } - return (0); + (*cell) = UNBOUND_OBJECT; } /***** Interface to compiled code. *****/ @@ -635,9 +730,17 @@ compiler_cache_global_operator (SCHEME_OBJECT name, SCHEME_OBJECT block, } SCHEME_OBJECT -compiler_var_error (SCHEME_OBJECT cache) +compiler_var_error (SCHEME_OBJECT cache, SCHEME_OBJECT block, + unsigned int reference_kind) { - return (GET_CACHE_NAME (cache)); + WALK_REFERENCES + ((GET_CACHE_REFERENCES (cache, reference_kind)), + reference, + { + if ((GET_CACHE_REFERENCE_BLOCK (reference)) == block) + return (PAIR_CAR (PAIR_CAR (*WR_palist))); + }); + return (SHARP_F); } long @@ -757,54 +860,66 @@ add_cache_reference (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, 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)); + DIE_IF_ERROR (guarantee_cache (cell)); { SCHEME_OBJECT cache = (GET_TRAP_CACHE (*cell)); - RETURN_IF_ERROR (add_reference (cache, reference_kind, block, offset)); - RETURN_IF_ERROR (update_clone (cache)); - return (install_cache (cache, block, offset, reference_kind)); + add_reference + ((GET_CACHE_REFERENCES (cache, reference_kind)), symbol, block, offset); + update_clone (cache); + install_cache (cache, block, offset, reference_kind); } + return (PRIM_DONE); } /* 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. */ -static long -add_reference (SCHEME_OBJECT cache, unsigned int reference_kind, - SCHEME_OBJECT block, unsigned long offset) +static void +add_reference (SCHEME_OBJECT * palist, + SCHEME_OBJECT symbol, SCHEME_OBJECT block, unsigned long offset) { - SCHEME_OBJECT * holder = (GET_CACHE_REFERENCES (cache, reference_kind)); - while (PAIR_P (*holder)) + while (PAIR_P (*palist)) { - SCHEME_OBJECT reference = (PAIR_CAR (*holder)); - if ((GET_CACHE_REFERENCE_BLOCK (reference)) == SHARP_F) + if ((PAIR_CAR (PAIR_CAR (*palist))) == symbol) { - SET_CACHE_REFERENCE_BLOCK (reference, block); - SET_CACHE_REFERENCE_OFFSET (reference, offset); - return (PRIM_DONE); + SCHEME_OBJECT * prefs = (PAIR_CDR_LOC (PAIR_CAR (*palist))); + while (PAIR_P (*prefs)) + { + if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (*prefs))) == SHARP_F) + { + SET_CACHE_REFERENCE_BLOCK ((PAIR_CAR (*prefs)), block); + SET_CACHE_REFERENCE_OFFSET ((PAIR_CAR (*prefs)), offset); + return; + } + prefs = (PAIR_CDR_LOC (*prefs)); + } + { + SCHEME_OBJECT reference; + DIE_IF_ERROR (make_cache_reference (block, offset, (&reference))); + (*prefs) = (cons (reference, EMPTY_LIST)); + } + return; } - holder = (PAIR_CDR_LOC (*holder)); + palist = (PAIR_CDR_LOC (*palist)); } { SCHEME_OBJECT reference; - RETURN_IF_ERROR (make_cache_reference (block, offset, (&reference))); - GC_CHECK (2); - (*holder) = (cons (reference, EMPTY_LIST)); + DIE_IF_ERROR (make_cache_reference (block, offset, (&reference))); + (*palist) + = (cons ((cons (symbol, (cons (reference, EMPTY_LIST)))), EMPTY_LIST)); } - return (PRIM_DONE); } -static long -install_cache (SCHEME_OBJECT cache, - SCHEME_OBJECT block, unsigned long offset, +static void +install_cache (SCHEME_OBJECT cache, SCHEME_OBJECT block, unsigned long offset, unsigned int reference_kind) { switch (reference_kind) { case CACHE_REFERENCES_LOOKUP: store_variable_cache (cache, block, offset); - return (PRIM_DONE); + break; case CACHE_REFERENCES_ASSIGNMENT: store_variable_cache @@ -813,136 +928,150 @@ install_cache (SCHEME_OBJECT cache, : cache), block, offset); - return (PRIM_DONE); + break; case CACHE_REFERENCES_OPERATOR: - return (install_operator_cache (cache, block, offset)); + install_operator_cache (cache, block, offset); + break; default: abort (); - return (0); + break; } } -static long +static void install_operator_cache (SCHEME_OBJECT cache, SCHEME_OBJECT block, unsigned long offset) { SCHEME_OBJECT value = (GET_CACHE_VALUE (cache)); - return + DIE_IF_ERROR ((REFERENCE_TRAP_P (value)) ? (make_fake_uuo_link (cache, block, offset)) : (make_uuo_link (value, cache, block, offset))); } -/* update_cache_for_define is invoked when a new binding is created. - It recaches (at the definition point) all the references that need - to point to the new cell. update_cache_for_unbind is called when a - binding is removed. It recaches references from the cache of the - now unbound variable. Both procedures call - update_cache_references, which does the following: - - First, split_cache_references is called to split all references - into those that need to be updated and those that do not. This is - 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. - - Second, after checking that there is enough space to proceed, the - references are moved to their new locations. */ - -static long -update_cache_for_define (SCHEME_OBJECT * new_cell, - SCHEME_OBJECT environment, SCHEME_OBJECT symbol) -{ - SCHEME_OBJECT * shadowed_cell - = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0)); - return - (((shadowed_cell != 0) - && ((get_trap_kind (*shadowed_cell)) == TRAP_COMPILER_CACHED)) - ? (update_cache_references - ((GET_TRAP_CACHE (*shadowed_cell)), new_cell, environment, symbol)) - : PRIM_DONE); -} - -static long -update_cache_for_unbind (SCHEME_OBJECT old_cache, - SCHEME_OBJECT environment, SCHEME_OBJECT symbol) +static unsigned long +update_cache_refs_space (SCHEME_OBJECT from_cache, SCHEME_OBJECT environment) { - SCHEME_OBJECT * shadowed_cell - = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0)); - SCHEME_OBJECT dummy_cell = UNBOUND_OBJECT; + unsigned long n_names = 0; + unsigned long n_lookups + = (ref_pairs_to_move ((GET_CACHE_LOOKUP_REFERENCES (from_cache)), + environment, (&n_names))); + unsigned long n_assignments + = (ref_pairs_to_move ((GET_CACHE_ASSIGNMENT_REFERENCES (from_cache)), + environment, (&n_names))); + unsigned long n_operators + = (ref_pairs_to_move ((GET_CACHE_OPERATOR_REFERENCES (from_cache)), + environment, (&n_names))); + + /* No references need to be updated. */ + if ((n_lookups == 0) && (n_assignments == 0) && (n_operators == 0)) + return (PRIM_DONE); return - (update_cache_references (old_cache, - ((shadowed_cell == 0) - ? (&dummy_cell) - : shadowed_cell), - environment, symbol)); + ((n_operators * SPACE_PER_UUO_LINK) + + (n_names * 4) + + (3 * SPACE_PER_CACHE)); } static long update_cache_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT * to_cell, - SCHEME_OBJECT environment, SCHEME_OBJECT symbol) + SCHEME_OBJECT environment) { - SCHEME_OBJECT * tail_holders [3]; - - /* Split the references lists. */ - split_cache_references - (from_cache, CACHE_REFERENCES_LOOKUP, environment, tail_holders); - split_cache_references - (from_cache, CACHE_REFERENCES_ASSIGNMENT, environment, tail_holders); - split_cache_references - (from_cache, CACHE_REFERENCES_OPERATOR, environment, tail_holders); - - /* Return if there are no references that need to be updated. */ - if ((!PAIR_P (* (tail_holders[CACHE_REFERENCES_LOOKUP]))) - && (!PAIR_P (* (tail_holders[CACHE_REFERENCES_ASSIGNMENT]))) - && (!PAIR_P (* (tail_holders[CACHE_REFERENCES_OPERATOR])))) - return (PRIM_DONE); - - RETURN_IF_ERROR (guarantee_cache (to_cell, symbol)); + DIE_IF_ERROR (guarantee_cache (to_cell)); + { + SCHEME_OBJECT to_cache = (GET_TRAP_CACHE (*to_cell)); + move_ref_pairs + (from_cache, to_cache, CACHE_REFERENCES_LOOKUP, environment); + move_ref_pairs + (from_cache, to_cache, CACHE_REFERENCES_ASSIGNMENT, environment); + move_ref_pairs + (from_cache, to_cache, CACHE_REFERENCES_OPERATOR, environment); + update_clone (to_cache); + } + update_clone (from_cache); + return (PRIM_DONE); +} - return - (move_cache_references - (from_cache, (GET_TRAP_CACHE (*to_cell)), tail_holders)); +static unsigned long +ref_pairs_to_move (SCHEME_OBJECT * palist, SCHEME_OBJECT environment, + unsigned long * n_names_ret) +{ + unsigned long n_refs = 0; + while (PAIR_P (*palist)) + { + int any_moved_p = 0; + SCHEME_OBJECT * prefs = (PAIR_CDR_LOC (PAIR_CAR (*palist))); + while (PAIR_P (*prefs)) + if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (*prefs))) == SHARP_F) + (*prefs) = (PAIR_CDR (*prefs)); + else + { + if (move_ref_pair_p ((*prefs), environment)) + { + n_refs += 1; + any_moved_p = 1; + } + prefs = (PAIR_CDR_LOC (*prefs)); + } + if (any_moved_p) + (*n_names_ret) += 1; + palist = (PAIR_CDR_LOC (*palist)); + } + return (n_refs); } static void -split_cache_references (SCHEME_OBJECT cache, - unsigned int reference_kind, - SCHEME_OBJECT environment, - SCHEME_OBJECT ** tail_holders) +move_ref_pairs (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache, + unsigned int reference_kind, SCHEME_OBJECT environment) { - SCHEME_OBJECT * holder = (GET_CACHE_REFERENCES (cache, reference_kind)); - SCHEME_OBJECT references_to_move = EMPTY_LIST; - while (PAIR_P (*holder)) + SCHEME_OBJECT * from_palist + = (GET_CACHE_REFERENCES (from_cache, reference_kind)); + SCHEME_OBJECT * to_palist + = (GET_CACHE_REFERENCES (to_cache, reference_kind)); + while (PAIR_P (*from_palist)) { - 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; - } + SCHEME_OBJECT * from_prefs = (PAIR_CDR_LOC (PAIR_CAR (*from_palist))); + SCHEME_OBJECT symbol = (PAIR_CAR (PAIR_CAR (*from_palist))); + SCHEME_OBJECT * to_prefs = (find_references_named (to_palist, symbol)); + while (PAIR_P (*from_prefs)) + if (move_ref_pair_p ((*from_prefs), environment)) + { + SCHEME_OBJECT p = (*from_prefs); + (*from_prefs) = (PAIR_CDR (p)); + if (to_prefs == 0) + { + SCHEME_OBJECT p2; + SET_PAIR_CDR (p, EMPTY_LIST); + p2 = (cons ((cons (symbol, p)), (*to_palist))); + (*to_palist) = p2; + } + else + { + SET_PAIR_CDR (p, (*to_prefs)); + (*to_prefs) = p; + } + install_cache (to_cache, + (GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (p))), + (GET_CACHE_REFERENCE_OFFSET (PAIR_CAR (p))), + reference_kind); + } + else + from_prefs = (PAIR_CDR_LOC (*from_prefs)); + if (PAIR_P (PAIR_CDR (PAIR_CAR (*from_palist)))) + from_palist = (PAIR_CDR_LOC (*from_palist)); else - holder = (PAIR_CDR_LOC (p)); + (*from_palist) = (PAIR_CDR (*from_palist)); } - (*holder) = references_to_move; - (tail_holders[reference_kind]) = holder; } static int -environment_ancestor_or_self_p (SCHEME_OBJECT ancestor, - SCHEME_OBJECT descendant) +move_ref_pair_p (SCHEME_OBJECT ref_pair, SCHEME_OBJECT ancestor) { + SCHEME_OBJECT descendant + = (compiled_block_environment + (GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (ref_pair)))); while (PROCEDURE_FRAME_P (descendant)) { if (descendant == ancestor) @@ -951,41 +1080,6 @@ environment_ancestor_or_self_p (SCHEME_OBJECT ancestor, } return (descendant == ancestor); } - -static long -move_cache_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache, - SCHEME_OBJECT ** tail_holders) -{ - GC_CHECK - (((count_references (tail_holders[CACHE_REFERENCES_OPERATOR])) - * SPACE_PER_UUO_LINK) - + (2 * SPACE_PER_CACHE)); - move_cache_references_1 (to_cache, tail_holders, CACHE_REFERENCES_LOOKUP); - move_cache_references_1 - (to_cache, tail_holders, CACHE_REFERENCES_ASSIGNMENT); - move_cache_references_1 (to_cache, tail_holders, CACHE_REFERENCES_OPERATOR); - RETURN_IF_ERROR (update_clone (from_cache)); - RETURN_IF_ERROR (update_clone (to_cache)); - return (PRIM_DONE); -} - -static void -move_cache_references_1 (SCHEME_OBJECT cache, SCHEME_OBJECT ** tail_holders, - unsigned int reference_kind) -{ - SCHEME_OBJECT tail = (* (tail_holders[reference_kind])); - (* (tail_holders[reference_kind])) = EMPTY_LIST; - (* (find_tail_holder (GET_CACHE_REFERENCES (cache, reference_kind)))) = tail; - 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)); - } -} /***** Utilities *****/ @@ -1074,64 +1168,45 @@ get_trap_kind (SCHEME_OBJECT object) } static unsigned long -count_references (SCHEME_OBJECT * holder) +count_references (SCHEME_OBJECT * palist) { 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)); - } - } + WALK_REFERENCES (palist, reference, { n_references += 1; }); return (n_references); } static SCHEME_OBJECT * -find_tail_holder (SCHEME_OBJECT * holder) +find_references_named (SCHEME_OBJECT * palist, SCHEME_OBJECT symbol) { - while (PAIR_P (*holder)) + while (PAIR_P (*palist)) { - SCHEME_OBJECT p = (*holder); - if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (p))) == SHARP_F) - (*holder) = (PAIR_CDR (p)); - else - holder = (PAIR_CDR_LOC (p)); + if ((PAIR_CAR (PAIR_CAR (*palist))) == symbol) + return (PAIR_CDR_LOC (PAIR_CAR (*palist))); + palist = (PAIR_CDR_LOC (*palist)); } - return (holder); + return (0); } static void update_assignment_references (SCHEME_OBJECT cache) { - SCHEME_OBJECT * holder = (GET_CACHE_ASSIGNMENT_REFERENCES (cache)); 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)); - } - } + WALK_REFERENCES + ((GET_CACHE_ASSIGNMENT_REFERENCES (cache)), + reference, + { + store_variable_cache + (reference_cache, + (GET_CACHE_REFERENCE_BLOCK (reference)), + (GET_CACHE_REFERENCE_OFFSET (reference))); + }); } static long -guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol) +guarantee_cache (SCHEME_OBJECT * cell) { SCHEME_OBJECT references; SCHEME_OBJECT cache; @@ -1145,8 +1220,7 @@ guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol) (*Free++) = EMPTY_LIST; (*Free++) = EMPTY_LIST; - RETURN_IF_ERROR - (make_cache ((*cell), symbol, SHARP_F, references, (&cache))); + RETURN_IF_ERROR (make_cache ((*cell), SHARP_F, references, (&cache))); GC_CHECK (2); (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED)); @@ -1155,7 +1229,7 @@ guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol) return (PRIM_DONE); } -static long +static void update_clone (SCHEME_OBJECT cache) { if ((PAIR_P (* (GET_CACHE_ASSIGNMENT_REFERENCES (cache)))) @@ -1164,9 +1238,8 @@ update_clone (SCHEME_OBJECT cache) if ((GET_CACHE_CLONE (cache)) == SHARP_F) { SCHEME_OBJECT clone; - RETURN_IF_ERROR + DIE_IF_ERROR (make_cache (EXPENSIVE_OBJECT, - (GET_CACHE_NAME (cache)), cache, (GET_CACHE_REFERENCES_OBJECT (cache)), (&clone))); @@ -1182,19 +1255,17 @@ update_clone (SCHEME_OBJECT cache) update_assignment_references (cache); } } - return (PRIM_DONE); } static long -make_cache (SCHEME_OBJECT value, SCHEME_OBJECT symbol, SCHEME_OBJECT clone, - SCHEME_OBJECT references, SCHEME_OBJECT * cache_ret) +make_cache (SCHEME_OBJECT value, SCHEME_OBJECT clone, SCHEME_OBJECT references, + SCHEME_OBJECT * cache_ret) { - GC_CHECK (4); + GC_CHECK (3); (*Free++) = value; - (*Free++) = symbol; (*Free++) = clone; (*Free++) = references; - (*cache_ret) = (MAKE_POINTER_OBJECT (CACHE_TYPE, (Free - 4))); + (*cache_ret) = (MAKE_POINTER_OBJECT (CACHE_TYPE, (Free - 3))); return (PRIM_DONE); } diff --git a/v7/src/microcode/lookup.h b/v7/src/microcode/lookup.h index bfe034858..48f78a4b9 100644 --- a/v7/src/microcode/lookup.h +++ b/v7/src/microcode/lookup.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookup.h,v 9.54 2001/08/02 04:30:12 cph Exp $ +$Id: lookup.h,v 9.55 2001/08/07 01:26:36 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -41,8 +41,8 @@ extern long assign_variable (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); extern long define_variable (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); -extern long link_variable - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); +extern long link_variables + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); extern long unbind_variable (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *); @@ -57,7 +57,8 @@ extern long compiler_cache_operator extern long compiler_cache_global_operator (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); -extern SCHEME_OBJECT compiler_var_error (SCHEME_OBJECT); +extern SCHEME_OBJECT compiler_var_error + (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int); extern long compiler_lookup_trap (SCHEME_OBJECT, SCHEME_OBJECT *); diff --git a/v7/src/microcode/psbmap.h b/v7/src/microcode/psbmap.h index 5e5a25d1f..7694a1534 100644 --- a/v7/src/microcode/psbmap.h +++ b/v7/src/microcode/psbmap.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: psbmap.h,v 9.44 2000/12/05 21:23:48 cph Exp $ +$Id: psbmap.h,v 9.45 2001/08/07 01:26:41 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 contains macros and declarations for "bintopsb.c" @@ -57,7 +58,7 @@ extern double EXFUN (frexp, (double, int *)), EXFUN (ldexp, (double, int)); -#define PORTABLE_VERSION 6 +#define PORTABLE_VERSION 7 /* Number of objects which, when traced recursively, point at all other objects dumped. @@ -167,7 +168,7 @@ static Boolean nmv_p = false; #define C_COMPILED_CLOSURE_HEADER 3 #define C_COMPILED_MULTI_CLOSURE_HEADER 4 #define C_COMPILED_LINKAGE_HEADER 5 -#define C_COMPILED_RAW_QUAD 6 +#define C_COMPILED_RAW_TRIPLE 6 #define C_COMPILED_EXECUTE_ENTRY 7 #define C_COMPILED_EXECUTE_ARITY 8 diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index e544e624a..3315c1652 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: psbtobin.c,v 9.58 2000/01/18 05:09:07 cph Exp $ +$Id: psbtobin.c,v 9.59 2001/08/07 01:26:49 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 contains the code to translate portable format binary @@ -952,13 +953,13 @@ DEFUN (Read_Pointers_and_Relocate, (how_many, to), continue; } - case C_COMPILED_RAW_QUAD: + case C_COMPILED_RAW_TRIPLE: { - long quad_datum; + long triple_datum; - VMS_BUG (quad_datum = 0); - fscanf (portable_file, "%lx", &quad_datum); - *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (quad_datum))); + VMS_BUG (triple_datum = 0); + fscanf (portable_file, "%lx", &triple_datum); + *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (triple_datum))); continue; } diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index ba1d29228..499e2b997 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: purify.c,v 9.59 2000/12/05 21:23:48 cph Exp $ +$Id: purify.c,v 9.60 2001/08/07 01:27:03 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-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,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 code that copies objects into pure @@ -147,7 +148,7 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), { Temp = (* Scan); PURIFY_RAW_POINTER (Setup_Internal (false, - TRANSPORT_RAW_QUADRUPLE (), + TRANSPORT_RAW_TRIPLE (), RAW_BH (false, continue))); } Scan -= 1; diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h index 4073e9072..9305634b3 100644 --- a/v7/src/microcode/sdata.h +++ b/v7/src/microcode/sdata.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: sdata.h,v 9.37 2001/08/02 04:30:16 cph Exp $ +$Id: sdata.h,v 9.38 2001/08/07 01:27:09 cph Exp $ Copyright (c) 1987-1989, 1999, 2001 Massachusetts Institute of Technology @@ -425,47 +425,36 @@ USA. #define GET_TRAP_TAG(object) \ (MEMORY_REF ((object), TRAP_TAG)) -#define GET_TRAP_EXTENSION(object) \ +#define GET_TRAP_CACHE(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 +#define CACHE_CELL HUNK3_CXR0 +#define CACHE_CLONE HUNK3_CXR1 +#define CACHE_REFERENCES HUNK3_CXR2 #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_VALUE(cache) \ - (MEMORY_REF ((cache), TRAP_EXTENSION_CELL)) + (MEMORY_REF ((cache), CACHE_CELL)) #define SET_CACHE_VALUE(cache, value) \ - MEMORY_SET ((cache), TRAP_EXTENSION_CELL, (value)) - -#define GET_CACHE_NAME(cache) \ - (MEMORY_REF ((cache), TRAP_EXTENSION_NAME)) + MEMORY_SET ((cache), CACHE_CELL, (value)) #define GET_CACHE_CLONE(cache) \ - (MEMORY_REF ((cache), TRAP_EXTENSION_CLONE)) + (MEMORY_REF ((cache), CACHE_CLONE)) #define SET_CACHE_CLONE(cache, clone) \ - MEMORY_SET ((cache), TRAP_EXTENSION_CLONE, (clone)) + MEMORY_SET ((cache), CACHE_CLONE, (clone)) #define GET_CACHE_REFERENCES_OBJECT(cache) \ - (MEMORY_REF ((cache), TRAP_EXTENSION_REFERENCES)) + (MEMORY_REF ((cache), CACHE_REFERENCES)) #define GET_CACHE_REFERENCES(cache, kind) \ - (MEMORY_LOC ((MEMORY_REF ((cache), TRAP_EXTENSION_REFERENCES)), \ - (kind))) + (MEMORY_LOC ((GET_CACHE_REFERENCES_OBJECT (cache)), (kind))) #define GET_CACHE_LOOKUP_REFERENCES(cache) \ (GET_CACHE_REFERENCES ((cache), CACHE_REFERENCES_LOOKUP)) diff --git a/v7/src/microcode/trap.h b/v7/src/microcode/trap.h index f7ebc4965..5234adb2d 100644 --- a/v7/src/microcode/trap.h +++ b/v7/src/microcode/trap.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: trap.h,v 9.47 2001/08/02 04:24:19 cph Exp $ +$Id: trap.h,v 9.48 2001/08/07 01:27:13 cph Exp $ Copyright (c) 1987-1989, 1999-2001 Massachusetts Institute of Technology @@ -67,8 +67,11 @@ typedef unsigned long trap_kind_t; a reference trap object. */ #define NON_TRAP_KIND 32 -/* These MUST be distinct */ -#define CACHE_TYPE TC_QUAD +/* The garbage collector knows that pointers of type CACHE_TYPE point + to three words of storage, because these pointers are embedded in + compiled-code linkage sections (TC_LINKAGE_SECTION) without types. + */ +#define CACHE_TYPE TC_HUNK3 #define CACHE_REFERENCES_TYPE TC_HUNK3 #if (SIZEOF_UNSIGNED_LONG == 4) /* 32 bit objects */ diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h index 0f1ce0be2..828a14f59 100644 --- a/v7/src/microcode/types.h +++ b/v7/src/microcode/types.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: types.h,v 9.37 1999/01/02 06:06:43 cph Exp $ +$Id: types.h,v 9.38 2001/08/07 01:27:17 cph Exp $ -Copyright (c) 1987-1999 Massachusetts Institute of Technology +Copyright (c) 1987-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,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. */ /* Type code definitions, numerical order */ @@ -79,7 +80,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define TC_DISJUNCTION 0x35 #define TC_CELL 0x36 #define TC_WEAK_CONS 0x37 -#define TC_QUAD 0x38 /* TRAP */ +#define TC_QUAD 0x38 #define TC_LINKAGE_SECTION 0x39 #define TC_RATNUM 0x3A /* COMPILER_LINK */ #define TC_STACK_ENVIRONMENT 0x3B -- 2.25.1