From 6262be4de04c372831f91717be62d78b283de967 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 3 Apr 1987 00:23:01 +0000 Subject: [PATCH] Rewrite of variable lookup code and some tuning of the interpreter. --- v7/src/microcode/bchgcl.c | 25 +- v7/src/microcode/bchmmg.c | 31 +- v7/src/microcode/bintopsb.c | 259 ++++------ v7/src/microcode/bkpt.h | 48 +- v7/src/microcode/boot.c | 13 +- v7/src/microcode/config.h | 26 +- v7/src/microcode/const.h | 58 +-- v7/src/microcode/daemon.c | 13 +- v7/src/microcode/debug.c | 126 +++-- v7/src/microcode/dump.c | 12 +- v7/src/microcode/errors.h | 5 +- v7/src/microcode/extern.h | 32 +- v7/src/microcode/fasdump.c | 57 +-- v7/src/microcode/fasl.h | 50 +- v7/src/microcode/fasload.c | 23 +- v7/src/microcode/findprim.c | 4 +- v7/src/microcode/fixobj.h | 4 +- v7/src/microcode/gc.h | 4 +- v7/src/microcode/gccode.h | 106 +--- v7/src/microcode/gcloop.c | 48 +- v7/src/microcode/gctype.c | 20 +- v7/src/microcode/hooks.c | 64 +-- v7/src/microcode/interp.c | 957 ++++++++++++++++++++---------------- v7/src/microcode/interp.h | 92 ++-- v7/src/microcode/list.c | 41 +- v7/src/microcode/memmag.c | 59 ++- v7/src/microcode/object.h | 61 ++- v7/src/microcode/ppband.c | 67 +-- v7/src/microcode/prim.c | 355 ++++--------- v7/src/microcode/prims.h | 29 +- v7/src/microcode/psbtobin.c | 26 +- v7/src/microcode/purify.c | 59 ++- v7/src/microcode/purutl.c | 8 +- v7/src/microcode/scheme.h | 45 +- v7/src/microcode/scode.h | 79 ++- v7/src/microcode/sdata.h | 216 +++----- v7/src/microcode/storage.c | 126 ++--- v7/src/microcode/types.h | 67 ++- v7/src/microcode/utabmd.scm | 28 +- v7/src/microcode/utils.c | 114 +++-- v7/src/microcode/version.h | 4 +- v8/src/microcode/bintopsb.c | 259 ++++------ v8/src/microcode/const.h | 58 +-- v8/src/microcode/fasl.h | 50 +- v8/src/microcode/fixobj.h | 4 +- v8/src/microcode/gctype.c | 20 +- v8/src/microcode/interp.c | 957 ++++++++++++++++++++---------------- v8/src/microcode/object.h | 61 ++- v8/src/microcode/ppband.c | 67 +-- v8/src/microcode/psbtobin.c | 26 +- v8/src/microcode/types.h | 67 ++- v8/src/microcode/utabmd.scm | 28 +- v8/src/microcode/version.h | 4 +- 53 files changed, 2509 insertions(+), 2553 deletions(-) diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c index f77348a82..fd9061430 100644 --- a/v7/src/microcode/bchgcl.c +++ b/v7/src/microcode/bchgcl.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.26 1987/02/12 01:14:59 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.27 1987/04/03 00:07:27 jinx Exp $ */ /* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag, purify, and fasdump, respectively, to provide garbage collection @@ -195,29 +195,22 @@ Pointer **To_ptr, **To_Address_ptr; case_Cell: relocate_normal_pointer(copy_cell(), 1); + case TC_REFERENCE_TRAP: + if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) + { + /* It is a non pointer. */ + break; + } + /* It is a pair, fall through. */ case_Pair: relocate_normal_pointer(copy_pair(), 2); + case TC_VARIABLE: case_Triple: relocate_normal_pointer(copy_triple(), 3); -#ifdef QUADRUPLE case_Quadruple: relocate_normal_pointer(copy_quadruple(), 4); -#endif - - case TC_VARIABLE: - relocate_normal_setup(); - { Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; - if ((Type_Code(Compiled_Type) == AUX_REF) && - (!Is_Constant(Get_Pointer(Compiled_Type))) && - (Type_Code(Vector_Ref(Compiled_Type, 0)) != TC_BROKEN_HEART)) - { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; - Old[VARIABLE_OFFSET] = NIL; - } - } - relocate_normal_transport(copy_triple(), 3); - relocate_normal_end(); #ifdef FLOATING_ALIGNMENT case TC_BIG_FLONUM: diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 6c9df28db..a94900628 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.26 1987/02/12 01:17:03 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.27 1987/04/03 00:07:44 jinx Exp $ */ /* Memory management top level. Garbage collection to disk. @@ -188,8 +188,8 @@ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; */ Highest_Allocated_Address = Allocate_Heap_Space(Real_Stack_Size + Our_Heap_Size + - Our_Constant_Size + (2 * GC_BUFFER_SPACE)); - Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE); + Our_Constant_Size + (2 * GC_BUFFER_SPACE) + + HEAP_BUFFER_SPACE); /* Consistency check 2 */ if (Heap == NULL) @@ -197,9 +197,12 @@ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; exit(1); } - /* Initialize the various global parameters. - Floating alignment will have to be added here. - */ + /* Trim the system buffer space. */ + + Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE); + Heap += HEAP_BUFFER_SPACE; + Initial_Align_Float(Heap); + Constant_Space = Heap + Our_Heap_Size; gc_disk_buffer_1 = Constant_Space + Our_Constant_Size + Real_Stack_Size; gc_disk_buffer_2 = (gc_disk_buffer_1 + GC_BUFFER_SPACE); @@ -421,13 +424,25 @@ Fix_Weak_Chain() *Scan = Temp; continue; + case GC_Special: + if (Type_Code(Temp) != TC_REFERENCE_TRAP) + { + /* No other special type makes sense here. */ + goto fail; + } + if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) + { + *Scan = Temp; + continue; + } + /* Otherwise, it is a pointer. Fall through */ + /* Normal pointer types, the broken heart is in the first word. Note that most special types are treated normally here. The BH code updates *Scan if the object has been relocated. Otherwise it falls through and we replace it with a full NIL. Eliminating this assignment would keep old data (pl. of datum). */ - case GC_Cell: case GC_Pair: case GC_Triple: @@ -462,9 +477,9 @@ Fix_Weak_Chain() *Scan = NIL; continue; - case GC_Special: case GC_Undefined: default: /* Non Marked Headers and Broken Hearts */ + fail: fprintf(stderr, "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n", Type_Code(Temp), Datum(Temp)); diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index 74d2a2eb5..cd1256767 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.22 1987/03/12 14:52:23 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.23 1987/04/03 00:05:18 jinx Exp $ * * This File contains the code to translate internal format binary * files to portable format. @@ -43,10 +43,10 @@ MIT in each case. */ #define Portable_File Output_File #include "translate.h" +#include "trap.h" static Boolean Shuffle_Bytes = false; -static Boolean Padded_Strings = true; -static Boolean Dense_Types = true; +static Boolean upgrade_traps = false; static Pointer *Mem_Base; static long Heap_Relocation, Constant_Relocation; @@ -117,27 +117,24 @@ char *name; } } -#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { fast long i; \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = STRING_0; \ - *(FObj)++ = Old_Contents; \ - i = Get_Integer(Old_Contents); \ - NStrings += 1; \ - NChars += (Padded_Strings ? \ - pointer_to_char(i-1) : \ - (1 + pointer_to_char(i-1))); \ - while(--i >= 0) *(FObj)++ = *Old_Address++; \ - } \ - if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \ +#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \ +{ Old_Address += (Rel); \ + Old_Contents = *Old_Address; \ + if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ + Mem_Base[(Scn)] = \ + Make_New_Pointer((Code), Old_Contents); \ + else \ + { fast long i; \ + Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ + *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ + (Obj) += 1; \ + *(FObj)++ = STRING_0; \ + *(FObj)++ = Old_Contents; \ + i = Get_Integer(Old_Contents); \ + NStrings += 1; \ + NChars += pointer_to_char(i-1); \ + while(--i >= 0) *(FObj)++ = *Old_Address++; \ + } \ } print_a_string(from) @@ -145,7 +142,6 @@ Pointer *from; { fast long len; fast char *string; long maxlen = pointer_to_char((Get_Integer(*from++))-1); - if (!Padded_Strings) maxlen += 1; len = Get_Integer(*from++); fprintf(Portable_File, "%02x %ld %ld ", TC_CHARACTER_STRING, @@ -189,26 +185,25 @@ long val; return; } -#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { fast long length; \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - NIntegers += 1; \ - NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \ - *(FObj)++ = Old_Contents; \ - for (length = Get_Integer(Old_Contents); \ - --length >= 0; ) \ - *(FObj)++ = *Old_Address++; \ - } \ - if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \ +#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \ +{ Old_Address += (Rel); \ + Old_Contents = *Old_Address; \ + if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ + Mem_Base[(Scn)] = \ + Make_New_Pointer((Code), Old_Contents); \ + else \ + { fast long length; \ + Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ + NIntegers += 1; \ + NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \ + *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ + (Obj) += 1; \ + *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \ + *(FObj)++ = Old_Contents; \ + for (length = Get_Integer(Old_Contents); \ + --length >= 0; ) \ + *(FObj)++ = *Old_Address++; \ + } \ } print_a_bignum(from) @@ -256,22 +251,21 @@ Pointer *from; return; } -#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \ - *((double *) (FObj)) = *((double *) Old_Address); \ - (FObj) += float_to_pointer; \ - NFlonums += 1; \ - } \ - if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \ +#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \ +{ Old_Address += (Rel); \ + Old_Contents = *Old_Address; \ + if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ + Mem_Base[(Scn)] = \ + Make_New_Pointer((Code), Old_Contents); \ + else \ + { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ + Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ + (Obj) += 1; \ + *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \ + *((double *) (FObj)) = *((double *) Old_Address); \ + (FObj) += float_to_pointer; \ + NFlonums += 1; \ + } \ } print_a_flonum(val) @@ -401,28 +395,6 @@ break #define Do_Area(Code, Area, Bound, Obj, FObj) \ Process_Area(Code, &Area, &Bound, &Obj, &FObj) -#if 0 - -#ifdef DEBUG -#define Show_Upgrade(This, New_Type) \ - fprintf(stderr, "Upgrading from 0x%02x|%06x to 0x%x\n", \ - Type_Code(This), Datum(This), New_Type); -#else -#define Show_Upgrade(This, New_Type) -#endif - -#define Upgrade(New_Type) \ -{ Boolean Was_Dangerous = Dangerous(This); \ - Show_Upgrade(This, New_Type); \ - if (Dense_Types) goto Bad_Type; \ - This = Make_New_Pointer(New_Type, Datum(This)); \ - if (Was_Dangerous) Set_Danger_Bit(This); \ - Mem_Base[*Area] = This; \ - break; \ -} - -#endif 0 - Process_Area(Code, Area, Bound, Obj, FObj) int Code; fast long *Area, *Bound; @@ -456,6 +428,12 @@ fast Pointer **FObj; *Area += 1; break; + case_compiled_entry_point: + fprintf(stderr, + "%s: File is not portable: Compiled code.\n", + Program_Name); + exit(1); + case TC_FIXNUM: NIntegers += 1; NBits += fixnum_to_bits; @@ -465,10 +443,6 @@ fast Pointer **FObj; Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj); *Obj += 1; **FObj = This; - if (Dangerous(This)) - { Set_Danger_Bit(Mem_Base[*Area]); - Clear_Danger_Bit(**FObj); - } *FObj += 1; /* Fall through */ case TC_MANIFEST_SPECIAL_NM_VECTOR: @@ -477,15 +451,45 @@ fast Pointer **FObj; *Area += 1; break; - case_compiled_entry_point: - fprintf(stderr, - "%s: File is not portable: Compiled code.\n", - Program_Name); - exit(1); - case_Cell: Do_Pointer(*Area, Do_Cell); + case TC_REFERENCE_TRAP: + { + long kind; + + kind = Datum(This); + + if (upgrade_traps) + { + /* It is an old UNASSIGNED object. */ + if (kind == 0) + { + Mem_Base[*Area] = UNASSIGNED_OBJECT; + *Area += 1; + break; + } + if (kind == 1) + { + Mem_Base[*Area] = UNBOUND_OBJECT; + *Area += 1; + break; + } + fprintf(stderr, + "%s: Bad old unassigned object. 0x%x.\n", + Program_Name, This); + exit(1); + } + if (kind <= TRAP_MAX_IMMEDIATE) + { + /* It is a non pointer. */ + + *Area += 1; + break; + } + } + /* Fall through */ + case TC_WEAK_CONS: case_Pair: Do_Pointer(*Area, Do_Pair); @@ -504,56 +508,18 @@ fast Pointer **FObj; Do_Pointer(*Area, Do_String); case TC_ENVIRONMENT: + if (upgrade_traps) + { + fprintf(stderr, + "%s: Cannot upgrade environments.\n", + Program_Name); + exit(1); + } + /* Fall through */ case TC_FUTURE: case_simple_Vector: Do_Pointer(*Area, Do_Vector); -#if 0 - -/* This should be cleaned up: We can no longer do it like this - since we have reused the types. - */ - - case OLD_TC_BROKEN_HEART: - Upgrade(TC_BROKEN_HEART); - case OLD_TC_SPECIAL_NM_VECTOR: - Upgrade(TC_MANIFEST_SPECIAL_NM_VECTOR); -#if 0 - case OLD_TC_UNASSIGNED: - Upgrade(TC_UNASSIGNED); - case OLD_TC_RETURN_CODE: - Upgrade(TC_RETURN_CODE); -#endif - case OLD_TC_PCOMB0: - Upgrade(TC_PCOMB0); - case OLD_TC_THE_ENVIRONMENT: - Upgrade(TC_THE_ENVIRONMENT); - case OLD_TC_CHARACTER: - Upgrade(TC_CHARACTER); - case OLD_TC_FIXNUM: - Upgrade(TC_FIXNUM); -#if 0 - case OLD_TC_SEQUENCE_3: - Upgrade(TC_SEQUENCE_3); -#endif - case OLD_TC_MANIFEST_NM_VECTOR: - Upgrade(TC_MANIFEST_NM_VECTOR); - case OLD_TC_VECTOR: - Upgrade(TC_VECTOR); -#if 0 - case OLD_TC_ENVIRONMENT: - Upgrade(TC_ENVIRONMENT); -#endif - case OLD_TC_CONTROL_POINT: - Upgrade(TC_CONTROL_POINT); - case OLD_TC_COMBINATION: - Upgrade(TC_COMBINATION); - case OLD_TC_PCOMB3: - Upgrade(TC_PCOMB3); - case OLD_TC_PCOMB2: - Upgrade(TC_PCOMB2); -#endif 0 - default: Bad_Type: fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n", @@ -664,10 +630,7 @@ do_it() if (Machine_Type == FASL_INTERNAL_FORMAT) Shuffle_Bytes = false; - if (Sub_Version < FASL_PADDED_STRINGS) - Padded_Strings = false; - if (Sub_Version < FASL_DENSE_TYPES) - Dense_Types = false; + upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP); /* Constant Space not currently supported */ @@ -679,10 +642,7 @@ do_it() } { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1); -#if 0 - Size += (FLOATING_ALIGNMENT+1)/sizeof(Pointer); -#endif - Allocate_Heap_Space(Size); + Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE); if (Heap == NULL) { fprintf(stderr, "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n", @@ -690,9 +650,8 @@ do_it() exit(1); } } -#if 0 - Align_Float(Heap); -#endif + Heap += HEAP_BUFFER_SPACE; + Initial_Align_Float(Heap); Load_Data(Heap_Count, &Heap[0]); Load_Data(Const_Count, &Heap[Heap_Count]); Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base); diff --git a/v7/src/microcode/bkpt.h b/v7/src/microcode/bkpt.h index 4880fa1b3..89844c17e 100644 --- a/v7/src/microcode/bkpt.h +++ b/v7/src/microcode/bkpt.h @@ -30,10 +30,11 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.21 1987/01/22 14:16:39 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.22 1987/04/03 00:08:07 jinx Exp $ * * This file contains breakpoint utilities. * Disabled when not debugging the interpreter. + * It "shadows" definitions in default.h * */ @@ -48,23 +49,25 @@ typedef struct sp_record *sp_record_list; #define sp_nil ((sp_record_list) NULL) #define debug_maxslots 64 -#define Eval_Ucode_Hook() \ - local_circle[local_slotno++] = Fetch_Expression(); \ - if (local_slotno >= debug_maxslots) local_slotno = 0; \ - if (local_nslots < debug_maxslots) local_nslots++ - -#ifdef Using_Registers -#define Pop_Return_Ucode_Hook() \ -if (SP_List != sp_nil) \ -{ Export_Registers(); \ - Pop_Return_Break_Point(); \ - Import_Registers(); \ +#define Eval_Ucode_Hook() \ +{ \ + local_circle[local_slotno++] = Fetch_Expression(); \ + if (local_slotno >= debug_maxslots) local_slotno = 0; \ + if (local_nslots < debug_maxslots) local_nslots++; \ } -#else -#define Pop_Return_Ucode_Hook() \ -if (SP_List != sp_nil) \ - Pop_Return_Break_Point(); -#endif + +#define Pop_Return_Ucode_Hook() \ +{ \ + if (SP_List != sp_nil) \ + { Export_Registers(); \ + Pop_Return_Break_Point(); \ + Import_Registers(); \ + } \ +} + +/* Not implemented yet */ + +#define Apply_Ucode_Hook() /* For performance metering we note the time spent handling each * primitive. This MIGHT help us figure out where all the time @@ -85,14 +88,13 @@ void Clear_Perfinfo_Data() } #define Metering_Apply_Primitive(Loc, N) \ -{ long Start_Time = Sys_Clock(); \ +{ \ + long Start_Time = Sys_Clock(); \ + \ Loc = Apply_Primitive(N) \ perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \ -} \ -Set_Time_Zone(Zone_Working) + Set_Time_Zone(Zone_Working); \ +} #endif - -/* Not implemented yet */ -#define Apply_Ucode_Hook() #endif /* ifdef ENABLE_DEBUGGING_TOOLS */ diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index d8f0c5d5a..a860d0d0a 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.28 1987/03/09 16:02:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.29 1987/04/03 00:08:22 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -50,7 +50,7 @@ MIT in each case. */ {-heap heap-size} {-stack stack-size} {-constant constant-size} - {-utabmd utab-filename} + {-utabmd utab-filename} or {-utab utab-filename} {other arguments ignored by the core microcode} with filespec either {-band band-name} or {{-}fasl file-name} @@ -422,9 +422,12 @@ Built_In_Primitive(Prim_Microcode_Tables_Filename, Pointer Result; Primitive_0_Args(); - if (((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true)) - != NOT_THERE) && - (position != (Saved_argc - 1))) + if ((((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true)) + != NOT_THERE) && + (position != (Saved_argc - 1))) || + (((position = Parse_Option("-utab", Saved_argc, Saved_argv, true)) + != NOT_THERE) && + (position != (Saved_argc - 1)))) { Prefix = ""; Suffix = Saved_argv[position + 1]; } diff --git a/v7/src/microcode/config.h b/v7/src/microcode/config.h index 02fa181fc..cf01f6b01 100644 --- a/v7/src/microcode/config.h +++ b/v7/src/microcode/config.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.22 1987/02/04 17:50:46 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.23 1987/04/03 00:09:46 jinx Exp $ * * This file contains the configuration information and the information * given on the command line on Unix. @@ -191,6 +191,7 @@ typedef unsigned long Pointer; machine where addresses are specified in bytes. The alignment must be an integral multiple of the length of a long, since it must pad with an explicit Pointer value. + This option is not completely working right now. */ @@ -207,7 +208,7 @@ typedef unsigned long Pointer; #define FASL_HP_SPECTRUM 10 /* These (pdp10 and nu) haven't worked in a while. - * Should be upgraded some day. + * Should be upgraded or flushed some day. */ #ifdef pdp10 @@ -247,8 +248,11 @@ typedef unsigned long Pointer; #define MAX_FLONUM_EXPONENT 127 #define HAS_FLOOR #define HAS_FREXP + /* Not on these, however */ + #ifdef vms + /* VMS C has not void type, thus make it go away */ #define void /* Name conflict in VMS with system variable */ @@ -270,14 +274,17 @@ if (value != 0) exit(value); \ longjmp(Exit_Point, NORMAL_EXIT) #else /* not a vms */ + /* Vax Unix C compiler bug */ + #define double_into_fixnum(what, target) \ { long For_Vaxes_Sake = (long) what; \ target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \ } + #endif /* not vms */ #endif /* vax */ - + #ifdef hp9000s200 /* and s300, pretty indistinguishable */ #define Heap_In_Low_Memory #define UNSIGNED_SHIFT @@ -291,7 +298,7 @@ longjmp(Exit_Point, NORMAL_EXIT) #define MAX_FLONUM_EXPONENT 1023 #define HAS_FLOOR #define HAS_FREXP -#define term_type int /* C compiler bug in GC_Type */ +#define term_type int /* C compiler bug in GC_Type */ #endif #ifdef hp9000s500 @@ -381,7 +388,7 @@ longjmp(Exit_Point, NORMAL_EXIT) #ifdef spectrum /* Heap resides in "Quad 1", and hence memory addresses have a 1 - in the second MSBit. This is taken care of in OBJECT.H, and is + in the second MSBit. This is taken care of in object.h, and is still considered Heap_In_Low_Memory. */ #define Heap_In_Low_Memory @@ -408,11 +415,18 @@ longjmp(Exit_Point, NORMAL_EXIT) #include "Error: config.h: Unknown configuration." #endif +#ifdef noquick +#define quick +#else +#define quick fast +#endif + #if (ULONG_SIZE == 32) #define b32 #endif - + /* Default "segment" sizes */ + #ifndef STACK_SIZE #ifndef USE_STACKLETS #define STACK_SIZE 30 /* Default Kcells for stack */ diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h index db2199709..1ae2303d2 100644 --- a/v7/src/microcode/const.h +++ b/v7/src/microcode/const.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.22 1987/02/04 17:49:56 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.23 1987/04/03 00:10:08 jinx Exp $ * * Named constants used throughout the interpreter * @@ -50,37 +50,18 @@ MIT in each case. */ #define NIL Make_Non_Pointer(TC_NULL, 0) #define TRUTH Make_Non_Pointer(TC_TRUE, 0) -#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNASSIGNED) -#define UNBOUND_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNBOUND) -#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0) #define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0) -#define LOCAL_REF_0 Make_Non_Pointer(LOCAL_REF, 0) #define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0) #define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0) #else /* 32 bit word */ #define NIL 0x00000000 #define TRUTH 0x08000000 -#define UNASSIGNED_OBJECT 0x32000000 -#define UNBOUND_OBJECT 0x32000001 -#define UNCOMPILED_VARIABLE 0x08000000 #define FIXNUM_0 0x1A000000 -#define LOCAL_REF_0 0x00000000 #define BROKEN_HEART_0 0x22000000 #define STRING_0 0x1E000000 #endif /* b32 */ -/* Some names for flag values */ - -#define SET_IT 0 /* Lookup */ -#define CLEAR_IT 1 -#define READ_IT 2 -#define TEST_IT 3 - -#define FOUND_SLOT 1 /* Slot lookup */ -#define NO_SLOT 2 -#define FOUND_UNBOUND 4 - #define NOT_THERE -1 /* Command line parser */ /* Assorted sizes used in various places */ @@ -99,7 +80,13 @@ MIT in each case. */ occurs */ #endif -#define FILE_CHANNELS 15 +/* Some versions of stdio define this. */ +#ifndef _NFILE +#define _NFILE 15 +#endif + +#define FILE_CHANNELS _NFILE + #define MAX_LIST_PRINT 10 #define ILLEGAL_PRIMITIVE -1 @@ -110,14 +97,9 @@ MIT in each case. */ #define LENGTH_MULTIPLIER 5 #define SHIFT_AMOUNT 2 -/* For looking up variable definitions */ - -#define UNCOMPILED_REF TC_TRUE -#define GLOBAL_REF TC_UNINTERNED_SYMBOL -#define FORMAL_REF TC_FIXNUM -#define AUX_REF TC_ENVIRONMENT -#define LOCAL_REF TC_NULL -/* LOCAL_REF must be 0 in order for code in interpret.c to work fast */ +/* Last immediate reference trap. */ + +#define TRAP_MAX_IMMEDIATE 9 /* For headers in pure / constant area */ @@ -160,21 +142,25 @@ MIT in each case. */ /* VMS preprocessor does not like line continuations in conditionals */ #define Are_The_Constants_Incompatible \ -((TC_NULL != 0x00) || (TC_TRUE != 0x08) || (TC_UNASSIGNED != 0x32) || \ - (UNASSIGNED != 0) || (UNBOUND != 1) || (UNCOMPILED_REF != 0x08) || \ +((TC_NULL != 0x00) || (TC_TRUE != 0x08) || \ (TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \ - (TC_CHARACTER_STRING != 0x1E) || (LOCAL_REF != 0x00)) + (TC_CHARACTER_STRING != 0x1E)) /* The values used above are in sdata.h and types.h, check for consistency if the check below fails. */ #if Are_The_Constants_Incompatible -#include "Error: disagreement in const.h" +#include "Error: const.h and types.h disagree" #endif /* These are the only entries in Registers[] needed by the microcode. All other entries are used only by the compiled code interface. */ -#define REGBLOCK_MEMTOP 0 -#define REGBLOCK_STACKGUARD 1 -#define REGBLOCK_MINIMUM_LENGTH 2 +#define REGBLOCK_MEMTOP 0 +#define REGBLOCK_STACKGUARD 1 +#define REGBLOCK_VAL 2 +#define REGBLOCK_ENV 3 +#define REGBLOCK_TEMP 4 +#define REGBLOCK_EXPR 5 +#define REGBLOCK_RETURN 6 +#define REGBLOCK_MINIMUM_LENGTH 7 diff --git a/v7/src/microcode/daemon.c b/v7/src/microcode/daemon.c index a9e3e1cd8..c458f702d 100644 --- a/v7/src/microcode/daemon.c +++ b/v7/src/microcode/daemon.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.22 1987/02/02 15:16:12 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.23 1987/04/03 00:10:26 jinx Exp $ This file contains code for the Garbage Collection daemons. There are currently two daemons, one for closing files which @@ -59,16 +59,19 @@ extern Boolean OS_file_close(); Built_In_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES") { fast Pointer *Smash, Cell, Weak_Cell; + long channel_number; Primitive_1_Arg(); for (Smash = Nth_Vector_Loc(Arg1, CONS_CDR), Cell = *Smash; Cell != NIL; Cell = *Smash) - { Weak_Cell = Fast_Vector_Ref(Cell, CONS_CAR); + { + Weak_Cell = Fast_Vector_Ref(Cell, CONS_CAR); if (Fast_Vector_Ref(Weak_Cell, CONS_CAR) == NIL) - { (void) - OS_file_close - (Channels[Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR))]); + { + channel_number = Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR)); + (void) OS_file_close (Channels[channel_number]); + Channels[channel_number] = NULL; *Smash = Fast_Vector_Ref(Cell, CONS_CDR); } else diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index f5858b089..93bf86e84 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.c @@ -30,13 +30,15 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.22 1987/03/11 07:37:06 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.23 1987/04/03 00:10:44 jinx Exp $ * * Utilities to help with debugging */ #include "scheme.h" #include "primitive.h" +#include "trap.h" +#include "lookup.h" void Show_Pure() { Pointer *Obj_Address; @@ -94,37 +96,56 @@ void Show_Pure() } } -void Show_Env(The_Env) -Pointer The_Env; -{ Pointer *Name_Ptr, *Value_Ptr, Aux_Ptr, Aux_Slot_Ptr; - long Count, i; - Value_Ptr = Nth_Vector_Loc(The_Env, HEAP_ENV_FUNCTION); - if ((Type_Code(*Value_Ptr) == TC_PROCEDURE) || - (Type_Code(*Value_Ptr) == TC_EXTENDED_PROCEDURE)) - { Name_Ptr = Nth_Vector_Loc(*Value_Ptr, PROCEDURE_LAMBDA_EXPR); - Name_Ptr = Nth_Vector_Loc(*Name_Ptr, LAMBDA_FORMALS); - Count = Vector_Length(*Name_Ptr); - Name_Ptr = Nth_Vector_Loc(*Name_Ptr, 1); - for (i=0; i < Count; i++) - { Print_Expression(*Name_Ptr++, "Name "); - Print_Expression(*Value_Ptr++, " Value "); +void +Show_Env(The_Env) + Pointer The_Env; +{ + Pointer *name_ptr, procedure, *value_ptr, extension; + long count, i; + + procedure = Vector_Ref(The_Env, ENVIRONMENT_FUNCTION); + value_ptr = Nth_Vector_Loc(The_Env, ENVIRONMENT_FIRST_ARG); + + if (Type_Code(procedure) == AUX_LIST_TYPE) + { + extension = procedure; + procedure = Fast_Vector_Ref(extension, ENVIRONMENT_EXTENSION_PROCEDURE); + } + else + extension = NIL; + + if ((Type_Code(procedure) != TC_PROCEDURE) && + (Type_Code(procedure) != TC_EXTENDED_PROCEDURE)) + { + printf("Not created by a procedure"); + return; + } + name_ptr = Nth_Vector_Loc(procedure, PROCEDURE_LAMBDA_EXPR); + name_ptr = Nth_Vector_Loc(*name_ptr, LAMBDA_FORMALS); + count = Vector_Length(*name_ptr) - 1; + + name_ptr = Nth_Vector_Loc(*name_ptr, 2); + for (i = 0; i < count; i++) + { + Print_Expression(*name_ptr++, "Name "); + Print_Expression(*value_ptr++, " Value "); + printf("\n"); + } + if (extension != NIL) + { + printf("Auxilliary Variables\n"); + count = Get_Integer(Vector_Ref(extension, AUX_LIST_COUNT)); + for (i = 0, name_ptr = Nth_Vector_Loc(extension, AUX_LIST_FIRST); + i < count; + i++, name_ptr++) + { + Print_Expression(Vector_Ref(*name_ptr, CONS_CAR), + "Name "); + Print_Expression(Vector_Ref(*name_ptr, CONS_CAR), + " Value "); printf("\n"); } - Aux_Ptr = Vector_Ref(The_Env, HEAP_ENV_AUX_SLOT); - if (Aux_Ptr != NIL) - { printf("Auxilliary Variables\n"); - while (Aux_Ptr != NIL) - { Aux_Slot_Ptr = Vector_Ref(Aux_Ptr, CONS_CAR); - Print_Expression(Vector_Ref(Aux_Slot_Ptr, CONS_CAR), - "Name "); - Print_Expression(Vector_Ref(Aux_Slot_Ptr, CONS_CAR), - " Value "); - Aux_Ptr = Vector_Ref(Aux_Ptr, CONS_CDR); - printf("\n"); - } - } } - else printf("Not created by a procedure"); } /* For debugging, given a String, return either a "not interned" @@ -216,8 +237,7 @@ Boolean Detailed; Boolean Return_After_Print; Temp_Address = Get_Integer(Expr); Return_After_Print = false; - if (Type_Code(Expr) > MAX_SAFE_TYPE) printf("{Dangerous}"); - switch(Safe_Type_Code(Expr)) + switch(Type_Code(Expr)) { case TC_ACCESS: printf("[ACCESS ("); Expr = Vector_Ref(Expr, ACCESS_NAME); @@ -356,12 +376,18 @@ SPrint: case TC_DELAYED: printf("[DELAYED"); break; case TC_DISJUNCTION: printf("[DISJUNCTION"); break; case TC_ENVIRONMENT: + { + Pointer procedure; + printf("[ENVIRONMENT 0x%x]", Temp_Address); printf(" (from "); - Do_Printing(Vector_Ref(Expr, HEAP_ENV_FUNCTION), false); + procedure = Vector_Ref(Expr, ENVIRONMENT_FUNCTION); + if (Type_Code(procedure) == TC_QUAD) + procedure = Vector_Ref(procedure, ENVIRONMENT_EXTENSION_PROCEDURE); + Do_Printing(procedure, false); printf(")"); return; - case TC_EXTENDED_FIXNUM: printf("[EXTENDED_FIXNUM"); break; + } case TC_EXTENDED_LAMBDA: if (Detailed) printf("[EXTENDED_LAMBDA ("); Do_Printing( @@ -381,7 +407,7 @@ SPrint: /* Do_Printing, continued */ case TC_FUTURE: printf("[FUTURE"); break; - case TC_HUNK3: printf("[HUNK3"); break; + case TC_HUNK3: printf("[TRIPLE"); break; case TC_IN_PACKAGE: printf("[IN_PACKAGE"); break; case TC_LAMBDA: if (Detailed) printf("[LAMBDA ("); @@ -414,6 +440,17 @@ SPrint: /* Do_Printing, continued */ + case TC_QUAD: printf("[QUAD"); break; + case TC_REFERENCE_TRAP: + { + printf("[REFERENCE-TRAP"); + if (Datum(Expr) <= TRAP_MAX_IMMEDIATE) + break; + Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag"); + Print_Expression(Vector_Ref(Expr, TRAP_EXTRA), " extra"); + printf("]"); + return; + } case TC_RETURN_CODE: printf("[RETURN_CODE "); Print_Return_Name(Expr); @@ -423,15 +460,6 @@ SPrint: case TC_SEQUENCE_2: printf("[SEQUENCE_2"); break; case TC_SEQUENCE_3: printf("[SEQUENCE_3"); break; case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break; - - case TC_TRAP: - printf("[TRAP "); - Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag"); - Print_Expression(Vector_Ref(Expr, TRAP_DEFAULT), " default"); - Print_Expression(Vector_Ref(Expr, TRAP_FROB), " frob"); - printf("]"); - return; - case TC_TRUE: if (Temp_Address == 0) { printf("#!true"); @@ -439,16 +467,6 @@ SPrint: } printf("[TRUE"); break; - case TC_UNASSIGNED: - if (Temp_Address == UNBOUND) - { printf("#!UNBOUND"); - return; - } - else if (Temp_Address == UNASSIGNED) - { printf("#!UNASSIGNED"); - return; - } - else printf("[UNASSIGNED"); break; case TC_VECTOR: printf("[VECTOR"); break; case TC_VECTOR_16B: printf("[VECTOR_16B"); break; case TC_VECTOR_1B: printf("[VECTOR_1B"); break; @@ -496,7 +514,7 @@ void Back_Trace() } else { Print_Expression(Temp, " ..."); - if (Safe_Type_Code(Temp) == TC_MANIFEST_NM_VECTOR) + if (Type_Code(Temp) == TC_MANIFEST_NM_VECTOR) { Stack_Pointer = Simulate_Popping(Get_Integer(Temp)); printf(" (skipping)"); } diff --git a/v7/src/microcode/dump.c b/v7/src/microcode/dump.c index ca091ea12..569de1df9 100644 --- a/v7/src/microcode/dump.c +++ b/v7/src/microcode/dump.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.21 1987/01/22 14:23:24 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.22 1987/04/03 00:11:11 jinx Exp $ * * This file contains common code for dumping internal format binary files. */ @@ -47,12 +47,12 @@ long Heap_Count, Constant_Count; #ifdef DEBUG #ifndef Heap_In_Low_Memory - printf("\nMemory_Base = 0x%x\n", Memory_Base); + fprintf(stderr, "\nMemory_Base = 0x%x\n", Memory_Base); #endif - printf("\nHeap_Relocation=0x%x, dumped as 0x%x\n", - Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation)); - printf("\nDumped object=0x%x, dumped as 0x%x\n", - Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object)); + fprintf(stderr, "\nHeap_Relocation=0x%x, dumped as 0x%x\n", + Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation)); + fprintf(stderr, "\nDumped object=0x%x, dumped as 0x%x\n", + Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object)); #endif Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER; Buffer[FASL_Offset_Heap_Count] = diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h index b39c48442..611b7bacd 100644 --- a/v7/src/microcode/errors.h +++ b/v7/src/microcode/errors.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.23 1987/02/07 15:28:03 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.24 1987/04/03 00:11:24 jinx Rel $ * * Error and termination code declarations. This must correspond * to UTABMD.SCM @@ -97,8 +97,9 @@ MIT in each case. */ #define ERR_INAPPLICABLE_CONTINUATION 0x30 #define ERR_COMPILED_CODE_ERROR 0x31 #define ERR_FLOATING_OVERFLOW 0x32 +#define ERR_UNIMPLEMENTED_PRIMITIVE 0x33 -#define MAX_ERROR 0x32 +#define MAX_ERROR 0x33 /* Termination codes: the interpreter halts on these */ diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h index 4305a74b2..07789d617 100644 --- a/v7/src/microcode/extern.h +++ b/v7/src/microcode/extern.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.22 1987/02/08 23:08:27 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.23 1987/04/03 00:11:43 jinx Exp $ * * External declarations. * @@ -67,12 +67,12 @@ extern int debug_slotno, debug_nslots, local_slotno, local_nslots, #define Fluids_Debug false #endif +/* The register block */ + +extern Pointer Registers[]; + extern Pointer - Env, /* The environment */ - Ext_Val, /* The value returned from primitives or apply */ - Return, /* The return address code */ - Ext_Expression, /* Expression to EVALuate */ - *History, /* History register */ + *Ext_History, /* History register */ *Free, /* Next free word in heap */ *MemTop, /* Top of heap space available */ *Ext_Stack_Pointer, /* Next available slot in control stack */ @@ -81,10 +81,10 @@ extern Pointer *Free_Stacklets, /* Free list of stacklets */ *Constant_Space, /* Bottom of constant+pure space */ *Free_Constant, /* Next free cell in constant+pure area */ - *Unused_Heap, /* Bottom of unused heap for GC */ - *Unused_Heap_Top, /* Top of unused heap for GC */ *Heap_Top, /* Top of current heap space */ *Heap_Bottom, /* Bottom of current heap space */ + *Unused_Heap_Top, /* Top of unused heap for GC */ + *Unused_Heap, /* Bottom of unused heap for GC */ *Local_Heap_Base, /* Per-processor CONSing area */ *Heap, /* Bottom of all heap space */ Current_State_Point, /* Dynamic state point */ @@ -139,18 +139,6 @@ extern char **Saved_argv; extern char *OS_Name, *OS_Variant; extern long Heap_Size, Constant_Size, Stack_Size; extern Pointer *Highest_Allocated_Address; - -/* External primitive data */ - -typedef struct ext_desc /* User supplied primitive data */ -{ Pointer (*proc)(); /* Location of actual procedure */ - int arity; /* Number of arguments */ - char *name; /* Name of primitive */ -} External_Descriptor; - -extern External_Descriptor Ext_Prim_Desc[]; -extern long MAX_EXTERNAL_PRIMITIVE, Get_Ext_Number(); -extern Pointer Undefined_Externals, Make_Prim_Exts(); /* String utilities */ @@ -207,10 +195,6 @@ extern Pointer (*(Primitive_Table[]))(), *Make_Dummy_History(), extern void Back_Trace(), Handle_Debug_Flags(), Find_Symbol(), Show_Env(), Show_Pure(), Print_Return(), Print_Expression(), Print_Primitive(); - -/* Compiler Stuff */ - -extern Pointer Registers[]; /* Conditional utilities */ diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index e9a5a6232..156439b3d 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.22 1987/02/03 15:56:43 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.23 1987/04/03 00:12:00 jinx Exp $ This file contains code for fasdump and dump-band. */ @@ -39,22 +39,24 @@ MIT in each case. */ #include "primitive.h" #define In_Fasdump #include "gccode.h" +#include "trap.h" +#include "lookup.h" #include "dump.c" /* Some statics used freely in this file */ Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free; /* FASDUMP: - - Hair squared! ... in order to dump an object it must be traced - (as in a garbage collection), but with some significant differences. - First, the copy must have (a) the global value cell of symbols set - to UNBOUND; (b) the danger bits cleared in symbols; and (c) - variables uncompiled. Second, and worse, all the broken hearts - created during the process must be restored to their original - values. This last is done by growing the copy of the object in the - bottom of spare heap, keeping track of the locations of broken - hearts and original contents at the top of the spare heap. + + Hair squared! ... in order to dump an object it must be traced (as + in a garbage collection), but with some significant differences. + First, the copy must have the global value cell of symbols set to + UNBOUND and variables uncompiled. Second, and worse, all the + broken hearts created during the process must be restored to their + original values. This last is done by growing the copy of the + object in the bottom of spare heap, keeping track of the locations + of broken hearts and original contents at the top of the spare + heap. FASDUMP is called with three arguments: Argument 1: Base of spare heap @@ -68,11 +70,11 @@ Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free; standard Pure/Constant block. */ -/* Copy of GCLoop, except (a) copies out of constant space into the +/* + Copy of GCLoop, except (a) copies out of constant space into the object to be dumped; (b) changes symbols and variables as - described; (c) clears danger bits as described; (d) keeps track of - broken hearts and their original contents (e) To_Pointer is now - NewFree. + described; (c) keeps track of broken hearts and their original + contents (e) To_Pointer is now NewFree. */ #define Dump_Pointer(Code) \ @@ -98,21 +100,9 @@ int Dump_Mode; To = NewFree; Fixes = Fixup; - if (Dump_Debug) printf( "Starting scan at 0x%08x\n", Scan); - for ( ; Scan != To; Scan++) { Temp = *Scan; - if (Dump_Debug) - { if (Temp != NIL) - fprintf(stderr, "0x%08x: %02x|%06x ... ", - Scan, Type_Code(Temp), Get_Integer(Temp)); - } - -/* DumpLoop continues on the next page */ - -/* DumpLoop, continued */ - Switch_by_GC_Type(Temp) { case TC_BROKEN_HEART: if (Datum(Temp) != 0) @@ -124,15 +114,12 @@ int Dump_Mode; case TC_MANIFEST_NM_VECTOR: case TC_MANIFEST_SPECIAL_NM_VECTOR: Scan += Get_Integer(Temp); - if (Dump_Debug) - fprintf(stderr, "skipping %d cells.", Get_Integer(Temp)); break; /* This should really be case_Fasdump_Non_Pointer, and PRIMITIVE_EXTERNAL should be handled specially */ case_Non_Pointer: - if (Dump_Debug) fprintf(stderr, "not a pointer."); break; case_compiled_entry_point: @@ -142,6 +129,13 @@ int Dump_Mode; case_Cell: Setup_Pointer_for_Dump(Transport_Cell()); + case TC_REFERENCE_TRAP: + if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) + { + /* It is a non pointer. */ + break; + } + /* Fall through. */ case TC_WEAK_CONS: case_Fasdump_Pair: Setup_Pointer_for_Dump(Transport_Pair()); @@ -162,10 +156,8 @@ int Dump_Mode; /* DumpLoop, continued */ -#ifdef QUADRUPLE case_Quadruple: Setup_Pointer_for_Dump(Transport_Quadruple()); -#endif #ifdef FLOATING_ALIGNMENT case TC_BIG_FLONUM: @@ -187,7 +179,6 @@ int Dump_Mode; Invalid_Type_Code(); } /* Switch_by_GC_Type */ - if (Dump_Debug) fprintf(stderr, "\n"); } /* For loop */ NewFree = To; Fixup = Fixes; diff --git a/v7/src/microcode/fasl.h b/v7/src/microcode/fasl.h index 3da723b65..a65a9837d 100644 --- a/v7/src/microcode/fasl.h +++ b/v7/src/microcode/fasl.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.22 1987/03/12 14:51:36 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $ Contains information relating to the format of FASL files. Some information is contained in CONFIG.H. @@ -39,9 +39,6 @@ MIT in each case. */ /* FASL Version */ #define FASL_FILE_MARKER 0XFAFAFAFA -#define FASL_FORMAT_ADDED_STACK 1 -#define FASL_FORMAT_VERSION 1 -#define FASL_SUBVERSION 5 /* The FASL file has a header which begins as follows: */ @@ -70,44 +67,27 @@ MIT in each case. */ #define The_Version(P) Type_Code(P) #define Make_Version(V, S, M) \ Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M))) - + #define WRITE_FLAG "w" #define OPEN_FLAG "r" - -/* "Memorable" FASL sub-versions -- ones where we modified something + +/* "Memorable" FASL versions -- ones where we modified something and want to remain backwards compatible. */ +/* Versions. */ + +#define FASL_FORMAT_ADDED_STACK 1 + +/* Subversions of highest numbered version. */ + #define FASL_LONG_HEADER 3 #define FASL_DENSE_TYPES 4 #define FASL_PADDED_STRINGS 5 -#define FASL_OLDEST_SUPPORTED 5 +#define FASL_REFERENCE_TRAP 6 -#if 0 -/* Old Type Codes -- used for conversion purposes - This is no longer possible, because some were re-used - without changing the fasl file version. -*/ +/* Current parameters. */ -#define OLD_TC_CHARACTER 0x40 -#define OLD_TC_PCOMB2 0x44 -#define OLD_TC_VECTOR 0x46 -#define OLD_TC_RETURN_CODE 0x48 -#define OLD_TC_COMPILED_PROCEDURE 0x49 -#define OLD_TC_ENVIRONMENT 0x4E -#define OLD_TC_FIXNUM 0x50 -#define OLD_TC_CONTROL_POINT 0x56 -#define OLD_TC_BROKEN_HEART 0x58 -#define OLD_TC_COMBINATION 0x5E -#define OLD_TC_MANIFEST_NM_VECTOR 0x60 -#define OLD_TC_PCOMB3 0x66 -#define OLD_TC_SPECIAL_NM_VECTOR 0x68 -#define OLD_TC_THE_ENVIRONMENT 0x70 -#define OLD_TC_VECTOR_1B 0x76 -#define OLD_TC_BIT_STRING 0x76 -#define OLD_TC_PCOMB0 0x78 -#define OLD_TC_VECTOR_16B 0x7E -#define OLD_TC_UNASSIGNED 0x38 -#define OLD_TC_SEQUENCE_3 0x3C - -#endif 0 +#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK +#define FASL_SUBVERSION FASL_REFERENCE_TRAP +#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 7ab38464c..7ea9b13a1 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.22 1987/03/12 17:45:09 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.23 1987/04/03 00:12:33 jinx Exp $ The "fast loader" which reads in and relocates binary files and then interns symbols. It is called with one argument: the (character @@ -41,6 +41,7 @@ MIT in each case. */ #include "scheme.h" #include "primitive.h" #include "gccode.h" +#include "trap.h" #define CCheck_or_Reloc_Debug Or2(Consistency_Check, Reloc_Debug) #define Reloc_or_Load_Debug Or2(Reloc_Debug, File_Load_Debug) @@ -246,7 +247,7 @@ Pointer Name; "\nLoad_File: FASL File Version %4d Subversion %4d Machine Type %4d.\n", Version, Sub_Version , Machine_Type); fprintf(stderr, - " Expected: Version %4d Subversion %4d Machine Type %4d.\n", + " Expected: Version %4d Subversion %4d Machine Type %4d.\n", FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT); CANNOT_LOAD: fclose(File_Handle); @@ -377,8 +378,15 @@ fast Pointer *Next_Pointer, *Stop_At; /* THEN FALL THROUGH */ #endif - /* These work automagically */ + case TC_REFERENCE_TRAP: + if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) + { + Next_Pointer += 1; + break; + } + /* It is a pointer, fall through. */ case_compiled_entry_point: + /* Compiled entry points work automagically. */ default: { fast long Next = Datum(Temp); *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next)); @@ -391,10 +399,7 @@ Intern_Block(Next_Pointer, Stop_At) Pointer *Next_Pointer, *Stop_At; { if (Reloc_Debug) printf("Interning a block.\n"); while (Next_Pointer <= Stop_At) /* BBN has < for <= */ - { if (Reloc_Debug && Dangerous(*Next_Pointer)) - printf("\nDangerous object at 0x%x: 0x%x", - Next_Pointer, *Next_Pointer); - switch (Safe_Type_Code(*Next_Pointer)) + { switch (Type_Code(*Next_Pointer)) { case TC_MANIFEST_NM_VECTOR: Next_Pointer += Get_Integer(*Next_Pointer)+1; break; @@ -454,8 +459,8 @@ Boolean Normal_FASLoad; Update_Ext_Prims(Next_Pointer, Stop_At) fast Pointer *Next_Pointer, *Stop_At; -{ for (;Next_Pointer < Stop_At; Next_Pointer++) - { switch (Safe_Type_Code(*Next_Pointer)) +{ for ( ; Next_Pointer < Stop_At; Next_Pointer++) + { switch (Type_Code(*Next_Pointer)) { case TC_MANIFEST_NM_VECTOR: Next_Pointer += Get_Integer(*Next_Pointer); break; diff --git a/v7/src/microcode/findprim.c b/v7/src/microcode/findprim.c index e629ce013..2e420d013 100644 --- a/v7/src/microcode/findprim.c +++ b/v7/src/microcode/findprim.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.21 1987/01/22 14:11:56 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.22 1987/04/03 00:05:46 jinx Exp $ * * Preprocessor to find and declare user defined primitives. * @@ -298,7 +298,7 @@ boolean check; fprintf(output, "/%c User defined primitive declarations %c/\n\n", '*', '*'); - fprintf(output, "#include \"scheme.h\"\n\n"); + fprintf(output, "#include \"usrdef.h\"\n\n"); if (max < 0) { diff --git a/v7/src/microcode/fixobj.h b/v7/src/microcode/fixobj.h index a7b7f889d..ba8933919 100644 --- a/v7/src/microcode/fixobj.h +++ b/v7/src/microcode/fixobj.h @@ -30,13 +30,13 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.23 1987/03/09 14:44:49 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $ * * Declarations of user offsets into the Fixed Objects Vector. * This should correspond to the file UTABMD.SCM */ -#define Non_Object 0x00 /* Value for UNBOUND variables */ +#define Non_Object 0x00 /* Used for unassigned variables */ #define System_Interrupt_Vector 0x01 /* Handlers for interrups */ #define System_Error_Vector 0x02 /* Handlers for errors */ #define OBArray 0x03 /* Array for interning symbols */ diff --git a/v7/src/microcode/gc.h b/v7/src/microcode/gc.h index 70d83e739..abdd9ad5e 100644 --- a/v7/src/microcode/gc.h +++ b/v7/src/microcode/gc.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.21 1987/01/22 14:26:12 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.22 1987/04/03 00:13:13 jinx Rel $ * * Garbage collection related macros of sufficient utility to be * included in all compilations. @@ -98,5 +98,5 @@ MIT in each case. */ #define Set_Stack_Guard(Addr) Stack_Guard = Addr #define New_Compiler_MemTop() \ - Registers[REGBLOCK_MEMTOP] = \ + Regs[REGBLOCK_MEMTOP] = \ ((IntCode & IntEnb)==0) ? ((Pointer) MemTop) : ((Pointer) -1) diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index 61259532b..07f17069e 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.21 1987/01/22 14:26:19 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.22 1987/04/03 00:13:28 jinx Exp $ * * This file contains the macros for use in code which does GC-like * loops over memory. It is only included in a few files, unlike @@ -38,10 +38,6 @@ MIT in each case. */ * */ -static Pointer *Low_Watch = ((Pointer *) NULL); -static Pointer *High_Watch = ((Pointer *) NULL); -static Boolean In_Range = false; - /* A SWITCH on GC types, duplicates information in GC_Type_Map[], but exists for efficiency reasons. Macros must be used by convention: first Switch_by_GC_Type, then each of the case_ macros (in any order). The @@ -49,33 +45,17 @@ static Boolean In_Range = false; */ #define Switch_by_GC_Type(P) \ - switch (Safe_Type_Code(P)) + switch(Safe_Type_Code(P)) #define case_simple_Non_Pointer \ - case_simple_Non_Pointer_poppers \ case TC_NULL: \ case TC_TRUE: \ - case TC_UNASSIGNED: \ case TC_THE_ENVIRONMENT: \ - case TC_EXTENDED_FIXNUM: \ case TC_RETURN_CODE: \ case TC_PRIMITIVE: \ case TC_PCOMB0: \ case TC_STACK_ENVIRONMENT -#if defined(MC68020) - -#define case_simple_Non_Pointer_poppers \ - case TC_PEA_INSTRUCTION: \ - case TC_JMP_INSTRUCTION: \ - case TC_DBF_INSTRUCTION: - -#else - -#define case_simple_Non_Pointer_poppers - -#endif - #define case_Fasdump_Non_Pointer \ case TC_FIXNUM: \ case TC_CHARACTER: \ @@ -89,6 +69,7 @@ static Boolean In_Range = false; TC_BROKEN_HEART TC_MANIFEST_NM_VECTOR TC_MANIFEST_SPECIAL_NM_VECTOR + TC_REFERENCE_TRAP */ #define case_compiled_entry_point \ @@ -99,11 +80,7 @@ static Boolean In_Range = false; case TC_CELL /* No missing Cell types */ - -/* Switch_by_GC_Type cases continue on the next page */ -/* Switch_by_GC_Type cases continued */ - #define case_Fasdump_Pair \ case TC_LIST: \ case TC_SCODE_QUOTE: \ @@ -141,22 +118,16 @@ static Boolean In_Range = false; case TC_HUNK3: \ case TC_CONDITIONAL: \ case TC_SEQUENCE_3: \ - case TC_PCOMB2: \ - case TC_TRAP + case TC_PCOMB2 -/* Missing Triple types (must be treated specially): +/* Missing triple types (must be treated specially): TC_VARIABLE - */ - -/* Switch_by_GC_Type cases continue on the next page */ +*/ -/* Switch_by_GC_Type cases continued */ - -/* There are currently no Quad types. - Type Code -1 should be ok for now. -SMC */ - #define case_Quadruple \ - case -1 + case TC_QUAD + +/* No missing quad types. */ #define case_simple_Vector \ case TC_NON_MARKED_VECTOR: \ @@ -181,51 +152,31 @@ static Boolean In_Range = false; TC_BIG_FLONUM */ +/* Macros for the garbage collector and related programs. */ + #define NORMAL_GC 0 #define PURE_COPY 1 #define CONSTANT_COPY 2 /* Pointer setup for the GC Type handlers. */ +/* Check whether it has been relocated. */ + #define Normal_BH(In_GC, then_what) \ -/* Has it already been relocated? */ \ if (Type_Code(*Old) == TC_BROKEN_HEART) \ { *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \ - if And2(In_GC, GC_Debug) \ - { if ((Get_Pointer(*Old) >= Low_Watch) && \ - (Get_Pointer(*Old) <= High_Watch)) \ - { fprintf(stderr, "0x%x: %x|%x ... From 0x%x", \ - Scan, Type_Code(Temp), Get_Integer(Temp), Old); \ - fprintf(stderr, ", To (BH) 0x%x\n", Datum(*Old)); \ - } \ - else if And2(In_GC, In_Range) \ - fprintf(stderr, ", To (BH) 0x%x", Datum(*Old)); \ - } \ then_what; \ } - + #define Setup_Internal(In_GC, Extra_Code, BH_Code) \ if And2(In_GC, Consistency_Check) \ if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \ { fprintf(stderr, "Out of range pointer: %x.\n", Temp); \ Microcode_Termination(TERM_EXIT); \ } \ - \ -/* Does it need relocation? */ \ - \ if (Old >= Low_Constant) \ -{ if And3(In_GC, GC_Debug, In_Range) \ - fprintf(stderr, " (constant)"); \ continue; \ -} \ - \ -if And3(In_GC, GC_Debug, In_Range) \ - fprintf(stderr, "From 0x%x", Old); \ - \ BH_Code; \ -/* It must be transported to New Space */ \ -if And3(In_GC, GC_Debug, In_Range) \ - fprintf(stderr, ", To 0x%x", To); \ New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \ Extra_Code; \ continue @@ -320,33 +271,6 @@ if (!(Future_Spliceable(Temp))) \ *Scan = Future_Value(Temp); \ Scan -= 1 -/* This is handled specially so the aux variable compilation - mechanism will not hang onto "garbage" environments. - */ - -#define Transport_Variable() \ -{ Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; \ - if ((Type_Code(Compiled_Type) == AUX_REF) && \ - (!Is_Constant(Get_Pointer(Compiled_Type))) && \ - (Type_Code(Vector_Ref(Compiled_Type, 0)) != TC_BROKEN_HEART)) \ - { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; \ - Old[VARIABLE_OFFSET] = NIL; \ - } \ -} \ -Transport_Triple() - -#define Purify_Transport_Variable() \ -{ Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; \ - if ((Type_Code(Compiled_Type)==AUX_REF) && \ - (GC_Mode==PURE_COPY) && \ - ((!Is_Constant(Get_Pointer(Compiled_Type))) || \ - (!Is_Constant(Get_Pointer(Old[VARIABLE_OFFSET]))))) \ - { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; \ - Old[VARIABLE_OFFSET] = NIL; \ - } \ -} \ -Transport_Triple() - /* Weak Pointer code. The idea here is to support a post-GC pass which removes any objects in the CAR of a WEAK_CONS cell which is no longer referenced by other objects in the system. @@ -399,7 +323,7 @@ continue /* Undefine Symbols */ #define Fasdump_Symbol(global_value) \ -*To++ = (*Old & ~DANGER_BIT); \ +*To++ = *Old; \ *To++ = global_value; \ Pointer_End() diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c index 626c4dfaa..0c66a1525 100644 --- a/v7/src/microcode/gcloop.c +++ b/v7/src/microcode/gcloop.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.23 1987/02/08 23:09:10 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.24 1987/04/03 00:13:50 jinx Rel $ * * This file contains the code for the most primitive part * of garbage collection. @@ -50,6 +50,12 @@ Code #define Setup_Pointer_for_GC(Extra_Code) \ GC_Pointer(Setup_Pointer(true, Extra_Code)) + +#ifdef ENABLE_DEBUGGING_TOOLS +static Pointer *gc_scan_trap = NULL; +static Pointer *gc_free_trap = NULL; +static Pointer gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE); +#endif Pointer *GCLoop(Scan, To_Pointer) @@ -59,28 +65,15 @@ Pointer **To_Pointer; To = *To_Pointer; Low_Constant = Constant_Space; - if (GC_Debug) - { fprintf(stderr, "Starting scan at 0x%08x\n", Scan); - if (Low_Watch == ((Pointer *) NULL)) - { fprintf(stderr, "Enter low watch range and high watch range: "); - scanf("%x %x", &Low_Watch, &High_Watch); - } - } - for ( ; Scan != To; Scan++) { Temp = *Scan; - if (GC_Debug) - { In_Range = (((Scan >= Low_Watch) && (Scan <= High_Watch)) || - ((Free >= Low_Watch) && (Free <= High_Watch))); - if (In_Range) - fprintf(stderr, "0x%08x: %02x|%06x ... ", - Scan, Type_Code(Temp), Get_Integer(Temp)); +#ifdef ENABLE_DEBUGGING_TOOLS + if ((Temp == gc_trap) || (Scan == gc_scan_trap) || (To == gc_free_trap)) + { + fprintf(stderr, "\nGCLoop: trap.\n"); } - -/* GCLoop continues on the next page */ - -/* GCLoop, continued */ +#endif Switch_by_GC_Type(Temp) { case TC_BROKEN_HEART: @@ -94,12 +87,9 @@ Pointer **To_Pointer; case TC_MANIFEST_NM_VECTOR: case TC_MANIFEST_SPECIAL_NM_VECTOR: Scan += Get_Integer(Temp); - if (GC_Debug && In_Range) - fprintf(stderr, "skipping %d cells.", Get_Integer(Temp)); break; case_Non_Pointer: - if (GC_Debug && In_Range) fprintf(stderr, "not a pointer."); break; case_compiled_entry_point: @@ -110,23 +100,26 @@ Pointer **To_Pointer; case_Cell: Setup_Pointer_for_GC(Transport_Cell()); + case TC_REFERENCE_TRAP: + if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) + { + /* It is a non pointer. */ + break; + } + /* It is a pair, fall through. */ case_Pair: Setup_Pointer_for_GC(Transport_Pair()); + case TC_VARIABLE: case_Triple: Setup_Pointer_for_GC(Transport_Triple()); - case TC_VARIABLE: - Setup_Pointer_for_GC(Transport_Variable()); - /* GCLoop continues on the next page */ /* GCLoop, continued */ -#ifdef QUADRUPLE case_Quadruple: Setup_Pointer_for_GC(Transport_Quadruple()); -#endif #ifdef FLOATING_ALIGNMENT case TC_BIG_FLONUM: @@ -151,7 +144,6 @@ Pointer **To_Pointer; Invalid_Type_Code(); } /* Switch_by_GC_Type */ - if (GC_Debug && In_Range) fprintf(stderr, "\n"); } /* For loop */ *To_Pointer = To; return To; diff --git a/v7/src/microcode/gctype.c b/v7/src/microcode/gctype.c index 59e258449..5f3904700 100644 --- a/v7/src/microcode/gctype.c +++ b/v7/src/microcode/gctype.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.21 1987/01/22 14:26:35 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $ * * This file contains the table which maps between Types and * GC Types. @@ -74,7 +74,7 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Pair, /* TC_INTERNED_SYMBOL */ GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */ GC_Pair, /* TC_ACCESS */ - GC_Non_Pointer, /* TC_EXTENDED_FIXNUM */ + GC_Undefined, /* 0x20 */ GC_Pair, /* TC_DEFINITION */ GC_Special, /* TC_BROKEN_HEART */ GC_Pair, /* TC_ASSIGNMENT */ @@ -97,13 +97,13 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */ GC_Non_Pointer, /* TC_PCOMB0 */ GC_Vector, /* TC_VECTOR_16B */ - GC_Non_Pointer, /* TC_UNASSIGNED */ + GC_Special, /* TC_REFERENCE_TRAP */ GC_Triple, /* TC_SEQUENCE_3 */ GC_Triple, /* TC_CONDITIONAL */ GC_Pair, /* TC_DISJUNCTION */ GC_Cell, /* TC_CELL */ GC_Pair, /* TC_WEAK_CONS */ - GC_Triple, /* TC_TRAP */ + GC_Quadruple, /* TC_QUAD */ GC_Compiled, /* TC_RETURN_ADDRESS */ GC_Pair, /* TC_COMPILER_LINK */ GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */ @@ -119,28 +119,16 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Undefined, /* 0x45 */ GC_Undefined, /* 0x46 */ GC_Undefined, /* 0x47 */ -#if defined(MC68020) - GC_Non_Pointer, /* TC_PEA_INSTRUCTION */ -#else GC_Undefined, /* 0x48 */ -#endif GC_Undefined, /* 0x49 */ GC_Undefined, /* 0x4A */ GC_Undefined, /* 0x4B */ GC_Undefined, /* 0x4C */ GC_Undefined, /* 0x4D */ -#if defined(MC68020) - GC_Non_Pointer, /* TC_JMP_INSTRUCTION */ -#else GC_Undefined, /* 0x4E */ -#endif GC_Undefined, /* 0x4F */ GC_Undefined, /* 0x50 */ -#if defined(MC68020) - GC_Non_Pointer, /* TC_DBF_INSTRUCTION */ -#else GC_Undefined, /* 0x51 */ -#endif GC_Undefined, /* 0x52 */ GC_Undefined, /* 0x53 */ GC_Undefined, /* 0x54 */ diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index ed9463f8e..a3c0aedf0 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.21 1987/01/22 14:27:02 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.22 1987/04/03 00:14:25 jinx Exp $ * * This file contains various hooks and handles which connect the * primitives with the main interpreter. @@ -195,8 +195,6 @@ Built_In_Primitive( Prim_Apply, 2, "APPLY") #endif /* (CATCH PROCEDURE) - [Primitive number 0x03] - Creates a control point (a pointer to the current stack) and passes it to PROCEDURE as its only argument. The inverse operation, typically called THROW, is performed by using the @@ -236,7 +234,6 @@ Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, "FAST-CALL-WITH-CURRENT-CONTINUA #endif /* (ENABLE-INTERRUPTS! INTERRUPTS) - [Primitive number 0x06] Changes the enabled interrupt bits to bitwise-or of INTERRUPTS and previous value of interrupts. Returns the previous value. See MASK_INTERRUPT_ENABLES for more information on interrupts. @@ -271,8 +268,7 @@ Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE") longjmp(*Back_To_Eval, PRIM_APPLY); } -/* (GET_FIXED_OBJECTS_VECTOR) - [Primitive number 0x7A] +/* (GET-FIXED-OBJECTS-VECTOR) Returns the current fixed objects vector. This vector is used for communication between the interpreter and the runtime system. See the file UTABCSCM.SCM in the runtime system for the @@ -287,7 +283,6 @@ Built_In_Primitive(Prim_Get_Fixed_Objects_Vector, 0, } /* (FORCE DELAYED-OBJECT) - [Primitive number 0xAF] Returns the memoized value of the DELAYED-OBJECT (created by a DELAY special form) if it has already been calculated. Otherwise, it calculates the value and memoizes it for future @@ -309,8 +304,7 @@ Built_In_Primitive(Prim_Force, 1, "FORCE") longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); /*NOTREACHED*/ } -/* (EXECUTE_AT_NEW_POINT SPACE BEFORE DURING AFTER) - [Primitive number 0xE2] +/* (EXECUTE-AT-NEW-POINT SPACE BEFORE DURING AFTER) Create a new state point in the specified state SPACE. To enter the new point you must execute the BEFORE thunk. On the way out, the AFTER thunk is executed. If SPACE is NIL, then the microcode @@ -359,8 +353,7 @@ Built_In_Primitive(Prim_Execute_At_New_Point, 4, "EXECUTE-AT-NEW-POINT") Translate_To_Point(New_Point); } -/* (MAKE_STATE_SPACE MUTABLE?) - [Primitive number 0xE1] +/* (MAKE-STATE-SPACE MUTABLE?) Creates a new state space for the dynamic winder. Used only internally to the dynamic wind operations. If the arugment is #!TRUE, then a real, mutable state space is created. @@ -427,8 +420,7 @@ Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!") return Result; } -/* (SCODE_EVAL SCODE-EXPRESSION ENVIRONMENT) - [Primitive number 0x04] +/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT) Evaluate the piece of SCode (SCODE-EXPRESSION) in the ENVIRONMENT. This is like Eval, except that it expects its input to be syntaxed into SCode rather than just a list. @@ -442,8 +434,7 @@ Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL") longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); } -/* (SET_INTERRUPT_ENABLES NEW-INT-ENABLES) - [Primitive number 0x06] +/* (SET-INTERRUPT-ENABLES! NEW-INT-ENABLES) Changes the enabled interrupt bits to NEW-INT-ENABLES and returns the previous value. See MASK_INTERRUPT_ENABLES for more information on interrupts. @@ -458,28 +449,41 @@ Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!") return Result; } -/* (SET_CURRENT_HISTORY TRIPLE) - [Primitive number 0x2F] +/* (SET-CURRENT-HISTORY! TRIPLE) Begins recording history into TRIPLE. The history structure is somewhat complex and should be understood before trying to use this primitive. It is used in the Read-Eval-Print loop in the Scheme runtime system. + + This primitive pops its own frame and escapes back to the interpreter + because it modifies one of the registers that the interpreter caches + (History). + + The longjmp forces the interpreter to recache. */ -Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY") -{ Pointer Result; +Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!") +{ Primitive_1_Arg(); - Arg_1_Type(TC_HUNK3); - Result = *History; + + /* History is one of the few places where we still used danger bits. + Check explicitely. + */ + + if ((safe_pointer_type (Arg1)) != TC_HUNK3) + error_wrong_type_arg_1 (); + + Val = *History; #ifdef COMPILE_HISTORY History = Get_Pointer(Arg1); #else History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); #endif - return Result; + Pop_Primitive_Frame( 1); + longjmp( *Back_To_Eval, PRIM_POP_RETURN); + /*NOTREACHED*/ } -/* (SET_FIXED_OBJECTS_VECTOR VECTOR) - [Primitive number 0x7B] +/* (SET-FIXED-OBJECTS-VECTOR! VECTOR) Replace the current fixed objects vector with VECTOR. The fixed objects vector is used for communication between the Scheme runtime system and the interpreter. The file UTABCSCM.SCM @@ -500,8 +504,7 @@ Built_In_Primitive(Prim_Set_Fixed_Objects_Vector, 1, return Result; } -/* (TRANSLATE_TO_STATE_POINT STATE_POINT) - [Primitive number 0xE3] +/* (TRANSLATE-TO-STATE-POINT STATE_POINT) Move to a new dynamic wind environment by performing all of the necessary enter and exit forms to get from the current state to the new state as specified by STATE_POINT. @@ -516,8 +519,7 @@ Built_In_Primitive(Prim_Translate_To_Point, 1, "TRANSLATE-TO-STATE-POINT") /* This ends by longjmp-ing back to the interpreter */ } -/* (WITH_HISTORY_DISABLED THUNK) - [Primitive number 0x9C] +/* (WITH-HISTORY-DISABLED THUNK) THUNK must be a procedure or primitive procedure which takes no arguments. Turns off the history collection mechanism. Removes the most recent reduction (the expression which called the @@ -592,8 +594,7 @@ Built_In_Primitive(Prim_With_Interrupts_Reduced, 2, "WITH-INTERRUPTS-REDUCED") longjmp(*Back_To_Eval, PRIM_APPLY); } -/* (WITHIN_CONTROL_POINT CONTROL-POINT THUNK) - [Primitive number 0xBF] +/* (WITHIN-CONTROL-POINT CONTROL-POINT THUNK) THUNK must be a procedure or primitive procedure which takes no arguments. Restores the state of the machine from the control point, and then calls the THUNK in this new state. @@ -610,8 +611,7 @@ Built_In_Primitive(Prim_Within_Control_Point, 2, "WITHIN-CONTROL-POINT") Pushed(); longjmp(*Back_To_Eval, PRIM_APPLY); } -/* (WITH_THREADED_STACK PROCEDURE THUNK) - [Primitive number 0xBE] +/* (WITH-THREADED-STACK PROCEDURE THUNK) THUNK must be a procedure or primitive procedure which takes no arguments. PROCEDURE must expect one argument. Basically this primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index 84d52dbb6..8e2e2a7cf 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.21 1987/01/22 14:27:50 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.22 1987/04/03 00:14:51 jinx Exp $ * * This file contains the heart of the Scheme Scode * interpreter @@ -39,6 +39,9 @@ MIT in each case. */ #define In_Main_Interpreter true #include "scheme.h" +#include "locks.h" +#include "trap.h" +#include "lookup.h" #include "zones.h" /* In order to make the interpreter tail recursive (i.e. @@ -79,50 +82,60 @@ MIT in each case. */ * ordered alphabetically by return code name. */ -#define Interrupt(Masked_Code) \ - { Export_Registers(); \ - Setup_Interrupt(Masked_Code); \ - Import_Registers(); \ - goto Perform_Application; \ - } +#define Interrupt(Masked_Code) \ +{ \ + Export_Registers(); \ + Setup_Interrupt(Masked_Code); \ + Import_Registers(); \ + goto Perform_Application; \ +} #define Immediate_GC(N) \ - { Request_GC(N); \ - Interrupt(IntCode & IntEnb); \ - } - +{ \ + Request_GC(N); \ + Interrupt(IntCode & IntEnb); \ +} + #define Prepare_Eval_Repeat() \ - {Will_Push(CONTINUATION_SIZE+1); \ - Push(Fetch_Env()); \ - Store_Return(RC_EVAL_ERROR); \ - Save_Cont(); \ - Pushed(); \ - } +{ \ + Will_Push(CONTINUATION_SIZE+1); \ + Push(Fetch_Env()); \ + Store_Return(RC_EVAL_ERROR); \ + Save_Cont(); \ + Pushed(); \ +} #define Eval_GC_Check(Amount) \ - if (GC_Check(Amount)) \ - { Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ - } +if (GC_Check(Amount)) \ +{ \ + Prepare_Eval_Repeat(); \ + Immediate_GC(Amount); \ +} #define Eval_Error(Err) \ - { Export_Registers(); \ - Do_Micro_Error(Err, false); \ - Import_Registers(); \ - goto Internal_Apply; \ - } +{ \ + Export_Registers(); \ + Do_Micro_Error(Err, false); \ + Import_Registers(); \ + goto Internal_Apply; \ +} #define Pop_Return_Error(Err) \ - { Export_Registers(); \ - Do_Micro_Error(Err, true); \ - Import_Registers(); \ - goto Internal_Apply; \ - } - +{ \ + Export_Registers(); \ + Do_Micro_Error(Err, true); \ + Import_Registers(); \ + goto Internal_Apply; \ +} + #define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ - Store_Return(Return_Code); \ - Val = Contents_of_Val; \ - Save_Cont() +{ \ + Store_Return(Return_Code); \ + Save_Cont(); \ + Store_Return(RC_RESTORE_VALUE); \ + Store_Expression(Contents_of_Val); \ + Save_Cont(); \ +} #define Reduces_To(Expr) \ { Store_Expression(Expr); \ @@ -152,40 +165,6 @@ MIT in each case. */ #define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT)) -/* This makes local variable references faster */ - -#if (LOCAL_REF == 0) -#define Local_Offset(Ind) Ind -#else -#define Local_Offset(Ind) Get_Integer(Ind) -#endif - -#ifdef COMPILE_FUTURES -#define Splice_Future_Value(The_Loc) \ -{ while ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val))) \ - { Pointer *Location; \ - Val = Future_Value(Val); \ - Location = The_Loc; \ - if Dangerous(*Location) Set_Danger_Bit(Val); \ - *Location = Val; \ - Clear_Danger_Bit(Val); \ - } \ - Set_Time_Zone(Zone_Working); \ - break; \ -} -#else -#define Splice_Future_Value(The_Loc) \ -{ Set_Time_Zone(Zone_Working); \ - break; \ -} -#endif - -#ifdef TRAP_ON_REFERENCE -#define Trap(Value) (Safe_Type_Code(Value) == TC_TRAP) -#else -#define Trap(Value) false -#endif - #define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */ #define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE) @@ -208,14 +187,23 @@ MIT in each case. */ their arguments and restarts them or suspends if the argument is a future. */ #define Arg_Type_Error(Arg_No, Err_No) \ -{ fast Pointer *Arg = &(Stack_Ref(Arg_No-1)); \ - fast Pointer Orig_Arg = *Arg; \ - if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \ +{ \ + fast Pointer *Arg, Orig_Arg; \ + \ + Arg = &(Stack_Ref(Arg_No-1)); \ + Orig_Arg = *Arg; \ + \ + if (Type_Code(*Arg) != TC_FUTURE) \ + Pop_Return_Error(Err_No); \ + \ while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ - { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ + { \ + if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ *Arg = Future_Value(*Arg); \ } \ - if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \ + if (Type_Code(*Arg) != TC_FUTURE) \ + goto Prim_No_Trap_Apply; \ + \ Save_Cont(); \ Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ Push(*Arg); /* Arg 1: The future itself */ \ @@ -232,13 +220,20 @@ MIT in each case. */ */ #define Apply_Future_Check(Name, Object) \ -{ fast Pointer *Arg = &(Object); \ - fast Pointer Orig_Answer = *Arg; \ +{ \ + fast Pointer *Arg, Orig_Answer; \ + \ + Arg = &(Object); \ + Orig_Answer = *Arg; \ + \ while (Type_Code(*Arg) == TC_FUTURE) \ - { if (Future_Has_Value(*Arg)) \ - { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ + { \ + if (Future_Has_Value(*Arg)) \ + { \ + if (Future_Is_Keep_Slot(*Arg)) \ + Log_Touch_Of_Future(*Arg); \ *Arg = Future_Value(*Arg); \ - } \ + } \ else \ { \ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ @@ -249,7 +244,7 @@ MIT in each case. */ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ Push(STACK_FRAME_HEADER+1); \ Pushed(); \ - *Arg = Orig_Answer; \ + *Arg = Orig_Answer; \ goto Internal_Apply; \ } \ } \ @@ -264,14 +259,20 @@ MIT in each case. */ a recursive call to EVAL is an undetermined future */ #define Pop_Return_Val_Check() \ -{ fast Pointer Orig_Val = Val; \ +{ \ + fast Pointer Orig_Val = Val; \ + \ while (Type_Code(Val) == TC_FUTURE) \ - { if (Future_Has_Value(Val)) \ - { if (Future_Is_Keep_Slot(Val)) Log_Touch_Of_Future(Val); \ + { \ + if (Future_Has_Value(Val)) \ + { \ + if (Future_Is_Keep_Slot(Val)) \ + Log_Touch_Of_Future(Val); \ Val = Future_Value(Val); \ - } \ + } \ else \ - { Save_Cont(); \ + { \ + Save_Cont(); \ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ Store_Return(RC_RESTORE_VALUE); \ Store_Expression(Orig_Val); \ @@ -286,9 +287,11 @@ MIT in each case. */ } #else /* Not compiling FUTURES code */ + #define Pop_Return_Val_Check() #define Apply_Future_Check(Name, Object) Name = (Object) #define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No) + #endif /* The EVAL/APPLY ying/yang */ @@ -296,12 +299,16 @@ MIT in each case. */ void Interpret(dumped_p) Boolean dumped_p; -{ long Which_Way; - fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer; +{ + long Which_Way; + fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History; + extern long enter_compiled_expression(); extern long apply_compiled_procedure(); extern long return_to_compiled_code(); + Reg_Block = &Registers[0]; + /* Primitives jump back here for errors, requests to * evaluate an expression, apply a function, or handle an * interrupt request. On errors or interrupts they leave @@ -325,6 +332,7 @@ Interpret(dumped_p) Pushed(); Call_Future_Logging(); } + Repeat_Dispatch: switch (Which_Way) { case PRIM_APPLY: goto Internal_Apply; @@ -344,10 +352,6 @@ Repeat_Dispatch: case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE); } - /*****************/ - /* Do_Expression */ - /*****************/ - Do_Expression: if (Eval_Debug) @@ -368,7 +372,7 @@ Do_Expression: * * An operation can terminate with a Reduces_To or * Reduces_To_Nth macro. This indicates that the value of - * the current S-Code item is the value returned when the + * the current Scode item is the value returned when the * new expression is evaluated. Therefore no new * continuation is created and processing continues at * Do_Expression with the new expression in the expression @@ -393,8 +397,7 @@ Do_Expression: */ - if (Microcode_Does_Stepping && Trapping && - (Fetch_Eval_Trapper() != NIL)) + if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL)) { Stop_Trapping(); Will_Push(4); Push(Fetch_Env()); @@ -417,23 +420,23 @@ Eval_Non_Trapping: case TC_CONTROL_POINT: case TC_DELAYED: case TC_ENVIRONMENT: - case TC_EXTENDED_FIXNUM: case TC_EXTENDED_PROCEDURE: case TC_FIXNUM: case TC_HUNK3: + case TC_INTERNED_SYMBOL: case TC_LIST: case TC_NON_MARKED_VECTOR: case TC_NULL: case TC_PRIMITIVE: case TC_PRIMITIVE_EXTERNAL: case TC_PROCEDURE: + case TC_QUAD: case TC_UNINTERNED_SYMBOL: - case TC_INTERNED_SYMBOL: case TC_TRUE: - case TC_UNASSIGNED: case TC_VECTOR: case TC_VECTOR_16B: case TC_VECTOR_1B: + case TC_REFERENCE_TRAP: Val = Fetch_Expression(); break; case TC_ACCESS: @@ -571,40 +574,37 @@ Eval_Non_Trapping: /* In case we back out */ Reserve_Stack_Space(); /* CONTINUATION_SIZE */ Finished_Eventual_Pushing(); /* of this primitive */ -/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive - combinations unless the primitive itself is output in the code stream. - Therefore, we don't have to explicitly check here that the expression - register has a primitive in it. -*/ + Primitive_Internal_Apply: if (Microcode_Does_Stepping && Trapping && (Fetch_Apply_Trapper() != NIL)) {Will_Push(3); Push(Fetch_Expression()); Push(Fetch_Apply_Trapper()); - Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression())); + Push(STACK_FRAME_HEADER + 1 + + N_Args_Primitive(Get_Integer(Fetch_Expression()))); Pushed(); Stop_Trapping(); goto Apply_Non_Trapping; } Prim_No_Trap_Apply: - Export_Registers(); - Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression())); - -/* Any primitive which does not do a long jump can have it's primitive - frame popped off here. At this point, it is guaranteed that the - primitive is in the expression register in case the primitive needs - to back out. -*/ - Import_Registers_Except_Val(); - Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression())); - if (Must_Report_References()) - { Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Call_Future_Logging(); + { + fast long primitive_code; + + primitive_code = Get_Integer(Fetch_Expression()); + + Export_Registers_Before_Primitive(); + Metering_Apply_Primitive(Val, primitive_code); + Import_Registers_After_Primitive(); + Pop_Primitive_Frame(N_Args_Primitive(primitive_code)); + if (Must_Report_References()) + { Store_Expression(Val); + Store_Return(RC_RESTORE_VALUE); + Save_Cont(); + Call_Future_Logging(); + } + break; } - break; case TC_PCOMB1: Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */ @@ -642,62 +642,85 @@ Prim_No_Trap_Apply: /* Interpret(), continued */ case TC_VARIABLE: -/* ASSUMPTION: The SYMBOL slot does NOT contain a future */ - { fast Pointer Compilation_Type, *Variable_Object; - int The_Type; + { + long temp; - Set_Time_Zone(Zone_Lookup); #ifndef No_In_Line_Lookup - Variable_Object = Get_Pointer(Fetch_Expression()); - Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE]; - The_Type = Type_Code(Compilation_Type); + fast Pointer *cell; - if (The_Type == LOCAL_REF) - { fast Pointer *Frame; - Frame = Get_Pointer(Fetch_Env()); - Val = Without_Danger_Bit(Frame[Local_Offset(Compilation_Type)]); - if (!Trap(Val)) - Splice_Future_Value(&(Frame[Local_Offset(Compilation_Type)])); - } - else if (The_Type == GLOBAL_REF) - { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE); - if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; - else if (!Trap(Val)) - Splice_Future_Value(Nth_Vector_Loc(Compilation_Type, - SYMBOL_GLOBAL_VALUE)); + Set_Time_Zone(Zone_Lookup); + cell = Get_Pointer(Fetch_Expression()); + lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); + Val = *cell; + if (Type_Code(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: + cell = Get_Pointer(Fetch_Expression()); + temp = + deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell), + cell); + goto external_lookup_return; + + /* No need to recompile, pass the fake variable. */ + case TRAP_FLUID: + temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object); + + external_lookup_return: + Import_Val(); + if (temp != PRIM_DONE) + break; + Set_Time_Zone(Zone_Working); + goto Pop_Return; + + case TRAP_UNBOUND: + temp = ERR_UNBOUND_VARIABLE; + break; + + case TRAP_UNASSIGNED: + temp = ERR_UNASSIGNED_VARIABLE; + break; + /* Interpret() continues on the next page */ /* Interpret(), continued */ - else if (The_Type == FORMAL_REF) - { fast long Frame_No; - fast Pointer *Frame; - - Frame = Get_Pointer(Fetch_Env()); - Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]); - while(--Frame_No >= 0) - Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION], - PROCEDURE_ENVIRONMENT)); - Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]; - if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; - else if (!Trap(Val)) - Splice_Future_Value( - &(Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])])); + default: + temp = ERR_BROKEN_COMPILED_VARIABLE; + break; } -#endif - /* Fall through in cases not handled above */ - { long Result; - Result = Lex_Ref(Fetch_Env(), Fetch_Expression()); - Import_Val(); - Set_Time_Zone(Zone_Working); - if (Result == PRIM_DONE) break; - Eval_Error(Result); + +#else No_In_Line_Lookup + + Set_Time_Zone(Zone_Lookup); + temp = Lex_Ref(Fetch_Env(), Fetch_Expression()); + Import_Val(); + if (temp == PRIM_DONE) + break; + +#endif No_In_Line_Lookup + + /* Back out of the evaluation. */ + + Set_Time_Zone(Zone_Working); + + if (temp == PRIM_INTERRUPT) + { + Prepare_Eval_Repeat(); + Interrupt(IntCode & IntEnb); } + + Eval_Error(temp); } case TC_RETURN_CODE: @@ -850,20 +873,37 @@ Pop_Return: Microcode_Termination(TERM_END_OF_COMPUTATION); case RC_EVAL_ERROR: + /* Should be called RC_REDO_EVALUATION. */ Store_Env(Pop()); Reduces_To(Fetch_Expression()); case RC_EXECUTE_ACCESS_FINISH: - { long Result; + { + long Result; + Pointer value; + Pop_Return_Val_Check(); + value = Val; + if (Environment_P(Val)) - { Result = Symbol_Lex_Ref(Val, - Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME)); + { Result = Symbol_Lex_Ref(value, + Fast_Vector_Ref(Fetch_Expression(), + ACCESS_NAME)); Import_Val(); - if (Result != PRIM_DONE) Pop_Return_Error(Result); - End_Subproblem(); - break; + if (Result == PRIM_DONE) + { + End_Subproblem(); + break; + } + if (Result != PRIM_INTERRUPT) + { + Val = value; + Pop_Return_Error(Result); + } + Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value); + Interrupt(IntCode & IntEnb); } + Val = value; Pop_Return_Error(ERR_BAD_FRAME); } @@ -872,91 +912,123 @@ Pop_Return: /* Interpret(), continued */ case RC_EXECUTE_ASSIGNMENT_FINISH: - { fast Pointer Compilation_Type, *Variable_Object; - Pointer The_Non_Object, Store_Value; - int The_Type; + { + long temp; + Pointer value; + Lock_Handle set_serializer; + +#ifndef No_In_Line_Lookup + + Pointer bogus_unassigned; + fast Pointer *cell; Set_Time_Zone(Zone_Lookup); Restore_Env(); - The_Non_Object = Get_Fixed_Obj_Slot(Non_Object); - Store_Value = (Val == The_Non_Object) ? UNASSIGNED_OBJECT : Val; + cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); + lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); + setup_lock(set_serializer, cell); + + value = Val; + bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); + if (value == bogus_unassigned) + value = UNASSIGNED_OBJECT; + + if (Type_Code(*cell) != TC_REFERENCE_TRAP) + { + Val = *cell; + + normal_assignment_done: + *cell = value; + remove_lock(set_serializer); + Set_Time_Zone(Zone_Working); + End_Subproblem(); + goto Pop_Return; + } -#ifndef No_In_Line_Lookup +/* Interpret() continues on the next page */ + +/* Interpret(), continued */ - Variable_Object = - Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); - Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE]; - The_Type = Type_Code(Compilation_Type); - - if (The_Type == LOCAL_REF) - { fast Pointer *Frame; - Frame = Get_Pointer(Fetch_Env()); - Val = Frame[Local_Offset(Compilation_Type)]; - if (Dangerous(Val)) - { Set_Danger_Bit(Store_Value); - Clear_Danger_Bit(Val); - } - if (!Trap(Val)) - { Frame[Local_Offset(Compilation_Type)] = Store_Value; - if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object; + get_trap_kind(temp, *cell); + switch(temp) + { + case TRAP_DANGEROUS: + case TRAP_UNBOUND_DANGEROUS: + case TRAP_UNASSIGNED_DANGEROUS: + case TRAP_FLUID_DANGEROUS: + remove_lock(set_serializer); + cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); + temp = + deep_assignment_end(deep_lookup(Fetch_Env(), + cell[VARIABLE_SYMBOL], + cell), + cell, + value, + false); + goto external_assignment_return; + + case TRAP_UNASSIGNED: + Val = bogus_unassigned; + goto normal_assignment_done; + + case TRAP_FLUID: + /* No need to recompile, pass the fake variable. */ + remove_lock(set_serializer); + temp = deep_assignment_end(lookup_fluid(*cell), + fake_variable_object, + value, + false); + + external_assignment_return: + Import_Val(); + if (temp != PRIM_DONE) + break; Set_Time_Zone(Zone_Working); End_Subproblem(); + goto Pop_Return; + + case TRAP_UNBOUND: + remove_lock(set_serializer); + temp = ERR_UNBOUND_VARIABLE; + break; + + default: + remove_lock(set_serializer); + temp = ERR_BROKEN_COMPILED_VARIABLE; break; - } - } - else if (The_Type == GLOBAL_REF) - { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE); - if (!Dangerous(Val) && !Trap(Val)) - { Vector_Set(Compilation_Type, SYMBOL_GLOBAL_VALUE, Store_Value); - if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - break; - } - else if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; } /* Interpret() continues on the next page */ /* Interpret(), continued */ - else if (The_Type == FORMAL_REF) - { fast long Frame_No; - fast Pointer *Frame; - - Frame = Get_Pointer(Fetch_Env()); - Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]); - while(--Frame_No >= 0) - Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION], - PROCEDURE_ENVIRONMENT)); - Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]; - if (!Dangerous(Val) && !Trap(Val)) - { Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])] = - Store_Value; - if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - break; - } - else if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; +#else + + Set_Time_Zone(Zone_Lookup); + Restore_Env(); + temp = Lex_Set(Fetch_Env(), + Vector_Ref(Fetch_Expression(), ASSIGN_NAME), + value); + Import_Val(); + if (temp == PRIM_DONE) + { End_Subproblem(); + Set_Time_Zone(Zone_Working); + break; } + #endif - /* Fall through in cases not handled above */ - { long Result; - Result = Lex_Set(Fetch_Env(), - Vector_Ref(Fetch_Expression(), ASSIGN_NAME), - Store_Value); - Import_Val(); - Set_Time_Zone(Zone_Working); - if (Result == PRIM_DONE) - { End_Subproblem(); - break; - } - Save_Env(); - Pop_Return_Error(Result); + + Set_Time_Zone(Zone_Working); + Save_Env(); + if (temp != PRIM_INTERRUPT) + { + Val = value; + Pop_Return_Error(temp); } + + Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, + value); + Interrupt(IntCode & IntEnb); } /* Interpret() continues on the next page */ @@ -964,32 +1036,38 @@ Pop_Return: /* Interpret(), continued */ case RC_EXECUTE_DEFINITION_FINISH: - { Pointer Saved_Val; - long Result; + { + Pointer value; + long result; - Saved_Val = Val; + value = Val; Restore_Env(); - Result = Local_Set(Fetch_Env(), + Export_Registers(); + result = Local_Set(Fetch_Env(), Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME), Val); - Import_Val(); - if (Result==PRIM_DONE) - { End_Subproblem(); + Import_Registers(); + if (result == PRIM_DONE) + { + End_Subproblem(); break; } Save_Env(); - if (Result==PRIM_INTERRUPT) - { Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - Saved_Val); + if (result == PRIM_INTERRUPT) + { + Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, + value); Interrupt(IntCode & IntEnb); } - Pop_Return_Error(Result); - }; + Val = value; + Pop_Return_Error(result); + } case RC_EXECUTE_IN_PACKAGE_CONTINUE: Pop_Return_Val_Check(); if (Environment_P(Val)) - { End_Subproblem(); + { + End_Subproblem(); Store_Env(Val); Reduces_To_Nth(IN_PACKAGE_EXPRESSION); } @@ -1014,109 +1092,129 @@ Pop_Return: case RC_HALT: Export_Registers(); Microcode_Termination(TERM_TERM_HANDLER); - -/* Interpret() continues on the next page */ -/* Interpret(), continued */ + case RC_INTERNAL_APPLY: + +Internal_Apply: -#define Prepare_Apply_Interrupt() \ - Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL) +/* Branch here to perform a function application. + + At this point the top of the stack contains an application frame + which consists of the following elements (see sdata.h): + - A header specifying the frame length. + - A procedure. + - The actual (evaluated) arguments. + + No registers (except the stack pointer) are meaning full at this point. + Before interrupts or errors are processed, some registers are cleared + to avoid holding onto garbage if a garbage collection occurs. +*/ + +#define Prepare_Apply_Interrupt() \ +{ \ + Store_Return(RC_INTERNAL_APPLY); \ + Store_Expression(NIL); \ + Save_Cont(); \ +} #define Apply_Error(N) \ - { Store_Return(RC_INTERNAL_APPLY); \ - Val = NIL; \ - Pop_Return_Error(N); \ - } +{ \ + Store_Return(RC_INTERNAL_APPLY); \ + Store_Expression(NIL); \ + Val = NIL; \ + Pop_Return_Error(N); \ +} /* Interpret() continues on the next page */ /* Interpret(), continued */ - case RC_INTERNAL_APPLY: -Internal_Apply: - -/* Branch here to perform a function application. At this point - it is necessary that the top of the stack contain a frame - for evaluation of the function to be applied. This frame - DOES NOT contain "finger" and "combination" slots, although - if the frame is to be copied into the heap, it will have NIL's - in the "finger" and "combination" slots which will correspond - to "potentially-dangerous" and "auxilliary variables" slots. - - Note, also, that unlike most return codes Val is not used here. - Thus, the error and interrupt macros above set it to NIL so that it - will not 'hold on' to anything if a GC occurs. Similarly, the - contents of Expression are discarded. -*/ if (Microcode_Does_Stepping && Trapping && - (Fetch_Apply_Trapper() != NIL)) - { long Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); + (Fetch_Apply_Trapper() != NIL)) + { + long Count; + + Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); Top_Of_Stack() = Fetch_Apply_Trapper(); Push(STACK_FRAME_HEADER+Count); Stop_Trapping(); } + Apply_Non_Trapping: - { long Interrupts; - Pointer Function; - - Store_Expression(NIL); - Interrupts = IntCode & IntEnb; - if (Interrupts != 0) - { Prepare_Apply_Interrupt(); - Interrupt(Interrupts); - } + + if ((IntCode & IntEnb) != 0) + { + long Interrupts; + + Interrupts = (IntCode & IntEnb); + Store_Expression(NIL); + Val = NIL; + Prepare_Apply_Interrupt(); + Interrupt(Interrupts); + } Perform_Application: + + Apply_Ucode_Hook(); + + { + fast Pointer Function; + Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION)); - Apply_Ucode_Hook(); + + switch(Type_Code(Function)) + { /* Interpret() continues on the next page */ /* Interpret(), continued */ - switch(Type_Code(Function)) - { case TC_PROCEDURE: - { Pointer Lambda_Expr, *Temp1, Temp2; - long NParams, Size; - fast long NArgs; - - Apply_Future_Check(Lambda_Expr, - Fast_Vector_Ref(Function, - PROCEDURE_LAMBDA_EXPR)); - Temp1 = Get_Pointer(Lambda_Expr); - Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]); - NArgs = Get_Integer(Pop()); - NParams = Vector_Length(Temp2); - if (Eval_Debug) - { Print_Expression(FIXNUM_0+NArgs, - "APPLY: Number of arguments"); - Print_Expression(FIXNUM_0+NParams, - " Number of parameters"); + case TC_PROCEDURE: + { + fast long nargs; + + nargs = Get_Integer(Pop()); + Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); + + { + fast Pointer formals; + + Apply_Future_Check(formals, + Fast_Vector_Ref(Function, LAMBDA_FORMALS)); + + if ((nargs != Vector_Length(formals)) && + ((Type_Code(Function) != TC_LEXPR) || + (nargs < Vector_Length(formals)))) + { + Push(STACK_FRAME_HEADER + nargs - 1); + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } } - if (Type_Code(Lambda_Expr) == TC_LAMBDA) - { if (NArgs != NParams) - { Push(STACK_FRAME_HEADER+NArgs-1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } + + if (Eval_Debug) + { + Print_Expression(Make_Unsigned_Fixnum(nargs), + "APPLY: Number of arguments"); } - else if (NArgs < NParams) - { Push(STACK_FRAME_HEADER+NArgs-1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1); - if (GC_Check(Size)) - { Push(STACK_FRAME_HEADER+NArgs-1); + + if (GC_Check(nargs + 1)) + { + Push(STACK_FRAME_HEADER + nargs - 1); Prepare_Apply_Interrupt(); - Immediate_GC(Size); + Immediate_GC(nargs + 1); } - /* Store Environment Frame into heap, putting extra slots - for Potentially Dangerous and Auxiliaries */ - Store_Env(Make_Pointer(TC_ENVIRONMENT, Free)); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size); - *Free++ = NIL; /* For PD list and Aux list */ - *Free++ = NIL; - for (; --NArgs >= 0; ) *Free++ = Pop(); - Reduces_To(Temp1[LAMBDA_SCODE]); + + { + fast Pointer *scan; + + scan = Free; + Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); + *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs); + while(--nargs >= 0) + *scan++ = Pop(); + Free = scan; + Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE)); + } } /* Interpret() continues on the next page */ @@ -1124,35 +1222,68 @@ Perform_Application: /* Interpret(), continued */ case TC_CONTROL_POINT: + { if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != STACK_ENV_FIRST_ARG) - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS) + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } Val = Stack_Ref(STACK_ENV_FIRST_ARG); Our_Throw(false, Function); Apply_Stacklet_Backout(); Our_Throw_Part_2(); goto Pop_Return; + } + +/* Interpret() continues on the next page */ + +/* Interpret(), continued */ + + /* + After checking the number of arguments, remove the + frame header since primitives do not expect it. + */ + + case TC_PRIMITIVE: + { + if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != + STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1) + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); + Store_Expression(Function); + goto Prim_No_Trap_Apply; + } case TC_PRIMITIVE_EXTERNAL: - { long NArgs, Proc = Datum(Function); + { + fast long NArgs, Proc; + + Proc = Datum(Function); if (Proc > MAX_EXTERNAL_PRIMITIVE) + { Apply_Error(ERR_UNDEFINED_PRIMITIVE); + } NArgs = Ext_Prim_Desc[Proc].arity; if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG+NArgs-1) + (NArgs + (STACK_ENV_FIRST_ARG - 1))) + { Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - /* Remove the frame overhead, since the primitives - just expect arguments on the stack */ Store_Expression(Function); + Repeat_External_Primitive: /* Reinitialize Proc in case we "goto Repeat_External..." */ Proc = Get_Integer(Fetch_Expression()); - Export_Registers(); + + Export_Registers_Before_Primitive(); Val = (*(Ext_Prim_Desc[Proc].proc))(); Set_Time_Zone(Zone_Working); - Import_Registers_Except_Val(); + Import_Registers_After_Primitive(); Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity); + goto Pop_Return; } @@ -1161,93 +1292,94 @@ Repeat_External_Primitive: /* Interpret(), continued */ case TC_EXTENDED_PROCEDURE: - { Pointer Lambda_Expr, *List_Car, Temp; - long NArgs, NParams, Formals, Params, Auxes, - Rest_Flag, Size, i; - -/* Selectors for the various parts */ - -#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE)) -#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES)) -#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT)) -#define Elambda_Formals_Count(Addr) \ - ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT) -#define Elambda_Opts_Count(Addr) \ - (((long) Addr) & EL_OPTS_MASK) -#define Elambda_Rest_Flag(Addr) \ - ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT) - - Apply_Future_Check(Lambda_Expr, - Fast_Vector_Ref(Function, - PROCEDURE_LAMBDA_EXPR)); - Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr, - ELAMBDA_NAMES)); - NParams = Vector_Length(Temp) - 1; - Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr)); - Formals = Elambda_Formals_Count(Temp); - /* Formals DOES NOT include the name of the lambda */ - Params = Elambda_Opts_Count(Temp) + Formals; - Rest_Flag = Elambda_Rest_Flag(Temp); - NArgs = Get_Integer(Pop()) - 1; - Auxes = NParams - (Params + Rest_Flag); - if ((NArgs < Formals) || - (!Rest_Flag && (NArgs > Params))) - { Push(STACK_FRAME_HEADER+NArgs); + { + Pointer lambda; + long nargs, nparams, formals, params, auxes, + rest_flag, size; + + fast long i; + fast Pointer *scan; + + nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER; + + if (Eval_Debug) + { + Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER), + "APPLY: Number of arguments"); + } + + lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); + Apply_Future_Check(Function, + Fast_Vector_Ref(lambda, ELAMBDA_NAMES)); + nparams = Vector_Length(Function) - 1; + + Apply_Future_Check(Function, Get_Count_Elambda(lambda)); + formals = Elambda_Formals_Count(Function); + params = Elambda_Opts_Count(Function) + formals; + rest_flag = Elambda_Rest_Flag(Function); + auxes = nparams - (params + rest_flag); + + if ((nargs < formals) || (!rest_flag && (nargs > params))) + { + Push(STACK_FRAME_HEADER + nargs); Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - Size = Params + Rest_Flag + Auxes + - (HEAP_ENV_EXTRA_SLOTS + 1); - List_Car = Free + Size; - if (GC_Check(Size + ((NArgs > Params) ? - 2 * (NArgs - Params) : 0))) - { Push(STACK_FRAME_HEADER+NArgs); + /* size includes the procedure slot, but not the header. */ + size = params + rest_flag + auxes + 1; + if (GC_Check(size + 1 + ((nargs > params) ? + (2 * (nargs - params)) : + 0))) + { + Push(STACK_FRAME_HEADER + nargs); Prepare_Apply_Interrupt(); - Immediate_GC(Size + ((NArgs > Params) ? - 2 * (NArgs - Params) : 0)); + Immediate_GC(size + 1 + ((nargs > params) ? + (2 * (nargs - params)) : + 0)); } - Store_Env(Make_Pointer(TC_ENVIRONMENT, Free)); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1); - /* Environment Header */ - *Free++ = NIL; /* Aux list */ - *Free++ = NIL; /* PD list */ - Size = 1 + ((NArgs < Params) ? NArgs : Params); - for (i = 0; i < Size; i++) *Free++ = Pop(); - for (i--; i < Params; i++) - *Free++ = UNASSIGNED_OBJECT; - if (Rest_Flag) - if (NArgs <= i) *Free++ = NIL; - else - { *Free++ = Make_Pointer(TC_LIST, List_Car); - for (; i < NArgs; i++, List_Car++) - { *List_Car++ = Pop(); - *List_Car = Make_Pointer(TC_LIST, List_Car+1); - } - List_Car[-1] = NIL; - } - for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT; - Free = List_Car; - Reduces_To(Get_Body_Elambda(Lambda_Expr)); - } /* Interpret() continues on the next page */ /* Interpret(), continued */ - case TC_PRIMITIVE: - { long Number_Of_Args = N_Args_Primitive(Function); - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG+Number_Of_Args-1) - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - /* Remove the frame overhead, since the primitives - just expect arguments on the stack */ - Store_Expression(Function); - goto Prim_No_Trap_Apply; + scan = Free; + Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); + *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size); + + if (nargs <= params) + { + for (i = (nargs + 1); --i >= 0; ) + *scan++ = Pop(); + for (i = (params - nargs); --i >= 0; ) + *scan++ = UNASSIGNED_OBJECT; + if (rest_flag) + *scan++ = NIL; + for (i = auxes; --i >= 0; ) + *scan++ = UNASSIGNED_OBJECT; + } + else + { + /* rest_flag must be true. */ + Pointer list; + + list = Make_Pointer(TC_LIST, (scan + size)); + for (i = (params + 1); --i >= 0; ) + *scan++ = Pop(); + *scan++ = list; + for (i = auxes; --i >= 0; ) + *scan++ = UNASSIGNED_OBJECT; + /* Now scan == Get_Pointer(list) */ + for (i = (nargs - params); --i >= 0; ) + { + *scan++ = Pop(); + *scan = Make_Pointer(TC_LIST, (scan + 1)); + scan += 1; + } + scan[-1] = NIL; + } + + Free = scan; + Reduces_To(Get_Body_Elambda(lambda)); } /* Interpret() continues on the next page */ @@ -1255,7 +1387,8 @@ Repeat_External_Primitive: /* Interpret(), continued */ case TC_COMPILED_PROCEDURE: - { apply_compiled_setup(STACK_ENV_EXTRA_SLOTS + + { + apply_compiled_setup(STACK_ENV_EXTRA_SLOTS + Get_Integer( Stack_Ref( STACK_ENV_HEADER))); Export_Registers(); Which_Way = apply_compiled_procedure(); @@ -1593,8 +1726,6 @@ return_from_compiled_code: break; /* We never get here.... */ } -/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */ - case RC_RETURN_TRAP_POINT: Store_Return(Old_Return_Code); Will_Push(CONTINUATION_SIZE+3); diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h index 7e4a4716a..4bf636fe4 100644 --- a/v7/src/microcode/interp.h +++ b/v7/src/microcode/interp.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.21 1987/01/22 14:28:12 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.22 1987/04/03 00:15:49 jinx Exp $ * * Macros used by the interpreter and some utilities. * @@ -40,22 +40,48 @@ MIT in each case. */ /* OPEN CODED RACKS */ /********************/ -#ifndef ENABLE_DEBUGGING_TOOLS -#ifdef In_Main_Interpreter -#define Using_Registers -#endif -#endif +/* Move from register to static storage and back */ -#ifdef Using_Registers -#define Val Reg_Val +#if defined(In_Main_Interpreter) && !defined(ENABLE_DEBUGGING_TOOLS) + +#define Regs Reg_Block #define Stack_Pointer Reg_Stack_Pointer -#define Expression Reg_Expression +#define History Reg_History + +#define Import_Registers() \ +{ \ + Reg_Stack_Pointer = Ext_Stack_Pointer; \ + Reg_History = Ext_History; \ +} + +#define Export_Registers() \ +{ \ + Ext_History = Reg_History; \ + Ext_Stack_Pointer = Reg_Stack_Pointer; \ +} + #else -#define Val Ext_Val + +#define Regs Registers #define Stack_Pointer Ext_Stack_Pointer -#define Expression Ext_Expression +#define History Ext_History + +#define Import_Registers() +#define Export_Registers() + #endif +#define Import_Val() +#define Import_Registers_Except_Val() Import_Registers() + +#define Import_Registers_After_Primitive() +#define Export_Registers_Before_Primitive() Export_Registers() + +#define Env Regs[REGBLOCK_ENV] +#define Val Regs[REGBLOCK_VAL] +#define Expression Regs[REGBLOCK_EXPR] +#define Return Regs[REGBLOCK_RETURN] + /* Internal_Will_Push is in stack.h. */ #ifdef ENABLE_DEBUGGING_TOOLS @@ -75,7 +101,7 @@ MIT in each case. */ #define Will_Eventually_Push(N) Internal_Will_Push(N) #define Finished_Eventual_Pushing() /* No op */ - + /* Primitive stack operations: * These operations hide the direction of stack growth. * Throw in stack.h, Allocate_New_Stacklet in utils.c, apply, cwcc and @@ -150,6 +176,10 @@ MIT in each case. */ #define Store_Return(P) \ Return = Make_Non_Pointer(TC_RETURN_CODE, (P)) +#define Save_Env() Push(Env) +#define Restore_Env() Env = Pop() +#define Restore_Then_Save_Env() Env = Top_Of_Stack() + /* Note: Save_Cont must match the definitions in sdata.h */ #define Save_Cont() { Push(Expression); \ @@ -173,48 +203,14 @@ MIT in each case. */ CONT_PRINT_EXPR_MESSAGE); \ CRLF(); \ } - -/* Racks operations continue on the next page */ - -/* Rack operations continued */ - -#define Save_Env() Push(Env) -#define Restore_Env() Env = Pop() -#define Restore_Then_Save_Env() Env = Top_Of_Stack() - -/* Move from register to static storage and back */ - -#ifdef Using_Registers -#define Import_Val() Reg_Val = Ext_Val - -#define Import_Registers_Except_Val() \ - { Reg_Expression = Ext_Expression; \ - Reg_Stack_Pointer = Ext_Stack_Pointer;\ - } - -#define Import_Registers() \ - { Import_Registers_Except_Val(); \ - Import_Val(); \ - } - -#define Export_Registers() { Ext_Val = Reg_Val; \ - Ext_Expression = Reg_Expression; \ - Ext_Stack_Pointer = Reg_Stack_Pointer;\ - } -#else -#define Import_Val() -#define Import_Registers() -#define Import_Registers_Except_Val() -#define Export_Registers() -#endif /* Random utility macros */ #define Pop_Primitive_Frame(NArgs) \ Stack_Pointer = Simulate_Popping(NArgs) -#define N_Args_Primitive(Function) \ - ((int) Arg_Count_Table[Get_Integer(Function)]) +#define N_Args_Primitive(primitive_code) \ + ((int) Arg_Count_Table[primitive_code]) #define Stop_Trapping() \ { Trapping = false; \ diff --git a/v7/src/microcode/list.c b/v7/src/microcode/list.c index 0d9181aa8..3c01fe6b6 100644 --- a/v7/src/microcode/list.c +++ b/v7/src/microcode/list.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.21 1987/01/22 14:28:26 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.22 1987/04/03 00:16:13 jinx Exp $ * * List creation and manipulation primitives. */ @@ -39,7 +39,6 @@ MIT in each case. */ #include "primitive.h" /* (CONS LEFT RIGHT) - [Primitive number 0x20] Creates a pair with left component LEFT and right component RIGHT. */ @@ -52,7 +51,6 @@ Built_In_Primitive(Prim_Cons, 2, "CONS") } /* (CDR PAIR) - [Primitive number 0x22] Returns the second element in the pair. By convention, (CAR NIL) is NIL. */ @@ -64,7 +62,6 @@ Built_In_Primitive(Prim_Cdr, 1, "CDR") } /* (CAR PAIR) - [Primitive number 0x21] Returns the first element in the pair. By convention, (CAR NIL) is NIL. */ @@ -76,7 +73,6 @@ Built_In_Primitive(Prim_Car, 1, "CAR") } /* (GENERAL_CAR_CDR LIST DIRECTIONS) - [Primitive number 0x27] DIRECTIONS encodes a string of CAR and CDR operations to be performed on LIST as follows: 1 = NOP 101 = CDAR @@ -126,7 +122,6 @@ Built_In_Primitive(Prim_Assq, 2, "ASSQ") } /* (LENGTH LIST) - [Primitive number 0x5D] Returns the number of items in the list. By convention, (LENGTH NIL) is 0. LENGTH will loop forever if given a circular structure. @@ -145,7 +140,6 @@ Built_In_Primitive(Prim_Length, 1, "LENGTH") } /* (MEMQ ITEM LIST) - [Primitive number 0x1C] Searches LIST for ITEM, using EQ? as a test. Returns NIL if it is not found, or the [first] tail of LIST whose CAR is ITEM. */ @@ -164,7 +158,6 @@ Built_In_Primitive(Prim_Memq, 2, "MEMQ") } /* (SET_CAR PAIR VALUE) - [Primitive number 0x23] Stores VALUE in the CAR of PAIR. Returns (bad style to count on this) the previous CAR of PAIR. */ @@ -176,7 +169,6 @@ Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!") } /* (SET_CDR PAIR VALUE) - [Primitive number 0x24] Stores VALUE in the CDR of PAIR. Returns (bad style to count on this) the previous CDR of PAIR. */ @@ -187,8 +179,7 @@ Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!") return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2); } -/* (PAIR OBJECT) - [Primitive number 0x7E] +/* (PAIR? OBJECT) Returns #!TRUE if OBJECT has the type-code LIST (ie if it was created by CONS). Return NIL otherwise. */ @@ -199,19 +190,21 @@ Built_In_Primitive(Prim_Pair, 1, "PAIR?") else return NIL; } -/* (SYS_PAIR OBJECT) - [Primitive number 0x85] +/* (SYSTEM-PAIR? OBJECT) Returns #!TRUE if the garbage collector type of OBJECT is PAIR. */ Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Touch_In_Primitive(Arg1, Arg1); - if (GC_Type_List(Arg1)) return TRUTH; - else return NIL; + if (GC_Type_List(Arg1)) + return TRUTH; + else + return NIL; } -/* (SYS_PAIR_CAR GC-PAIR) - [Primitive number 0x86] +/* (SYSTEM-PAIR-CAR GC-PAIR) Same as CAR, but for anything of GC type PAIR. */ Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR") @@ -220,8 +213,7 @@ Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR") return Vector_Ref(Arg1, CONS_CAR); } -/* (SYS_PAIR_CDR GC-PAIR) - [Primitive number 0x87] +/* (SYSTEM-PAIR-CDR GC-PAIR) Same as CDR, but for anything of GC type PAIR. */ Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR") @@ -230,8 +222,7 @@ Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR") return Vector_Ref(Arg1, CONS_CDR); } -/* (SYS_PAIR_CONS TYPE-CODE OBJECT-1 OBJECT-2) - [Primitive number 0x84] +/* (SYSTEM-PAIR-CONS TYPE-CODE OBJECT-1 OBJECT-2) Like CONS, but returns an object with the specified type code (not limited to type code LIST). */ @@ -251,8 +242,7 @@ Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS") } -/* (SYS_SET_CAR GC-PAIR NEW_CAR) - [Primitive number 0x88] +/* (SYSTEM-PAIR-SET-CAR! GC-PAIR NEW_CAR) Same as SET_CAR, but for anything of GC type PAIR. */ Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!") @@ -262,8 +252,7 @@ Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!") return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2); } -/* (SYS_SET_CDR GC-PAIR NEW_CDR) - [Primitive number 0x89] +/* (SYSTEM-PAIR-SET-CDR! GC-PAIR NEW_CDR) Same as SET_CDR, but for anything of GC type PAIR. */ Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!") diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index c3587e48f..e8657d5bb 100644 --- a/v7/src/microcode/memmag.c +++ b/v7/src/microcode/memmag.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.26 1987/02/08 23:06:34 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.27 1987/04/03 00:17:25 jinx Exp $ */ /* Memory management top level. @@ -110,7 +110,9 @@ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; /* Allocate */ Highest_Allocated_Address = Allocate_Heap_Space(Stack_Allocation_Size(Our_Stack_Size) + - 2*Our_Heap_Size + Our_Constant_Size); + (2 * Our_Heap_Size) + + Our_Constant_Size + + HEAP_BUFFER_SPACE); /* Consistency check 2 */ if (Heap == NULL) @@ -119,8 +121,9 @@ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; } /* Initialize the various global parameters */ - Align_Float(Heap); - Unused_Heap = Heap+Our_Heap_Size; + Heap += HEAP_BUFFER_SPACE; + Initial_Align_Float(Heap); + Unused_Heap = Heap + Our_Heap_Size; Align_Float(Unused_Heap); Constant_Space = Heap + 2*Our_Heap_Size; Align_Float(Constant_Space); @@ -171,14 +174,8 @@ void GCFlip() either updates the new copy's CAR with the relocated version of the object, or replaces it with NIL. - This code could be implemented as a GC daemon, just like - REHASH-GC-DAEMON, but there is no "good" way of getting Weak_Chain - to it. Note that Weak_Chain points to Old Space unless no weak - conses were found. - - This code should be reimplemented so it does not need to look at both - old and new space at the same time. Only the "real" garbage collector - should be allowed to do that. + Note that this is the only code in the system, besides the inner garbage + collector, which looks at both old and new space. */ void Fix_Weak_Chain() @@ -197,13 +194,25 @@ void Fix_Weak_Chain() *Scan = Temp; continue; + case GC_Special: + if (Type_Code(Temp) != TC_REFERENCE_TRAP) + { + /* No other special type makes sense here. */ + goto fail; + } + if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) + { + *Scan = Temp; + continue; + } + /* Otherwise, it is a pointer. Fall through */ + /* Normal pointer types, the broken heart is in the first word. Note that most special types are treated normally here. The BH code updates *Scan if the object has been relocated. Otherwise it falls through and we replace it with a full NIL. Eliminating this assignment would keep old data (pl. of datum). */ - case GC_Cell: case GC_Pair: case GC_Triple: @@ -228,9 +237,9 @@ void Fix_Weak_Chain() *Scan = NIL; continue; - case GC_Special: case GC_Undefined: default: /* Non Marked Headers and Broken Hearts */ + fail: fprintf(stderr, "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n", Type_Code(Temp), Datum(Temp)); @@ -321,11 +330,14 @@ void GC() return; } -/* (GARBAGE_COLLECT SLACK) - [Primitive number 0x3A] +/* (GARBAGE-COLLECT SLACK) Requests a garbage collection leaving the specified amount of slack for the top of heap check on the next GC. The primitive ends by invoking the GC daemon if there is one. + + This primitive never returns normally. It always escapes into + the interpreter because some of its cached registers (eg. History) + have changed. */ Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") @@ -334,8 +346,11 @@ Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") Arg_1_Type(TC_FIXNUM); if (Free > Heap_Top) - { fprintf(stderr, "\nGC has been delayed too long, and you are truly out of room!\n"); - fprintf(stderr, "Free=0x%x, MemTop=0x%x, Heap_Top=0x%x\n", Free, MemTop, Heap_Top); + { fprintf(stderr, + "\nGC has been delayed too long, and you are out of room!\n"); + fprintf(stderr, + "Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n", + Free, MemTop, Heap_Top); Microcode_Termination(TERM_NO_SPACE); } GC_Reserve = Get_Integer(Arg1); @@ -351,10 +366,14 @@ Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") MemTop, GC_Space_Needed); Microcode_Termination(TERM_NO_SPACE); } + Pop_Primitive_Frame(1); GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); if (GC_Daemon_Proc == NIL) - return FIXNUM_0 + (MemTop - Free); - Pop_Primitive_Frame(1); + { + Val = Make_Unsigned_Fixnum(MemTop - Free); + longjmp( *Back_To_Eval, PRIM_POP_RETURN); + /*NOTREACHED*/ + } Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1)); Store_Return(RC_NORMAL_GC_DONE); Store_Expression(FIXNUM_0 + (MemTop - Free)); diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index f3e6c6db3..b4be07519 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.20 1987/01/21 20:24:48 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.21 1987/04/03 00:18:15 jinx Exp $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -46,11 +46,9 @@ MIT in each case. */ #define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */ #define MAX_TYPE_CODE 0xFF /* ((1<= end_of_memory) || - scheme_string(via(From+SYMBOL_NAME), false)) + !scheme_string(via(From+SYMBOL_NAME), false)) printf("symbol not in memory; datum = %x\n", From); return; } @@ -153,59 +153,62 @@ long Location, Type, The_Datum; return; case TC_CHARACTER_STRING: scheme_string(Points_To, true); return; - case TC_EXTENDED_FIXNUM: printf("%d\n", The_Datum); - return; case TC_FIXNUM: printf("%d\n", Points_To); return; /* Default cases */ - case TC_LIST: printf("[CONS "); break; - case TC_WEAK_CONS: printf("[WEAK-CONS "); break; - case TC_SCODE_QUOTE: printf("[QUOTE "); break; - case TC_BIG_FLONUM: printf("[FLONUM "); break; - case TC_COMBINATION_1: printf( "[COMB-1 "); break; - case TC_EXTENDED_PROCEDURE: printf("[EPROCEDURE "); break; - case TC_COMBINATION_2: printf("[COMB-2 "); break; - case TC_BIG_FIXNUM: printf("[BIGNUM "); break; + case TC_LIST: printf("[LIST "); break; + case TC_CHARACTER: printf("[CHARACTER "); break; + case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break; + case TC_PCOMB2: printf("[PCOMB2 "); break; + case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break; + case TC_COMBINATION_1: printf("[COMBINATION-1 "); break; + case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break; + case TC_VECTOR: printf("[VECTOR "); break; + case TC_RETURN_CODE: printf("[RETURN-CODE "); break; + case TC_COMBINATION_2: printf("[COMBINATION-2 "); break; + case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break; + case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break; case TC_PROCEDURE: printf("[PROCEDURE "); break; - case TC_PRIMITIVE_EXTERNAL: printf("[EXTERNAL-PRIMITIVE "); break; + case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break; case TC_DELAY: printf("[DELAY "); break; + case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break; case TC_DELAYED: printf("[DELAYED "); break; - case TC_EXTENDED_LAMBDA: printf("[ELAMBDA "); break; + case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break; case TC_COMMENT: printf("[COMMENT "); break; case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break; case TC_LAMBDA: printf("[LAMBDA "); break; case TC_PRIMITIVE: printf("[PRIMITIVE "); break; - case TC_SEQUENCE_2: printf("[SEQ-2 "); break; - case TC_PCOMB1: printf("[PCOMB-1 "); break; + case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break; + case TC_PCOMB1: printf("[PCOMB1 "); break; + case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break; case TC_ACCESS: printf("[ACCESS "); break; case TC_DEFINITION: printf("[DEFINITION "); break; case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break; case TC_HUNK3: printf("[HUNK3 "); break; case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break; + case TC_COMBINATION: printf("[COMBINATION "); break; + case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break; case TC_LEXPR: printf("[LEXPR "); break; + case TC_PCOMB3: printf("[PCOMB3 "); break; + case TC_VARIABLE: printf("[VARIABLE "); break; - case TC_CONDITIONAL: printf("[CONDITIONAL "); break; - case TC_DISJUNCTION: printf("[DISJUNCTION "); break; - case TC_UNASSIGNED: printf("[UNASSIGNED "); break; - case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break; - case TC_CHARACTER: printf("[CHARACTER "); break; - case TC_PCOMB2: printf("[PCOMB-2 "); break; - case TC_VECTOR: printf("[VECTOR "); break; - case TC_RETURN_CODE: printf("[RETURN-CODE "); break; - case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break; - case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break; - case TC_COMBINATION: printf("[COMBINATION "); break; - case TC_PCOMB3: printf("[PCOMB-3 "); break; case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break; + case TC_FUTURE: printf("[FUTURE "); break; case TC_VECTOR_1B: printf("[VECTOR-1B "); break; - case TC_PCOMB0: printf("[PCOMB-0 "); break; + case TC_PCOMB0: printf("[PCOMB0 "); break; case TC_VECTOR_16B: printf("[VECTOR-16B "); break; + case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break; + case TC_CONDITIONAL: printf("[CONDITIONAL "); break; + case TC_DISJUNCTION: printf("[DISJUNCTION "); break; case TC_CELL: printf("[CELL "); break; - case TC_FUTURE: printf("[FUTURE "); break; - case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break; - case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break; + case TC_WEAK_CONS: printf("[WEAK-CONS "); break; + case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break; case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break; + case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break; + case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break; + case TC_COMPLEX: printf("[COMPLEX "); break; + case TC_QUAD: printf("[QUAD "); break; default: printf("[02x%x ", Type); break; } printf("%x]\n", Points_To); diff --git a/v7/src/microcode/prim.c b/v7/src/microcode/prim.c index 3b3e9823c..672035a94 100644 --- a/v7/src/microcode/prim.c +++ b/v7/src/microcode/prim.c @@ -30,36 +30,37 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.22 1987/02/03 15:59:58 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.23 1987/04/03 00:18:31 jinx Exp $ * - * The leftovers ... primitives that don't seem to belong elsewhere + * The leftovers ... primitives that don't seem to belong elsewhere. * */ #include "scheme.h" #include "primitive.h" -#include "prims.h" /* Random predicates: */ /* (NULL OBJECT) - [Primitive number 0x0C] Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is the primitive known as NOT, NIL?, and NULL? in Scheme. */ Built_In_Primitive(Prim_Null, 1, "NULL?") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Touch_In_Primitive(Arg1, Arg1); return (Arg1 == NIL) ? TRUTH : NIL; } /* (EQ? OBJECT-1 OBJECT-2) - [Primitive number 0x0D] - Returns #!TRUE if the two objects have the same type code, - address portion, and danger bit. Returns NIL otherwise. + Returns #!TRUE if the two objects have the same type code + and datum. Returns NIL otherwise. */ Built_In_Primitive(Prim_Eq, 2, "EQ?") -{ Primitive_2_Args(); +{ + Primitive_2_Args(); + if (Arg1 == Arg2) return TRUTH; Touch_In_Primitive(Arg1, Arg1); Touch_In_Primitive(Arg2, Arg2); @@ -68,74 +69,82 @@ Built_In_Primitive(Prim_Eq, 2, "EQ?") /* Pointer manipulation */ -/* (MAKE_NON_POINTER NUMBER) - [Primitive number 0xB1] +/* (MAKE-NON-POINTER NUMBER) Returns an (extended) fixnum with the same value as NUMBER. In the CScheme interpreter this is basically a no-op, since fixnums already store 24 bits. */ Built_In_Primitive(Prim_Make_Non_Pointer, 1, "MAKE-NON-POINTER") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Arg_1_Type(TC_FIXNUM); return Arg1; } -/* (PRIMITIVE_DATUM OBJECT) - [Primitive number 0xB0] - Returns the address part of OBJECT. +/* (PRIMITIVE-DATUM OBJECT) + Returns the datum part of OBJECT. */ Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + return Make_New_Pointer(TC_ADDRESS, Arg1); } /* (PRIMITIVE-TYPE OBJECT) - [Primitive number 0x10] - Returns the type code of OBJECT as a number. This includes the - danger bit, if it is set. THE OBJECT IS TOUCHED FIRST. + Returns the type code of OBJECT as a number. + Note: THE OBJECT IS TOUCHED FIRST. */ Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Touch_In_Primitive(Arg1, Arg1); - return FIXNUM_0+Type_Code(Arg1); + return Make_Unsigned_Fixnum(Type_Code(Arg1)); } /* (GC_TYPE OBJECT) - [Primitive number 0xBC] Returns a fixnum indicating the GC type of the object. The object is NOT touched first. */ Built_In_Primitive(Prim_Gc_Type, 1, "GC-TYPE") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + return Make_Non_Pointer(TC_FIXNUM, GC_Type(Arg1)); } /* (PRIMITIVE-TYPE? TYPE-CODE OBJECT) - [Primitive number 0x0F] Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL - otherwise. The check includes the danger bit of OBJECT. - THE OBJECT IS TOUCHED FIRST. + otherwise. + Note: THE OBJECT IS TOUCHED FIRST. */ Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?") -{ Primitive_2_Args(); +{ + Primitive_2_Args(); + Arg_1_Type(TC_FIXNUM); Touch_In_Primitive(Arg2, Arg2); - if (Type_Code(Arg2) == Get_Integer(Arg1)) return TRUTH; - else return NIL; + if (Type_Code(Arg2) == Get_Integer(Arg1)) + return TRUTH; + else + return NIL; } /* (PRIMITIVE-SET-TYPE TYPE-CODE OBJECT) - [Primitive number 0x11] - - Returns a new object with TYPE-CODE and the address part of - OBJECT. TOUCHES ITS SECOND ARGUMENT (for completeness sake). + Returns a new object with TYPE-CODE and the datum part of + OBJECT. + Note : IT TOUCHES ITS SECOND ARGUMENT (for completeness sake). This is a "gc-safe" (paranoid) operation. */ Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE") -{ long New_GC_Type, New_Type; +{ + long New_GC_Type, New_Type; Primitive_2_Args(); + Arg_1_Type(TC_FIXNUM); Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE); Touch_In_Primitive(Arg2, Arg2); @@ -145,289 +154,137 @@ Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE") return Make_New_Pointer(New_Type, Arg2); else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/ } + +/* Subprimitives. + Many primitives can be built out of these, and eventually should be. + These are extremely unsafe, since there is no consistency checking. + In particular, they are not gc-safe: You can screw yourself royally + by using them. +*/ /* (&MAKE-OBJECT TYPE-CODE OBJECT) - [Primitive number 0x8D] - - Makes a Scheme object whose datum field is the datum field of - OBJECT, and whose type code is TYPE-CODE. It does not touch, - and is not "gc-safe": You can screw yourself royally by using - this. + Makes a Scheme object whose datum field is the datum field of + OBJECT, and whose type code is TYPE-CODE. It does not touch. */ Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT") -{ long New_Type; +{ + long New_Type; Primitive_2_Args(); + Arg_1_Type(TC_FIXNUM); Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE); return Make_New_Pointer(New_Type, Arg2); } + +/* (SYSTEM-MEMORY-REF OBJECT INDEX) + Fetches the index'ed slot in object. + Performs no type checking in object. +*/ + +Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF") +{ + Primitive_2_Args(); + + Arg_2_Type(TC_FIXNUM); + return Vector_Ref(Arg1, Get_Integer(Arg2)); +} + +/* (SYSTEM-MEMORY-SET! OBJECT INDEX VALUE) + Stores value in the index'ed slot in object. + Performs no type checking in object. +*/ + +Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!") +{ + long index; + Primitive_3_Args(); + + Arg_2_Type(TC_FIXNUM); + index = Get_Integer(Arg2); + return Swap_Pointers(Nth_Vector_Loc(Arg1, index), Arg3); +} /* Playing with the danger bit */ /* (DANGEROUS? OBJECT) - [Primitive number 0x49] Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise. */ Built_In_Primitive(Prim_Dangerous_QM, 1, "DANGEROUS?") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + return (Dangerous(Arg1)) ? TRUTH : NIL; } -/* (DANGERIZE OBJECT) - [Primitive number 0x48] +/* (MAKE-OBJECT-DANGEROUS OBJECT) Returns OBJECT, but with the danger bit set. */ -Built_In_Primitive(Prim_Dangerize, 1, "DANGERIZE") -{ Primitive_1_Arg(); +Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS") +{ + Primitive_1_Arg(); + return Set_Danger_Bit(Arg1); } /* (UNDANGERIZE OBJECT) - [Primitive number 0x47] Returns OBJECT with the danger bit cleared. This does not side-effect the object, it merely returns a new (non-dangerous) pointer to the same item. */ Built_In_Primitive(Prim_Undangerize, 1, "UNDANGERIZE") -{ Primitive_1_Arg(); - return Clear_Danger_Bit(Arg1); -} - -/* Mapping between the internal and external representations of - primitives, return addresses, external primitives, etc. - */ - -/* (MAP_CODE_TO_ADDRESS TYPE-CODE VALUE-CODE) - [Primitive number 0x93] - For return codes and primitives, this returns the internal - representation of the return address or primitive address given - the external representation. Currently in CScheme these two are - the same. In the 68000 assembly version the internal - representation is an actual address in memory. -*/ -Built_In_Primitive(Prim_Map_Code_To_Address, 2, "MAP-CODE-TO-ADDRESS") -{ long Code, Offset; - Primitive_2_Args(); - Arg_1_Type(TC_FIXNUM); - Arg_2_Type(TC_FIXNUM); - Code = Get_Integer(Arg1); - Offset = Get_Integer(Arg2); - switch (Code) - { case TC_RETURN_CODE: - if (Offset > MAX_RETURN_CODE) Primitive_Error(ERR_ARG_2_BAD_RANGE); - break; - - case TC_PRIMITIVE: - if (Offset > MAX_PRIMITIVE) Primitive_Error(ERR_ARG_2_BAD_RANGE); - break; - - default: Primitive_Error(ERR_ARG_1_BAD_RANGE); - } - return Make_Non_Pointer(Code, Offset); -} - -/* (MAP_ADDRESS_TO_CODE TYPE-CODE ADDRESS) - [Primitive number 0x90] - This is the inverse operation for MAP_CODE_TO_ADDRESS. - Given a machine ADDRESS and a TYPE-CODE (either return code or - primitive) it finds the number for the external representation - for the internal address. -*/ -Built_In_Primitive(Prim_Map_Address_To_Code, 2, "MAP-ADDRESS-TO-CODE") -{ long Code, Offset; - Primitive_2_Args(); - Arg_1_Type(TC_FIXNUM); - Code = Get_Integer(Arg1); - Arg_2_Type(Code); - Offset = Get_Integer(Arg2); - switch (Code) - { case TC_RETURN_CODE: - if (Offset > MAX_RETURN_CODE) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - break; - - case TC_PRIMITIVE: - if (Offset > MAX_PRIMITIVE) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - break; - - default: - Primitive_Error(ERR_ARG_1_BAD_RANGE); - } - return FIXNUM_0+Offset; -} - -/* (MAP_PRIM_ADDRESS_TO_ARITY INTERNAL-PRIMITIVE) - [Primitive number 0x96] - Given the internal representation of a primitive (in CScheme the - internal and external representations are the same), return the - number of arguments it requires. -*/ -Built_In_Primitive(Prim_Map_Prim_Address_To_Arity, 1, - "PRIMITIVE-PROCEDURE-ARITY") -{ long Prim_Num; - Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_PRIMITIVE_EXTERNAL) - { Arg_1_Type(TC_PRIMITIVE); - Range_Check(Prim_Num, Arg1, 0, MAX_PRIMITIVE, ERR_ARG_1_BAD_RANGE); - return FIXNUM_0 + (int) Arg_Count_Table[Prim_Num]; - } - /* External primitives here */ - Prim_Num = Get_Integer(Arg1); - if (Prim_Num <= MAX_EXTERNAL_PRIMITIVE) - return FIXNUM_0 + Ext_Prim_Desc[Prim_Num].arity; - if (Undefined_Externals==NIL) Primitive_Error(ERR_ARG_1_BAD_RANGE); - if (Prim_Num > (MAX_EXTERNAL_PRIMITIVE+ - Get_Integer(User_Vector_Ref(Undefined_Externals, 0)))) - Primitive_Error(ERR_ARG_1_BAD_RANGE); - return NIL; -} - -/* Playing with non marked vectors. */ - -/* (NON_MARKED_VECTOR_CONS LENGTH) - [Primitive number 0x31] - Creates a non-marked vector of the specified LENGTH. The - contents of such a vector are not seen by the garbage collector. - There are no ordinary operations which can be performed on - non-marked vectors, but the SYS_VECTOR operations can be used - with care. [This primitive appears to be a relic of days gone - by.] -*/ -Built_In_Primitive(Prim_Non_Marked_Vector_Cons, 1, "NON-MARKED-VECTOR-CONS") -{ long Length; +{ Primitive_1_Arg(); - Arg_1_Type(TC_FIXNUM); - Length = Get_Integer(Arg1); - Primitive_GC_If_Needed(Length+1); - *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Length); - Free += Length+1; - return Make_Pointer(TC_NON_MARKED_VECTOR, Free-(Length+1)); -} - -/* (INSERT_NON_MARKED_VECTOR TO-GC-VECTOR N FROM-GC-VECTOR) - [Primitive number 0x19] - This primitive performs a side-effect on the TO-GC-VECTOR. Both - TO- and FROM-GC-VECTOR must be of the garbage collector type - vector (i.e. vectors, strings, non-marked vectors, bignums, - etc.). The FROM-GC-VECTOR is inserted in the middle of - TO-GC-VECTOR, preceded by a non-marked vector header. The - insertion begins at the Nth position of the vector with the - non-marked header. Notice that this is really an "overwrite" - rather than an insertion, since the length of the TO-GC-VECTOR - does not change and the data which was formerly in the part of - the vector now occupied by FROM-GC-VECTOR and its header has - been lost. This primitive was added for the use of certain - parts of the compiler and runtime system which need to make - objects that have an internal part which is "hidden" from the - garbage collector. The value returned is TO-GC-VECTOR. -*/ -Built_In_Primitive(Prim_Insert_Non_Marked_Vector, 3, - "INSERT-NON-MARKED-VECTOR!") -{ Pointer *To,*From; - long Index,NM_Length,Length,i; - Primitive_3_Args(); - Arg_1_GC_Type(GC_Vector); - Arg_2_Type(TC_FIXNUM); - Arg_3_GC_Type(GC_Vector); - Length = Vector_Length(Arg1); - NM_Length = Vector_Length(Arg3); - Range_Check(Index, Arg2, 0, Length-1, ERR_ARG_2_BAD_RANGE); - if (Length-Index <= NM_Length) - Primitive_Error(ERR_ARG_3_BAD_RANGE); - From = Nth_Vector_Loc(Arg3, VECTOR_TYPE); - To = Nth_Vector_Loc(Arg1, VECTOR_DATA+Index); - for (i=0; i<=NM_Length; i++) - *To++ = *From++; - return Arg1; + + return Clear_Danger_Bit(Arg1); } /* Cells */ /* (MAKE-CELL CONTENTS) - [Primitive number 0x61] Creates a cell with contents CONTENTS. */ Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Primitive_GC_If_Needed(1); *Free++ = Arg1; return Make_Pointer(TC_CELL, Free-1); } /* (CONTENTS CELL) - [Primitive number 0x62] Returns the contents of the cell CELL. */ Built_In_Primitive(Prim_Cell_Contents, 1, "CONTENTS") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Arg_1_Type(TC_CELL); return(Vector_Ref(Arg1, CELL_CONTENTS)); } /* (CELL? OBJECT) - [Primitive number 0x63] Returns #!TRUE if OBJECT has type-code CELL, otherwise returns NIL. */ Built_In_Primitive(Prim_Cell, 1,"CELL?") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Touch_In_Primitive(Arg1,Arg1); return (Type_Code(Arg1 == TC_CELL)) ? TRUTH : NIL; } /* (SET-CONTENTS! CELL VALUE) - [Primitive number 0x8C] Stores VALUE as contents of CELL. Returns (bad style to count on this) the previous contents of CELL. */ Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CONTENTS!") -{ Primitive_2_Args(); +{ + Primitive_2_Args(); + Arg_1_Type(TC_CELL); Side_Effect_Impurify(Arg1, Arg2); return Swap_Pointers(Nth_Vector_Loc(Arg1, CELL_CONTENTS), Arg2); } - -/* Multiprocessor scheduling primitive */ - -#ifndef butterfly -#ifdef COMPILE_FUTURES -Built_In_Primitive(Prim_Get_Work, 1, "GET-WORK") -{ Pointer The_Queue, Queue_Head, Result; - Primitive_1_Arg(); - - The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue); - if (The_Queue != NIL) Queue_Head = Vector_Ref(The_Queue, CONS_CAR); - if ((The_Queue==NIL) || (Queue_Head==NIL)) - if (Arg1 == NIL) - { printf("\nNo work available, but some has been requested!\n"); - Microcode_Termination(TERM_EXIT); - } - else - { Pop_Primitive_Frame(1); - Will_Push(2*(STACK_ENV_EXTRA_SLOTS+1) + 1 + CONTINUATION_SIZE); - Push(NIL); /* Upon return, no hope if there is no work */ - Push(Make_Non_Pointer(TC_PRIMITIVE, PC_GET_WORK)); - Push(STACK_FRAME_HEADER+1); - Store_Expression(NIL); - Store_Return(RC_INTERNAL_APPLY); - Save_Cont(); - Push(Arg1); - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - } - Result = Vector_Ref(Queue_Head, CONS_CAR); - Queue_Head = Vector_Ref(Queue_Head, CONS_CDR); - Vector_Set(The_Queue, CONS_CAR, Queue_Head); - if (Queue_Head==NIL) Vector_Set(The_Queue, CONS_CDR, NIL); - return Result; -} -#else /* #ifdef COMPILE_FUTURES */ -Built_In_Primitive(Prim_Get_Work, 1, "GET-WORK") -{ Primitive_1_Arg(); - Primitive_Error(ERR_UNDEFINED_PRIMITIVE); -} -#endif /* #ifdef COMPILE_FUTURES */ -#endif /* #ifndef butterfly */ diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index 7004b1931..6d992170d 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.20 1987/01/21 20:25:11 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.21 1987/04/03 00:18:49 jinx Exp $ */ /* This file contains some macros for defining primitives, for argument type or value checking, and for accessing @@ -58,26 +58,25 @@ Built_In_Primitive(C_Name, Number_of_args, Scheme_Name) \ #define Primitive_0_Args() -#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0);\ - Primitive_0_Args() +#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0) -#define Primitive_2_Args() fast Pointer Arg2 = Stack_Ref(1);\ - Primitive_1_Args() +#define Primitive_2_Args() Primitive_1_Args(); \ + fast Pointer Arg2 = Stack_Ref(1) -#define Primitive_3_Args() fast Pointer Arg3 = Stack_Ref(2);\ - Primitive_2_Args() +#define Primitive_3_Args() Primitive_2_Args(); \ + fast Pointer Arg3 = Stack_Ref(2) -#define Primitive_4_Args() fast Pointer Arg4 = Stack_Ref(3);\ - Primitive_3_Args() +#define Primitive_4_Args() Primitive_3_Args(); \ + fast Pointer Arg4 = Stack_Ref(3) -#define Primitive_5_Args() fast Pointer Arg5 = Stack_Ref(4);\ - Primitive_4_Args() +#define Primitive_5_Args() Primitive_4_Args(); \ + fast Pointer Arg5 = Stack_Ref(4) -#define Primitive_6_Args() fast Pointer Arg6 = Stack_Ref(5);\ - Primitive_5_Args() +#define Primitive_6_Args() Primitive_5_Args(); \ + fast Pointer Arg6 = Stack_Ref(5) -#define Primitive_7_Args() fast Pointer Arg7 = Stack_Ref(6);\ - Primitive_6_Args() +#define Primitive_7_Args() Primitive_6_Args(); \ + fast Pointer Arg7 = Stack_Ref(6) #define Primitive_1_Arg() Primitive_1_Args() diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index b18c92756..922352658 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.21 1987/01/22 14:13:43 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.22 1987/04/03 00:06:48 jinx Exp $ * * This File contains the code to translate portable format binary * files to internal format. @@ -350,22 +350,12 @@ fast Pointer *To; /* Align_Float(To); */ while (--N >= 0) { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum); - switch((The_Type) & SAFE_TYPE_MASK) + switch(The_Type) { case CONSTANT_CODE: - if (The_Type > MAX_SAFE_TYPE) - { *To = Constant_Table[The_Datum]; - Set_Danger_Bit(*To++); - continue; - } *To++ = Constant_Table[The_Datum]; continue; case HEAP_CODE: - if (The_Type > MAX_SAFE_TYPE) - { *To = Heap_Table[The_Datum]; - Set_Danger_Bit(*To++); - continue; - } *To++ = Heap_Table[The_Datum]; continue; @@ -395,6 +385,13 @@ fast Pointer *To; *To++ = Make_Non_Pointer(The_Type, The_Datum); continue; + case TC_REFERENCE_TRAP: + if (The_Datum <= TRAP_MAX_IMMEDIATE) + { + *To++ = Make_Non_Pointer(The_Type, The_Datum); + continue; + } + /* It is a pointer, fall through. */ default: /* Should be stricter */ *To++ = Make_Pointer(The_Type, Relocate(The_Datum)); @@ -500,6 +497,7 @@ long Read_Header_and_Allocate() Read_Flags(Flags); Size = (6 + /* SNMV */ + HEAP_BUFFER_SPACE + Heap_Count + Heap_Objects + Constant_Count + Constant_Objects + Pure_Count + Pure_Objects + @@ -515,7 +513,9 @@ long Read_Header_and_Allocate() Program_Name, Size); exit(1); } - return Size; + Heap += HEAP_BUFFER_SPACE; + Initial_Align_Float(Heap); + return (Size - HEAP_BUFFER_SPACE); } do_it() diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index 363466da8..be71edebf 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.24 1987/02/09 00:34:50 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.25 1987/04/03 00:19:30 jinx Exp $ * * This file contains the code that copies objects into pure * and constant space. @@ -64,7 +64,7 @@ Purify_Pointer(Setup_Pointer(false, Extra_Code)) #define Indirect_BH(In_GC) \ if (Type_Code(*Old) == TC_BROKEN_HEART) continue; -#define Transport_Indirect() \ +#define Transport_Vector_Indirect() \ Real_Transport_Vector(); \ *Get_Pointer(Temp) = New_Address @@ -108,27 +108,37 @@ int GC_Mode; /* PurifyLoop, continued */ + /* + Symbols, variables, and reference traps cannot be put into + pure space. The strings contained in the first two can, on the + other hand. + */ + + case TC_REFERENCE_TRAP: + if ((Datum(Temp) <= TRAP_MAX_IMMEDIATE) || (GC_Mode == PURE_COPY)) + { + /* It is a non pointer. */ + break; + } + goto purify_pair; + case TC_INTERNED_SYMBOL: case TC_UNINTERNED_SYMBOL: if (GC_Mode == PURE_COPY) { Temp = Vector_Ref(Temp, SYMBOL_NAME); Purify_Pointer(Setup_Internal(false, - Transport_Indirect(), + Transport_Vector_Indirect(), Indirect_BH(false))); } /* Fall through */ case_Fasdump_Pair: + purify_pair: Setup_Pointer_for_Purify(Transport_Pair()); case TC_WEAK_CONS: Setup_Pointer_for_Purify(Transport_Weak_Cons()); -/* Because variables no longer contain pointers (except for the symbol), - they are permitted into pure space now. */ - case TC_VARIABLE: - Setup_Pointer_for_Purify(Purify_Transport_Variable()); - case_Triple: Setup_Pointer_for_Purify(Transport_Triple()); @@ -136,10 +146,8 @@ int GC_Mode; /* PurifyLoop, continued */ -#ifdef QUADRUPLE case_Quadruple: Setup_Pointer_for_Purify(Transport_Quadruple()); -#endif /* No need to handle futures specially here, since PurifyLoop is always invoked after running GCLoop, which will have @@ -149,7 +157,13 @@ int GC_Mode; case TC_FUTURE: case TC_ENVIRONMENT: - if (GC_Mode == PURE_COPY) break; + if (GC_Mode == PURE_COPY) + { + /* This should actually do an indirect pair transport of + the procedure, at least. + */ + break; + } /* Fall through */ #ifndef FLOATING_ALIGNMENT case TC_BIG_FLONUM: @@ -330,7 +344,6 @@ Pointer Info; } /* (PRIMITIVE-PURIFY OBJECT PURE?) - [Primitive number 0xB4] Copy an object from the heap into constant space. This requires a spare heap, and is tricky to use -- it should only be used through the wrapper provided in the Scheme runtime system. @@ -345,13 +358,18 @@ Pointer Info; multiprocessor, this primitive uses the master-gc-loop and it should only be used as one would use master-gc-loop i.e. with everyone else halted. + + This primitive does not return normally. It always escapes into + the interpreter because some of its cached registers (eg. History) + have changed. */ Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY") -{ long Saved_Zone; - Pointer Object, Lost_Objects, Purify_Result; - +{ + long Saved_Zone; + Pointer Object, Lost_Objects, Purify_Result, Daemon; Primitive_2_Args(); + Save_Time_Zone(Zone_Purify); if ((Arg2 != TRUTH) && (Arg2 != NIL)) Primitive_Error(ERR_ARG_2_WRONG_TYPE); @@ -362,14 +380,19 @@ Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY") Touch_In_Primitive(Arg1, Object); Purify_Result = Purify(Object, Arg2); - if (Get_Fixed_Obj_Slot(GC_Daemon) == NIL) - return (Purify_Pass_2(Purify_Result)); Pop_Primitive_Frame(2); + Daemon = Get_Fixed_Obj_Slot(GC_Daemon); + if (Daemon == NIL) + { + Val = Purify_Pass_2(Purify_Result); + longjmp( *Back_To_Eval, PRIM_POP_RETURN); + /*NOTREACHED*/ + } Store_Expression(Purify_Result); Store_Return(RC_PURIFY_GC_1); Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1); Save_Cont(); - Push(Get_Fixed_Obj_Slot(GC_Daemon)); + Push(Daemon); Push(STACK_FRAME_HEADER); Pushed(); longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/ diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c index d86003abd..712bc2636 100644 --- a/v7/src/microcode/purutl.c +++ b/v7/src/microcode/purutl.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.26 1987/02/09 00:37:58 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.27 1987/04/03 00:19:50 jinx Exp $ */ /* Pure/Constant space utilities. */ @@ -121,7 +121,6 @@ Pointer Object; } /* (IMPURIFY OBJECT) - [Primitive number 0xBD] */ Built_In_Primitive(Prim_Impurify, 1, "IMPURIFY") { Pointer Result; @@ -166,7 +165,6 @@ fast Pointer *Obj_Address; } /* (PURE? OBJECT) - [Primitive number 0xBB] Returns #!TRUE if the object is pure (ie it doesn't point to any other object, or it is in a pure section of the constant space). */ @@ -186,7 +184,6 @@ Built_In_Primitive(Prim_Pure_P, 1, "PURE?") } /* (CONSTANT? OBJECT) - [Primitive number 0xBA] Returns #!TRUE if the object is in constant space or isn't a pointer. */ @@ -201,7 +198,6 @@ Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?") } /* (GET-NEXT-CONSTANT) - [Primitive number 0xE4] Returns the next free address in constant space. */ Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT") @@ -227,7 +223,7 @@ long nobjects; Pointer *result; dest = Free_Constant; - if (!Test_Pure_Space_Top(dest+nobjects+6)) + if (!Test_Pure_Space_Top(dest + nobjects + 6)) { fprintf(stderr, "copy_to_constant_space: Not enough constant space!\n"); Microcode_Termination(TERM_NO_SPACE); diff --git a/v7/src/microcode/scheme.h b/v7/src/microcode/scheme.h index fbebe1f4c..325446e61 100644 --- a/v7/src/microcode/scheme.h +++ b/v7/src/microcode/scheme.h @@ -30,26 +30,26 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.21 1987/01/22 14:31:48 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.22 1987/04/03 00:20:06 jinx Exp $ * * General declarations for the SCode interpreter. This * file is INCLUDED by others and contains declarations only. */ -/* "fast" is a register declaration if we aren't debugging code */ +/* Certain debuggers cannot really deal with variables in registers. + When debugging, NO_REGISTERS can be defined. +*/ -#ifdef ENABLE_DEBUGGING_TOOLS -#define Consistency_Check true +#ifdef NO_REGISTERS #define fast #else -#define Consistency_Check false #define fast register #endif -#ifdef noquick -#define quick +#ifdef ENABLE_DEBUGGING_TOOLS +#define Consistency_Check true #else -#define quick fast +#define Consistency_Check false #endif #ifdef COMPILE_STEPPER @@ -60,30 +60,29 @@ MIT in each case. */ #define forward extern /* For forward references */ +#include +#include + #include "config.h" /* Machine and OS configuration info */ -#include "bkpt.h" /* May shadow some defaults */ -#include "object.h" /* Scheme Object Representation */ -#include "scode.h" /* Scheme SCode Representation */ -#include "sdata.h" /* Scheme User Data Representation */ -#include "gc.h" /* Garbage Collector related macros */ -#include "history.h" /* History maintenance */ -#include "interpret.h" /* Macros for interpreter */ -#include "stack.h" /* Macros for stack (stacklet) manipulation */ -#include "futures.h" /* Support macros, etc. for FUTURE */ #include "types.h" /* Type code numbers */ +#include "const.h" /* Various named constants */ +#include "object.h" /* Scheme object representation */ +#include "gc.h" /* Garbage collector related macros */ +#include "scode.h" /* Scheme scode representation */ +#include "sdata.h" /* Scheme user data representation */ +#include "futures.h" /* Support macros, etc. for FUTURE */ #include "errors.h" /* Error code numbers */ #include "returns.h" /* Return code numbers */ -#include "const.h" /* Various named constants */ #include "fixobj.h" /* Format of fixed objects vector */ -#ifdef RENAME -#include "rename.c" /* Rename of identifiers for some compilers */ -#endif -#include -#include +#include "stack.h" /* Macros for stack (stacklet) manipulation */ +#include "history.h" /* History maintenance */ +#include "interpret.h" /* Macros for interpreter */ #ifdef butterfly #include "butterfly.h" #endif +#include "bkpt.h" /* Shadows some defaults */ #include "default.h" /* Defaults for various hooks. */ #include "extern.h" /* External declarations */ +#include "prim.h" /* Declarations for external primitives. */ diff --git a/v7/src/microcode/scode.h b/v7/src/microcode/scode.h index 098dc85ea..243fa65cb 100644 --- a/v7/src/microcode/scode.h +++ b/v7/src/microcode/scode.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.21 1987/01/22 14:31:54 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.22 1987/04/03 00:20:19 jinx Rel $ * * Format of the SCode representation of programs. Each of these * is described in terms of the slots in the data structure. @@ -56,7 +56,7 @@ MIT in each case. */ /* COMBINATIONS come in several formats */ -/* Non-primitive combinations are vector-like: */ +/* General combinations are vector-like: */ #define COMB_VECTOR_HEADER 0 #define COMB_FN_SLOT 1 #define COMB_ARG_1_SLOT 2 @@ -73,10 +73,7 @@ MIT in each case. */ #define COMMENT_EXPRESSION 0 #define COMMENT_TEXT 1 -/* COMPILED_CODE_ENTRY operation: */ -#define CCE_BYTE_ADDRESS 0 - -/* CONDITIONAL operation (used for COND, IF, CONJUNCTION): */ +/* CONDITIONAL operation (used for COND, IF, AND): */ #define COND_PREDICATE 0 #define COND_CONSEQUENT 1 #define COND_ALTERNATIVE 2 @@ -89,14 +86,68 @@ MIT in each case. */ #define DELAY_OBJECT 0 #define DELAY_UNUSED 1 -/* DISJUNCTION operation (formerly OR): */ +/* DISJUNCTION or OR operation: */ #define OR_PREDICATE 0 #define OR_ALTERNATIVE 1 +/* EXTENDED_LAMBDA operation: + * Support for optional parameters and auxiliary local variables. The + * Extended Lambda is similar to LAMBDA, except that it has an extra + * word called the ARG_COUNT. This contains an 8-bit count of the + * number of optional arguments, an 8-bit count of the number of + * required (formal) parameters, and a bit to indicate that additional + * (rest) arguments are allowed. The vector of argument names + * contains, of course, a size count which allows the calculation of + * the number of auxiliary variables required. Auxiliary variables + * are created for any internal DEFINEs which are found at syntax time + * in the body of a LAMBDA-like special form. + */ + +#define ELAMBDA_SCODE 0 +#define ELAMBDA_NAMES 1 +#define ELAMBDA_ARG_COUNT 2 + +/* Masks. The infomation on the number of each type of argument is + * separated at byte boundaries for easy extraction in the 68000 code. + */ + +#define EL_OPTS_MASK 0xFF +#define EL_FORMALS_MASK 0xFF00 +#define EL_REST_MASK 0x10000 +#define EL_FORMALS_SHIFT 8 +#define EL_REST_SHIFT 16 + +/* Selectors */ + +#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE)) +#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES)) +#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT)) +#define Elambda_Formals_Count(Addr) \ + ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT) +#define Elambda_Opts_Count(Addr) \ + (((long) Addr) & EL_OPTS_MASK) +#define Elambda_Rest_Flag(Addr) \ + ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT) + /* IN-PACKAGE operation: */ #define IN_PACKAGE_ENVIRONMENT 0 #define IN_PACKAGE_EXPRESSION 1 +/* LAMBDA operation: + * Object representing a LAMBDA expression with a fixed number of + * arguments. It consists of a list of the names of the arguments + * (the first is the name by which the procedure refers to itself) and + * the SCode for the procedure. + */ + +#define LAMBDA_SCODE 0 +#define LAMBDA_FORMALS 1 + +/* LEXPR + * Same as LAMBDA (q.v.) except additional arguments are permitted + * beyond those indicated in the LAMBDA_FORMALS list. + */ + /* Primitive combinations with 0 arguments are not pointers */ /* Primitive combinations, 1 argument: */ @@ -122,3 +173,17 @@ MIT in each case. */ #define SEQUENCE_1 0 #define SEQUENCE_2 1 #define SEQUENCE_3 2 + +/* VARIABLE operation. + * Corresponds to a variable lookup or variable reference. Contains the + * symbol referenced, and (if it has been compiled) the frame and + * offset in the frame in which it was found. One of these cells is + * multiplexed by having its type code indicate one of several modes + * of reference: not yet compiled, local reference, formal reference, + * auxiliary reference, or global value reference. + * There are extra definitions in lookup.h. + */ +#define VARIABLE_SYMBOL 0 +#define VARIABLE_FRAME_NO 1 +#define VARIABLE_OFFSET 2 +#define VARIABLE_COMPILED_TYPE 1 diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h index 8b3fbb773..b16d9d8d3 100644 --- a/v7/src/microcode/sdata.h +++ b/v7/src/microcode/sdata.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.21 1987/01/22 14:32:00 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.22 1987/04/03 00:20:33 jinx Exp $ * * Description of the user data objects. This should parallel the * file SDATA.SCM in the runtime system. @@ -152,61 +152,40 @@ MIT in each case. */ #define THUNK_VALUE 1 #define THUNK_ENVIRONMENT 0 #define THUNK_PROCEDURE 1 - + /* ENVIRONMENT - * Associates identifiers with values. The identifiers are either from - * a lambda-binding (as in a procedure call) or a run-time DEFINE (known - * as an 'auxilliary' binding). The environment contains three things: - * the list of identifiers which must be marked DANGEROUS if they are - * created in this environment (the 'potentially dangerous' list); the - * A-list associating auxilliary variables with their values; and the - * values of lambda-bound variables. The names of the lambda-bound - * variables are found by looking at the PROCEDURE which is stored in - * the first formal value slot. This will contain a LEXPR or LAMBDA - * object, which contains a list of names associated with the slots in - * the environment. Notice that the FINGER used in the process of - * constructing an environment frame is stored in the same place where - * the potentially dangerous variables will eventually go. - * - * There are actually 3 data structures which are used at distinct - * times to store an environment. A HEAP_ENVIRONMENT is the format - * used by the interpreter for a completely formed environment in - * which variable lookups will occur. A STACK_COMBINATION is the - * structure built on the stack to evaluate normal (long) - * combinations. It contains a slot for the finger and the - * combination whose operands are being evaluated. Only some of the - * argument slots in a stack-combination are meaningful: those which - * have already been evaluated (those not "hidden" by the finger). - * Finally, a STACK_ENVIRONMENT is the format used at Internal_Apply - * just as an application is about to occur. This does NOT have slots - * for auxilliary variables or the potentially dangerous list, since - * primitives, compiled code, and control points don't need these - * slots. + * Associates identifiers with values. + * The identifiers are either from a lambda-binding (as in a procedure + * call) or a incremental (run-time) DEFINE (known as an 'auxilliary' + * binding). + * When an environment frame is created, it only contains lambda + * bindings. If incremental defines are performed in it or its + * children, it acquires an extension which contains a list of the + * auxiliary bindings. Some of these bindings are fictitious in that + * their only purpose is to make the real bindings (if and when they + * occur) become automatically dangerous. Bindings become dangerous + * when they are shadowed by incremental bindings in children frames. + * Besides the lambda bindings, an environment frame contains a + * pointer to the procedure which created it. It is through this + * procedure that the parent frame is found. * - * The "life cycle" of an environment is: (a) it is born on the stack - * during the evaluation of a COMBINATION as a STACK_COMBINATION; (b) - * when all of the operands and the operator have been evaluated and - * stored into this frame, the finger is removed and the function - * is stored ... the result is a STACK_ENVIRONMENT; (c) finally, if - * the operator is an interpreted procedure, the frame has is copied - * onto the heap as a HEAP_ENVIRONMENT (i.e. by adding the two missing - * slots). For the optimized combinations (COMBINATION-1, 2, 3 and - * PCOMB0, 1, 2, 3), the STACK_ENVIRONMENT is used directly, without - * ever creating a STACK_COMBINATION. + * An environment frame has three distinct stages in its formation: + * - A STACK_COMBINATION is the structure built on the stack to + * evaluate normal (long) combinations. It contains a slot for the + * finger and the combination whose operands are being evaluated. + * Only some of the argument slots in a stack-combination are + * meaningful: those which have already been evaluated (those not + * "hidden" by the finger). This is the first stage. + * - A STACK_ENVIRONMENT is the format used at Internal_Apply + * just as an application is about to occur. + * - An ENVIRONMENT is a real environment frame, containing + * associations between names and values. It is the final stage, and + * corresponds to the structure described above. */ -/* ENVIRONMENT, continued */ - -#define HEAP_ENV_EXTRA_SLOTS 3 - /* Slots over and above those used to store - function (procedure) and its arguments in - a HEAP environment */ - -#define HEAP_ENV_HEADER 0 -#define HEAP_ENV_AUX_SLOT 1 -#define HEAP_ENV_P_DANGER 2 -#define HEAP_ENV_FUNCTION 3 -#define HEAP_ENV_FIRST_ARG 4 +#define ENVIRONMENT_HEADER 0 +#define ENVIRONMENT_FUNCTION 1 +#define ENVIRONMENT_FIRST_ARG 2 #define STACK_ENV_EXTRA_SLOTS 1 #define STACK_ENV_HEADER 0 @@ -224,40 +203,34 @@ MIT in each case. */ #define GO_TO_GLOBAL 0 #define END_OF_CHAIN 1 -/* EXTENDED_FIXNUM - * Not used in the C version. On the 68000 this is used for 24-bit - * integers, while FIXNUM is used for 16-bit integers. - */ - -/* EXTENDED_LAMBDA - * Support for optional parameters and auxiliary local variables. The - * Extended Lambda is similar to LAMBDA, except that it has an extra - * word called the ARG_COUNT. This contains an 8-bit count of the - * number of optional arguments, an 8-bit count of the number of - * required (formal) parameters, and a bit to indicate that additional - * (rest) arguments are allowed. The vector of argument names - * contains, of course, a size count which allows the calculation of - * the number of auxiliary variables required. Auxiliary variables - * are created for any internal DEFINEs which are found at syntax time - * in the body of a LAMBDA-like special form. - */ +/* Environment extension objects: -#define ELAMBDA_SCODE 0 -#define ELAMBDA_NAMES 1 -#define ELAMBDA_ARG_COUNT 2 + These objects replace the procedure in environment frames when an + aux slot is desired. The parent frame is copied into the extension + so that the "compiled" lookup code does not have to check whether + the frame has been extended or not. -/* Masks. The infomation on the number of each type of argument is - * separated at byte boundaries for easy extraction in the 68000 code. + Note that for the code to work, ENVIRONMENT_EXTENSION_PARENT_FRAME + must be equal to PROCEDURE_ENVIRONMENT. + + The following constants are implicitely hard-coded in lookup.c, + where a new extension object is consed in extend_frame. */ -#define EL_OPTS_MASK 0xFF -#define EL_FORMALS_MASK 0xFF00 -#define EL_REST_MASK 0x10000 -#define EL_FORMALS_SHIFT 8 -#define EL_REST_SHIFT 16 +#define ENVIRONMENT_EXTENSION_HEADER 0 +#define ENVIRONMENT_EXTENSION_PARENT_FRAME 1 +#define ENVIRONMENT_EXTENSION_PROCEDURE 2 +#define ENVIRONMENT_EXTENSION_COUNT 3 +#define ENVIRONMENT_EXTENSION_MIN_SIZE 4 + +/* EXTENDED_FIXNUM + * Not used in the C version. On the 68000 this is used for 24-bit + * integers, while FIXNUM is used for 16-bit integers. + */ /* EXTENDED_PROCEDURE - * Counterpart to EXTENDED_LAMBDA. Same format as PROCEDURE. + * Type of procedure created by evaluation of EXTENDED_LAMBDA. + * It's fields are the same as those for PROCEDURE. */ /* FALSE @@ -275,37 +248,17 @@ MIT in each case. */ #define HUNK_CXR0 0 #define HUNK_CXR1 1 #define HUNK_CXR2 2 - + /* INTERNED_SYMBOL - * A symbol, such as the result of evaluating (QUOTE A). Some important - * properties of symbols are that they have a print name, and may be - * 'interned' so that all instances of a symbol with the same name share - * a unique object. The storage pointed to by a symbol includes both - * the print name (a string) and the value associated with a variable of - * that name in the global environment. In looking for the value of a - * variable in the global environment, the dangerous and potentially - * dangerous bits are stored in the dangerous bits of these two cells as - * indicated below. + * A symbol, such as the result of evaluating (QUOTE A). Some + * important properties of symbols are that they have a print name, + * and may be 'interned' so that all instances of a symbol with the + * same name share a unique object. The storage pointed to by a + * symbol includes both the print name (a string) and the value cell + * associated with a variable of that name in the global environment. */ #define SYMBOL_NAME 0 #define SYMBOL_GLOBAL_VALUE 1 -#define GLOBAL_P_DANGER 0 -#define GLOBAL_DANGER 1 - -/* LAMBDA - * Object representing a LAMBDA expression with a fixed number of - * arguments. It consists of a list of the names of the arguments - * (the first is the name by which the procedure refers to itself) and - * the SCode for the procedure. - */ - -#define LAMBDA_SCODE 0 -#define LAMBDA_FORMALS 1 - -/* LEXPR - * Same as LAMBDA (q.v.) except additional arguments are permitted - * beyond those indicated in the LAMBDA_FORMALS list. - */ /* LIST * Ordinary CONS cell as supplied to a user. Perhaps this data type is @@ -369,6 +322,17 @@ MIT in each case. */ #define PROCEDURE_LAMBDA_EXPR 0 #define PROCEDURE_ENVIRONMENT 1 +/* 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. + */ + +#define TRAP_TAG 0 +#define TRAP_EXTRA 1 + /* RETURN_CODE * Represents an address where computation is to continue. These can be * thought of as states in a finite state machine, labels in an assembly @@ -411,54 +375,16 @@ MIT in each case. */ #define TRANSLATE_TO_POINT 2 #define TRANSLATE_TO_DISTANCE 3 -/* TRAP - * Trap-on-reference object. Used as a placeholder for a variable's value - * when special action must be taken at lookup time. Used to implement - * fluid variables, active values, etc. - */ - -#define TRAP_TAG 0 /* NIL => fluid variable - else handler procedure */ -#define TRAP_DEFAULT 1 /* Default value of this slot */ -#define TRAP_FROB 2 /* For user supplied handlers */ -#define TRAP_SIZE 3 - /* TRUE * The initial binding of the variable T is to an object of this type. * This type is the beginnings of a possible move toward a system where * predicates check for TRUE / FALSE rather than not-NULL / NULL. */ -/* UNASSIGNED - * There are two objects made with a data type of UNASSIGNED. The first - * (called the "unassigned object") is a value stored in an environment - * to indicate that a variable is lambda-bound in that environment but - * does not yet have an initial value. The second (called the "unbound - * object") is stored in the global value slot of a value when it is - * created, and will therefore be returned when a variable is referenced - * in an environment where there are no bindings for it. The numbers - * here show the data parts corresponding to the two interpretations. - */ - -#define UNASSIGNED 0 -#define UNBOUND 1 - /* UNINTERNED_SYMBOL * This indicates that the object is in the format of an INTERNED_SYMBOL * but is not interned. */ - -/* VARIABLE - * Variable reference. Contains the symbol referenced, and (if it has - * been compiled) the frame and offset in the frame in which it was - * found. One of these cells is multiplexed by having its type code - * indicate one of four modes of reference: not yet compiled, local - * (formal) reference, auxiliary reference, or global value reference - */ -#define VARIABLE_SYMBOL 0 -#define VARIABLE_FRAME_NO 1 -#define VARIABLE_OFFSET 2 -#define VARIABLE_COMPILED_TYPE 1 /* VECTOR * A group of contiguous cells with a header (of type MANIFEST_VECTOR) diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c index a5e8562fe..e0dee4ece 100644 --- a/v7/src/microcode/storage.c +++ b/v7/src/microcode/storage.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.26 1987/03/12 17:45:52 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.27 1987/04/03 00:20:53 jinx Exp $ This file defines the storage for global variables for the Scheme Interpreter. */ @@ -44,34 +44,30 @@ the Scheme Interpreter. */ /*************/ Pointer - Env, /* The environment */ - Val, /* The value returned from primitives or apply */ - Return, /* The return address code */ - Expression, /* Expression to EVALuate */ - *History, /* History register */ + *Ext_History, /* History register */ *Free, /* Next free word in storage */ *MemTop, /* Top of free space available */ - *Stack_Pointer, /* Next available slot in control stack */ + *Ext_Stack_Pointer, /* Next available slot in control stack */ *Stack_Top, /* Top of control stack */ *Stack_Guard, /* Guard area at end of stack */ *Free_Stacklets, /* Free list of stacklets */ *Constant_Space, /* Bottom of constant+pure space */ *Free_Constant, /* Next free cell in constant+pure area */ - *Unused_Heap_Top, *Unused_Heap, - /* Top and bottom of 'other' heap for GC */ - *Heap_Top, *Heap_Bottom, /* Top and bottom of current heap area */ + *Heap_Top, /* Top of current heap */ + *Heap_Bottom, /* Bottom of current heap */ + *Unused_Heap_Top, /* Top of other heap */ + *Unused_Heap, /* Bottom of other heap */ *Local_Heap_Base, /* Per-processor CONSing area */ *Heap, /* Bottom of entire heap */ - Swap_Temp, /* Used by Swap_Pointers in default.h */ - Lookup_Base, /* Slot lookup returns result here */ - Fluid_Bindings=NIL, /* Fluid bindings AList */ - Current_State_Point=NIL, /* Used by dynamic winder */ - return_to_interpreter, /* Return address/code left by interpreter - when calling compiled code */ - *last_return_code; /* Address of the most recent return code in the stack. + Current_State_Point = NIL, /* Used by dynamic winder */ + Fluid_Bindings = NIL, /* Fluid bindings AList */ + return_to_interpreter, /* Return address/code left by interpreter + when calling compiled code */ + *last_return_code, /* Address of the most recent return code in the stack. This is only meaningful while in compiled code. *** This must be changed when stacklets are used. *** */ + Swap_Temp; /* Used by Swap_Pointers in default.h */ long IntCode, /* Interrupts requesting */ IntEnb, /* Interrupts enabled */ @@ -298,30 +294,30 @@ char Arg_Count_Table[] = { /* 081 */ (char) 2, /* GREATER-THAN-FIXNUM? */ /* 082 */ (char) 2, /* GREATER-THAN-BIGNUM? */ /* 083 */ (char) 1, /* STRING-HASH */ -/* 084 */ (char) 3, /* Sys-PAIR-CONS */ -/* 085 */ (char) 1, /* Sys-PAIR? */ -/* 086 */ (char) 1, /* Sys-PAIR-CAR */ -/* 087 */ (char) 1, /* Sys-PAIR-CDR */ -/* 088 */ (char) 2, /* Sys-PAIR-SET!-CAR */ -/* 089 */ (char) 2, /* Sys-PAIR-SET!-CDR */ +/* 084 */ (char) 3, /* SYS-PAIR-CONS */ +/* 085 */ (char) 1, /* SYS-PAIR? */ +/* 086 */ (char) 1, /* SYS-PAIR-CAR */ +/* 087 */ (char) 1, /* SYS-PAIR-CDR */ +/* 088 */ (char) 2, /* SYS-PAIR-SET!-CAR */ +/* 089 */ (char) 2, /* SYS-PAIR-SET!-CDR */ /* 08A */ (char) 0, /* unused */ /* 08B */ (char) 0, /* unused */ /* 08C */ (char) 2, /* SET-CONTENTS! */ /* 08D */ (char) 2, /* &MAKE-OBJECT */ -/* 08E */ (char) 1, /* Sys-HUNK3-CXR0 */ -/* 08F */ (char) 2, /* Sys-HUNK3-SET!-CXR0 */ +/* 08E */ (char) 1, /* SYSTEM-HUNK3-CXR0 */ +/* 08F */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR0 */ /* 090 */ (char) 2, /* MAP-MACHINE-ADDRESS-TO-CODE */ -/* 091 */ (char) 1, /* Sys-HUNK3-CXR1 */ -/* 092 */ (char) 2, /* Sys-HUNK3-SET!-CXR1 */ +/* 091 */ (char) 1, /* SYSTEM-HUNK3-CXR1 */ +/* 092 */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR1 */ /* 093 */ (char) 2, /* MAP-CODE-TO-MACHINE-ADDRESS */ -/* 094 */ (char) 1, /* Sys-HUNK3-CXR2 */ -/* 095 */ (char) 2, /* Sys-HUNK3-SET!-CXR2 */ +/* 094 */ (char) 1, /* SYSTEM-HUNK3-CXR2 */ +/* 095 */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR2 */ /* 096 */ (char) 1, /* MAP-PRIMITIVE-ADDRESS-TO-ARITY */ -/* 097 */ (char) 2, /* Sys-LIST-TO-VECTOR */ -/* 098 */ (char) 3, /* Sys-SUBVECTOR-TO-LIST */ -/* 099 */ (char) 1, /* Sys-VECTOR? */ -/* 09A */ (char) 2, /* Sys-VECTOR-REF */ -/* 09B */ (char) 3, /* Sys-VECTOR-SET! */ +/* 097 */ (char) 2, /* SYSTEM-LIST->VECTOR */ +/* 098 */ (char) 3, /* SYSTEM-SUBVECTOR->LIST */ +/* 099 */ (char) 1, /* SYSTEM-VECTOR? */ +/* 09A */ (char) 2, /* SYSTEM-VECTOR-REF */ +/* 09B */ (char) 3, /* SYSTEM-VECTOR-SET! */ /* 09C */ (char) 1, /* WITH-HISTORY-DISABLED */ /* 09D */ (char) 0, /* unused */ /* 09E */ (char) 0, /* unused */ @@ -586,8 +582,8 @@ char Arg_Count_Table[] = { /* 192 */ (char) 0, /* RE-MATCH */ /* 193 */ (char) 0, /* RE-SEARCH-FORWARD */ /* 194 */ (char) 0, /* RE-SEARCH-BACKWARD */ -/* 195 */ (char) 0, /* SYS-MEMORY-REF */ -/* 196 */ (char) 0, /* SYS-MEMORY-SET */ +/* 195 */ (char) 2, /* SYS-MEMORY-REF */ +/* 196 */ (char) 3, /* SYS-MEMORY-SET! */ /* 197 */ (char) 2, /* BIT-STRING-FILL-X */ /* 198 */ (char) 2, /* BIT-STRING-MOVE-X */ /* 199 */ (char) 2, /* BIT-STRING-MOVEC-X */ @@ -739,7 +735,9 @@ extern Pointer Prim_Sys_Set_Cdr(), Prim_Sys_Subvector_To_List(), Prim_Sys_Vector(), Prim_Sys_Vector_Ref(), Prim_Sys_Vec_Set(), Prim_Sys_Vec_Size(), - Prim_System_Clock(), Prim_Temp_Printer(), + Prim_System_Clock(), + Prim_System_Memory_Ref(), Prim_System_Memory_Set(), + Prim_Temp_Printer(), Prim_Translate_File(), Prim_Translate_To_Point(), Prim_Truncate(), Prim_Truncate_Flonum(), Prim_Truncate_String(), Prim_Unassigned_Test(), Prim_Unbound_Test(), @@ -810,7 +808,7 @@ extern Pointer Prim_Tty_Write_Byte(), Prim_File_Read_Byte(), Prim_File_Write_Byte(), -#if 0 +#if false Prim_And_Gcd(), Prim_Save_Screen(), Prim_Restore_Screen(), @@ -829,20 +827,6 @@ extern Pointer Prim_Char_To_Syntax_Code(), Prim_Quoted_Char_P(), Prim_Microcode_Tables_Filename(), -#if 0 - Prim_Find_Pascal_Program(), - Prim_Execute_Pascal_Program(), - Prim_Graphics_Move(), - Prim_Graphics_Line(), - Prim_Graphics_Pixel(), - Prim_Graphics_Set_Drawing_Mode(), - Prim_Alpha_Raster_P(), - Prim_Toggle_Alpha_Raster(), - Prim_Graphics_Raster_P(), - Prim_Toggle_Graphics_Raster(), - Prim_Graphics_Clear(), - Prim_Graphics_Set_Line_Style(), -#endif Prim_Error_Procedure(), Prim_Volume_Exists_P(), Prim_Re_Char_Set_Adjoin(), @@ -850,8 +834,6 @@ extern Pointer Prim_Re_Match(), Prim_Re_Search_Forward(), Prim_Re_Search_Backward(), - Prim_Sys_Memory_Ref(), - Prim_Sys_Memory_Set(), /* new directory access primitives */ Prim_working_directory_pathname(), @@ -1315,8 +1297,8 @@ Pointer (*(Primitive_Table[]))() = { /* 192 */ Prim_Re_Match, /* 193 */ Prim_Re_Search_Forward, /* 194 */ Prim_Re_Search_Backward, -/* 195 */ Prim_Sys_Memory_Ref, -/* 196 */ Prim_Sys_Memory_Set, +/* 195 */ Prim_System_Memory_Ref, +/* 196 */ Prim_System_Memory_Set, /* 197 */ Prim_bit_string_fill_x, /* 198 */ Prim_bit_string_move_x, /* 199 */ Prim_bit_string_movec_x, @@ -1351,7 +1333,7 @@ char *Primitive_Names[] = { /* 0x05 in hooks */ "APPLY", /* 0x06 in hooks */ "SET-INTERRUPT-ENABLES!", /* 0x07 in fasload */ "STRING->SYMBOL", -/* 0x08 in prim */ "GET-WORK", +/* 0x08 in random */ "GET-WORK", /* 0x09 in hooks */ "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", /* 0x0A in hooks */ "CURRENT-DYNAMIC-STATE", /* 0x0B in hooks */ "SET-CURRENT-DYNAMIC-STATE!", @@ -1368,7 +1350,7 @@ char *Primitive_Names[] = { /* 0x16 in sysprim */ "EXIT", /* 0x17 in character */ "CHAR-CODE", /* 0x18 in lookup */ "LEXICAL-UNASSIGNED?", -/* 0x19 in prim */ "INSERT-NON-MARKED-VECTOR!", +/* 0x19 in random */ "INSERT-NON-MARKED-VECTOR!", /* 0x1A in sysprim */ "HALT", /* 0x1B in character */ "CHAR->INTEGER", /* 0x1C in list */ "MEMQ", @@ -1397,7 +1379,7 @@ char *Primitive_Names[] = { /* 0x2E in vector */ "VECTOR-REF", /* 0x2F in hooks */ "SET-CURRENT-HISTORY!", /* 0x30 in vector */ "VECTOR-SET!", -/* 0x31 in prim */ "NON-MARKED-VECTOR-CONS", +/* 0x31 in random */ "NON-MARKED-VECTOR-CONS", /* 0x32 not here */ No_Name, /* 0x33 in lookup */ "LEXICAL-UNBOUND?", /* 0x34 in character */ "INTEGER->CHAR", @@ -1502,13 +1484,13 @@ char *Primitive_Names[] = { /* 0x8D in prim */ "&MAKE-OBJECT", /* 0x8E in hunk */ "SYSTEM-HUNK3-CXR0", /* 0x8F in hunk */ "SYSTEM-HUNK3-SET-CXR0!", -/* 0x90 in prim */ "MAP-MACHINE-ADDRESS-TO-CODE", +/* 0x90 in random */ "MAP-MACHINE-ADDRESS-TO-CODE", /* 0x91 in hunk */ "SYSTEM-HUNK3-CXR1", /* 0x92 in hunk */ "SYSTEM-HUNK3-SET-CXR1!", -/* 0x93 in prim */ "MAP-CODE-TO-MACHINE-ADDRESS", +/* 0x93 in random */ "MAP-CODE-TO-MACHINE-ADDRESS", /* 0x94 in hunk */ "SYSTEM-HUNK3-CXR2", /* 0x95 in hunk */ "SYSTEM-HUNK3-SET-CXR2!", -/* 0x96 in prim */ "PRIMITIVE-PROCEDURE-ARITY", +/* 0x96 in random */ "PRIMITIVE-PROCEDURE-ARITY", /* 0x97 in vector */ "SYSTEM-LIST-TO-VECTOR", /* 0x98 in vector */ "SYSTEM-SUBVECTOR-TO-LIST", /* 0x99 in vector */ "SYSTEM-VECTOR?", @@ -1573,10 +1555,10 @@ char *Primitive_Names[] = { /* 0xCA in step */ "PRIMITIVE-EVAL-STEP", /* 0xCB in step */ "PRIMITIVE-APPLY-STEP", /* 0xCC in step */ "PRIMITIVE-RETURN-STEP", -/* 0xCD in console */ "TTY-READ-CHAR-READY?", -/* 0xCE in console */ "TTY-READ-CHAR", -/* 0xCF in console */ "TTY-READ-CHAR-IMMEDIATE", -/* 0xD0 in console */ "TTY-READ-FINISH", +/* 0xCD in ttyio */ "TTY-READ-CHAR-READY?", +/* 0xCE in ttyio */ "TTY-READ-CHAR", +/* 0xCF in ttyio */ "TTY-READ-CHAR-IMMEDIATE", +/* 0xD0 in ttyio */ "TTY-READ-FINISH", /* 0xD1 in bitstr */ "BIT-STRING-ALLOCATE", /* 0xD2 in bitstr */ "MAKE-BIT-STRING", /* 0xD3 in bitstr */ "BIT-STRING?", @@ -1626,10 +1608,10 @@ char *Primitive_Names[] = { /* 0xFA in generic */ "SIN", /* 0xFB in generic */ "COS", /* 0xFC in generic */ "&ATAN", -/* 0xFD in console */ "TTY-WRITE-CHAR", -/* 0xFE in console */ "TTY-WRITE-STRING", -/* 0xFF in console */ "TTY-BEEP", -/* 0x100 in console */ "TTY-CLEAR", +/* 0xFD in ttyio */ "TTY-WRITE-CHAR", +/* 0xFE in ttyio */ "TTY-WRITE-STRING", +/* 0xFF in ttyio */ "TTY-BEEP", +/* 0x100 in ttyio */ "TTY-CLEAR", /* 0x101 in extern */ "GET-EXTERNAL-COUNTS", /* 0x102 in extern */ "GET-EXTERNAL-NAME", /* 0x103 in extern */ "GET-EXTERNAL-NUMBER", @@ -1782,8 +1764,8 @@ char *Primitive_Names[] = { /* 0x192 in nihil */ "RE-MATCH", /* 0x193 in nihil */ "RE-SEARCH-FORWARD", /* 0x194 in nihil */ "RE-SEARCH-BACKWARD", -/* 0x195 in nihil */ "SYSTEM-MEMORY-REF", -/* 0x196 in nihil */ "SYSTEM-MEMORY-SET!", +/* 0x195 in prim */ "SYSTEM-MEMORY-REF", +/* 0x196 in prim */ "SYSTEM-MEMORY-SET!", /* 0x197 in bitstr */ "BIT-STRING-FILL!", /* 0x198 in bitstr */ "BIT-STRING-MOVE!", /* 0x199 in bitstr */ "BIT-STRING-MOVEC!", diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h index 8567683bd..d62337e32 100644 --- a/v7/src/microcode/types.h +++ b/v7/src/microcode/types.h @@ -30,35 +30,31 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.21 1987/01/22 14:34:14 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $ * * Type code definitions, numerical order * */ #define TC_NULL 0x00 -#define TC_FALSE 0x00 -#define TC_MANIFEST_VECTOR 0x00 -#define GLOBAL_ENV 0x00 - #define TC_LIST 0x01 #define TC_CHARACTER 0x02 #define TC_SCODE_QUOTE 0x03 -#define TC_PCOMB2 0x04 /* Was 0x44 */ +#define TC_PCOMB2 0x04 #define TC_UNINTERNED_SYMBOL 0x05 #define TC_BIG_FLONUM 0x06 #define TC_COMBINATION_1 0x07 #define TC_TRUE 0x08 #define TC_EXTENDED_PROCEDURE 0x09 -#define TC_VECTOR 0x0A /* Was 0x46 */ -#define TC_RETURN_CODE 0x0B /* Was 0x48 */ +#define TC_VECTOR 0x0A +#define TC_RETURN_CODE 0x0B #define TC_COMBINATION_2 0x0C -#define TC_COMPILED_PROCEDURE 0x0D /* Was 0x49 */ +#define TC_COMPILED_PROCEDURE 0x0D #define TC_BIG_FIXNUM 0x0E #define TC_PROCEDURE 0x0F #define TC_PRIMITIVE_EXTERNAL 0x10 #define TC_DELAY 0x11 -#define TC_ENVIRONMENT 0x12 /* Was 0x4E */ +#define TC_ENVIRONMENT 0x12 #define TC_DELAYED 0x13 #define TC_EXTENDED_LAMBDA 0x14 #define TC_COMMENT 0x15 @@ -67,54 +63,49 @@ MIT in each case. */ #define TC_PRIMITIVE 0x18 #define TC_SEQUENCE_2 0x19 -#define TC_FIXNUM 0x1A /* Was 0x50 */ -#define TC_ADDRESS 0x1A - /* Notice that TC_FIXNUM and TC_ADDRESS are the same */ +#define TC_FIXNUM 0x1A #define TC_PCOMB1 0x1B -#define TC_CONTROL_POINT 0x1C /* Was 0x56 */ +#define TC_CONTROL_POINT 0x1C #define TC_INTERNED_SYMBOL 0x1D #define TC_CHARACTER_STRING 0x1E -#define TC_VECTOR_8B 0x1E - /* VECTOR_8B and STRING are the same */ #define TC_ACCESS 0x1F -#define TC_EXTENDED_FIXNUM 0x20 /* Not used */ +/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */ #define TC_DEFINITION 0x21 -#define TC_BROKEN_HEART 0x22 /* Was 0x58 */ +#define TC_BROKEN_HEART 0x22 #define TC_ASSIGNMENT 0x23 #define TC_HUNK3 0x24 #define TC_IN_PACKAGE 0x25 -#define TC_COMBINATION 0x26 /* Was 0x5E */ -#define TC_MANIFEST_NM_VECTOR 0x27 /* Was 0x60 */ +#define TC_COMBINATION 0x26 +#define TC_MANIFEST_NM_VECTOR 0x27 #define TC_COMPILED_EXPRESSION 0x28 #define TC_LEXPR 0x29 -#define TC_PCOMB3 0x2A /* Was 0x66 */ -#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B /* Was 0x68 */ +#define TC_PCOMB3 0x2A +#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B #define TC_VARIABLE 0x2C -#define TC_THE_ENVIRONMENT 0x2D /* Was 0x70 */ +#define TC_THE_ENVIRONMENT 0x2D #define TC_FUTURE 0x2E -#define TC_VECTOR_1B 0x2F /* Was 0x76 */ -#define TC_BIT_STRING 0x2F /* Was 0x76 */ - /* Notice TC_VECTOR_1B and TC_BIT_STRING are the same */ -#define TC_PCOMB0 0x30 /* Was 0x78 */ -#define TC_VECTOR_16B 0x31 /* Was 0x7E */ -#define TC_UNASSIGNED 0x32 /* Was 0x38 */ -#define TC_SEQUENCE_3 0x33 /* Was 0x3C */ +#define TC_VECTOR_1B 0x2F +#define TC_PCOMB0 0x30 +#define TC_VECTOR_16B 0x31 +#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */ +#define TC_SEQUENCE_3 0x33 #define TC_CONDITIONAL 0x34 #define TC_DISJUNCTION 0x35 #define TC_CELL 0x36 #define TC_WEAK_CONS 0x37 -#define TC_TRAP 0x38 +#define TC_QUAD 0x38 /* Used to be TC_TRAP. */ #define TC_RETURN_ADDRESS 0x39 #define TC_COMPILER_LINK 0x3A #define TC_STACK_ENVIRONMENT 0x3B #define TC_COMPLEX 0x3C -#if defined(MC68020) - -#define TC_PEA_INSTRUCTION 0x48 -#define TC_JMP_INSTRUCTION 0x4E -#define TC_DBF_INSTRUCTION 0x51 +/* If you add a new type, don't forget to update gccode.h and gctype.c */ -#endif +/* Aliases */ -/* If you add a new type, don't forget to update gccode.h and gctype.c */ +#define TC_FALSE TC_NULL +#define TC_MANIFEST_VECTOR TC_NULL +#define GLOBAL_ENV TC_NULL +#define TC_BIT_STRING TC_VECTOR_1B +#define TC_VECTOR_8B TC_CHARACTER_STRING +#define TC_ADDRESS TC_FIXNUM diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index fd1d73d36..387a3934d 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -37,7 +37,7 @@ ;;;; Machine Dependent Type Tables -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $ (declare (usual-integrations)) @@ -130,7 +130,7 @@ INTERNED-SYMBOL ;1D (STRING CHARACTER-STRING VECTOR-8B) ;1E ACCESS ;1F - EXTENDED-FIXNUM ;20 + #F ;20 DEFINITION ;21 BROKEN-HEART ;22 ASSIGNMENT ;23 @@ -148,13 +148,13 @@ VECTOR-1B ;2F PRIMITIVE-COMBINATION-0 ;30 VECTOR-16B ;31 - UNASSIGNED ;32 + (REFERENCE-TRAP UNASSIGNED) ;32 SEQUENCE-3 ;33 CONDITIONAL ;34 DISJUNCTION ;35 CELL ;36 WEAK-CONS ;37 - TRAP ;38 + QUAD ;38 COMPILER-RETURN-ADDRESS ;39 COMPILER-LINK ;3A STACK-ENVIRONMENT ;3B @@ -170,16 +170,16 @@ #F ;45 #F ;46 #F ;47 - #F ;48 reserved for PEA instruction on 68000 + #F ;48 #F ;49 #F ;4A #F ;4B #F ;4C #F ;4D - #F ;4E reserved for JMP/JSR instruction on 68000 + #F ;4E #F ;4F #F ;50 - #F ;51 reserved for DBF instruction on 68000 + #F ;51 #F ;52 #F ;53 #F ;54 @@ -228,7 +228,7 @@ #F ;7F )) -;;; [] Return +;;; [] Returns (vector-set! (get-fixed-objects-vector) 5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR) @@ -724,8 +724,8 @@ RE-MATCH ;$192 RE-SEARCH-FORWARD ;$193 RE-SEARCH-BACKWARD ;$194 - SYSTEM-MEMORY-REF ;$195 - SYSTEM-MEMORY-SET! ;$196 + (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195 + (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196 BIT-STRING-FILL! ;$197 BIT-STRING-MOVE! ;$198 BIT-STRING-MOVEC! ;$199 @@ -780,7 +780,7 @@ WRITE-INTO-PURE-SPACE ;1A #F ;1B #F ;1C - ASSIGN-LAMBDA-NAME ;1D + #F ;1D FAILED-ARG-1-COERCION ;1E FAILED-ARG-2-COERCION ;1F OUT-OF-FILE-HANDLES ;20 @@ -799,6 +799,10 @@ WRONG-TYPE-ARGUMENT-7 ;2D WRONG-TYPE-ARGUMENT-8 ;2E WRONG-TYPE-ARGUMENT-9 ;2F + INAPPLICABLE-CONTINUATION ;30 + COMPILED-CODE-ERROR ;31 + FLOATING-OVERFLOW ;32 + UNIMPLEMENTED-PRIMITIVE ;33 )) ;;; [] Terminations @@ -850,4 +854,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $" +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $" diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 2c919ae27..8ddf39bd6 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.21 1987/02/02 15:15:54 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.22 1987/04/03 00:22:38 jinx Exp $ */ /* This file contains utilities for interrupts, errors, etc. */ @@ -53,20 +53,28 @@ Setup_Interrupt (Masked_Interrupts) long Save_Space; Int_Vector = Get_Fixed_Obj_Slot(System_Interrupt_Vector); - for (Int_Number=0, i=1; Int_Number < MAX_INTERRUPT_NUMBER; - i = i<<1, Int_Number++) if ((Masked_Interrupts & i) != 0) goto OK; - printf("Int_Vector %x\n", Int_Vector); - printf("\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", + + for (Int_Number=0, i=1; + Int_Number < MAX_INTERRUPT_NUMBER; + i = i<<1, Int_Number++) + if ((Masked_Interrupts & i) != 0) + goto OK; + + fprintf(stderr, "\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", IntCode, IntEnb, Masked_Interrupts); + fprintf(stderr, "Int_Vector %x\n", Int_Vector); Microcode_Termination(TERM_NO_INTERRUPT_HANDLER); + OK: - New_Int_Enb = (1< Vector_Length(Int_Vector)) - { printf("\nInterrupt out of range: 0x%x (vector length = 0x%x)\n", - Int_Number, Vector_Length(Int_Vector)); - printf("Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", - IntCode, IntEnb, Masked_Interrupts); + { fprintf(stderr, + "\nInterrupt out of range: 0x%x (vector length = 0x%x)\n", + Int_Number, Vector_Length(Int_Vector)); + fprintf(stderr, + "Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", + IntCode, IntEnb, Masked_Interrupts); Microcode_Termination(TERM_NO_INTERRUPT_HANDLER); } else Handler = User_Vector_Ref(Int_Vector, Int_Number); @@ -207,21 +215,26 @@ void Back_Out_Of_Primitive () { long nargs; + Pointer expression = Fetch_Expression(); /* When primitives are called from compiled code, the type code may * not be in the expression register. */ - if (Safe_Type_Code(Fetch_Expression()) == 0) - Store_Expression(Make_Non_Pointer(TC_PRIMITIVE, Fetch_Expression())); + if (Safe_Type_Code(expression) == 0) + { + expression = Make_Non_Pointer(TC_PRIMITIVE, expression); + Store_Expression(expression); + } /* Setup a continuation to return to compiled code if the primitive is * restarted and completes successfully. */ - nargs = N_Args_Primitive(Fetch_Expression()); + nargs = N_Args_Primitive(Get_Integer(expression)); if (Type_Code(Stack_Ref(nargs)) == TC_RETURN_ADDRESS) - { Pointer expression = Fetch_Expression(); + { + /* This clobbers the expression register. */ compiler_apply_procedure(nargs); Store_Expression(expression); } @@ -515,18 +528,23 @@ Do_Micro_Error (Err, From_Pop_Return) Print_Return("Return code"); printf( "\n"); } + Error_Exit_Hook(); + if (Trace_On_Error) - { printf( "\n\nStack trace:\n\n"); + { + printf( "\n**** Stack Trace ****\n\n"); Back_Trace(); } #ifdef ENABLE_DEBUGGING_TOOLS -{ int *From = &(local_circle[0]), *To = &(debug_circle[0]), i; - for (i=0; i < local_nslots; i++) *To++ = *From++; - debug_nslots = local_nslots; - debug_slotno = local_slotno; -} + { + int *From = &(local_circle[0]), *To = &(debug_circle[0]), i; + + for (i=0; i < local_nslots; i++) *To++ = *From++; + debug_nslots = local_nslots; + debug_slotno = local_slotno; + } #endif /* Do_Micro_Error continues on the next page. */ @@ -537,45 +555,69 @@ Do_Micro_Error (Err, From_Pop_Return) (Type_Code((Error_Vector = Get_Fixed_Obj_Slot(System_Error_Vector))) != TC_VECTOR)) - { printf("\nBogus Error Vector! I'm terribly confused!\n"); + { + fprintf(stderr, + "\nMicrocode Error: code = 0x%x; Bad error handlers vector.\n", + Err); printf("\n**** Stack Trace ****\n\n"); Back_Trace(); Microcode_Termination(TERM_NO_ERROR_HANDLER, Err); } + if (Err >= Vector_Length(Error_Vector)) - { if (Vector_Length(Error_Vector) == 0) - { printf("\nEmpty Error Vector! I'm terribly confused!\n"); + { + if (Vector_Length(Error_Vector) == 0) + { + fprintf(stderr, + "\nMicrocode Error: code = 0x%x; Empty error handlers vector.\n", + Err); + printf("\n**** Stack Trace ****\n\n"); + Back_Trace(); Microcode_Termination(TERM_NO_ERROR_HANDLER, Err); } Handler = User_Vector_Ref(Error_Vector, ERR_BAD_ERROR_CODE); } - else Handler = User_Vector_Ref(Error_Vector, Err); + else + Handler = User_Vector_Ref(Error_Vector, Err); + + /* This can NOT be folded into the Will_Push below since we cannot + afford to have the Will_Push put down its own continuation. + There is guaranteed to be enough space for this one + continuation; in fact, the Will_Push here is really unneeded! + */ + if (From_Pop_Return) - { /* This can NOT be folded into the Will_Push below since we cannot */ - /* afford to have the Will_Push put down its own continuation. */ - /* There is guaranteed to be enough space for this one */ - /* continuation; in fact, the Will_Push here is really unneeded! */ + { Will_Push(CONTINUATION_SIZE); Save_Cont(); Pushed(); } Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+HISTORY_SIZE+ (From_Pop_Return ? 0 : 1)); - if (From_Pop_Return) Store_Expression(Val); - else Push(Fetch_Env()); - Store_Return(From_Pop_Return? RC_POP_RETURN_ERROR : RC_EVAL_ERROR); + + if (From_Pop_Return) + Store_Expression(Val); + else + Push(Fetch_Env()); + + Store_Return((From_Pop_Return) ? + RC_POP_RETURN_ERROR : + RC_EVAL_ERROR); Save_Cont(); + /* Return from error handler will re-enable interrupts & restore history */ + Stop_History(); Store_Return(RC_RESTORE_INT_MASK); Store_Expression(FIXNUM_0 + IntEnb); Save_Cont(); - Push(FIXNUM_0+IntEnb); /* Arg 2: Int. mask */ - Push(FIXNUM_0+Err); /* Arg 1: Err. No */ - Push(Handler); /* Function: Handler */ + Push(Make_Unsigned_Fixnum(IntEnb)); /* Arg 2: Int. mask */ + Push(Make_Unsigned_Fixnum(Err)); /* Arg 1: Err. No */ + Push(Handler); /* Procedure: Handler */ Push(STACK_FRAME_HEADER+2); Pushed(); - IntEnb = 0; /* Turn off interrupts */ + + IntEnb = 0; /* Turn off interrupts */ New_Compiler_MemTop(); } @@ -704,7 +746,7 @@ Copy_Rib (Orig_Rib) /* Restore_History pops a history object off the stack and makes a COPY of it the current history collection object. This is called only from the RC_RESTORE_HISTORY case in - Basmod. + interpret.c . */ Boolean diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index db3f7f17b..7d400c0e1 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.34 1987/03/12 17:44:30 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.35 1987/04/03 00:23:01 jinx Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 9 #endif #ifndef SUBVERSION -#define SUBVERSION 34 +#define SUBVERSION 35 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c index c413d0e97..5591dc2c4 100644 --- a/v8/src/microcode/bintopsb.c +++ b/v8/src/microcode/bintopsb.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.22 1987/03/12 14:52:23 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.23 1987/04/03 00:05:18 jinx Exp $ * * This File contains the code to translate internal format binary * files to portable format. @@ -43,10 +43,10 @@ MIT in each case. */ #define Portable_File Output_File #include "translate.h" +#include "trap.h" static Boolean Shuffle_Bytes = false; -static Boolean Padded_Strings = true; -static Boolean Dense_Types = true; +static Boolean upgrade_traps = false; static Pointer *Mem_Base; static long Heap_Relocation, Constant_Relocation; @@ -117,27 +117,24 @@ char *name; } } -#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { fast long i; \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = STRING_0; \ - *(FObj)++ = Old_Contents; \ - i = Get_Integer(Old_Contents); \ - NStrings += 1; \ - NChars += (Padded_Strings ? \ - pointer_to_char(i-1) : \ - (1 + pointer_to_char(i-1))); \ - while(--i >= 0) *(FObj)++ = *Old_Address++; \ - } \ - if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \ +#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \ +{ Old_Address += (Rel); \ + Old_Contents = *Old_Address; \ + if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ + Mem_Base[(Scn)] = \ + Make_New_Pointer((Code), Old_Contents); \ + else \ + { fast long i; \ + Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ + *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ + (Obj) += 1; \ + *(FObj)++ = STRING_0; \ + *(FObj)++ = Old_Contents; \ + i = Get_Integer(Old_Contents); \ + NStrings += 1; \ + NChars += pointer_to_char(i-1); \ + while(--i >= 0) *(FObj)++ = *Old_Address++; \ + } \ } print_a_string(from) @@ -145,7 +142,6 @@ Pointer *from; { fast long len; fast char *string; long maxlen = pointer_to_char((Get_Integer(*from++))-1); - if (!Padded_Strings) maxlen += 1; len = Get_Integer(*from++); fprintf(Portable_File, "%02x %ld %ld ", TC_CHARACTER_STRING, @@ -189,26 +185,25 @@ long val; return; } -#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { fast long length; \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - NIntegers += 1; \ - NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \ - *(FObj)++ = Old_Contents; \ - for (length = Get_Integer(Old_Contents); \ - --length >= 0; ) \ - *(FObj)++ = *Old_Address++; \ - } \ - if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \ +#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \ +{ Old_Address += (Rel); \ + Old_Contents = *Old_Address; \ + if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ + Mem_Base[(Scn)] = \ + Make_New_Pointer((Code), Old_Contents); \ + else \ + { fast long length; \ + Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ + NIntegers += 1; \ + NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \ + *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ + (Obj) += 1; \ + *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \ + *(FObj)++ = Old_Contents; \ + for (length = Get_Integer(Old_Contents); \ + --length >= 0; ) \ + *(FObj)++ = *Old_Address++; \ + } \ } print_a_bignum(from) @@ -256,22 +251,21 @@ Pointer *from; return; } -#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \ - *((double *) (FObj)) = *((double *) Old_Address); \ - (FObj) += float_to_pointer; \ - NFlonums += 1; \ - } \ - if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \ +#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \ +{ Old_Address += (Rel); \ + Old_Contents = *Old_Address; \ + if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ + Mem_Base[(Scn)] = \ + Make_New_Pointer((Code), Old_Contents); \ + else \ + { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ + Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ + (Obj) += 1; \ + *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \ + *((double *) (FObj)) = *((double *) Old_Address); \ + (FObj) += float_to_pointer; \ + NFlonums += 1; \ + } \ } print_a_flonum(val) @@ -401,28 +395,6 @@ break #define Do_Area(Code, Area, Bound, Obj, FObj) \ Process_Area(Code, &Area, &Bound, &Obj, &FObj) -#if 0 - -#ifdef DEBUG -#define Show_Upgrade(This, New_Type) \ - fprintf(stderr, "Upgrading from 0x%02x|%06x to 0x%x\n", \ - Type_Code(This), Datum(This), New_Type); -#else -#define Show_Upgrade(This, New_Type) -#endif - -#define Upgrade(New_Type) \ -{ Boolean Was_Dangerous = Dangerous(This); \ - Show_Upgrade(This, New_Type); \ - if (Dense_Types) goto Bad_Type; \ - This = Make_New_Pointer(New_Type, Datum(This)); \ - if (Was_Dangerous) Set_Danger_Bit(This); \ - Mem_Base[*Area] = This; \ - break; \ -} - -#endif 0 - Process_Area(Code, Area, Bound, Obj, FObj) int Code; fast long *Area, *Bound; @@ -456,6 +428,12 @@ fast Pointer **FObj; *Area += 1; break; + case_compiled_entry_point: + fprintf(stderr, + "%s: File is not portable: Compiled code.\n", + Program_Name); + exit(1); + case TC_FIXNUM: NIntegers += 1; NBits += fixnum_to_bits; @@ -465,10 +443,6 @@ fast Pointer **FObj; Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj); *Obj += 1; **FObj = This; - if (Dangerous(This)) - { Set_Danger_Bit(Mem_Base[*Area]); - Clear_Danger_Bit(**FObj); - } *FObj += 1; /* Fall through */ case TC_MANIFEST_SPECIAL_NM_VECTOR: @@ -477,15 +451,45 @@ fast Pointer **FObj; *Area += 1; break; - case_compiled_entry_point: - fprintf(stderr, - "%s: File is not portable: Compiled code.\n", - Program_Name); - exit(1); - case_Cell: Do_Pointer(*Area, Do_Cell); + case TC_REFERENCE_TRAP: + { + long kind; + + kind = Datum(This); + + if (upgrade_traps) + { + /* It is an old UNASSIGNED object. */ + if (kind == 0) + { + Mem_Base[*Area] = UNASSIGNED_OBJECT; + *Area += 1; + break; + } + if (kind == 1) + { + Mem_Base[*Area] = UNBOUND_OBJECT; + *Area += 1; + break; + } + fprintf(stderr, + "%s: Bad old unassigned object. 0x%x.\n", + Program_Name, This); + exit(1); + } + if (kind <= TRAP_MAX_IMMEDIATE) + { + /* It is a non pointer. */ + + *Area += 1; + break; + } + } + /* Fall through */ + case TC_WEAK_CONS: case_Pair: Do_Pointer(*Area, Do_Pair); @@ -504,56 +508,18 @@ fast Pointer **FObj; Do_Pointer(*Area, Do_String); case TC_ENVIRONMENT: + if (upgrade_traps) + { + fprintf(stderr, + "%s: Cannot upgrade environments.\n", + Program_Name); + exit(1); + } + /* Fall through */ case TC_FUTURE: case_simple_Vector: Do_Pointer(*Area, Do_Vector); -#if 0 - -/* This should be cleaned up: We can no longer do it like this - since we have reused the types. - */ - - case OLD_TC_BROKEN_HEART: - Upgrade(TC_BROKEN_HEART); - case OLD_TC_SPECIAL_NM_VECTOR: - Upgrade(TC_MANIFEST_SPECIAL_NM_VECTOR); -#if 0 - case OLD_TC_UNASSIGNED: - Upgrade(TC_UNASSIGNED); - case OLD_TC_RETURN_CODE: - Upgrade(TC_RETURN_CODE); -#endif - case OLD_TC_PCOMB0: - Upgrade(TC_PCOMB0); - case OLD_TC_THE_ENVIRONMENT: - Upgrade(TC_THE_ENVIRONMENT); - case OLD_TC_CHARACTER: - Upgrade(TC_CHARACTER); - case OLD_TC_FIXNUM: - Upgrade(TC_FIXNUM); -#if 0 - case OLD_TC_SEQUENCE_3: - Upgrade(TC_SEQUENCE_3); -#endif - case OLD_TC_MANIFEST_NM_VECTOR: - Upgrade(TC_MANIFEST_NM_VECTOR); - case OLD_TC_VECTOR: - Upgrade(TC_VECTOR); -#if 0 - case OLD_TC_ENVIRONMENT: - Upgrade(TC_ENVIRONMENT); -#endif - case OLD_TC_CONTROL_POINT: - Upgrade(TC_CONTROL_POINT); - case OLD_TC_COMBINATION: - Upgrade(TC_COMBINATION); - case OLD_TC_PCOMB3: - Upgrade(TC_PCOMB3); - case OLD_TC_PCOMB2: - Upgrade(TC_PCOMB2); -#endif 0 - default: Bad_Type: fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n", @@ -664,10 +630,7 @@ do_it() if (Machine_Type == FASL_INTERNAL_FORMAT) Shuffle_Bytes = false; - if (Sub_Version < FASL_PADDED_STRINGS) - Padded_Strings = false; - if (Sub_Version < FASL_DENSE_TYPES) - Dense_Types = false; + upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP); /* Constant Space not currently supported */ @@ -679,10 +642,7 @@ do_it() } { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1); -#if 0 - Size += (FLOATING_ALIGNMENT+1)/sizeof(Pointer); -#endif - Allocate_Heap_Space(Size); + Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE); if (Heap == NULL) { fprintf(stderr, "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n", @@ -690,9 +650,8 @@ do_it() exit(1); } } -#if 0 - Align_Float(Heap); -#endif + Heap += HEAP_BUFFER_SPACE; + Initial_Align_Float(Heap); Load_Data(Heap_Count, &Heap[0]); Load_Data(Const_Count, &Heap[Heap_Count]); Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base); diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h index 600a0ed3a..8f6b11e57 100644 --- a/v8/src/microcode/const.h +++ b/v8/src/microcode/const.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.22 1987/02/04 17:49:56 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.23 1987/04/03 00:10:08 jinx Exp $ * * Named constants used throughout the interpreter * @@ -50,37 +50,18 @@ MIT in each case. */ #define NIL Make_Non_Pointer(TC_NULL, 0) #define TRUTH Make_Non_Pointer(TC_TRUE, 0) -#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNASSIGNED) -#define UNBOUND_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNBOUND) -#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0) #define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0) -#define LOCAL_REF_0 Make_Non_Pointer(LOCAL_REF, 0) #define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0) #define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0) #else /* 32 bit word */ #define NIL 0x00000000 #define TRUTH 0x08000000 -#define UNASSIGNED_OBJECT 0x32000000 -#define UNBOUND_OBJECT 0x32000001 -#define UNCOMPILED_VARIABLE 0x08000000 #define FIXNUM_0 0x1A000000 -#define LOCAL_REF_0 0x00000000 #define BROKEN_HEART_0 0x22000000 #define STRING_0 0x1E000000 #endif /* b32 */ -/* Some names for flag values */ - -#define SET_IT 0 /* Lookup */ -#define CLEAR_IT 1 -#define READ_IT 2 -#define TEST_IT 3 - -#define FOUND_SLOT 1 /* Slot lookup */ -#define NO_SLOT 2 -#define FOUND_UNBOUND 4 - #define NOT_THERE -1 /* Command line parser */ /* Assorted sizes used in various places */ @@ -99,7 +80,13 @@ MIT in each case. */ occurs */ #endif -#define FILE_CHANNELS 15 +/* Some versions of stdio define this. */ +#ifndef _NFILE +#define _NFILE 15 +#endif + +#define FILE_CHANNELS _NFILE + #define MAX_LIST_PRINT 10 #define ILLEGAL_PRIMITIVE -1 @@ -110,14 +97,9 @@ MIT in each case. */ #define LENGTH_MULTIPLIER 5 #define SHIFT_AMOUNT 2 -/* For looking up variable definitions */ - -#define UNCOMPILED_REF TC_TRUE -#define GLOBAL_REF TC_UNINTERNED_SYMBOL -#define FORMAL_REF TC_FIXNUM -#define AUX_REF TC_ENVIRONMENT -#define LOCAL_REF TC_NULL -/* LOCAL_REF must be 0 in order for code in interpret.c to work fast */ +/* Last immediate reference trap. */ + +#define TRAP_MAX_IMMEDIATE 9 /* For headers in pure / constant area */ @@ -160,21 +142,25 @@ MIT in each case. */ /* VMS preprocessor does not like line continuations in conditionals */ #define Are_The_Constants_Incompatible \ -((TC_NULL != 0x00) || (TC_TRUE != 0x08) || (TC_UNASSIGNED != 0x32) || \ - (UNASSIGNED != 0) || (UNBOUND != 1) || (UNCOMPILED_REF != 0x08) || \ +((TC_NULL != 0x00) || (TC_TRUE != 0x08) || \ (TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \ - (TC_CHARACTER_STRING != 0x1E) || (LOCAL_REF != 0x00)) + (TC_CHARACTER_STRING != 0x1E)) /* The values used above are in sdata.h and types.h, check for consistency if the check below fails. */ #if Are_The_Constants_Incompatible -#include "Error: disagreement in const.h" +#include "Error: const.h and types.h disagree" #endif /* These are the only entries in Registers[] needed by the microcode. All other entries are used only by the compiled code interface. */ -#define REGBLOCK_MEMTOP 0 -#define REGBLOCK_STACKGUARD 1 -#define REGBLOCK_MINIMUM_LENGTH 2 +#define REGBLOCK_MEMTOP 0 +#define REGBLOCK_STACKGUARD 1 +#define REGBLOCK_VAL 2 +#define REGBLOCK_ENV 3 +#define REGBLOCK_TEMP 4 +#define REGBLOCK_EXPR 5 +#define REGBLOCK_RETURN 6 +#define REGBLOCK_MINIMUM_LENGTH 7 diff --git a/v8/src/microcode/fasl.h b/v8/src/microcode/fasl.h index 62019c3fc..d1917ae2d 100644 --- a/v8/src/microcode/fasl.h +++ b/v8/src/microcode/fasl.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.22 1987/03/12 14:51:36 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $ Contains information relating to the format of FASL files. Some information is contained in CONFIG.H. @@ -39,9 +39,6 @@ MIT in each case. */ /* FASL Version */ #define FASL_FILE_MARKER 0XFAFAFAFA -#define FASL_FORMAT_ADDED_STACK 1 -#define FASL_FORMAT_VERSION 1 -#define FASL_SUBVERSION 5 /* The FASL file has a header which begins as follows: */ @@ -70,44 +67,27 @@ MIT in each case. */ #define The_Version(P) Type_Code(P) #define Make_Version(V, S, M) \ Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M))) - + #define WRITE_FLAG "w" #define OPEN_FLAG "r" - -/* "Memorable" FASL sub-versions -- ones where we modified something + +/* "Memorable" FASL versions -- ones where we modified something and want to remain backwards compatible. */ +/* Versions. */ + +#define FASL_FORMAT_ADDED_STACK 1 + +/* Subversions of highest numbered version. */ + #define FASL_LONG_HEADER 3 #define FASL_DENSE_TYPES 4 #define FASL_PADDED_STRINGS 5 -#define FASL_OLDEST_SUPPORTED 5 +#define FASL_REFERENCE_TRAP 6 -#if 0 -/* Old Type Codes -- used for conversion purposes - This is no longer possible, because some were re-used - without changing the fasl file version. -*/ +/* Current parameters. */ -#define OLD_TC_CHARACTER 0x40 -#define OLD_TC_PCOMB2 0x44 -#define OLD_TC_VECTOR 0x46 -#define OLD_TC_RETURN_CODE 0x48 -#define OLD_TC_COMPILED_PROCEDURE 0x49 -#define OLD_TC_ENVIRONMENT 0x4E -#define OLD_TC_FIXNUM 0x50 -#define OLD_TC_CONTROL_POINT 0x56 -#define OLD_TC_BROKEN_HEART 0x58 -#define OLD_TC_COMBINATION 0x5E -#define OLD_TC_MANIFEST_NM_VECTOR 0x60 -#define OLD_TC_PCOMB3 0x66 -#define OLD_TC_SPECIAL_NM_VECTOR 0x68 -#define OLD_TC_THE_ENVIRONMENT 0x70 -#define OLD_TC_VECTOR_1B 0x76 -#define OLD_TC_BIT_STRING 0x76 -#define OLD_TC_PCOMB0 0x78 -#define OLD_TC_VECTOR_16B 0x7E -#define OLD_TC_UNASSIGNED 0x38 -#define OLD_TC_SEQUENCE_3 0x3C - -#endif 0 +#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK +#define FASL_SUBVERSION FASL_REFERENCE_TRAP +#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS diff --git a/v8/src/microcode/fixobj.h b/v8/src/microcode/fixobj.h index 0af6f4d13..76757713c 100644 --- a/v8/src/microcode/fixobj.h +++ b/v8/src/microcode/fixobj.h @@ -30,13 +30,13 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.23 1987/03/09 14:44:49 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $ * * Declarations of user offsets into the Fixed Objects Vector. * This should correspond to the file UTABMD.SCM */ -#define Non_Object 0x00 /* Value for UNBOUND variables */ +#define Non_Object 0x00 /* Used for unassigned variables */ #define System_Interrupt_Vector 0x01 /* Handlers for interrups */ #define System_Error_Vector 0x02 /* Handlers for errors */ #define OBArray 0x03 /* Array for interning symbols */ diff --git a/v8/src/microcode/gctype.c b/v8/src/microcode/gctype.c index 22de5d9c5..465ff9d58 100644 --- a/v8/src/microcode/gctype.c +++ b/v8/src/microcode/gctype.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.21 1987/01/22 14:26:35 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $ * * This file contains the table which maps between Types and * GC Types. @@ -74,7 +74,7 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Pair, /* TC_INTERNED_SYMBOL */ GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */ GC_Pair, /* TC_ACCESS */ - GC_Non_Pointer, /* TC_EXTENDED_FIXNUM */ + GC_Undefined, /* 0x20 */ GC_Pair, /* TC_DEFINITION */ GC_Special, /* TC_BROKEN_HEART */ GC_Pair, /* TC_ASSIGNMENT */ @@ -97,13 +97,13 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */ GC_Non_Pointer, /* TC_PCOMB0 */ GC_Vector, /* TC_VECTOR_16B */ - GC_Non_Pointer, /* TC_UNASSIGNED */ + GC_Special, /* TC_REFERENCE_TRAP */ GC_Triple, /* TC_SEQUENCE_3 */ GC_Triple, /* TC_CONDITIONAL */ GC_Pair, /* TC_DISJUNCTION */ GC_Cell, /* TC_CELL */ GC_Pair, /* TC_WEAK_CONS */ - GC_Triple, /* TC_TRAP */ + GC_Quadruple, /* TC_QUAD */ GC_Compiled, /* TC_RETURN_ADDRESS */ GC_Pair, /* TC_COMPILER_LINK */ GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */ @@ -119,28 +119,16 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Undefined, /* 0x45 */ GC_Undefined, /* 0x46 */ GC_Undefined, /* 0x47 */ -#if defined(MC68020) - GC_Non_Pointer, /* TC_PEA_INSTRUCTION */ -#else GC_Undefined, /* 0x48 */ -#endif GC_Undefined, /* 0x49 */ GC_Undefined, /* 0x4A */ GC_Undefined, /* 0x4B */ GC_Undefined, /* 0x4C */ GC_Undefined, /* 0x4D */ -#if defined(MC68020) - GC_Non_Pointer, /* TC_JMP_INSTRUCTION */ -#else GC_Undefined, /* 0x4E */ -#endif GC_Undefined, /* 0x4F */ GC_Undefined, /* 0x50 */ -#if defined(MC68020) - GC_Non_Pointer, /* TC_DBF_INSTRUCTION */ -#else GC_Undefined, /* 0x51 */ -#endif GC_Undefined, /* 0x52 */ GC_Undefined, /* 0x53 */ GC_Undefined, /* 0x54 */ diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index eebb49ad3..13af89029 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.21 1987/01/22 14:27:50 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.22 1987/04/03 00:14:51 jinx Exp $ * * This file contains the heart of the Scheme Scode * interpreter @@ -39,6 +39,9 @@ MIT in each case. */ #define In_Main_Interpreter true #include "scheme.h" +#include "locks.h" +#include "trap.h" +#include "lookup.h" #include "zones.h" /* In order to make the interpreter tail recursive (i.e. @@ -79,50 +82,60 @@ MIT in each case. */ * ordered alphabetically by return code name. */ -#define Interrupt(Masked_Code) \ - { Export_Registers(); \ - Setup_Interrupt(Masked_Code); \ - Import_Registers(); \ - goto Perform_Application; \ - } +#define Interrupt(Masked_Code) \ +{ \ + Export_Registers(); \ + Setup_Interrupt(Masked_Code); \ + Import_Registers(); \ + goto Perform_Application; \ +} #define Immediate_GC(N) \ - { Request_GC(N); \ - Interrupt(IntCode & IntEnb); \ - } - +{ \ + Request_GC(N); \ + Interrupt(IntCode & IntEnb); \ +} + #define Prepare_Eval_Repeat() \ - {Will_Push(CONTINUATION_SIZE+1); \ - Push(Fetch_Env()); \ - Store_Return(RC_EVAL_ERROR); \ - Save_Cont(); \ - Pushed(); \ - } +{ \ + Will_Push(CONTINUATION_SIZE+1); \ + Push(Fetch_Env()); \ + Store_Return(RC_EVAL_ERROR); \ + Save_Cont(); \ + Pushed(); \ +} #define Eval_GC_Check(Amount) \ - if (GC_Check(Amount)) \ - { Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ - } +if (GC_Check(Amount)) \ +{ \ + Prepare_Eval_Repeat(); \ + Immediate_GC(Amount); \ +} #define Eval_Error(Err) \ - { Export_Registers(); \ - Do_Micro_Error(Err, false); \ - Import_Registers(); \ - goto Internal_Apply; \ - } +{ \ + Export_Registers(); \ + Do_Micro_Error(Err, false); \ + Import_Registers(); \ + goto Internal_Apply; \ +} #define Pop_Return_Error(Err) \ - { Export_Registers(); \ - Do_Micro_Error(Err, true); \ - Import_Registers(); \ - goto Internal_Apply; \ - } - +{ \ + Export_Registers(); \ + Do_Micro_Error(Err, true); \ + Import_Registers(); \ + goto Internal_Apply; \ +} + #define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ - Store_Return(Return_Code); \ - Val = Contents_of_Val; \ - Save_Cont() +{ \ + Store_Return(Return_Code); \ + Save_Cont(); \ + Store_Return(RC_RESTORE_VALUE); \ + Store_Expression(Contents_of_Val); \ + Save_Cont(); \ +} #define Reduces_To(Expr) \ { Store_Expression(Expr); \ @@ -152,40 +165,6 @@ MIT in each case. */ #define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT)) -/* This makes local variable references faster */ - -#if (LOCAL_REF == 0) -#define Local_Offset(Ind) Ind -#else -#define Local_Offset(Ind) Get_Integer(Ind) -#endif - -#ifdef COMPILE_FUTURES -#define Splice_Future_Value(The_Loc) \ -{ while ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val))) \ - { Pointer *Location; \ - Val = Future_Value(Val); \ - Location = The_Loc; \ - if Dangerous(*Location) Set_Danger_Bit(Val); \ - *Location = Val; \ - Clear_Danger_Bit(Val); \ - } \ - Set_Time_Zone(Zone_Working); \ - break; \ -} -#else -#define Splice_Future_Value(The_Loc) \ -{ Set_Time_Zone(Zone_Working); \ - break; \ -} -#endif - -#ifdef TRAP_ON_REFERENCE -#define Trap(Value) (Safe_Type_Code(Value) == TC_TRAP) -#else -#define Trap(Value) false -#endif - #define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */ #define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE) @@ -208,14 +187,23 @@ MIT in each case. */ their arguments and restarts them or suspends if the argument is a future. */ #define Arg_Type_Error(Arg_No, Err_No) \ -{ fast Pointer *Arg = &(Stack_Ref(Arg_No-1)); \ - fast Pointer Orig_Arg = *Arg; \ - if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \ +{ \ + fast Pointer *Arg, Orig_Arg; \ + \ + Arg = &(Stack_Ref(Arg_No-1)); \ + Orig_Arg = *Arg; \ + \ + if (Type_Code(*Arg) != TC_FUTURE) \ + Pop_Return_Error(Err_No); \ + \ while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ - { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ + { \ + if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ *Arg = Future_Value(*Arg); \ } \ - if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \ + if (Type_Code(*Arg) != TC_FUTURE) \ + goto Prim_No_Trap_Apply; \ + \ Save_Cont(); \ Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ Push(*Arg); /* Arg 1: The future itself */ \ @@ -232,13 +220,20 @@ MIT in each case. */ */ #define Apply_Future_Check(Name, Object) \ -{ fast Pointer *Arg = &(Object); \ - fast Pointer Orig_Answer = *Arg; \ +{ \ + fast Pointer *Arg, Orig_Answer; \ + \ + Arg = &(Object); \ + Orig_Answer = *Arg; \ + \ while (Type_Code(*Arg) == TC_FUTURE) \ - { if (Future_Has_Value(*Arg)) \ - { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ + { \ + if (Future_Has_Value(*Arg)) \ + { \ + if (Future_Is_Keep_Slot(*Arg)) \ + Log_Touch_Of_Future(*Arg); \ *Arg = Future_Value(*Arg); \ - } \ + } \ else \ { \ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ @@ -249,7 +244,7 @@ MIT in each case. */ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ Push(STACK_FRAME_HEADER+1); \ Pushed(); \ - *Arg = Orig_Answer; \ + *Arg = Orig_Answer; \ goto Internal_Apply; \ } \ } \ @@ -264,14 +259,20 @@ MIT in each case. */ a recursive call to EVAL is an undetermined future */ #define Pop_Return_Val_Check() \ -{ fast Pointer Orig_Val = Val; \ +{ \ + fast Pointer Orig_Val = Val; \ + \ while (Type_Code(Val) == TC_FUTURE) \ - { if (Future_Has_Value(Val)) \ - { if (Future_Is_Keep_Slot(Val)) Log_Touch_Of_Future(Val); \ + { \ + if (Future_Has_Value(Val)) \ + { \ + if (Future_Is_Keep_Slot(Val)) \ + Log_Touch_Of_Future(Val); \ Val = Future_Value(Val); \ - } \ + } \ else \ - { Save_Cont(); \ + { \ + Save_Cont(); \ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ Store_Return(RC_RESTORE_VALUE); \ Store_Expression(Orig_Val); \ @@ -286,9 +287,11 @@ MIT in each case. */ } #else /* Not compiling FUTURES code */ + #define Pop_Return_Val_Check() #define Apply_Future_Check(Name, Object) Name = (Object) #define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No) + #endif /* The EVAL/APPLY ying/yang */ @@ -296,12 +299,16 @@ MIT in each case. */ void Interpret(dumped_p) Boolean dumped_p; -{ long Which_Way; - fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer; +{ + long Which_Way; + fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History; + extern long enter_compiled_expression(); extern long apply_compiled_procedure(); extern long return_to_compiled_code(); + Reg_Block = &Registers[0]; + /* Primitives jump back here for errors, requests to * evaluate an expression, apply a function, or handle an * interrupt request. On errors or interrupts they leave @@ -325,6 +332,7 @@ Interpret(dumped_p) Pushed(); Call_Future_Logging(); } + Repeat_Dispatch: switch (Which_Way) { case PRIM_APPLY: goto Internal_Apply; @@ -344,10 +352,6 @@ Repeat_Dispatch: case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE); } - /*****************/ - /* Do_Expression */ - /*****************/ - Do_Expression: if (Eval_Debug) @@ -368,7 +372,7 @@ Do_Expression: * * An operation can terminate with a Reduces_To or * Reduces_To_Nth macro. This indicates that the value of - * the current S-Code item is the value returned when the + * the current Scode item is the value returned when the * new expression is evaluated. Therefore no new * continuation is created and processing continues at * Do_Expression with the new expression in the expression @@ -393,8 +397,7 @@ Do_Expression: */ - if (Microcode_Does_Stepping && Trapping && - (Fetch_Eval_Trapper() != NIL)) + if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL)) { Stop_Trapping(); Will_Push(4); Push(Fetch_Env()); @@ -417,23 +420,23 @@ Eval_Non_Trapping: case TC_CONTROL_POINT: case TC_DELAYED: case TC_ENVIRONMENT: - case TC_EXTENDED_FIXNUM: case TC_EXTENDED_PROCEDURE: case TC_FIXNUM: case TC_HUNK3: + case TC_INTERNED_SYMBOL: case TC_LIST: case TC_NON_MARKED_VECTOR: case TC_NULL: case TC_PRIMITIVE: case TC_PRIMITIVE_EXTERNAL: case TC_PROCEDURE: + case TC_QUAD: case TC_UNINTERNED_SYMBOL: - case TC_INTERNED_SYMBOL: case TC_TRUE: - case TC_UNASSIGNED: case TC_VECTOR: case TC_VECTOR_16B: case TC_VECTOR_1B: + case TC_REFERENCE_TRAP: Val = Fetch_Expression(); break; case TC_ACCESS: @@ -571,40 +574,37 @@ Eval_Non_Trapping: /* In case we back out */ Reserve_Stack_Space(); /* CONTINUATION_SIZE */ Finished_Eventual_Pushing(); /* of this primitive */ -/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive - combinations unless the primitive itself is output in the code stream. - Therefore, we don't have to explicitly check here that the expression - register has a primitive in it. -*/ + Primitive_Internal_Apply: if (Microcode_Does_Stepping && Trapping && (Fetch_Apply_Trapper() != NIL)) {Will_Push(3); Push(Fetch_Expression()); Push(Fetch_Apply_Trapper()); - Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression())); + Push(STACK_FRAME_HEADER + 1 + + N_Args_Primitive(Get_Integer(Fetch_Expression()))); Pushed(); Stop_Trapping(); goto Apply_Non_Trapping; } Prim_No_Trap_Apply: - Export_Registers(); - Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression())); - -/* Any primitive which does not do a long jump can have it's primitive - frame popped off here. At this point, it is guaranteed that the - primitive is in the expression register in case the primitive needs - to back out. -*/ - Import_Registers_Except_Val(); - Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression())); - if (Must_Report_References()) - { Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Call_Future_Logging(); + { + fast long primitive_code; + + primitive_code = Get_Integer(Fetch_Expression()); + + Export_Registers_Before_Primitive(); + Metering_Apply_Primitive(Val, primitive_code); + Import_Registers_After_Primitive(); + Pop_Primitive_Frame(N_Args_Primitive(primitive_code)); + if (Must_Report_References()) + { Store_Expression(Val); + Store_Return(RC_RESTORE_VALUE); + Save_Cont(); + Call_Future_Logging(); + } + break; } - break; case TC_PCOMB1: Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */ @@ -642,62 +642,85 @@ Prim_No_Trap_Apply: /* Interpret(), continued */ case TC_VARIABLE: -/* ASSUMPTION: The SYMBOL slot does NOT contain a future */ - { fast Pointer Compilation_Type, *Variable_Object; - int The_Type; + { + long temp; - Set_Time_Zone(Zone_Lookup); #ifndef No_In_Line_Lookup - Variable_Object = Get_Pointer(Fetch_Expression()); - Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE]; - The_Type = Type_Code(Compilation_Type); + fast Pointer *cell; - if (The_Type == LOCAL_REF) - { fast Pointer *Frame; - Frame = Get_Pointer(Fetch_Env()); - Val = Without_Danger_Bit(Frame[Local_Offset(Compilation_Type)]); - if (!Trap(Val)) - Splice_Future_Value(&(Frame[Local_Offset(Compilation_Type)])); - } - else if (The_Type == GLOBAL_REF) - { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE); - if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; - else if (!Trap(Val)) - Splice_Future_Value(Nth_Vector_Loc(Compilation_Type, - SYMBOL_GLOBAL_VALUE)); + Set_Time_Zone(Zone_Lookup); + cell = Get_Pointer(Fetch_Expression()); + lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); + Val = *cell; + if (Type_Code(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: + cell = Get_Pointer(Fetch_Expression()); + temp = + deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell), + cell); + goto external_lookup_return; + + /* No need to recompile, pass the fake variable. */ + case TRAP_FLUID: + temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object); + + external_lookup_return: + Import_Val(); + if (temp != PRIM_DONE) + break; + Set_Time_Zone(Zone_Working); + goto Pop_Return; + + case TRAP_UNBOUND: + temp = ERR_UNBOUND_VARIABLE; + break; + + case TRAP_UNASSIGNED: + temp = ERR_UNASSIGNED_VARIABLE; + break; + /* Interpret() continues on the next page */ /* Interpret(), continued */ - else if (The_Type == FORMAL_REF) - { fast long Frame_No; - fast Pointer *Frame; - - Frame = Get_Pointer(Fetch_Env()); - Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]); - while(--Frame_No >= 0) - Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION], - PROCEDURE_ENVIRONMENT)); - Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]; - if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; - else if (!Trap(Val)) - Splice_Future_Value( - &(Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])])); + default: + temp = ERR_BROKEN_COMPILED_VARIABLE; + break; } -#endif - /* Fall through in cases not handled above */ - { long Result; - Result = Lex_Ref(Fetch_Env(), Fetch_Expression()); - Import_Val(); - Set_Time_Zone(Zone_Working); - if (Result == PRIM_DONE) break; - Eval_Error(Result); + +#else No_In_Line_Lookup + + Set_Time_Zone(Zone_Lookup); + temp = Lex_Ref(Fetch_Env(), Fetch_Expression()); + Import_Val(); + if (temp == PRIM_DONE) + break; + +#endif No_In_Line_Lookup + + /* Back out of the evaluation. */ + + Set_Time_Zone(Zone_Working); + + if (temp == PRIM_INTERRUPT) + { + Prepare_Eval_Repeat(); + Interrupt(IntCode & IntEnb); } + + Eval_Error(temp); } case TC_RETURN_CODE: @@ -850,20 +873,37 @@ Pop_Return: Microcode_Termination(TERM_END_OF_COMPUTATION); case RC_EVAL_ERROR: + /* Should be called RC_REDO_EVALUATION. */ Store_Env(Pop()); Reduces_To(Fetch_Expression()); case RC_EXECUTE_ACCESS_FINISH: - { long Result; + { + long Result; + Pointer value; + Pop_Return_Val_Check(); + value = Val; + if (Environment_P(Val)) - { Result = Symbol_Lex_Ref(Val, - Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME)); + { Result = Symbol_Lex_Ref(value, + Fast_Vector_Ref(Fetch_Expression(), + ACCESS_NAME)); Import_Val(); - if (Result != PRIM_DONE) Pop_Return_Error(Result); - End_Subproblem(); - break; + if (Result == PRIM_DONE) + { + End_Subproblem(); + break; + } + if (Result != PRIM_INTERRUPT) + { + Val = value; + Pop_Return_Error(Result); + } + Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value); + Interrupt(IntCode & IntEnb); } + Val = value; Pop_Return_Error(ERR_BAD_FRAME); } @@ -872,91 +912,123 @@ Pop_Return: /* Interpret(), continued */ case RC_EXECUTE_ASSIGNMENT_FINISH: - { fast Pointer Compilation_Type, *Variable_Object; - Pointer The_Non_Object, Store_Value; - int The_Type; + { + long temp; + Pointer value; + Lock_Handle set_serializer; + +#ifndef No_In_Line_Lookup + + Pointer bogus_unassigned; + fast Pointer *cell; Set_Time_Zone(Zone_Lookup); Restore_Env(); - The_Non_Object = Get_Fixed_Obj_Slot(Non_Object); - Store_Value = (Val == The_Non_Object) ? UNASSIGNED_OBJECT : Val; + cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); + lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); + setup_lock(set_serializer, cell); + + value = Val; + bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); + if (value == bogus_unassigned) + value = UNASSIGNED_OBJECT; + + if (Type_Code(*cell) != TC_REFERENCE_TRAP) + { + Val = *cell; + + normal_assignment_done: + *cell = value; + remove_lock(set_serializer); + Set_Time_Zone(Zone_Working); + End_Subproblem(); + goto Pop_Return; + } -#ifndef No_In_Line_Lookup +/* Interpret() continues on the next page */ + +/* Interpret(), continued */ - Variable_Object = - Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); - Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE]; - The_Type = Type_Code(Compilation_Type); - - if (The_Type == LOCAL_REF) - { fast Pointer *Frame; - Frame = Get_Pointer(Fetch_Env()); - Val = Frame[Local_Offset(Compilation_Type)]; - if (Dangerous(Val)) - { Set_Danger_Bit(Store_Value); - Clear_Danger_Bit(Val); - } - if (!Trap(Val)) - { Frame[Local_Offset(Compilation_Type)] = Store_Value; - if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object; + get_trap_kind(temp, *cell); + switch(temp) + { + case TRAP_DANGEROUS: + case TRAP_UNBOUND_DANGEROUS: + case TRAP_UNASSIGNED_DANGEROUS: + case TRAP_FLUID_DANGEROUS: + remove_lock(set_serializer); + cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); + temp = + deep_assignment_end(deep_lookup(Fetch_Env(), + cell[VARIABLE_SYMBOL], + cell), + cell, + value, + false); + goto external_assignment_return; + + case TRAP_UNASSIGNED: + Val = bogus_unassigned; + goto normal_assignment_done; + + case TRAP_FLUID: + /* No need to recompile, pass the fake variable. */ + remove_lock(set_serializer); + temp = deep_assignment_end(lookup_fluid(*cell), + fake_variable_object, + value, + false); + + external_assignment_return: + Import_Val(); + if (temp != PRIM_DONE) + break; Set_Time_Zone(Zone_Working); End_Subproblem(); + goto Pop_Return; + + case TRAP_UNBOUND: + remove_lock(set_serializer); + temp = ERR_UNBOUND_VARIABLE; + break; + + default: + remove_lock(set_serializer); + temp = ERR_BROKEN_COMPILED_VARIABLE; break; - } - } - else if (The_Type == GLOBAL_REF) - { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE); - if (!Dangerous(Val) && !Trap(Val)) - { Vector_Set(Compilation_Type, SYMBOL_GLOBAL_VALUE, Store_Value); - if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - break; - } - else if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; } /* Interpret() continues on the next page */ /* Interpret(), continued */ - else if (The_Type == FORMAL_REF) - { fast long Frame_No; - fast Pointer *Frame; - - Frame = Get_Pointer(Fetch_Env()); - Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]); - while(--Frame_No >= 0) - Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION], - PROCEDURE_ENVIRONMENT)); - Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]; - if (!Dangerous(Val) && !Trap(Val)) - { Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])] = - Store_Value; - if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - break; - } - else if (Dangerous(Val)) - Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; +#else + + Set_Time_Zone(Zone_Lookup); + Restore_Env(); + temp = Lex_Set(Fetch_Env(), + Vector_Ref(Fetch_Expression(), ASSIGN_NAME), + value); + Import_Val(); + if (temp == PRIM_DONE) + { End_Subproblem(); + Set_Time_Zone(Zone_Working); + break; } + #endif - /* Fall through in cases not handled above */ - { long Result; - Result = Lex_Set(Fetch_Env(), - Vector_Ref(Fetch_Expression(), ASSIGN_NAME), - Store_Value); - Import_Val(); - Set_Time_Zone(Zone_Working); - if (Result == PRIM_DONE) - { End_Subproblem(); - break; - } - Save_Env(); - Pop_Return_Error(Result); + + Set_Time_Zone(Zone_Working); + Save_Env(); + if (temp != PRIM_INTERRUPT) + { + Val = value; + Pop_Return_Error(temp); } + + Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, + value); + Interrupt(IntCode & IntEnb); } /* Interpret() continues on the next page */ @@ -964,32 +1036,38 @@ Pop_Return: /* Interpret(), continued */ case RC_EXECUTE_DEFINITION_FINISH: - { Pointer Saved_Val; - long Result; + { + Pointer value; + long result; - Saved_Val = Val; + value = Val; Restore_Env(); - Result = Local_Set(Fetch_Env(), + Export_Registers(); + result = Local_Set(Fetch_Env(), Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME), Val); - Import_Val(); - if (Result==PRIM_DONE) - { End_Subproblem(); + Import_Registers(); + if (result == PRIM_DONE) + { + End_Subproblem(); break; } Save_Env(); - if (Result==PRIM_INTERRUPT) - { Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - Saved_Val); + if (result == PRIM_INTERRUPT) + { + Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, + value); Interrupt(IntCode & IntEnb); } - Pop_Return_Error(Result); - }; + Val = value; + Pop_Return_Error(result); + } case RC_EXECUTE_IN_PACKAGE_CONTINUE: Pop_Return_Val_Check(); if (Environment_P(Val)) - { End_Subproblem(); + { + End_Subproblem(); Store_Env(Val); Reduces_To_Nth(IN_PACKAGE_EXPRESSION); } @@ -1014,109 +1092,129 @@ Pop_Return: case RC_HALT: Export_Registers(); Microcode_Termination(TERM_TERM_HANDLER); - -/* Interpret() continues on the next page */ -/* Interpret(), continued */ + case RC_INTERNAL_APPLY: + +Internal_Apply: -#define Prepare_Apply_Interrupt() \ - Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL) +/* Branch here to perform a function application. + + At this point the top of the stack contains an application frame + which consists of the following elements (see sdata.h): + - A header specifying the frame length. + - A procedure. + - The actual (evaluated) arguments. + + No registers (except the stack pointer) are meaning full at this point. + Before interrupts or errors are processed, some registers are cleared + to avoid holding onto garbage if a garbage collection occurs. +*/ + +#define Prepare_Apply_Interrupt() \ +{ \ + Store_Return(RC_INTERNAL_APPLY); \ + Store_Expression(NIL); \ + Save_Cont(); \ +} #define Apply_Error(N) \ - { Store_Return(RC_INTERNAL_APPLY); \ - Val = NIL; \ - Pop_Return_Error(N); \ - } +{ \ + Store_Return(RC_INTERNAL_APPLY); \ + Store_Expression(NIL); \ + Val = NIL; \ + Pop_Return_Error(N); \ +} /* Interpret() continues on the next page */ /* Interpret(), continued */ - case RC_INTERNAL_APPLY: -Internal_Apply: - -/* Branch here to perform a function application. At this point - it is necessary that the top of the stack contain a frame - for evaluation of the function to be applied. This frame - DOES NOT contain "finger" and "combination" slots, although - if the frame is to be copied into the heap, it will have NIL's - in the "finger" and "combination" slots which will correspond - to "potentially-dangerous" and "auxilliary variables" slots. - - Note, also, that unlike most return codes Val is not used here. - Thus, the error and interrupt macros above set it to NIL so that it - will not 'hold on' to anything if a GC occurs. Similarly, the - contents of Expression are discarded. -*/ if (Microcode_Does_Stepping && Trapping && - (Fetch_Apply_Trapper() != NIL)) - { long Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); + (Fetch_Apply_Trapper() != NIL)) + { + long Count; + + Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); Top_Of_Stack() = Fetch_Apply_Trapper(); Push(STACK_FRAME_HEADER+Count); Stop_Trapping(); } + Apply_Non_Trapping: - { long Interrupts; - Pointer Function; - - Store_Expression(NIL); - Interrupts = IntCode & IntEnb; - if (Interrupts != 0) - { Prepare_Apply_Interrupt(); - Interrupt(Interrupts); - } + + if ((IntCode & IntEnb) != 0) + { + long Interrupts; + + Interrupts = (IntCode & IntEnb); + Store_Expression(NIL); + Val = NIL; + Prepare_Apply_Interrupt(); + Interrupt(Interrupts); + } Perform_Application: + + Apply_Ucode_Hook(); + + { + fast Pointer Function; + Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION)); - Apply_Ucode_Hook(); + + switch(Type_Code(Function)) + { /* Interpret() continues on the next page */ /* Interpret(), continued */ - switch(Type_Code(Function)) - { case TC_PROCEDURE: - { Pointer Lambda_Expr, *Temp1, Temp2; - long NParams, Size; - fast long NArgs; - - Apply_Future_Check(Lambda_Expr, - Fast_Vector_Ref(Function, - PROCEDURE_LAMBDA_EXPR)); - Temp1 = Get_Pointer(Lambda_Expr); - Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]); - NArgs = Get_Integer(Pop()); - NParams = Vector_Length(Temp2); - if (Eval_Debug) - { Print_Expression(FIXNUM_0+NArgs, - "APPLY: Number of arguments"); - Print_Expression(FIXNUM_0+NParams, - " Number of parameters"); + case TC_PROCEDURE: + { + fast long nargs; + + nargs = Get_Integer(Pop()); + Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); + + { + fast Pointer formals; + + Apply_Future_Check(formals, + Fast_Vector_Ref(Function, LAMBDA_FORMALS)); + + if ((nargs != Vector_Length(formals)) && + ((Type_Code(Function) != TC_LEXPR) || + (nargs < Vector_Length(formals)))) + { + Push(STACK_FRAME_HEADER + nargs - 1); + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } } - if (Type_Code(Lambda_Expr) == TC_LAMBDA) - { if (NArgs != NParams) - { Push(STACK_FRAME_HEADER+NArgs-1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } + + if (Eval_Debug) + { + Print_Expression(Make_Unsigned_Fixnum(nargs), + "APPLY: Number of arguments"); } - else if (NArgs < NParams) - { Push(STACK_FRAME_HEADER+NArgs-1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1); - if (GC_Check(Size)) - { Push(STACK_FRAME_HEADER+NArgs-1); + + if (GC_Check(nargs + 1)) + { + Push(STACK_FRAME_HEADER + nargs - 1); Prepare_Apply_Interrupt(); - Immediate_GC(Size); + Immediate_GC(nargs + 1); } - /* Store Environment Frame into heap, putting extra slots - for Potentially Dangerous and Auxiliaries */ - Store_Env(Make_Pointer(TC_ENVIRONMENT, Free)); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size); - *Free++ = NIL; /* For PD list and Aux list */ - *Free++ = NIL; - for (; --NArgs >= 0; ) *Free++ = Pop(); - Reduces_To(Temp1[LAMBDA_SCODE]); + + { + fast Pointer *scan; + + scan = Free; + Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); + *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs); + while(--nargs >= 0) + *scan++ = Pop(); + Free = scan; + Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE)); + } } /* Interpret() continues on the next page */ @@ -1124,35 +1222,68 @@ Perform_Application: /* Interpret(), continued */ case TC_CONTROL_POINT: + { if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != STACK_ENV_FIRST_ARG) - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS) + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } Val = Stack_Ref(STACK_ENV_FIRST_ARG); Our_Throw(false, Function); Apply_Stacklet_Backout(); Our_Throw_Part_2(); goto Pop_Return; + } + +/* Interpret() continues on the next page */ + +/* Interpret(), continued */ + + /* + After checking the number of arguments, remove the + frame header since primitives do not expect it. + */ + + case TC_PRIMITIVE: + { + if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != + STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1) + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); + Store_Expression(Function); + goto Prim_No_Trap_Apply; + } case TC_PRIMITIVE_EXTERNAL: - { long NArgs, Proc = Datum(Function); + { + fast long NArgs, Proc; + + Proc = Datum(Function); if (Proc > MAX_EXTERNAL_PRIMITIVE) + { Apply_Error(ERR_UNDEFINED_PRIMITIVE); + } NArgs = Ext_Prim_Desc[Proc].arity; if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG+NArgs-1) + (NArgs + (STACK_ENV_FIRST_ARG - 1))) + { Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - /* Remove the frame overhead, since the primitives - just expect arguments on the stack */ Store_Expression(Function); + Repeat_External_Primitive: /* Reinitialize Proc in case we "goto Repeat_External..." */ Proc = Get_Integer(Fetch_Expression()); - Export_Registers(); + + Export_Registers_Before_Primitive(); Val = (*(Ext_Prim_Desc[Proc].proc))(); Set_Time_Zone(Zone_Working); - Import_Registers_Except_Val(); + Import_Registers_After_Primitive(); Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity); + goto Pop_Return; } @@ -1161,93 +1292,94 @@ Repeat_External_Primitive: /* Interpret(), continued */ case TC_EXTENDED_PROCEDURE: - { Pointer Lambda_Expr, *List_Car, Temp; - long NArgs, NParams, Formals, Params, Auxes, - Rest_Flag, Size, i; - -/* Selectors for the various parts */ - -#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE)) -#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES)) -#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT)) -#define Elambda_Formals_Count(Addr) \ - ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT) -#define Elambda_Opts_Count(Addr) \ - (((long) Addr) & EL_OPTS_MASK) -#define Elambda_Rest_Flag(Addr) \ - ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT) - - Apply_Future_Check(Lambda_Expr, - Fast_Vector_Ref(Function, - PROCEDURE_LAMBDA_EXPR)); - Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr, - ELAMBDA_NAMES)); - NParams = Vector_Length(Temp) - 1; - Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr)); - Formals = Elambda_Formals_Count(Temp); - /* Formals DOES NOT include the name of the lambda */ - Params = Elambda_Opts_Count(Temp) + Formals; - Rest_Flag = Elambda_Rest_Flag(Temp); - NArgs = Get_Integer(Pop()) - 1; - Auxes = NParams - (Params + Rest_Flag); - if ((NArgs < Formals) || - (!Rest_Flag && (NArgs > Params))) - { Push(STACK_FRAME_HEADER+NArgs); + { + Pointer lambda; + long nargs, nparams, formals, params, auxes, + rest_flag, size; + + fast long i; + fast Pointer *scan; + + nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER; + + if (Eval_Debug) + { + Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER), + "APPLY: Number of arguments"); + } + + lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); + Apply_Future_Check(Function, + Fast_Vector_Ref(lambda, ELAMBDA_NAMES)); + nparams = Vector_Length(Function) - 1; + + Apply_Future_Check(Function, Get_Count_Elambda(lambda)); + formals = Elambda_Formals_Count(Function); + params = Elambda_Opts_Count(Function) + formals; + rest_flag = Elambda_Rest_Flag(Function); + auxes = nparams - (params + rest_flag); + + if ((nargs < formals) || (!rest_flag && (nargs > params))) + { + Push(STACK_FRAME_HEADER + nargs); Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - Size = Params + Rest_Flag + Auxes + - (HEAP_ENV_EXTRA_SLOTS + 1); - List_Car = Free + Size; - if (GC_Check(Size + ((NArgs > Params) ? - 2 * (NArgs - Params) : 0))) - { Push(STACK_FRAME_HEADER+NArgs); + /* size includes the procedure slot, but not the header. */ + size = params + rest_flag + auxes + 1; + if (GC_Check(size + 1 + ((nargs > params) ? + (2 * (nargs - params)) : + 0))) + { + Push(STACK_FRAME_HEADER + nargs); Prepare_Apply_Interrupt(); - Immediate_GC(Size + ((NArgs > Params) ? - 2 * (NArgs - Params) : 0)); + Immediate_GC(size + 1 + ((nargs > params) ? + (2 * (nargs - params)) : + 0)); } - Store_Env(Make_Pointer(TC_ENVIRONMENT, Free)); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1); - /* Environment Header */ - *Free++ = NIL; /* Aux list */ - *Free++ = NIL; /* PD list */ - Size = 1 + ((NArgs < Params) ? NArgs : Params); - for (i = 0; i < Size; i++) *Free++ = Pop(); - for (i--; i < Params; i++) - *Free++ = UNASSIGNED_OBJECT; - if (Rest_Flag) - if (NArgs <= i) *Free++ = NIL; - else - { *Free++ = Make_Pointer(TC_LIST, List_Car); - for (; i < NArgs; i++, List_Car++) - { *List_Car++ = Pop(); - *List_Car = Make_Pointer(TC_LIST, List_Car+1); - } - List_Car[-1] = NIL; - } - for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT; - Free = List_Car; - Reduces_To(Get_Body_Elambda(Lambda_Expr)); - } /* Interpret() continues on the next page */ /* Interpret(), continued */ - case TC_PRIMITIVE: - { long Number_Of_Args = N_Args_Primitive(Function); - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG+Number_Of_Args-1) - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - /* Remove the frame overhead, since the primitives - just expect arguments on the stack */ - Store_Expression(Function); - goto Prim_No_Trap_Apply; + scan = Free; + Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); + *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size); + + if (nargs <= params) + { + for (i = (nargs + 1); --i >= 0; ) + *scan++ = Pop(); + for (i = (params - nargs); --i >= 0; ) + *scan++ = UNASSIGNED_OBJECT; + if (rest_flag) + *scan++ = NIL; + for (i = auxes; --i >= 0; ) + *scan++ = UNASSIGNED_OBJECT; + } + else + { + /* rest_flag must be true. */ + Pointer list; + + list = Make_Pointer(TC_LIST, (scan + size)); + for (i = (params + 1); --i >= 0; ) + *scan++ = Pop(); + *scan++ = list; + for (i = auxes; --i >= 0; ) + *scan++ = UNASSIGNED_OBJECT; + /* Now scan == Get_Pointer(list) */ + for (i = (nargs - params); --i >= 0; ) + { + *scan++ = Pop(); + *scan = Make_Pointer(TC_LIST, (scan + 1)); + scan += 1; + } + scan[-1] = NIL; + } + + Free = scan; + Reduces_To(Get_Body_Elambda(lambda)); } /* Interpret() continues on the next page */ @@ -1255,7 +1387,8 @@ Repeat_External_Primitive: /* Interpret(), continued */ case TC_COMPILED_PROCEDURE: - { apply_compiled_setup(STACK_ENV_EXTRA_SLOTS + + { + apply_compiled_setup(STACK_ENV_EXTRA_SLOTS + Get_Integer( Stack_Ref( STACK_ENV_HEADER))); Export_Registers(); Which_Way = apply_compiled_procedure(); @@ -1593,8 +1726,6 @@ return_from_compiled_code: break; /* We never get here.... */ } -/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */ - case RC_RETURN_TRAP_POINT: Store_Return(Old_Return_Code); Will_Push(CONTINUATION_SIZE+3); diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index 07a45afba..0726e0b8a 100644 --- a/v8/src/microcode/object.h +++ b/v8/src/microcode/object.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.20 1987/01/21 20:24:48 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.21 1987/04/03 00:18:15 jinx Exp $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -46,11 +46,9 @@ MIT in each case. */ #define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */ #define MAX_TYPE_CODE 0xFF /* ((1<= end_of_memory) || - scheme_string(via(From+SYMBOL_NAME), false)) + !scheme_string(via(From+SYMBOL_NAME), false)) printf("symbol not in memory; datum = %x\n", From); return; } @@ -153,59 +153,62 @@ long Location, Type, The_Datum; return; case TC_CHARACTER_STRING: scheme_string(Points_To, true); return; - case TC_EXTENDED_FIXNUM: printf("%d\n", The_Datum); - return; case TC_FIXNUM: printf("%d\n", Points_To); return; /* Default cases */ - case TC_LIST: printf("[CONS "); break; - case TC_WEAK_CONS: printf("[WEAK-CONS "); break; - case TC_SCODE_QUOTE: printf("[QUOTE "); break; - case TC_BIG_FLONUM: printf("[FLONUM "); break; - case TC_COMBINATION_1: printf( "[COMB-1 "); break; - case TC_EXTENDED_PROCEDURE: printf("[EPROCEDURE "); break; - case TC_COMBINATION_2: printf("[COMB-2 "); break; - case TC_BIG_FIXNUM: printf("[BIGNUM "); break; + case TC_LIST: printf("[LIST "); break; + case TC_CHARACTER: printf("[CHARACTER "); break; + case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break; + case TC_PCOMB2: printf("[PCOMB2 "); break; + case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break; + case TC_COMBINATION_1: printf("[COMBINATION-1 "); break; + case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break; + case TC_VECTOR: printf("[VECTOR "); break; + case TC_RETURN_CODE: printf("[RETURN-CODE "); break; + case TC_COMBINATION_2: printf("[COMBINATION-2 "); break; + case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break; + case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break; case TC_PROCEDURE: printf("[PROCEDURE "); break; - case TC_PRIMITIVE_EXTERNAL: printf("[EXTERNAL-PRIMITIVE "); break; + case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break; case TC_DELAY: printf("[DELAY "); break; + case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break; case TC_DELAYED: printf("[DELAYED "); break; - case TC_EXTENDED_LAMBDA: printf("[ELAMBDA "); break; + case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break; case TC_COMMENT: printf("[COMMENT "); break; case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break; case TC_LAMBDA: printf("[LAMBDA "); break; case TC_PRIMITIVE: printf("[PRIMITIVE "); break; - case TC_SEQUENCE_2: printf("[SEQ-2 "); break; - case TC_PCOMB1: printf("[PCOMB-1 "); break; + case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break; + case TC_PCOMB1: printf("[PCOMB1 "); break; + case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break; case TC_ACCESS: printf("[ACCESS "); break; case TC_DEFINITION: printf("[DEFINITION "); break; case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break; case TC_HUNK3: printf("[HUNK3 "); break; case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break; + case TC_COMBINATION: printf("[COMBINATION "); break; + case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break; case TC_LEXPR: printf("[LEXPR "); break; + case TC_PCOMB3: printf("[PCOMB3 "); break; + case TC_VARIABLE: printf("[VARIABLE "); break; - case TC_CONDITIONAL: printf("[CONDITIONAL "); break; - case TC_DISJUNCTION: printf("[DISJUNCTION "); break; - case TC_UNASSIGNED: printf("[UNASSIGNED "); break; - case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break; - case TC_CHARACTER: printf("[CHARACTER "); break; - case TC_PCOMB2: printf("[PCOMB-2 "); break; - case TC_VECTOR: printf("[VECTOR "); break; - case TC_RETURN_CODE: printf("[RETURN-CODE "); break; - case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break; - case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break; - case TC_COMBINATION: printf("[COMBINATION "); break; - case TC_PCOMB3: printf("[PCOMB-3 "); break; case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break; + case TC_FUTURE: printf("[FUTURE "); break; case TC_VECTOR_1B: printf("[VECTOR-1B "); break; - case TC_PCOMB0: printf("[PCOMB-0 "); break; + case TC_PCOMB0: printf("[PCOMB0 "); break; case TC_VECTOR_16B: printf("[VECTOR-16B "); break; + case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break; + case TC_CONDITIONAL: printf("[CONDITIONAL "); break; + case TC_DISJUNCTION: printf("[DISJUNCTION "); break; case TC_CELL: printf("[CELL "); break; - case TC_FUTURE: printf("[FUTURE "); break; - case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break; - case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break; + case TC_WEAK_CONS: printf("[WEAK-CONS "); break; + case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break; case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break; + case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break; + case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break; + case TC_COMPLEX: printf("[COMPLEX "); break; + case TC_QUAD: printf("[QUAD "); break; default: printf("[02x%x ", Type); break; } printf("%x]\n", Points_To); diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c index 050d15bd2..20b2b1765 100644 --- a/v8/src/microcode/psbtobin.c +++ b/v8/src/microcode/psbtobin.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.21 1987/01/22 14:13:43 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.22 1987/04/03 00:06:48 jinx Exp $ * * This File contains the code to translate portable format binary * files to internal format. @@ -350,22 +350,12 @@ fast Pointer *To; /* Align_Float(To); */ while (--N >= 0) { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum); - switch((The_Type) & SAFE_TYPE_MASK) + switch(The_Type) { case CONSTANT_CODE: - if (The_Type > MAX_SAFE_TYPE) - { *To = Constant_Table[The_Datum]; - Set_Danger_Bit(*To++); - continue; - } *To++ = Constant_Table[The_Datum]; continue; case HEAP_CODE: - if (The_Type > MAX_SAFE_TYPE) - { *To = Heap_Table[The_Datum]; - Set_Danger_Bit(*To++); - continue; - } *To++ = Heap_Table[The_Datum]; continue; @@ -395,6 +385,13 @@ fast Pointer *To; *To++ = Make_Non_Pointer(The_Type, The_Datum); continue; + case TC_REFERENCE_TRAP: + if (The_Datum <= TRAP_MAX_IMMEDIATE) + { + *To++ = Make_Non_Pointer(The_Type, The_Datum); + continue; + } + /* It is a pointer, fall through. */ default: /* Should be stricter */ *To++ = Make_Pointer(The_Type, Relocate(The_Datum)); @@ -500,6 +497,7 @@ long Read_Header_and_Allocate() Read_Flags(Flags); Size = (6 + /* SNMV */ + HEAP_BUFFER_SPACE + Heap_Count + Heap_Objects + Constant_Count + Constant_Objects + Pure_Count + Pure_Objects + @@ -515,7 +513,9 @@ long Read_Header_and_Allocate() Program_Name, Size); exit(1); } - return Size; + Heap += HEAP_BUFFER_SPACE; + Initial_Align_Float(Heap); + return (Size - HEAP_BUFFER_SPACE); } do_it() diff --git a/v8/src/microcode/types.h b/v8/src/microcode/types.h index 9276374ad..a6e1c9fcc 100644 --- a/v8/src/microcode/types.h +++ b/v8/src/microcode/types.h @@ -30,35 +30,31 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.21 1987/01/22 14:34:14 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $ * * Type code definitions, numerical order * */ #define TC_NULL 0x00 -#define TC_FALSE 0x00 -#define TC_MANIFEST_VECTOR 0x00 -#define GLOBAL_ENV 0x00 - #define TC_LIST 0x01 #define TC_CHARACTER 0x02 #define TC_SCODE_QUOTE 0x03 -#define TC_PCOMB2 0x04 /* Was 0x44 */ +#define TC_PCOMB2 0x04 #define TC_UNINTERNED_SYMBOL 0x05 #define TC_BIG_FLONUM 0x06 #define TC_COMBINATION_1 0x07 #define TC_TRUE 0x08 #define TC_EXTENDED_PROCEDURE 0x09 -#define TC_VECTOR 0x0A /* Was 0x46 */ -#define TC_RETURN_CODE 0x0B /* Was 0x48 */ +#define TC_VECTOR 0x0A +#define TC_RETURN_CODE 0x0B #define TC_COMBINATION_2 0x0C -#define TC_COMPILED_PROCEDURE 0x0D /* Was 0x49 */ +#define TC_COMPILED_PROCEDURE 0x0D #define TC_BIG_FIXNUM 0x0E #define TC_PROCEDURE 0x0F #define TC_PRIMITIVE_EXTERNAL 0x10 #define TC_DELAY 0x11 -#define TC_ENVIRONMENT 0x12 /* Was 0x4E */ +#define TC_ENVIRONMENT 0x12 #define TC_DELAYED 0x13 #define TC_EXTENDED_LAMBDA 0x14 #define TC_COMMENT 0x15 @@ -67,54 +63,49 @@ MIT in each case. */ #define TC_PRIMITIVE 0x18 #define TC_SEQUENCE_2 0x19 -#define TC_FIXNUM 0x1A /* Was 0x50 */ -#define TC_ADDRESS 0x1A - /* Notice that TC_FIXNUM and TC_ADDRESS are the same */ +#define TC_FIXNUM 0x1A #define TC_PCOMB1 0x1B -#define TC_CONTROL_POINT 0x1C /* Was 0x56 */ +#define TC_CONTROL_POINT 0x1C #define TC_INTERNED_SYMBOL 0x1D #define TC_CHARACTER_STRING 0x1E -#define TC_VECTOR_8B 0x1E - /* VECTOR_8B and STRING are the same */ #define TC_ACCESS 0x1F -#define TC_EXTENDED_FIXNUM 0x20 /* Not used */ +/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */ #define TC_DEFINITION 0x21 -#define TC_BROKEN_HEART 0x22 /* Was 0x58 */ +#define TC_BROKEN_HEART 0x22 #define TC_ASSIGNMENT 0x23 #define TC_HUNK3 0x24 #define TC_IN_PACKAGE 0x25 -#define TC_COMBINATION 0x26 /* Was 0x5E */ -#define TC_MANIFEST_NM_VECTOR 0x27 /* Was 0x60 */ +#define TC_COMBINATION 0x26 +#define TC_MANIFEST_NM_VECTOR 0x27 #define TC_COMPILED_EXPRESSION 0x28 #define TC_LEXPR 0x29 -#define TC_PCOMB3 0x2A /* Was 0x66 */ -#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B /* Was 0x68 */ +#define TC_PCOMB3 0x2A +#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B #define TC_VARIABLE 0x2C -#define TC_THE_ENVIRONMENT 0x2D /* Was 0x70 */ +#define TC_THE_ENVIRONMENT 0x2D #define TC_FUTURE 0x2E -#define TC_VECTOR_1B 0x2F /* Was 0x76 */ -#define TC_BIT_STRING 0x2F /* Was 0x76 */ - /* Notice TC_VECTOR_1B and TC_BIT_STRING are the same */ -#define TC_PCOMB0 0x30 /* Was 0x78 */ -#define TC_VECTOR_16B 0x31 /* Was 0x7E */ -#define TC_UNASSIGNED 0x32 /* Was 0x38 */ -#define TC_SEQUENCE_3 0x33 /* Was 0x3C */ +#define TC_VECTOR_1B 0x2F +#define TC_PCOMB0 0x30 +#define TC_VECTOR_16B 0x31 +#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */ +#define TC_SEQUENCE_3 0x33 #define TC_CONDITIONAL 0x34 #define TC_DISJUNCTION 0x35 #define TC_CELL 0x36 #define TC_WEAK_CONS 0x37 -#define TC_TRAP 0x38 +#define TC_QUAD 0x38 /* Used to be TC_TRAP. */ #define TC_RETURN_ADDRESS 0x39 #define TC_COMPILER_LINK 0x3A #define TC_STACK_ENVIRONMENT 0x3B #define TC_COMPLEX 0x3C -#if defined(MC68020) - -#define TC_PEA_INSTRUCTION 0x48 -#define TC_JMP_INSTRUCTION 0x4E -#define TC_DBF_INSTRUCTION 0x51 +/* If you add a new type, don't forget to update gccode.h and gctype.c */ -#endif +/* Aliases */ -/* If you add a new type, don't forget to update gccode.h and gctype.c */ +#define TC_FALSE TC_NULL +#define TC_MANIFEST_VECTOR TC_NULL +#define GLOBAL_ENV TC_NULL +#define TC_BIT_STRING TC_VECTOR_1B +#define TC_VECTOR_8B TC_CHARACTER_STRING +#define TC_ADDRESS TC_FIXNUM diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm index 01d7c0e9d..cc4940c0d 100644 --- a/v8/src/microcode/utabmd.scm +++ b/v8/src/microcode/utabmd.scm @@ -37,7 +37,7 @@ ;;;; Machine Dependent Type Tables -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $ (declare (usual-integrations)) @@ -130,7 +130,7 @@ INTERNED-SYMBOL ;1D (STRING CHARACTER-STRING VECTOR-8B) ;1E ACCESS ;1F - EXTENDED-FIXNUM ;20 + #F ;20 DEFINITION ;21 BROKEN-HEART ;22 ASSIGNMENT ;23 @@ -148,13 +148,13 @@ VECTOR-1B ;2F PRIMITIVE-COMBINATION-0 ;30 VECTOR-16B ;31 - UNASSIGNED ;32 + (REFERENCE-TRAP UNASSIGNED) ;32 SEQUENCE-3 ;33 CONDITIONAL ;34 DISJUNCTION ;35 CELL ;36 WEAK-CONS ;37 - TRAP ;38 + QUAD ;38 COMPILER-RETURN-ADDRESS ;39 COMPILER-LINK ;3A STACK-ENVIRONMENT ;3B @@ -170,16 +170,16 @@ #F ;45 #F ;46 #F ;47 - #F ;48 reserved for PEA instruction on 68000 + #F ;48 #F ;49 #F ;4A #F ;4B #F ;4C #F ;4D - #F ;4E reserved for JMP/JSR instruction on 68000 + #F ;4E #F ;4F #F ;50 - #F ;51 reserved for DBF instruction on 68000 + #F ;51 #F ;52 #F ;53 #F ;54 @@ -228,7 +228,7 @@ #F ;7F )) -;;; [] Return +;;; [] Returns (vector-set! (get-fixed-objects-vector) 5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR) @@ -724,8 +724,8 @@ RE-MATCH ;$192 RE-SEARCH-FORWARD ;$193 RE-SEARCH-BACKWARD ;$194 - SYSTEM-MEMORY-REF ;$195 - SYSTEM-MEMORY-SET! ;$196 + (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195 + (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196 BIT-STRING-FILL! ;$197 BIT-STRING-MOVE! ;$198 BIT-STRING-MOVEC! ;$199 @@ -780,7 +780,7 @@ WRITE-INTO-PURE-SPACE ;1A #F ;1B #F ;1C - ASSIGN-LAMBDA-NAME ;1D + #F ;1D FAILED-ARG-1-COERCION ;1E FAILED-ARG-2-COERCION ;1F OUT-OF-FILE-HANDLES ;20 @@ -799,6 +799,10 @@ WRONG-TYPE-ARGUMENT-7 ;2D WRONG-TYPE-ARGUMENT-8 ;2E WRONG-TYPE-ARGUMENT-9 ;2F + INAPPLICABLE-CONTINUATION ;30 + COMPILED-CODE-ERROR ;31 + FLOATING-OVERFLOW ;32 + UNIMPLEMENTED-PRIMITIVE ;33 )) ;;; [] Terminations @@ -850,4 +854,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $" +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $" diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index b588039fc..23104dda5 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.34 1987/03/12 17:44:30 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.35 1987/04/03 00:23:01 jinx Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 9 #endif #ifndef SUBVERSION -#define SUBVERSION 34 +#define SUBVERSION 35 #endif #ifndef UCODE_TABLES_FILENAME -- 2.25.1