From: Guillermo J. Rozas Date: Fri, 4 Dec 1987 22:20:47 +0000 (+0000) Subject: Some changes to make calling primitives from compiled code cheaper: X-Git-Tag: 20090517-FFI~13015 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9fbe72d23cd44f7a234a19f3155e7d96d10f0cd8;p=mit-scheme.git Some changes to make calling primitives from compiled code cheaper: - Primitives back out in the interpreter, rather than directly. - A table with the arity in bytes has been added to usrdef.c - Primitive objects have two fields: a table index for invocation, and a virtual number for bookkeeping purposes. The table index is always valid, even for unimplemented primitives. In this case it points to a procedure which causes an UNIMPLEMENTE-PRIMITIVE error when invoked. The back out mechanism takes care --- diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index 750526fa6..6a57cd526 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.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/bchdmp.c,v 9.37 1987/11/24 07:58:33 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.38 1987/12/04 22:13:25 jinx Rel $ */ /* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag, purify, and fasdump, respectively, to provide garbage collection @@ -388,8 +388,7 @@ end_dumploop: on an object that is too large). */ -Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) -Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") +DEFINE_PRIMITIVE("PRIMITIVE-FASDUMP", Prim_Prim_Fasdump, 3) { Boolean success; long length, hlength, tlength, tsize; @@ -419,7 +418,7 @@ Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") if (table_start >= table_top) { fasdump_exit(0); - Primitive_GC(table_top - saved_free); + Primitive_GC(table_start - saved_free); } #if (GC_DISK_BUFFER_SIZE <= FASL_HEADER_LENGTH) @@ -452,7 +451,7 @@ Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") if (table_end >= table_top) { fasdump_exit(0); - Primitive_GC(table_top - saved_free); + Primitive_GC(table_end - saved_free); } tsize = (table_end - table_start); @@ -485,8 +484,8 @@ Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") file is loaded back using BAND_LOAD, PROCEDURE is called with an argument of NIL. */ -Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7) -Define_Primitive(Prim_Band_Dump, 2, "DUMP-BAND") + +DEFINE_PRIMITIVE("DUMP-BAND", Prim_Band_Dump, 2) { extern Pointer compiler_utilities; Pointer Combination, *table_start, *table_end, *saved_free; diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 35c1ce545..cf1ded675 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.38 1987/11/17 08:06:33 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.39 1987/12/04 22:13:39 jinx Rel $ */ /* Memory management top level. Garbage collection to disk. @@ -704,8 +704,7 @@ GC(initial_weak_chain) the GC daemon if there is one. */ -Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A) -Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") +DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_Garbage_Collect, 1) { Pointer GC_Daemon_Proc; Primitive_1_Arg(); @@ -713,12 +712,7 @@ Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") Arg_1_Type(TC_FIXNUM); if (Free > Heap_Top) { - fprintf(stderr, - "\nGC has been delayed too long; You are truly 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); + Microcode_Termination(TERM_GC_OUT_OF_SPACE); /*NOTREACHED*/ } GC_Reserve = Get_Integer(Arg1); @@ -733,7 +727,7 @@ Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") Store_Expression(Make_Unsigned_Fixnum(MemTop - Free)); Save_Cont(); Pushed(); - longjmp( *Back_To_Eval, PRIM_POP_RETURN); + PRIMITIVE_ABORT(PRIM_POP_RETURN); /*NOTREACHED*/ } Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); @@ -743,7 +737,7 @@ Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") Push(GC_Daemon_Proc); Push(STACK_FRAME_HEADER); Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); + PRIMITIVE_ABORT(PRIM_APPLY); /* The following comment is by courtesy of LINT, your friendly sponsor. */ /*NOTREACHED*/ } diff --git a/v7/src/microcode/bkpt.h b/v7/src/microcode/bkpt.h index d737da110..9f7052de1 100644 --- a/v7/src/microcode/bkpt.h +++ b/v7/src/microcode/bkpt.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/bkpt.h,v 9.23 1987/04/16 02:08:44 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.24 1987/12/04 22:13:56 jinx Rel $ * * This file contains breakpoint utilities. * Disabled when not debugging the interpreter. @@ -77,7 +77,8 @@ typedef struct sp_record *sp_record_list; #if false /* This code disabled by SAS 6/24/86 */ struct -{ int nprims; +{ + int nprims; int primtime[1]; } perfinfo_data; @@ -85,16 +86,20 @@ void Clear_Perfinfo_Data() { int i; perfinfo_data.nprims = MAX_PRIMITIVE + 1; for (i = 0; i <= MAX_PRIMITIVE; i++) + { perfinfo_data.primtime[i] = 0; + } } -#define Metering_Apply_Primitive(Loc, N) \ -{ \ - long Start_Time = Sys_Clock(); \ - \ - Loc = Apply_Primitive(N) \ - perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \ - Set_Time_Zone(Zone_Working); \ +#define Metering_Apply_Primitive(Loc, prim) +{ + long Start_Time; + + Start_Time = Sys_Clock(); + Loc = Apply_Primitive(prim); + perfinfo_data.primtime[PRIMITIVE_NUMBER(prim)] += + (Sys_Clock() - Start_Time); + Set_Time_Zone(Zone_Working); } #endif #endif /* ifdef ENABLE_DEBUGGING_TOOLS */ diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index dd600d9c1..adf560a7a 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.42 1987/11/23 05:16:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.43 1987/12/04 22:14:06 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -489,7 +489,7 @@ Start_Scheme(Start_Prim, File_Name) Enter_Interpreter() { jmp_buf Orig_Eval_Point; - Back_To_Eval = (jmp_buf *) Orig_Eval_Point; + Back_To_Eval = ((jmp_buf *) Orig_Eval_Point); Interpret(Was_Scheme_Dumped); fprintf(stderr, "\nThe interpreter returned to top level!\n"); @@ -538,7 +538,7 @@ Microcode_Termination(code) } putchar('\n'); - if ((code < 0) || (code > MAX_ERROR)) + if ((code < 0) || (code > MAX_TERMINATION)) { printf("Unknown termination code 0x%x\n", code); } @@ -563,15 +563,6 @@ Microcode_Termination(code) value = 0; break; - case TERM_NON_EXISTENT_CONTINUATION: - printf("Return code = 0x%x\n", Fetch_Return()); - goto normal_termination; - - case TERM_GC_OUT_OF_SPACE: - printf("Memory: required = %d; available = %d\n", - Get_Integer(Fetch_Expression()), Space_Before_GC()); - goto normal_termination; - case TERM_NO_ERROR_HANDLER: /* This does not print a back trace because it was printed before getting here irrelevant of the state of Trace_On_Error. @@ -579,6 +570,18 @@ Microcode_Termination(code) value = 1; break; + case TERM_NON_EXISTENT_CONTINUATION: + printf("Return code = 0x%lx\n", Fetch_Return()); + goto normal_termination; + + case TERM_GC_OUT_OF_SPACE: + printf("You are out of space at the end of a Garbage Collection!\n"); + printf("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n", + Free, MemTop, Heap_Top); + printf("Words required = %ld; Words available = %ld\n", + (MemTop - Free), GC_Space_Needed); + goto normal_termination; + default: normal_termination: value = 1; diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h index c63684df6..289142eae 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.25 1987/11/17 08:08:36 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.26 1987/12/04 22:14:55 jinx Rel $ * * Named constants used throughout the interpreter * @@ -115,6 +115,7 @@ MIT in each case. */ #define PRIM_NO_TRAP_EVAL -5 #define PRIM_NO_TRAP_APPLY -6 #define PRIM_POP_RETURN -7 +#define PRIM_TOUCH -8 /* Some numbers of parameters which mean something special */ diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index 57caa68b0..fea910a09 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.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/debug.c,v 9.26 1987/11/17 08:08:55 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.27 1987/12/04 22:15:07 jinx Rel $ * * Utilities to help with debugging */ @@ -201,27 +201,36 @@ Pointer Ptr; printf("[0x%x]", index); } -void Print_Return(String) -char *String; -{ printf("%s: ", String); +void +Print_Return(String) + char *String; +{ + printf("%s: ", String); Print_Return_Name(Fetch_Return()); CRLF(); } extern Boolean Prt_PName(); -void Print_Expression(Expr, String) -char *String; -Pointer Expr; -{ if (String[0] != 0) printf("%s: ", String); +void +Print_Expression(Expr, String) + char *String; + Pointer Expr; +{ + if (String[0] != 0) + { + printf("%s: ", String); + } Do_Printing(Expr, true); } Do_Printing(Expr, Detailed) -Pointer Expr; -Boolean Detailed; -{ long Temp_Address; + Pointer Expr; + Boolean Detailed; +{ + long Temp_Address; Boolean Return_After_Print; + Temp_Address = Get_Integer(Expr); Return_After_Print = false; switch(Type_Code(Expr)) @@ -244,8 +253,9 @@ Boolean Detailed; printf("\""); Length = ((long) (Vector_Ref(Expr, STRING_LENGTH))); Next = (char *) Nth_Vector_Loc(Expr, STRING_CHARS); - for (i=0; i < Length; i++) - { This = *Next++; + for (i = 0; i < Length; i++) + { + This = *Next++; printf((This < ' ') || (This > '|') ? "\\%03o" : "%c", This); } @@ -275,7 +285,7 @@ Boolean Detailed; case TC_LIST: List_Print(Expr); return; case TC_NULL: - if (Temp_Address==0) + if (Temp_Address == 0) { printf("()"); return; } @@ -378,17 +388,19 @@ SPrint: return; } case TC_EXTENDED_LAMBDA: - if (Detailed) printf("[EXTENDED_LAMBDA ("); - Do_Printing( - Vector_Ref( - Vector_Ref(Expr, ELAMBDA_NAMES), - 1), false); - if (Detailed) printf(") 0x%x", Temp_Address); + if (Detailed) + printf("[EXTENDED_LAMBDA ("); + Do_Printing(Vector_Ref(Vector_Ref(Expr, ELAMBDA_NAMES), 1), false); + if (Detailed) + printf(") 0x%x", Temp_Address); return; + case TC_EXTENDED_PROCEDURE: - if (Detailed) printf("[EXTENDED_PROCEDURE ("); + if (Detailed) + printf("[EXTENDED_PROCEDURE ("); Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false); - if (Detailed) printf(") 0x%x]", Temp_Address); + if (Detailed) + printf(") 0x%x]", Temp_Address); break; /* Do_Printing continues on the next page */ @@ -423,7 +435,7 @@ SPrint: case TC_PCOMB2: printf("[PCOMB2"); break; case TC_PCOMB3: printf("[PCOMB3"); break; case TC_PRIMITIVE: - printf("[PRIMITIVE "); Prt_PName(Temp_Address); + printf("[PRIMITIVE "); Prt_PName(Expr); printf("]"); return; case TC_PROCEDURE: if (Detailed) @@ -463,7 +475,8 @@ SPrint: case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break; case TC_TRUE: if (Temp_Address == 0) - { printf("#!true"); + { + printf("#T"); return; } printf("[TRUE"); @@ -567,16 +580,16 @@ Print_Stack(SP) } Boolean -Prt_PName(Number) - long Number; +Prt_PName(primitive) + Pointer primitive; { extern char *primitive_to_name(); char *name; - name = primitive_to_name(Number); + name = primitive_to_name(primitive); if (name == ((char *) NULL)) { - printf("Unknown primitive 0x%08x", Number); + printf("Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive)); return false; } else @@ -586,8 +599,8 @@ Prt_PName(Number) } } -void Print_Primitive(Number) - long Number; +void Print_Primitive(primitive) + Pointer primitive; { extern long primitive_to_arity(); @@ -595,10 +608,14 @@ void Print_Primitive(Number) int NArgs, i; printf("Primitive: "); - if (Prt_PName(Number)) - NArgs = primitive_to_arity(Number); + if (Prt_PName(primitive)) + { + NArgs = primitive_to_arity(primitive); + } else + { NArgs = 3; /* Unknown primitive */ + } printf("\n"); for (i = 0; i < NArgs; i++) @@ -611,8 +628,9 @@ void Print_Primitive(Number) } Debug_Printer(Expr) -Pointer Expr; -{ Print_Expression(Expr, ""); + Pointer Expr; +{ + Print_Expression(Expr, ""); putchar('\n'); } diff --git a/v7/src/microcode/dmpwrld.c b/v7/src/microcode/dmpwrld.c index f0cb31043..6dfb17168 100644 --- a/v7/src/microcode/dmpwrld.c +++ b/v7/src/microcode/dmpwrld.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/dmpwrld.c,v 9.25 1987/06/18 22:15:11 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.26 1987/12/04 22:15:25 jinx Rel $ * * This file contains a primitive to dump an executable version of Scheme. * It uses unexec.c from GNU Emacs. @@ -181,7 +181,7 @@ Restore_Input_Buffer(Buflen) extern Boolean Was_Scheme_Dumped; extern unix_find_pathname(); -Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD") +DEFINE_PRIMITIVE ("DUMP-WORLD", Prim_Dump_World, 1) { char *fname, path_buffer[FILE_NAME_LENGTH]; Boolean Saved_Dumped_Value, Saved_Photo_Open; @@ -192,7 +192,9 @@ Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD") Arg_1_Type(TC_CHARACTER_STRING); if (there_are_open_files()) - Primitive_Error(ERR_OUT_OF_FILE_HANDLES); + { + Primitive_Error(ERR_OUT_OF_FILE_HANDLES); + } fname = Scheme_String_To_C_String(Arg1); @@ -246,7 +248,7 @@ Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD") Primitive_Error(ERR_EXTERNAL_RETURN); } - longjmp(*Back_To_Eval, PRIM_POP_RETURN); + PRIMITIVE_ABORT(PRIM_POP_RETURN); /*NOTREACHED*/ } diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h index 9cf1d9273..d4fd58b2b 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.26 1987/11/17 08:09:19 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.27 1987/12/04 22:15:36 jinx Exp $ * * Error and termination code declarations. * @@ -134,10 +134,11 @@ MIT in each case. */ #define TERM_GC_OUT_OF_SPACE 0x14 #define TERM_NO_SPACE 0x15 #define TERM_SIGNAL 0x16 +#define TERM_TOUCH 0x17 /* If you add any termination codes here, remember to add them to storage.c as well. */ -#define MAX_TERMINATION 0x16 +#define MAX_TERMINATION 0x17 diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c index faf5659eb..dce62ed67 100644 --- a/v7/src/microcode/extern.c +++ b/v7/src/microcode/extern.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/extern.c,v 9.24 1987/11/18 00:09:22 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.25 1987/12/04 22:15:47 jinx Rel $ */ #include "scheme.h" #include "primitive.h" @@ -39,44 +39,53 @@ MIT in each case. */ primitives and return addresses. */ -/* (MAP-CODE-TO-MACHINE-ADDRESS TYPE-CODE VALUE-CODE) - 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. +/* (MAP-CODE-TO-MACHINE-ADDRESS TYPE-CODE VALUE-CODE) 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 for + return codes, but for primitives there are two parts to the code. + 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-MACHINE-ADDRESS", 0x93) -Define_Primitive(Prim_Map_Code_To_Address, 2, - "MAP-CODE-TO-MACHINE-ADDRESS") + +DEFINE_PRIMITIVE("MAP-CODE-TO-MACHINE-ADDRESS", Prim_Map_Code_To_Address, 2) { - long Code, Offset; + Pointer result; + long tc, number; Primitive_2_Args(); Arg_1_Type(TC_FIXNUM); Arg_2_Type(TC_FIXNUM); - Code = Get_Integer(Arg1); - Offset = Get_Integer(Arg2); - switch (Code) + tc = Get_Integer(Arg1); + number = Get_Integer(Arg2); + switch (tc) { case TC_RETURN_CODE: - if (Offset > MAX_RETURN_CODE) + if (number > MAX_RETURN_CODE) { Primitive_Error(ERR_ARG_2_BAD_RANGE); } + result = (Make_Non_Pointer(tc, number)); break; case TC_PRIMITIVE: - if (Offset >= NUMBER_OF_PRIMITIVES()) + if (number >= NUMBER_OF_PRIMITIVES()) { Primitive_Error(ERR_ARG_2_BAD_RANGE); } + if (number > MAX_PRIMITIVE) + { + result = MAKE_PRIMITIVE_OBJECT(number, (MAX_PRIMITIVE + 1)); + } + else + { + result = MAKE_PRIMITIVE_OBJECT(0, number); + } break; default: Primitive_Error(ERR_ARG_1_BAD_RANGE); } - return (Make_Non_Pointer(Code, Offset)); + PRIMITIVE_RETURN(result); } /* (MAP-MACHINE-ADDRESS-TO-CODE TYPE-CODE ADDRESS) @@ -85,62 +94,54 @@ Define_Primitive(Prim_Map_Code_To_Address, 2, primitive) it finds the number for the external representation for the internal address. */ -Built_In_Primitive(Prim_Map_Address_To_Code, 2, - "MAP-MACHINE-ADDRESS-TO-CODE", 0x90) -Define_Primitive(Prim_Map_Address_To_Code, 2, - "MAP-MACHINE-ADDRESS-TO-CODE") + +DEFINE_PRIMITIVE("MAP-MACHINE-ADDRESS-TO-CODE", Prim_Map_Address_To_Code, 2) { - long Code, Offset; + long tc, number; Primitive_2_Args(); Arg_1_Type(TC_FIXNUM); - Code = Get_Integer(Arg1); - Arg_2_Type(Code); - Offset = Get_Integer(Arg2); - switch (Code) + tc = Get_Integer(Arg1); + Arg_2_Type(tc); + switch (tc) { case TC_RETURN_CODE: - if (Offset > MAX_RETURN_CODE) + number = Get_Integer(Arg2); + if (number > MAX_RETURN_CODE) { Primitive_Error(ERR_ARG_2_BAD_RANGE); } break; case TC_PRIMITIVE: - if (Offset > NUMBER_OF_PRIMITIVES()) - { - Primitive_Error(ERR_ARG_2_BAD_RANGE); - } + number = PRIMITIVE_NUMBER(Arg2); break; default: Primitive_Error(ERR_ARG_1_BAD_RANGE); } - return (MAKE_UNSIGNED_FIXNUM(Offset)); + PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(number)); } -/* (PRIMITIVE-PROCEDURE-ARITY INTERNAL-PRIMITIVE) +/* (PRIMITIVE-PROCEDURE-ARITY PRIMITIVE) 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", 0x96) -Define_Primitive(Prim_Map_Prim_Address_To_Arity, 1, - "PRIMITIVE-PROCEDURE-ARITY") + +DEFINE_PRIMITIVE("PRIMITIVE-PROCEDURE-ARITY", Prim_Map_Prim_Address_To_Arity, 1) { extern long primitive_to_arity(); - long Prim_Num, answer; + long answer; Primitive_1_Arg(); Arg_1_Type(TC_PRIMITIVE); - Prim_Num = Get_Integer(Arg1); - if (Prim_Num >= NUMBER_OF_PRIMITIVES()) + if (PRIMITIVE_NUMBER(Arg1) >= NUMBER_OF_PRIMITIVES()) { Primitive_Error(ERR_ARG_1_BAD_RANGE); } - answer = primitive_to_arity(Prim_Num); - return (MAKE_SIGNED_FIXNUM(answer)); + answer = primitive_to_arity(Arg1); + PRIMITIVE_RETURN(MAKE_SIGNED_FIXNUM(answer)); } /* (GET-PRIMITIVE-COUNTS) @@ -149,8 +150,7 @@ Define_Primitive(Prim_Map_Prim_Address_To_Arity, 1, defined. */ -Built_In_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS", 0x101) -Define_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS") +DEFINE_PRIMITIVE("GET-PRIMITIVE-COUNTS", Prim_Get_Primitive_Counts, 0) { Primitive_0_Args(); @@ -164,20 +164,22 @@ Define_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS") primitive procedure. It causes an error if the number is out of range. */ -Built_In_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME", 0x102) -Define_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME") +DEFINE_PRIMITIVE("GET-PRIMITIVE-NAME", Prim_Get_Primitive_Name, 1) { extern Pointer primitive_name(); long Number, TC; Primitive_1_Arg(); - TC = Type_Code(Arg1); + TC = OBJECT_TYPE(Arg1); if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE)) { Primitive_Error(ERR_ARG_1_WRONG_TYPE); } - Range_Check(Number, Arg1, 0, (NUMBER_OF_PRIMITIVES() - 1), - ERR_ARG_1_BAD_RANGE); + Number = PRIMITIVE_NUMBER(Arg1); + if ((Number < 0) || (Number >= NUMBER_OF_PRIMITIVES())) + { + Primitive_Error(ERR_ARG_1_BAD_RANGE); + } PRIMITIVE_RETURN(primitive_name(Number)); } @@ -191,8 +193,7 @@ Define_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME") whether the corresponding primitive is implemented or not. */ -Built_In_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS", 0x103) -Define_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS") +DEFINE_PRIMITIVE("GET-PRIMITIVE-ADDRESS", Prim_Get_Primitive_Address, 2) { extern Pointer find_primitive(); Boolean intern_p, allow_p; diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 4efdcd66a..b96140efd 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.31 1987/11/17 08:09:49 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.32 1987/12/04 22:16:00 jinx Rel $ This file contains code for fasdump and dump-band. */ @@ -233,8 +233,8 @@ Fasdump_Exit() The code for dumping pure is severely broken and conditionalized out. */ -Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) -Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") + +DEFINE_PRIMITIVE("PRIMITIVE-FASDUMP", Prim_Prim_Fasdump, 3) { Pointer Object, File_Name, Flag, *New_Object; Pointer *table_start, *table_end; @@ -265,7 +265,7 @@ Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") table_start = initialize_primitive_table(Free, table_end); if (table_start >= table_end) { - Primitive_GC(table_end - table_start); + Primitive_GC(table_start - Free); } Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free); @@ -365,8 +365,8 @@ Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP") file is loaded back using BAND_LOAD, PROCEDURE is called with an argument of NIL. */ -Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7) -Define_Primitive(Prim_Band_Dump, 2, "DUMP-BAND") + +DEFINE_PRIMITIVE("DUMP-BAND", Prim_Band_Dump, 2) { extern Pointer compiler_utilities; Pointer Combination, *table_start, *table_end, *saved_free; diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 991f572af..1b8cd23b2 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.31 1987/11/17 08:10:13 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.32 1987/12/04 22:16:13 jinx Rel $ The "fast loader" which reads in and relocates binary files and then interns symbols. It is called with one argument: the (character @@ -276,13 +276,13 @@ Relocate_Block(Next_Pointer, Stop_At) break; case TC_PRIMITIVE: - *Next_Pointer++ = load_renumber_table[Get_Integer(Temp)]; + *Next_Pointer++ = load_renumber_table[PRIMITIVE_NUMBER(Temp)]; break; case TC_PCOMB0: *Next_Pointer++ = Make_Non_Pointer(TC_PCOMB0, - load_renumber_table[Get_Integer(Temp)]); + load_renumber_table[PRIMITIVE_NUMBER(Temp)]); break; case TC_MANIFEST_NM_VECTOR: @@ -462,8 +462,8 @@ load_file(from_band_load) will be a piece of SCode which is then evaluated to perform definitions in some environment. */ -Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57) -Define_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD") + +DEFINE_PRIMITIVE("BINARY-FASLOAD", Prim_Binary_Fasload, 1) { long result; Primitive_1_Arg(); @@ -492,17 +492,17 @@ static char *reload_band_name = ((char *) NULL); Returns the filename (as a Scheme string) from which the runtime system was band loaded (load-band'ed ?), or NIL if the system was fasl'ed. */ -Built_In_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME", 0x1A3) -Define_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME") + +DEFINE_PRIMITIVE("RELOAD-BAND-NAME", Prim_reload_band_name, 0) { Primitive_0_Args(); if (reload_band_name == NULL) { - return NIL; + PRIMITIVE_RETURN(NIL); } - return (C_String_To_Scheme_String(reload_band_name)); + PRIMITIVE_RETURN(C_String_To_Scheme_String(reload_band_name)); } /* Utility for load band below. */ @@ -524,8 +524,8 @@ compiler_reset_error() which is typically a file created by DUMP-BAND. The file can, however, be any file which can be loaded with BINARY-FASLOAD. */ -Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND", 0xB9) -Define_Primitive(Prim_Band_Load, 1, "LOAD-BAND") + +DEFINE_PRIMITIVE("LOAD-BAND", Prim_Band_Load, 1) { extern char *malloc(); extern strcpy(), free(); @@ -633,7 +633,6 @@ Setup_For_String_Inversion() Finish_String_Inversion() { - if (Byte_Invert_Fasl_Files) { while (String_Chain != NIL) diff --git a/v7/src/microcode/findprim.c b/v7/src/microcode/findprim.c index 90063e6c5..8faaaefe0 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.31 1987/12/03 19:30:52 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.32 1987/12/04 22:13:04 jinx Exp $ * * Preprocessor to find and declare defined primitives. * @@ -511,11 +511,39 @@ static descriptor Inexistent_Entry = static char Inexistent_Error_String[] = "Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)"; - + static int C_Size = 0; static int A_Size = 0; static int S_Size = 0; static int F_Size = 0; + +void +update_from_entry(primitive_descriptor) + descriptor *primitive_descriptor; +{ + int temp; + temp = strlen(primitive_descriptor->C_Name); + if (temp > C_Size) + { + C_Size = temp; + } + temp = strlen(primitive_descriptor->Arity); + if (temp > A_Size) + { + A_Size = temp; + } + temp = strlen(primitive_descriptor->Scheme_Name); + if (temp > S_Size) + { + S_Size = temp; + } + temp = strlen(primitive_descriptor->File_Name); + if (temp > F_Size) + { + F_Size = temp; + } + return; +} pseudo_void create_normal_entry() @@ -571,6 +599,7 @@ initialize_external() (token_processors [1]) = NULL; The_Kind = &External_Kind[0]; The_Variable = &External_Variable[0]; + update_from_entry(&Inexistent_Entry); return; } @@ -586,17 +615,7 @@ initialize_default() (token_processors [2]) = NULL; The_Kind = &Default_Kind[0]; The_Variable = &Default_Variable[0]; - return; -} - -void -initialize_from_entry(primitive_descriptor) - descriptor *primitive_descriptor; -{ - C_Size = strlen(primitive_descriptor->C_Name); - A_Size = strlen(primitive_descriptor->Arity); - S_Size = strlen(primitive_descriptor->Scheme_Name); - F_Size = strlen(primitive_descriptor->File_Name); + update_from_entry(&Inexistent_Entry); return; } @@ -679,7 +698,7 @@ initialize_builtin(arg) { Result_Buffer[index] = &Inexistent_Entry; } - initialize_from_entry(&Inexistent_Entry); + update_from_entry(&Inexistent_Entry); return; } @@ -822,9 +841,13 @@ void initialize_index_size() { if (Built_in_p) + { max = Built_in_table_size; + } else + { max = buffer_index; + } find_index_size(max, max_index_size); max -= 1; return; @@ -835,7 +858,9 @@ print_spaces(how_many) register int how_many; { for(; --how_many >= 0;) + { putc(' ', output); + } return; } @@ -856,9 +881,18 @@ print_entry(index, primitive_descriptor) (primitive_descriptor->Scheme_Name)); print_spaces(S_Size-(strlen(primitive_descriptor->Scheme_Name))); fprintf(output, " %s ", The_Kind); - find_index_size(index, index_size); - print_spaces(max_index_size - index_size); - fprintf(output, "0x%x in %s %c/", index, (primitive_descriptor->File_Name), '*'); + if (index >= 0) + { + find_index_size(index, index_size); + print_spaces(max_index_size - index_size); + fprintf(output, "0x%x", index); + } + else + { + print_spaces(max_index_size - 1); + fprintf(output, "???"); + } + fprintf(output, " in %s %c/", (primitive_descriptor->File_Name), '*'); return; } @@ -873,6 +907,7 @@ print_procedure(primitive_descriptor, error_string) fprintf(output, " Primitive_%s_Args();\n", (primitive_descriptor->Arity)); fprintf(output, "\n"); fprintf(output, " %s;\n", error_string); + fprintf(output, " /%cNOTREACHED%c/\n", '*', '*'); fprintf(output, "}\n"); return; } @@ -888,14 +923,25 @@ print_primitives(last) fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Kind); - for (count = 0; count < last; count++) + for (count = 0; count <= last; count++) { print_entry(count, Result_Buffer[count]); fprintf(output, ",\n"); } - print_entry(last, Result_Buffer[last]); + print_entry(-1, &Inexistent_Entry); fprintf(output, "\n};\n\f\n"); + /* Print the names table. */ + + fprintf(output, "char *%s_Name_Table[] = {\n", The_Kind); + + for (count = 0; count < last; count++) + { + fprintf(output, " \"%s\",\n", ((Result_Buffer[count])->Scheme_Name)); + } + fprintf(output, " \"%s\"\n", ((Result_Buffer[last])->Scheme_Name)); + fprintf(output, "};\n\f\n"); + /* Print the arity table. */ fprintf(output, "int %s_Arity_Table[] = {\n", The_Kind); @@ -907,15 +953,19 @@ print_primitives(last) fprintf(output, " %s\n", ((Result_Buffer[last])->Arity)); fprintf(output, "};\n\f\n"); - /* Print the names table. */ + /* Print the counts table. */ - fprintf(output, "char *%s_Name_Table[] = {\n", The_Kind); + fprintf(output, "int %s_Count_Table[] = {\n", The_Kind); for (count = 0; count < last; count++) { - fprintf(output, " \"%s\",\n", ((Result_Buffer[count])->Scheme_Name)); + fprintf(output, + " (%s * sizeof(Pointer)),\n", + ((Result_Buffer[count])->Arity)); } - fprintf(output, " \"%s\"\n", ((Result_Buffer[last])->Scheme_Name)); + fprintf(output, + " (%s * sizeof(Pointer))\n", + ((Result_Buffer[last])->Arity)); fprintf(output, "};\n\n"); return; @@ -940,16 +990,23 @@ dump(check) fprintf(output, "#include \"usrdef.h\"\n\n"); - fprintf(output, "long %s = %d;\n\n", The_Variable, max); + fprintf(output, + "long %s = %d; /%c = 0x%x %c/\n\n", + The_Variable, max, '*', max, '*'); + if (Built_in_p) + { fprintf(output, "/%c The number of implemented primitives is %d. %c/\n\n", '*', buffer_index, '*'); + } if (max < 0) { if (check) + { fprintf(stderr, "No primitives found!\n"); + } /* C does not understand the empty array, thus it must be faked. */ @@ -959,9 +1016,9 @@ dump(check) /* Dummy entry */ Result_Buffer[0] = &Dummy_Entry; - initialize_from_entry(&Dummy_Entry); + update_from_entry(&Dummy_Entry); print_procedure(&Dummy_Entry, &Dummy_Error_String[0]); - + fprintf(output, "\n"); } else @@ -976,17 +1033,10 @@ dump(check) fprintf(output, " %s(),\n", &(Data_Buffer[count].C_Name)[0]); } - if (Built_in_p) - { - fprintf(output, " %s();\n\n", &(Inexistent_Entry.C_Name)[0]); - print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]); - } - else - { - fprintf(output, " %s();\n", &(Data_Buffer[end].C_Name)[0]); - } + fprintf(output, " %s();\n\n", &(Data_Buffer[end].C_Name)[0]); } + print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]); fprintf(output, "\f\n"); print_primitives((max < 0) ? 0 : max); return; diff --git a/v7/src/microcode/futures.h b/v7/src/microcode/futures.h index 01c0e5264..4a8bd036c 100644 --- a/v7/src/microcode/futures.h +++ b/v7/src/microcode/futures.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/futures.h,v 9.22 1987/07/07 19:59:21 cph Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.23 1987/12/04 22:16:33 jinx Rel $ * * This file contains macros useful for dealing with futures */ @@ -75,29 +75,43 @@ MIT in each case. */ (Vector_Ref((P), FUTURE_IS_DETERMINED) != TRUTH)) #ifdef COMPILE_FUTURES + /* Touch_In_Primitive is used by primitives which are not - * strict in an argument but which touch it none the less. + * strict in an argument but which touch it none the less. */ -#define Touch_In_Primitive(P, To_Where) \ -{ Pointer Value = (P); \ - while (Type_Code(Value) == TC_FUTURE) \ - { if (Future_Has_Value(Value)) \ - { if (Future_Is_Keep_Slot(Value)) Log_Touch_Of_Future(Value);\ - Value = Future_Value(Value); \ - } \ - else \ - { Back_Out_Of_Primitive(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Save_Cont(); \ - Push(Value); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - longjmp(*Back_To_Eval, PRIM_APPLY); \ - } \ - } \ - To_Where = Value; \ +#define Touch_In_Primitive(P, To_Where) \ +{ \ + Pointer Value; \ + \ + Value = (P); \ + while (OBJECT_TYPE(Value) == TC_FUTURE) \ + { \ + if (Future_Has_Value(Value)) \ + { \ + if (Future_Is_Keep_Slot(Value)) \ + { \ + Log_Touch_Of_Future(Value); \ + } \ + Value = Future_Value(Value); \ + } \ + else \ + { \ + Val = Value; \ + PRIMITIVE_ABORT(PRIM_TOUCH); \ + } \ + } \ + To_Where = Value; \ +} + +#define TOUCH_SETUP(object) \ +{ \ + Save_Cont(); \ + Will_Push(STACK_ENV_EXTRA_SLOTS + 2); \ + Push(object); \ + Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ + Push(STACK_FRAME_HEADER + 1); \ + Pushed(); \ } /* NOTES ON FUTURES, derived from the rest of the interpreter code */ @@ -110,9 +124,6 @@ MIT in each case. */ ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor do the cached lexical address slots. - ASSUMPTION: Compiled code calls to the interpreter require the results - be touched before returning to the compiled code. This may be very wrong. - ASSUMPTION: History objects are never created using futures. ASSUMPTION: State points, which are created only by the interpreter, @@ -140,7 +151,7 @@ MIT in each case. */ */ /* KNOWN PROBLEMS: - (1) Garbage collector should be modified to splice out futures. + (1) Garbage collector should be modified to splice out futures. DONE. (2) Purify should be looked at and we should decide what to do about purifying an object with a reference to a future (it should probably @@ -161,28 +172,34 @@ MIT in each case. */ of touched futures about which the scheme portion of the system has not yet been informed */ -#define Log_Touch_Of_Future(F) \ +#define Log_Touch_Of_Future(F) \ if (Logging_On()) \ -{ Pointer TFV = Touched_Futures_Vector(); \ - long Count = Get_Integer(User_Vector_Ref(TFV, 0))+1; \ - User_Vector_Ref(TFV, 0) = FIXNUM_0 + Count; \ +{ \ + Pointer TFV; \ + long Count; \ + \ + TFV = Touched_Futures_Vector(); \ + Count = Get_Integer(User_Vector_Ref(TFV, 0)) + 1; \ + User_Vector_Ref(TFV, 0) = MAKE_UNSIGNED_FIXNUM(Count); \ if (Count < Vector_Length(TFV)) \ - User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \ + { \ + User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \ + } \ } /* Call_Future_Logging calls a user defined scheme routine if the vector of touched futures has a nonzero length. */ #define Must_Report_References() \ -( Logging_On() && \ +( (Logging_On()) && \ (Get_Integer(User_Vector_Ref(Touched_Futures_Vector(), 0)) > 0)) #define Call_Future_Logging() \ { \ - Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ + Will_Push(STACK_ENV_EXTRA_SLOTS + 2); \ Push(Touched_Futures_Vector()); \ Push(Get_Fixed_Obj_Slot(Future_Logger)); \ - Push(STACK_FRAME_HEADER+1); \ + Push(STACK_FRAME_HEADER + 1); \ Pushed(); \ Touched_Futures_Vector() = NIL; \ goto Apply_Non_Trapping; \ @@ -197,14 +214,18 @@ if (Logging_On()) \ #endif /* FUTURE_LOGGING */ #define FUTURE_VARIABLE_SPLICE(P, Offset, Value) \ -while (Type_Code(Value) == TC_FUTURE && Future_Spliceable(Value)) \ -{ Value = Future_Value(Value); \ - Vector_Set(P, Offset, Value); \ +{ \ + while ((OBJECT_TYPE(Value) == TC_FUTURE) && Future_Spliceable(Value)) \ + { \ + Value = Future_Value(Value); \ + Vector_Set(P, Offset, Value); \ + } \ } #else /* not COMPILE_FUTURES */ #define Touch_In_Primitive(P, To_Where) To_Where = (P) +#define TOUCH_SETUP(object) Microcode_Termination(TERM_TOUCH) #define Log_Touch_Of_Future(F) { } #define Call_Future_Logging() #define Must_Report_References() (false) diff --git a/v7/src/microcode/gc.h b/v7/src/microcode/gc.h index 3fb627444..573d6f019 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.24 1987/11/17 08:11:37 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.25 1987/12/04 22:16:46 jinx Rel $ * * Garbage collection related macros of sufficient utility to be * included in all compilations. @@ -75,12 +75,13 @@ MIT in each case. */ #define GC_ENABLED_P() (INTERRUPT_ENABLED_P(INT_GC)) -#define GC_Check(Amount) (((Amount + Free) >= MemTop) && \ - (GC_ENABLED_P())) +#define GC_Check(Amount) \ +(((Amount + Free) >= MemTop) && (GC_ENABLED_P())) -#define Space_Before_GC() ((GC_ENABLED_P()) ? \ - (MemTop - Free) : \ - (Heap_Top - Free)) +#define Space_Before_GC() \ +((GC_ENABLED_P()) ? \ + ((Free <= MemTop) ? (MemTop - Free) : 0) : \ + (Heap_Top - Free)) #define Request_GC(Amount) \ { \ diff --git a/v7/src/microcode/intercom.c b/v7/src/microcode/intercom.c index 69807075b..978be6dae 100644 --- a/v7/src/microcode/intercom.c +++ b/v7/src/microcode/intercom.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/intercom.c,v 9.23 1987/07/07 21:02:14 cph Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.24 1987/12/04 22:16:56 jinx Rel $ * * Single-processor simulation of locking, propagating, and * communicating stuff. @@ -62,7 +62,7 @@ MIT in each case. */ processors have begun execution of WORK (or TEST returns false). */ -Define_Primitive(Prim_Send_Global_Interrupt, 3, "GLOBAL-INTERRUPT") +DEFINE_PRIMITIVE("GLOBAL-INTERRUPT", Prim_Send_Global_Interrupt, 3) { long Saved_Zone, Which_Level; @@ -79,7 +79,7 @@ Define_Primitive(Prim_Send_Global_Interrupt, 3, "GLOBAL-INTERRUPT") Push(STACK_FRAME_HEADER); Pushed(); Restore_Time_Zone(); - longjmp(*Back_To_Eval, PRIM_APPLY); + PRIMITIVE_ABORT(PRIM_APPLY); /*NOTREACHED*/ } @@ -90,7 +90,7 @@ Global_Int_Part_2(Which_Level, Do_It) return Do_It; } -Define_Primitive(Prim_Put_Work, 1, "PUT-WORK") +DEFINE_PRIMITIVE("PUT-WORK", Prim_Put_Work, 1) { Pointer The_Queue, Queue_Tail, New_Entry; Primitive_1_Arg(); @@ -105,54 +105,70 @@ Define_Primitive(Prim_Put_Work, 1, "PUT-WORK") *Free++ = NIL; } else + { Primitive_GC_If_Needed(2); + } Queue_Tail = Vector_Ref(The_Queue, CONS_CDR); New_Entry = Make_Pointer(TC_WEAK_CONS, Free); *Free++ = Arg1; *Free++ = NIL; Vector_Set(The_Queue, CONS_CDR, New_Entry); if (Queue_Tail == NIL) + { Vector_Set(The_Queue, CONS_CAR, New_Entry); - else Vector_Set(Queue_Tail, CONS_CDR, New_Entry); - return TRUTH; + } + else + { + Vector_Set(Queue_Tail, CONS_CDR, New_Entry); + } + PRIMITIVE_RETURN(TRUTH); } - -Define_Primitive(Prim_Put_Work_In_Front, 1, "PUT-WORK-IN-FRONT") -{ Pointer The_Queue, Queue_Head, New_Entry; + +DEFINE_PRIMITIVE("PUT-WORK-IN-FRONT", Prim_Put_Work_In_Front, 1) +{ + Pointer The_Queue, Queue_Head, New_Entry; Primitive_1_Arg(); The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue); - if (The_Queue==NIL) + if (The_Queue == NIL) { Primitive_GC_If_Needed(4); The_Queue = Make_Pointer(TC_LIST, Free); Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue); *Free++ = NIL; *Free++ = NIL; } - else Primitive_GC_If_Needed(2); + else + { + Primitive_GC_If_Needed(2); + } Queue_Head = Vector_Ref(The_Queue, CONS_CDR); New_Entry = Make_Pointer(TC_WEAK_CONS, Free); *Free++ = Arg1; *Free++ = Queue_Head; Vector_Set(The_Queue, CONS_CAR, New_Entry); - if (Queue_Head==NIL) Vector_Set(The_Queue, CONS_CDR, New_Entry); + if (Queue_Head == NIL) + { + Vector_Set(The_Queue, CONS_CDR, New_Entry); + } + PRIMITIVE_RETURN(TRUTH); } - -Define_Primitive(Prim_Drain_Queue, 0, "DRAIN-WORK-QUEUE!") + +DEFINE_PRIMITIVE("DRAIN-WORK-QUEUE!", Prim_Drain_Queue, 0) { Pointer The_Queue; Primitive_0_Args(); The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue); Set_Fixed_Obj_Slot(The_Work_Queue, NIL); - return ((The_Queue != NIL) ? - Vector_Ref(The_Queue, CONS_CAR) : - NIL); + PRIMITIVE_RETURN((The_Queue != NIL) ? + Vector_Ref(The_Queue, CONS_CAR) : + NIL); } -Define_Primitive(Prim_Peek_Queue, 0, "PEEK-AT-WORK-QUEUE") -{ Pointer The_Queue, This_Cons, Last_Cons; +DEFINE_PRIMITIVE("PEEK-AT-WORK-QUEUE", Prim_Peek_Queue, 0) +{ + Pointer The_Queue, This_Cons, Last_Cons; Primitive_0_Args(); The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue); @@ -161,98 +177,161 @@ Define_Primitive(Prim_Peek_Queue, 0, "PEEK-AT-WORK-QUEUE") Last_Cons = NIL; for (The_Queue = Vector_Ref(The_Queue, CONS_CAR); The_Queue != NIL; - The_Queue = Vector_Ref(The_Queue, CONS_CDR)) { + The_Queue = Vector_Ref(The_Queue, CONS_CDR)) + { Primitive_GC_If_Needed(2); This_Cons = Make_Pointer(TC_LIST, Free); *Free++ = Vector_Ref(The_Queue, CONS_CAR); *Free++ = Last_Cons; - Last_Cons = This_Cons; } + Last_Cons = This_Cons; + } + + PRIMITIVE_RETURN(This_Cons); +} + +DEFINE_PRIMITIVE("GET-WORK", Prim_Get_Work, 1) +{ + Pointer Get_Work(); + Primitive_1_Arg(); - return This_Cons; + PRIMITIVE_RETURN(Get_Work(Arg1)); +} + +Pointer Get_Work(Arg1) + Pointer Arg1; +{ + Pointer The_Queue, Queue_Head, Result, The_Prim; + + /* This gets this primitive's code which is in the expression register. */ + The_Prim = Fetch_Expression(); + 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(The_Prim); + Push(STACK_FRAME_HEADER+1); + Store_Expression(NIL); + Store_Return(RC_INTERNAL_APPLY); + Save_Cont(); + Push(Arg1); + Push(STACK_FRAME_HEADER); + Pushed(); + PRIMITIVE_ABORT(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); } -Define_Primitive(Prim_Await_Sync, 1, "AWAIT-SYNCHRONY") +DEFINE_PRIMITIVE("AWAIT-SYNCHRONY", Prim_Await_Sync, 1) { Primitive_1_Arg(); Arg_1_Type(TC_LIST); if (Type_Code(Vector_Ref(Arg1, CONS_CDR)) != TC_FIXNUM) + { Primitive_Error(ERR_ARG_1_BAD_RANGE); - return TRUTH; + } + PRIMITIVE_RETURN(TRUTH); } -Define_Primitive(Prim_N_Interps, 0, "N-INTERPRETERS") +DEFINE_PRIMITIVE("N-INTERPRETERS", Prim_N_Interps, 0) { Primitive_0_Args(); - return Make_Unsigned_Fixnum(1); + PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(1)); } -Define_Primitive(Prim_My_Proc, 0, "MY-PROCESSOR-NUMBER") +DEFINE_PRIMITIVE("MY-PROCESSOR-NUMBER", Prim_My_Proc, 0) { Primitive_0_Args(); - return Make_Unsigned_Fixnum(0); + PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(0)); } -Define_Primitive(Prim_My_Interp_Number, 0, "MY-INTERPRETER-NUMBER") +DEFINE_PRIMITIVE("MY-INTERPRETER-NUMBER", Prim_My_Interp_Number, 0) { Primitive_0_Args(); - return Make_Unsigned_Fixnum(0); + PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(0)); } -Define_Primitive(Prim_Zero_Zones, 0, "ZERO-ZONES") +DEFINE_PRIMITIVE("ZERO-ZONES", Prim_Zero_Zones, 0) { long i; Primitive_0_Args(); #ifdef METERING for (i=0; i < Max_Meters; i++) - Time_Meters[i]=0; + { + Time_Meters[i] = 0; + } Old_Time=Sys_Clock(); #endif - return TRUTH; + PRIMITIVE_RETURN(TRUTH); } /* These are really used by GC on a true parallel machine */ -Define_Primitive(Prim_GC_Needed, 0, "GC-NEEDED?") +DEFINE_PRIMITIVE("GC-NEEDED?", Prim_GC_Needed, 0) { Primitive_0_Args(); - if ((Free+GC_Space_Needed) >= MemTop) return TRUTH; - else return NIL; + if ((Free + GC_Space_Needed) >= MemTop) + { + PRIMITIVE_RETURN(TRUTH); + } + else + { + PRIMITIVE_RETURN(NIL); + } } -Define_Primitive(Prim_Slave_Before, 0, "SLAVE-GC-BEFORE-SYNC") +DEFINE_PRIMITIVE("SLAVE-GC-BEFORE-SYNC", Prim_Slave_Before, 0) { Primitive_0_Args(); - return TRUTH; + PRIMITIVE_RETURN(TRUTH); } -Define_Primitive(Prim_Slave_After, 0, "SLAVE-GC-AFTER-SYNC") +DEFINE_PRIMITIVE("SLAVE-GC-AFTER-SYNC", Prim_Slave_After, 0) { Primitive_0_Args(); - return TRUTH; + PRIMITIVE_RETURN(TRUTH); } -Define_Primitive(Prim_Master_Before, 0, "MASTER-GC-BEFORE-SYNC") +DEFINE_PRIMITIVE("MASTER-GC-BEFORE-SYNC", Prim_Master_Before, 0) { Primitive_0_Args(); - return TRUTH; + PRIMITIVE_RETURN(TRUTH); } /* This primitive caches the Scheme object for the garbage collector - primitive so that it does not have to perform an expensive search - each time. + primitive so that it does not have to perform a potentially + expensive search each time. */ -Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP") +DEFINE_PRIMITIVE("MASTER-GC-LOOP", Prim_Master_GC, 1) { static Pointer gc_prim = NIL; extern Pointer make_primitive(); @@ -268,5 +347,5 @@ Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP") Push(gc_prim); Push(STACK_FRAME_HEADER + 1); Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); + PRIMITIVE_ABORT(PRIM_APPLY); } diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index d34bc9c64..ce4bfbaeb 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.36 1987/11/20 08:18:21 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.37 1987/12/04 22:17:11 jinx Rel $ * * This file contains the heart of the Scheme Scode * interpreter @@ -84,6 +84,15 @@ MIT in each case. */ * ordered alphabetically by return code name. */ +#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ +{ \ + Store_Return(Return_Code); \ + Save_Cont(); \ + Store_Return(RC_RESTORE_VALUE); \ + Store_Expression(Contents_of_Val); \ + Save_Cont(); \ +} + #define Interrupt(Masked_Code) \ { \ Export_Registers(); \ @@ -98,6 +107,13 @@ MIT in each case. */ Interrupt(PENDING_INTERRUPTS()); \ } +#define Eval_GC_Check(Amount) \ +if (GC_Check(Amount)) \ +{ \ + Prepare_Eval_Repeat(); \ + Immediate_GC(Amount); \ +} + #define Prepare_Eval_Repeat() \ { \ Will_Push(CONTINUATION_SIZE+1); \ @@ -107,13 +123,6 @@ MIT in each case. */ Pushed(); \ } -#define Eval_GC_Check(Amount) \ -if (GC_Check(Amount)) \ -{ \ - Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ -} - #define Eval_Error(Err) \ { \ Export_Registers(); \ @@ -130,13 +139,11 @@ if (GC_Check(Amount)) \ goto Internal_Apply; \ } -#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ +#define BACK_OUT_AFTER_PRIMITIVE() \ { \ - Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Contents_of_Val); \ - Save_Cont(); \ + Export_Registers(); \ + Back_Out_Of_Primitive(); \ + Import_Registers(); \ } #define Reduces_To(Expr) \ @@ -182,22 +189,23 @@ if (GC_Check(Amount)) \ #ifdef COMPILE_FUTURES -/* Arg_Type_Error handles the error returns from primitives which type check - their arguments and restarts them or suspends if the argument is a future. */ +/* ARG_TYPE_ERROR handles the error returns from primitives which type check + their arguments and restarts them or suspends if the argument is a future. + */ -#define Arg_Type_Error(Arg_No, Err_No) \ +#define ARG_TYPE_ERROR(Arg_No, Err_No) \ { \ fast Pointer *Arg, Orig_Arg; \ \ - Arg = &(Stack_Ref(Arg_No-1)); \ + Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \ Orig_Arg = *Arg; \ \ - if (Type_Code(*Arg) != TC_FUTURE) \ + if (OBJECT_TYPE(*Arg) != TC_FUTURE) \ { \ Pop_Return_Error(Err_No); \ } \ \ - while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ + while ((OBJECT_TYPE(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ { \ if (Future_Is_Keep_Slot(*Arg)) \ { \ @@ -205,17 +213,12 @@ if (GC_Check(Amount)) \ } \ *Arg = Future_Value(*Arg); \ } \ - if (Type_Code(*Arg) != TC_FUTURE) \ + if (OBJECT_TYPE(*Arg) != TC_FUTURE) \ { \ goto Apply_Non_Trapping; \ } \ \ - Save_Cont(); \ - Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ - Push(*Arg); /* Arg 1: The future itself */ \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ + TOUCH_SETUP(*Arg); \ *Arg = Orig_Arg; \ goto Apply_Non_Trapping; \ } @@ -237,19 +240,16 @@ if (GC_Check(Amount)) \ 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)); \ Store_Return(RC_INTERNAL_APPLY); \ Val = NIL; \ - Save_Cont(); \ - Push(*Arg); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ + TOUCH_SETUP(*Arg); \ *Arg = Orig_Answer; \ goto Internal_Apply; \ } \ @@ -268,39 +268,109 @@ if (GC_Check(Amount)) \ { \ fast Pointer Orig_Val = Val; \ \ - while (Type_Code(Val) == TC_FUTURE) \ + while (OBJECT_TYPE(Val) == TC_FUTURE) \ { \ if (Future_Has_Value(Val)) \ { \ if (Future_Is_Keep_Slot(Val)) \ + { \ Log_Touch_Of_Future(Val); \ + } \ Val = Future_Value(Val); \ } \ else \ { \ Save_Cont(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ + Will_Push(CONTINUATION_SIZE + + (STACK_ENV_EXTRA_SLOTS + 2)); \ Store_Return(RC_RESTORE_VALUE); \ Store_Expression(Orig_Val); \ Save_Cont(); \ Push(Val); \ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ + Push(STACK_FRAME_HEADER + 1); \ Pushed(); \ goto Internal_Apply; \ } \ } \ } + +/* This saves stuff unnecessarily in most cases. + For example, when Which_Way is PRIM_APPLY, Val, Env, Expr, + and Return_Code are undefined. + */ + +#define LOG_FUTURES() \ +{ \ + if (Must_Report_References()) \ + { \ + Save_Cont(); \ + Will_Push(CONTINUATION_SIZE + 2); \ + Push(Val); \ + Save_Env(); \ + Store_Return(RC_REPEAT_DISPATCH); \ + Store_Expression(MAKE_SIGNED_FIXNUM(CODE_MAP(Which_Way))); \ + Save_Cont(); \ + Pushed(); \ + Call_Future_Logging(); \ + } \ +} -#else /* Not compiling FUTURES code */ +#else /* not COMPILE_FUTURES */ #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) +#define ARG_TYPE_ERROR(Arg_No, Err_No) \ +{ \ + Pop_Return_Error(Err_No) \ +} + +#define LOG_FUTURES() + +#endif /* COMPILE_FUTURES */ + +/* Notes on Repeat_Dispatch: + + The codes used (values of Which_Way) are divided into two groups: + Those for which the primitive has already backed out, and those for + which the back out code has not yet been executed, and is therefore + executed below. + + Under most circumstances the distinction is moot, but if there are + futures in the system, and future touches must be logged, the code + must be set up to "interrupt" the dispatch, and proceed it later. + The primitive back out code must be done before the furure is + logged, so all of these codes are split into two versions: one set + before doing the back out, and another afterwards. + */ + +/* This is assumed to be larger (in absolute value) than any PRIM_ + and ERR_. + */ +#define PRIM_BIAS_AMOUNT 1000 + +#if (MAX_ERROR >= PRIM_BIAS_AMOUNT) +#include "Inconsistency: errors.h and interp.c" #endif + +#define CODE_MAP(code) \ +((code < 0) ? \ + (code - PRIM_BIAS_AMOUNT) : \ + (code + PRIM_BIAS_AMOUNT)) + +#define CODE_UNMAP(code) \ +((code < 0) ? \ + (code + PRIM_BIAS_AMOUNT) : \ + (code - PRIM_BIAS_AMOUNT)) + +#define CODE_MAPPED_P(code) \ +((code < (- PRIM_BIAS_AMOUNT)) || \ + (code >= PRIM_BIAS_AMOUNT)) -/* The EVAL/APPLY ying/yang */ +/* + The EVAL/APPLY ying/yang + */ void Interpret(dumped_p) @@ -315,72 +385,103 @@ Interpret(dumped_p) 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 - * their arguments on the stack, the primitive itself in - * Expression, and a RESTART_PRIMITIVE continuation in the - * return register. In the other cases, they have removed - * their stack frames entirely. + /* 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 their arguments on the stack, the + * primitive itself in Expression. The code should do a primitive + * backout in these cases, but not in others (apply, eval, etc.), since + * the primitive itself will have left the state of the interpreter ready + * for operation. */ Which_Way = setjmp(*Back_To_Eval); Set_Time_Zone(Zone_Working); Import_Registers(); - if (Must_Report_References()) - { Save_Cont(); - Will_Push(CONTINUATION_SIZE + 2); - Push(Val); - Save_Env(); - Store_Return(RC_REPEAT_DISPATCH); - Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way)); - Save_Cont(); - Pushed(); - Call_Future_Logging(); - } Repeat_Dispatch: switch (Which_Way) - { case PRIM_APPLY: + { + case PRIM_APPLY: + LOG_FUTURES(); goto Internal_Apply; case PRIM_NO_TRAP_APPLY: + LOG_FUTURES(); goto Apply_Non_Trapping; case PRIM_DO_EXPRESSION: + LOG_FUTURES(); Reduces_To(Fetch_Expression()); case PRIM_NO_TRAP_EVAL: - New_Reduction(Fetch_Expression(),Fetch_Env()); + LOG_FUTURES(); + New_Reduction(Fetch_Expression(), Fetch_Env()); goto Eval_Non_Trapping; - case 0: - if (!dumped_p) + case 0: /* first time */ + if (dumped_p) { - break; + goto Pop_Return; + } + else + { + break; /* fall into eval */ } - /* Else fall through */ case PRIM_POP_RETURN: + LOG_FUTURES(); goto Pop_Return; - - default: - Pop_Return_Error(Which_Way); + + case PRIM_TOUCH: + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(PRIM_TOUCH): + TOUCH_SETUP(Val); + goto Internal_Apply; case PRIM_INTERRUPT: - { + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(PRIM_INTERRUPT): Save_Cont(); Interrupt(PENDING_INTERRUPTS()); - } case ERR_ARG_1_WRONG_TYPE: - Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE); + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(ERR_ARG_1_WRONG_TYPE): + ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE); case ERR_ARG_2_WRONG_TYPE: - Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE); + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(ERR_ARG_2_WRONG_TYPE): + ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE); case ERR_ARG_3_WRONG_TYPE: - Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE); + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(ERR_ARG_3_WRONG_TYPE): + ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE); + + default: + { + if (!CODE_MAPPED_P(Which_Way)) + { + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + } + else + { + Which_Way = CODE_UNMAP(Which_Way); + } + Pop_Return_Error(Which_Way); + } } Do_Expression: @@ -1169,7 +1270,7 @@ external_assignment_return: Reduces_To_Nth(IN_PACKAGE_EXPRESSION); } Pop_Return_Error(ERR_BAD_FRAME); - + #ifdef COMPILE_FUTURES case RC_FINISH_GLOBAL_INT: Export_Registers(); @@ -1178,23 +1279,13 @@ external_assignment_return: break; #endif - case RC_GC_CHECK: - if (Get_Integer(Fetch_Expression()) > Space_Before_GC()) - { - Export_Registers(); - Microcode_Termination(TERM_GC_OUT_OF_SPACE); - } - break; - case RC_HALT: Export_Registers(); Microcode_Termination(TERM_TERM_HANDLER); - case RC_INTERNAL_APPLY: - -Internal_Apply: -/* Branch here to perform a function application. +/* Internal_Apply, the core of the application mechanism. + 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): @@ -1226,6 +1317,9 @@ Internal_Apply: /* Interpret(), continued */ + case RC_INTERNAL_APPLY: +Internal_Apply: + if (Microcode_Does_Stepping && Trapping && (Fetch_Apply_Trapper() != NIL)) { @@ -1233,7 +1327,7 @@ Internal_Apply: Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); Top_Of_Stack() = Fetch_Apply_Trapper(); - Push(STACK_FRAME_HEADER+Count); + Push(STACK_FRAME_HEADER + Count); Stop_Trapping(); } @@ -1346,32 +1440,31 @@ Perform_Application: case TC_PRIMITIVE: { - long nargs; - fast long primitive_code; + fast long nargs; - primitive_code = OBJECT_DATUM(Function); - if (primitive_code > MAX_PRIMITIVE) + if (!IMPLEMENTED_PRIMITIVE_P(Function)) { Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); } - /* Note that the test below will fail for lexpr primitives. */ + /* Note that the first test below will fail for lexpr primitives. */ - nargs = (OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER)) - - (STACK_ENV_FIRST_ARG - 1)); - if (nargs != PRIMITIVE_ARITY(primitive_code)) + nargs = ((OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER))) - + (STACK_ENV_FIRST_ARG - 1)); + if (nargs != PRIMITIVE_ARITY(Function)) { - if (PRIMITIVE_ARITY(primitive_code) != LEXPR_PRIMITIVE_ARITY) + if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY) { Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); } Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs); } + Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); Store_Expression(Function); Export_Regs_Before_Primitive(); - Metering_Apply_Primitive(Val, primitive_code); + Metering_Apply_Primitive(Val, Function); Import_Regs_After_Primitive(); Pop_Primitive_Frame(nargs); @@ -1531,12 +1624,9 @@ return_from_compiled_code: /* This error code means that compiled code attempted to call an unimplemented primitive. */ - extern void Back_Out_Of_Primitive(); - Export_Registers(); - Back_Out_Of_Primitive(); - Import_Registers(); - goto Repeat_Dispatch; + BACK_OUT_AFTER_PRIMITIVE(); + Pop_Return_Error( ERR_UNIMPLEMENTED_PRIMITIVE); } case ERR_EXECUTE_MANIFEST_VECTOR: @@ -1639,14 +1729,15 @@ return_from_compiled_code: case RC_NORMAL_GC_DONE: End_GC_Hook(); + if (GC_Space_Needed < 0) + { + /* Paranoia */ + + GC_Space_Needed = 0; + } if (GC_Check(GC_Space_Needed)) - { fprintf(stderr, - "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n", - Free); - fprintf(stderr, - "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n", - MemTop, GC_Space_Needed); - Microcode_Termination(TERM_NO_SPACE); + { + Microcode_Termination(TERM_GC_OUT_OF_SPACE); } GC_Space_Needed = 0; Val = Fetch_Expression(); @@ -1669,32 +1760,30 @@ Primitive_Internal_Apply: Push(Fetch_Expression()); Push(Fetch_Apply_Trapper()); Push(STACK_FRAME_HEADER + 1 + - PRIMITIVE_N_PARAMETERS(OBJECT_DATUM(Fetch_Expression()))); + PRIMITIVE_N_PARAMETERS(Fetch_Expression())); Pushed(); Stop_Trapping(); goto Apply_Non_Trapping; } + /* NOTE: This code must match the code in the TC_PRIMITIVE case of Internal_Apply. - This code is simpler because it need not deal with lexpr - primitives. + This code is simpler because: + 1) The arity was checked at syntax time. + 2) We don't have to deal with "lexpr" primitives. + 3) We don't need to worry about unimplemented primitives because + unimplemented primitives will cause an error at invocation. */ - { - fast long primitive_code; - primitive_code = OBJECT_DATUM(Fetch_Expression()); - if (primitive_code > MAX_PRIMITIVE) - { - Push(Fetch_Expression()); - Push(STACK_FRAME_HEADER + PRIMITIVE_N_PARAMETERS(primitive_code)); - Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); - } + { + fast Pointer primitive; + primitive = Fetch_Expression(); Export_Regs_Before_Primitive(); - Metering_Apply_Primitive(Val, primitive_code); + Metering_Apply_Primitive(Val, primitive); Import_Regs_After_Primitive(); - Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive_code)); + Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive)); if (Must_Report_References()) { Store_Expression(Val); @@ -1729,7 +1818,9 @@ Primitive_Internal_Apply: /* Interpret(), continued */ case RC_PCOMB3_DO_1: - { Pointer Temp; + { + Pointer Temp; + Temp = Pop(); /* Value of arg. 3 */ Restore_Env(); Push(Temp); /* Save arg. 3 again */ @@ -1752,12 +1843,15 @@ Primitive_Internal_Apply: /* Interpret(), continued */ case RC_PURIFY_GC_1: - { Pointer GC_Daemon_Proc, Result; + { + Pointer GC_Daemon_Proc, Result; + Export_Registers(); Result = Purify_Pass_2(Fetch_Expression()); Import_Registers(); if (Result == NIL) - { /* The object does not fit in Constant space. + { + /* The object does not fit in Constant space. There is no need to run the daemons, and we should let the runtime system know what happened. */ @@ -1765,8 +1859,9 @@ Primitive_Internal_Apply: break; } GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc==NIL) - { Val = TRUTH; + if (GC_Daemon_Proc == NIL) + { + Val = TRUTH; break; } Store_Expression(NIL); @@ -1831,10 +1926,13 @@ Primitive_Internal_Apply: /* Interpret(), continued */ case RC_RESTORE_HISTORY: - { Pointer Stacklet; + { + Pointer Stacklet; + Export_Registers(); if (! Restore_History(Fetch_Expression())) - { Import_Registers(); + { + Import_Registers(); Save_Cont(); Will_Push(CONTINUATION_SIZE); Store_Expression(Val); diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h index 8278ca20e..d20bc1ff1 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.27 1987/11/20 08:17:10 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.28 1987/12/04 22:17:56 jinx Exp $ * * Macros used by the interpreter and some utilities. * @@ -211,25 +211,62 @@ MIT in each case. */ /* Primitive utility macros */ -/* The first two are only valid for implemented primitives. */ +/* A primitive object has two components (besides the type code), a + table index in the low 12 bits (assuming datum fields are 24 bits + wide), and a virtual index in the upper 12 bits. The table index + is always guaranteed to be a valid entry into + Primitive_Procedure_Table. For unimplemented primitives it is the + index of the last entry in the table, which causes an error when + invoked. For implemented primitives it is the real index. The + virtual index is 0 for implemented primitives (for histerical + reasons), and the actual virtual index (higher than any real table + index) for unimplemented primitives. + */ + +#define PRIMITIVE_TABLE_INDEX(primitive) \ +((primitive) & HALF_ADDRESS_MASK) + +#define PRIMITIVE_VIRTUAL_INDEX(primitive) \ +(((primitive) >> HALF_ADDRESS_LENGTH) & HALF_ADDRESS_MASK) + +#define MAKE_PRIMITIVE_OBJECT(virtual, real) \ +(Make_Non_Pointer(TC_PRIMITIVE, (((virtual) << HALF_ADDRESS_LENGTH) | (real)))) + +/* Does this fail for the first unimplemented primitive if there are no + implemented primitives? + */ + +#define IMPLEMENTED_PRIMITIVE_P(primitive) \ +(PRIMITIVE_VIRTUAL_INDEX(primitive) == 0) + +#define PRIMITIVE_NUMBER(primitive) \ +((IMPLEMENTED_PRIMITIVE_P(primitive)) ? \ + (PRIMITIVE_TABLE_INDEX(primitive)) : \ + (PRIMITIVE_VIRTUAL_INDEX(primitive))) + +/* This will automagically cause an error if the primitive is + not implemented. + */ + +#define Internal_Apply_Primitive(primitive) \ +((*(Primitive_Procedure_Table[PRIMITIVE_TABLE_INDEX(primitive)]))()) -#define Internal_Apply_Primitive(primitive_code) \ - ((*(Primitive_Procedure_Table[primitive_code]))()) +/* This is only valid for implemented primitives. */ -#define PRIMITIVE_ARITY(primitive_code) \ - (Primitive_Arity_Table[primitive_code]) +#define PRIMITIVE_ARITY(primitive) \ +(Primitive_Arity_Table[PRIMITIVE_TABLE_INDEX(primitive)]) extern long primitive_to_arity(); -#define PRIMITIVE_N_PARAMETERS(primitive_code) \ - (primitive_to_arity(primitive_code)) +#define PRIMITIVE_N_PARAMETERS(primitive) \ + (primitive_to_arity(primitive)) /* This is only valid during a primitive call. */ extern long primitive_to_arguments(); -#define PRIMITIVE_N_ARGUMENTS(primitive_code) \ - (primitive_to_arguments(primitive_code)) +#define PRIMITIVE_N_ARGUMENTS(primitive) \ + (primitive_to_arguments(primitive)) #define Pop_Primitive_Frame(NArgs) \ Stack_Pointer = Simulate_Popping(NArgs) diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index 53467e408..c52bbb312 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.32 1987/11/17 08:14:38 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.33 1987/12/04 22:18:09 jinx Rel $ */ /* Memory management top level. @@ -377,8 +377,7 @@ void GC() have changed. */ -Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A) -Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") +DEFINE_PRIMITIVE("GARBAGE-COLLECT", Prim_Garbage_Collect, 1) { Pointer GC_Daemon_Proc; Primitive_1_Arg(); @@ -406,17 +405,17 @@ Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT") Store_Expression(Make_Unsigned_Fixnum(MemTop - Free)); Save_Cont(); Pushed(); - longjmp( *Back_To_Eval, PRIM_POP_RETURN); + PRIMITIVE_ABORT(PRIM_POP_RETURN); /*NOTREACHED*/ } - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1)); + Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); Store_Return(RC_NORMAL_GC_DONE); Store_Expression(Make_Unsigned_Fixnum(MemTop - Free)); Save_Cont(); Push(GC_Daemon_Proc); Push(STACK_FRAME_HEADER); Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); + PRIMITIVE_ABORT(PRIM_APPLY); /* The following comment is by courtesy of LINT, your friendly sponsor. */ /*NOTREACHED*/ } diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index d287d444e..aaf9b9974 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.26 1987/10/09 16:12:57 jinx Rel $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.27 1987/12/04 22:18:23 jinx Rel $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -49,14 +49,17 @@ MIT in each case. */ #ifndef b32 /* Portable versions */ #define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH) -#define ADDRESS_MASK ((1< size) || (code < 0)) - { - return ((char *) NULL); - } - else - { - return table[code]; - } -} - long -primitive_code_to_arity(code, table, size) - int code; - int table[]; - int size; +primitive_code_to_arity(number) + long number; { - if ((code > size) || (code < 0)) + if (number <= MAX_PRIMITIVE) { - return ((long) -1); + return ((long) Primitive_Arity_Table[number]); } else { - return ((long) table[code]); + Pointer entry; + long arity; + + entry = User_Vector_Ref(Undefined_Primitives_Arity, + (number - MAX_PRIMITIVE)); + if (entry == NIL) + { + return ((long) UNKNOWN_PRIMITIVE_ARITY); + } + else + { + Sign_Extend(entry, arity); + } + return (arity); } } @@ -195,34 +190,10 @@ find_primitive(name, intern_p, allow_p, arity) extern long primitive_to_arity(); long -primitive_to_arity(code) - int code; +primitive_to_arity(primitive) + Pointer primitive; { - if (code <= MAX_PRIMITIVE) - { - return - ((long) - (primitive_code_to_arity(code, - &Primitive_Arity_Table[0], - MAX_PRIMITIVE))); - } - else - { - Pointer entry; - long arity; - - entry = User_Vector_Ref(Undefined_Primitives_Arity, - (code - MAX_PRIMITIVE)); - if (entry == NIL) - { - return ((long) UNKNOWN_PRIMITIVE_ARITY); - } - else - { - Sign_Extend(entry, arity); - } - return (arity); - } + return (primitive_code_to_arity(PRIMITIVE_NUMBER(primitive))); } extern long primitive_to_arguments(); @@ -233,12 +204,12 @@ extern long primitive_to_arguments(); */ long -primitive_to_arguments(code) - long code; +primitive_to_arguments(primitive) + Pointer primitive; { long arity; - arity = primitive_to_arity(code); + arity = primitive_code_to_arity(PRIMITIVE_NUMBER(primitive)); if (arity == ((long) LEXPR_PRIMITIVE_ARITY)) { @@ -247,11 +218,9 @@ primitive_to_arguments(code) return (arity); } -extern char *primitive_to_name(); - char * -primitive_to_name(code) - int code; +primitive_code_to_name(code) + int code; { char *string; @@ -276,6 +245,15 @@ primitive_to_name(code) } return (string); } + +extern char *primitive_to_name(); + +char * +primitive_to_name(primitive) + Pointer primitive; +{ + return (primitive_code_to_name(PRIMITIVE_NUMBER(primitive))); +} /* this avoids some consing. */ @@ -322,7 +300,7 @@ search_for_primitive(scheme_name, c_name, intern_p, allow_p, arity) old_arity = Primitive_Arity_Table[i]; if ((arity == UNKNOWN_PRIMITIVE_ARITY) || (arity == old_arity)) { - return (Make_Non_Pointer(TC_PRIMITIVE, i)); + return (MAKE_PRIMITIVE_OBJECT(0, i)); } else { @@ -368,7 +346,7 @@ search_for_primitive(scheme_name, c_name, intern_p, allow_p, arity) } } } - return (Make_Non_Pointer(TC_PRIMITIVE, (MAX_PRIMITIVE + i))); + return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + i), (MAX_PRIMITIVE + 1))); } } } @@ -439,7 +417,7 @@ search_for_primitive(scheme_name, c_name, intern_p, allow_p, arity) } User_Vector_Set(Undefined_Primitives, 0, (MAKE_UNSIGNED_FIXNUM(Max))); } - return (Make_Non_Pointer(TC_PRIMITIVE, (MAX_PRIMITIVE + Max))); + return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + Max), (MAX_PRIMITIVE + 1))); } /* Dumping and loading primitive object references. */ @@ -486,14 +464,16 @@ Pointer dump_renumber_primitive(primitive) fast Pointer primitive; { + fast long number; fast Pointer result; - result = internal_renumber_table[OBJECT_DATUM(primitive)]; + number = PRIMITIVE_NUMBER(primitive); + result = internal_renumber_table[number]; if (result == NIL) { result = Make_Non_Pointer(OBJECT_TYPE(primitive), next_primitive_renumber); - internal_renumber_table[OBJECT_DATUM(primitive)] = result; + internal_renumber_table[number] = result; external_renumber_table[next_primitive_renumber] = primitive; next_primitive_renumber += 1; return (result); @@ -513,10 +493,10 @@ copy_primitive_information(code, start, end) if (start < end) { - *start++ = MAKE_SIGNED_FIXNUM(primitive_to_arity(((int) code))); + *start++ = MAKE_SIGNED_FIXNUM(primitive_code_to_arity(((int) code))); } return - copy_c_string_to_scheme_string(primitive_to_name(((int) code)), + copy_c_string_to_scheme_string(primitive_code_to_name(((int) code)), start, end); } @@ -536,7 +516,7 @@ cons_primitive_table(start, end, length) ((count < next_primitive_renumber) && (start < end)); count += 1) { - code = (OBJECT_DATUM(external_renumber_table[count])); + code = (PRIMITIVE_NUMBER(external_renumber_table[count])); start = copy_primitive_information(code, start, end); } return (start); diff --git a/v7/src/microcode/step.c b/v7/src/microcode/step.c index cc390006f..6921c4c49 100644 --- a/v7/src/microcode/step.c +++ b/v7/src/microcode/step.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/step.c,v 9.23 1987/11/17 08:16:54 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.24 1987/12/04 22:19:24 jinx Rel $ * * Support for the stepper */ @@ -42,22 +42,27 @@ MIT in each case. */ /* Support of stepping primitives */ /**********************************/ -long Install_Traps(Hunk3, Return_Hook_Too) /* UGLY ... this knows (a) that it is called with the primitive frame already popped off the stack; and (b) the order in which Save_Cont stores things on the stack. */ -Pointer Hunk3; -Boolean Return_Hook_Too; -{ Pointer Eval_Hook, Apply_Hook, Return_Hook; + +void +Install_Traps(Hunk3, Return_Hook_Too) + Pointer Hunk3; + Boolean Return_Hook_Too; +{ + Pointer Eval_Hook, Apply_Hook, Return_Hook; + Stop_Trapping(); Eval_Hook = Vector_Ref(Hunk3, HUNK_CXR0); Apply_Hook = Vector_Ref(Hunk3, HUNK_CXR1); Return_Hook = Vector_Ref(Hunk3, HUNK_CXR2); Set_Fixed_Obj_Slot(Stepper_State, Hunk3); - Trapping = (Eval_Hook != NIL) | (Apply_Hook != NIL); + Trapping = ((Eval_Hook != NIL) | (Apply_Hook != NIL)); if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != NIL)) - { /* Here it is ... gross and ugly. We know that the top of stack + { + /* Here it is ... gross and ugly. We know that the top of stack has the existing return code to be clobbered, since it was put there by Save_Cont. */ @@ -66,6 +71,7 @@ Boolean Return_Hook_Too; *Return_Hook_Address = Make_Non_Pointer(TC_RETURN_CODE, RC_RETURN_TRAP_POINT); } + return; } /* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3) @@ -75,8 +81,7 @@ Boolean Return_Hook_Too; APPLY or return. */ -Built_In_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP", 0xCA) -Define_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP") +DEFINE_PRIMITIVE("PRIMITIVE-EVAL-STEP", Prim_Eval_Step, 3) { Primitive_3_Args(); @@ -84,7 +89,7 @@ Define_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP") Pop_Primitive_Frame(3); Store_Expression(Arg1); Store_Env(Arg2); - longjmp(*Back_To_Eval, PRIM_NO_TRAP_EVAL); + PRIMITIVE_ABORT(PRIM_NO_TRAP_EVAL); /*NOTREACHED*/ } @@ -98,8 +103,7 @@ Define_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP") required before actually building a frame */ -Built_In_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP", 0xCB) -Define_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP") +DEFINE_PRIMITIVE("PRIMITIVE-APPLY-STEP", Prim_Apply_Step, 3) { Pointer Next_From_Slot, *Next_To_Slot; long Number_Of_Args, i; @@ -114,7 +118,9 @@ Define_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP") Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR); } if (Next_From_Slot != NIL) + { Primitive_Error(ERR_ARG_2_WRONG_TYPE); + } Install_Traps(Arg3, true); Pop_Primitive_Frame(3); Next_From_Slot = Arg2; @@ -130,7 +136,7 @@ Define_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP") Push(Arg1); /* The function */ Push(STACK_FRAME_HEADER + Number_Of_Args); Pushed(); - longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY); + PRIMITIVE_ABORT(PRIM_NO_TRAP_APPLY); /*NOTREACHED*/ } @@ -144,15 +150,16 @@ Define_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP") this is ever changed, be sure to check for COMPILE_STEPPER flag! */ -Built_In_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP", 0xCC) -Define_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP") +DEFINE_PRIMITIVE("PRIMITIVE-RETURN-STEP", Prim_Return_Step, 2) { Pointer Return_Hook; Primitive_2_Args(); Return_Hook = Vector_Ref(Arg2, HUNK_CXR2); if (Return_Hook != NIL) + { Primitive_Error(ERR_ARG_2_BAD_RANGE); + } Install_Traps(Arg2, false); - return Arg1; + PRIMITIVE_RETURN(Arg1); } diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c index f067aec49..d9471a87f 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.38 1987/11/17 08:17:03 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.39 1987/12/04 22:19:35 jinx Exp $ This file defines the storage for global variables for the Scheme Interpreter. */ @@ -347,12 +347,13 @@ char *Term_Names[] = { /* 0x13 */ "COMPILER-DEATH", /* 0x14 */ "GC-OUT-OF-SPACE", /* 0x15 */ "NO-SPACE", -/* 0x16 */ "SIGNAL" +/* 0x16 */ "SIGNAL", +/* 0x17 */ "TOUCH" }; /* If you change this table, change the Term_Messages table below as well. */ -#if (MAX_TERMINATION != 0x16) +#if (MAX_TERMINATION != 0x17) /* Cause an error */ #include "Inconsistency: errors.h and storage.c (Termination code table)" #endif @@ -382,5 +383,6 @@ char *Term_Messages[] = { /* 0x13 */ "Mismatch between compiled code and compiled code support", /* 0x14 */ "Out of space after garbage collection", /* 0x15 */ "Out of memory: Available memory exceeded", -/* 0x16 */ "Unhandled signal received" +/* 0x16 */ "Unhandled signal received", +/* 0x17 */ "Touch without futures support" }; diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 895f23b25..254714fa7 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.35 1987/11/17 08:20:10 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.36 1987/12/04 22:20:24 jinx Rel $ */ /* This file contains utilities for interrupts, errors, etc. */ @@ -52,7 +52,6 @@ Setup_Interrupt (Masked_Interrupts) { Pointer Int_Vector, Handler; long i, Int_Number, The_Int_Code, New_Int_Enb; - long Save_Space; The_Int_Code = FETCH_INTERRUPT_CODE(); Int_Vector = (Get_Fixed_Obj_Slot (System_Interrupt_Vector)); @@ -83,10 +82,10 @@ Setup_Interrupt (Masked_Interrupts) if (Int_Number >= (Vector_Length (Int_Vector))) { fprintf (stderr, - "\nInterrupt out of range: 0x%x (vector length = 0x%x)\n", + "\nInterrupt out of range: %ld (vector length = %ld)\n", Int_Number, (Vector_Length (Int_Vector))); fprintf (stderr, - "Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", + "Interrupts = 0x%08lx, Mask = 0x%08lx, Masked = 0x%08lx\n", FETCH_INTERRUPT_CODE(), FETCH_INTERRUPT_MASK(), Masked_Interrupts); @@ -102,22 +101,15 @@ Setup_Interrupt (Masked_Interrupts) Passed_Checks: /* This label may be used in Global_Interrupt_Hook */ Stop_History(); - Save_Space = CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS+3; - if ((New_Int_Enb + 1) == INT_GC) - { - Save_Space += CONTINUATION_SIZE; - } - Will_Push(Save_Space); + Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 3); /* Return from interrupt handler will re-enable interrupts */ Store_Return(RC_RESTORE_INT_MASK); Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK())); Save_Cont(); - if ((New_Int_Enb + 1) == INT_GC) - { - Store_Return(RC_GC_CHECK); - Store_Expression(Make_Unsigned_Fixnum(GC_Space_Needed)); - Save_Cont(); - } +/* + There used to be some code here for gc checks, but that is done + uniformly now by RC_NORMAL_GC_DONE. + */ /* Now make an environment frame for use in calling the * user supplied interrupt routine. It will be given @@ -128,7 +120,7 @@ Passed_Checks: /* This label may be used in Global_Interrupt_Hook */ Push(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK())); Push(MAKE_SIGNED_FIXNUM(The_Int_Code)); Push(Handler); - Push(STACK_FRAME_HEADER+2); + Push(STACK_FRAME_HEADER + 2); Pushed(); /* Turn off interrupts */ SET_INTERRUPT_MASK(New_Int_Enb); @@ -190,7 +182,7 @@ Stack_Death() void Back_Out_Of_Primitive () { - long nargs, code; + long nargs; Pointer primitive; /* Setup a continuation to return to compiled code if the primitive is @@ -198,8 +190,7 @@ Back_Out_Of_Primitive () */ primitive = Fetch_Expression(); - code = OBJECT_DATUM(primitive); - nargs = PRIMITIVE_N_ARGUMENTS(code); + nargs = PRIMITIVE_N_ARGUMENTS(primitive); if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_RETURN_ADDRESS) { compiler_apply_procedure(nargs); @@ -216,10 +207,16 @@ Back_Out_Of_Primitive () /* Useful error procedures */ +/* Note that backing out of the primitives happens after aborting, + not before. + This guarantees that the interpreter state is consistent, since the + longjmp restores the relevant registers even if the primitive was + invoked from compiled code. + */ + extern void signal_error_from_primitive(), signal_interrupt_from_primitive(), - specl_interrupt_from_primitive(), error_wrong_type_arg(), error_bad_range_arg(), error_external_return(); @@ -228,7 +225,7 @@ void signal_error_from_primitive (error_code) long error_code; { - Back_Out_Of_Primitive (); + PRIMITIVE_ABORT(error_code); /*NOTREACHED*/ } @@ -236,20 +233,6 @@ signal_error_from_primitive (error_code) void signal_interrupt_from_primitive () { - Back_Out_Of_Primitive (); - PRIMITIVE_ABORT(PRIM_INTERRUPT); - /*NOTREACHED*/ -} - -void -specl_interrupt_from_primitive(local_mask) - int local_mask; -{ - Back_Out_Of_Primitive(); - Save_Cont(); - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK())); - SET_INTERRUPT_MASK(local_mask); PRIMITIVE_ABORT(PRIM_INTERRUPT); /*NOTREACHED*/ } @@ -759,27 +742,24 @@ Restore_History (Hist_Obj) #ifdef ENABLE_DEBUGGING_TOOLS Pointer -Apply_Primitive (Primitive_Number) - long Primitive_Number; +Apply_Primitive (primitive) + Pointer primitive; { Pointer Result, *Saved_Stack; - int NArgs; - if (Primitive_Number > MAX_PRIMITIVE) - { - Primitive_Error(ERR_UNDEFINED_PRIMITIVE); - } if (Primitive_Debug) { - Print_Primitive(Primitive_Number); + Print_Primitive(primitive); } - NArgs = PRIMITIVE_N_ARGUMENTS(Primitive_Number); Saved_Stack = Stack_Pointer; - Result = Internal_Apply_Primitive(Primitive_Number); + Result = Internal_Apply_Primitive(primitive); if (Saved_Stack != Stack_Pointer) { - Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number), - "Stack bad after "); + + int NArgs; + + NArgs = PRIMITIVE_N_ARGUMENTS(primitive); + Print_Expression(primitive, "Stack bad after "); fprintf(stderr, "\nStack was 0x%x, now 0x%x, #args=%d.\n", Saved_Stack, Stack_Pointer, NArgs); diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index ac36aec74..c5127030c 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 10.10 1987/12/04 05:16:15 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.11 1987/12/04 22:20:47 jinx Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 10 +#define SUBVERSION 11 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h index 501c943d3..ba201fa1c 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.25 1987/11/17 08:08:36 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.26 1987/12/04 22:14:55 jinx Rel $ * * Named constants used throughout the interpreter * @@ -115,6 +115,7 @@ MIT in each case. */ #define PRIM_NO_TRAP_EVAL -5 #define PRIM_NO_TRAP_APPLY -6 #define PRIM_POP_RETURN -7 +#define PRIM_TOUCH -8 /* Some numbers of parameters which mean something special */ diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index 1c1841d52..1888d6e88 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.36 1987/11/20 08:18:21 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.37 1987/12/04 22:17:11 jinx Rel $ * * This file contains the heart of the Scheme Scode * interpreter @@ -84,6 +84,15 @@ MIT in each case. */ * ordered alphabetically by return code name. */ +#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ +{ \ + Store_Return(Return_Code); \ + Save_Cont(); \ + Store_Return(RC_RESTORE_VALUE); \ + Store_Expression(Contents_of_Val); \ + Save_Cont(); \ +} + #define Interrupt(Masked_Code) \ { \ Export_Registers(); \ @@ -98,6 +107,13 @@ MIT in each case. */ Interrupt(PENDING_INTERRUPTS()); \ } +#define Eval_GC_Check(Amount) \ +if (GC_Check(Amount)) \ +{ \ + Prepare_Eval_Repeat(); \ + Immediate_GC(Amount); \ +} + #define Prepare_Eval_Repeat() \ { \ Will_Push(CONTINUATION_SIZE+1); \ @@ -107,13 +123,6 @@ MIT in each case. */ Pushed(); \ } -#define Eval_GC_Check(Amount) \ -if (GC_Check(Amount)) \ -{ \ - Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ -} - #define Eval_Error(Err) \ { \ Export_Registers(); \ @@ -130,13 +139,11 @@ if (GC_Check(Amount)) \ goto Internal_Apply; \ } -#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ +#define BACK_OUT_AFTER_PRIMITIVE() \ { \ - Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Contents_of_Val); \ - Save_Cont(); \ + Export_Registers(); \ + Back_Out_Of_Primitive(); \ + Import_Registers(); \ } #define Reduces_To(Expr) \ @@ -182,22 +189,23 @@ if (GC_Check(Amount)) \ #ifdef COMPILE_FUTURES -/* Arg_Type_Error handles the error returns from primitives which type check - their arguments and restarts them or suspends if the argument is a future. */ +/* ARG_TYPE_ERROR handles the error returns from primitives which type check + their arguments and restarts them or suspends if the argument is a future. + */ -#define Arg_Type_Error(Arg_No, Err_No) \ +#define ARG_TYPE_ERROR(Arg_No, Err_No) \ { \ fast Pointer *Arg, Orig_Arg; \ \ - Arg = &(Stack_Ref(Arg_No-1)); \ + Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \ Orig_Arg = *Arg; \ \ - if (Type_Code(*Arg) != TC_FUTURE) \ + if (OBJECT_TYPE(*Arg) != TC_FUTURE) \ { \ Pop_Return_Error(Err_No); \ } \ \ - while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ + while ((OBJECT_TYPE(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ { \ if (Future_Is_Keep_Slot(*Arg)) \ { \ @@ -205,17 +213,12 @@ if (GC_Check(Amount)) \ } \ *Arg = Future_Value(*Arg); \ } \ - if (Type_Code(*Arg) != TC_FUTURE) \ + if (OBJECT_TYPE(*Arg) != TC_FUTURE) \ { \ goto Apply_Non_Trapping; \ } \ \ - Save_Cont(); \ - Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ - Push(*Arg); /* Arg 1: The future itself */ \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ + TOUCH_SETUP(*Arg); \ *Arg = Orig_Arg; \ goto Apply_Non_Trapping; \ } @@ -237,19 +240,16 @@ if (GC_Check(Amount)) \ 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)); \ Store_Return(RC_INTERNAL_APPLY); \ Val = NIL; \ - Save_Cont(); \ - Push(*Arg); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ + TOUCH_SETUP(*Arg); \ *Arg = Orig_Answer; \ goto Internal_Apply; \ } \ @@ -268,39 +268,109 @@ if (GC_Check(Amount)) \ { \ fast Pointer Orig_Val = Val; \ \ - while (Type_Code(Val) == TC_FUTURE) \ + while (OBJECT_TYPE(Val) == TC_FUTURE) \ { \ if (Future_Has_Value(Val)) \ { \ if (Future_Is_Keep_Slot(Val)) \ + { \ Log_Touch_Of_Future(Val); \ + } \ Val = Future_Value(Val); \ } \ else \ { \ Save_Cont(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ + Will_Push(CONTINUATION_SIZE + + (STACK_ENV_EXTRA_SLOTS + 2)); \ Store_Return(RC_RESTORE_VALUE); \ Store_Expression(Orig_Val); \ Save_Cont(); \ Push(Val); \ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ + Push(STACK_FRAME_HEADER + 1); \ Pushed(); \ goto Internal_Apply; \ } \ } \ } + +/* This saves stuff unnecessarily in most cases. + For example, when Which_Way is PRIM_APPLY, Val, Env, Expr, + and Return_Code are undefined. + */ + +#define LOG_FUTURES() \ +{ \ + if (Must_Report_References()) \ + { \ + Save_Cont(); \ + Will_Push(CONTINUATION_SIZE + 2); \ + Push(Val); \ + Save_Env(); \ + Store_Return(RC_REPEAT_DISPATCH); \ + Store_Expression(MAKE_SIGNED_FIXNUM(CODE_MAP(Which_Way))); \ + Save_Cont(); \ + Pushed(); \ + Call_Future_Logging(); \ + } \ +} -#else /* Not compiling FUTURES code */ +#else /* not COMPILE_FUTURES */ #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) +#define ARG_TYPE_ERROR(Arg_No, Err_No) \ +{ \ + Pop_Return_Error(Err_No) \ +} + +#define LOG_FUTURES() + +#endif /* COMPILE_FUTURES */ + +/* Notes on Repeat_Dispatch: + + The codes used (values of Which_Way) are divided into two groups: + Those for which the primitive has already backed out, and those for + which the back out code has not yet been executed, and is therefore + executed below. + + Under most circumstances the distinction is moot, but if there are + futures in the system, and future touches must be logged, the code + must be set up to "interrupt" the dispatch, and proceed it later. + The primitive back out code must be done before the furure is + logged, so all of these codes are split into two versions: one set + before doing the back out, and another afterwards. + */ + +/* This is assumed to be larger (in absolute value) than any PRIM_ + and ERR_. + */ +#define PRIM_BIAS_AMOUNT 1000 + +#if (MAX_ERROR >= PRIM_BIAS_AMOUNT) +#include "Inconsistency: errors.h and interp.c" #endif + +#define CODE_MAP(code) \ +((code < 0) ? \ + (code - PRIM_BIAS_AMOUNT) : \ + (code + PRIM_BIAS_AMOUNT)) + +#define CODE_UNMAP(code) \ +((code < 0) ? \ + (code + PRIM_BIAS_AMOUNT) : \ + (code - PRIM_BIAS_AMOUNT)) + +#define CODE_MAPPED_P(code) \ +((code < (- PRIM_BIAS_AMOUNT)) || \ + (code >= PRIM_BIAS_AMOUNT)) -/* The EVAL/APPLY ying/yang */ +/* + The EVAL/APPLY ying/yang + */ void Interpret(dumped_p) @@ -315,72 +385,103 @@ Interpret(dumped_p) 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 - * their arguments on the stack, the primitive itself in - * Expression, and a RESTART_PRIMITIVE continuation in the - * return register. In the other cases, they have removed - * their stack frames entirely. + /* 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 their arguments on the stack, the + * primitive itself in Expression. The code should do a primitive + * backout in these cases, but not in others (apply, eval, etc.), since + * the primitive itself will have left the state of the interpreter ready + * for operation. */ Which_Way = setjmp(*Back_To_Eval); Set_Time_Zone(Zone_Working); Import_Registers(); - if (Must_Report_References()) - { Save_Cont(); - Will_Push(CONTINUATION_SIZE + 2); - Push(Val); - Save_Env(); - Store_Return(RC_REPEAT_DISPATCH); - Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way)); - Save_Cont(); - Pushed(); - Call_Future_Logging(); - } Repeat_Dispatch: switch (Which_Way) - { case PRIM_APPLY: + { + case PRIM_APPLY: + LOG_FUTURES(); goto Internal_Apply; case PRIM_NO_TRAP_APPLY: + LOG_FUTURES(); goto Apply_Non_Trapping; case PRIM_DO_EXPRESSION: + LOG_FUTURES(); Reduces_To(Fetch_Expression()); case PRIM_NO_TRAP_EVAL: - New_Reduction(Fetch_Expression(),Fetch_Env()); + LOG_FUTURES(); + New_Reduction(Fetch_Expression(), Fetch_Env()); goto Eval_Non_Trapping; - case 0: - if (!dumped_p) + case 0: /* first time */ + if (dumped_p) { - break; + goto Pop_Return; + } + else + { + break; /* fall into eval */ } - /* Else fall through */ case PRIM_POP_RETURN: + LOG_FUTURES(); goto Pop_Return; - - default: - Pop_Return_Error(Which_Way); + + case PRIM_TOUCH: + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(PRIM_TOUCH): + TOUCH_SETUP(Val); + goto Internal_Apply; case PRIM_INTERRUPT: - { + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(PRIM_INTERRUPT): Save_Cont(); Interrupt(PENDING_INTERRUPTS()); - } case ERR_ARG_1_WRONG_TYPE: - Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE); + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(ERR_ARG_1_WRONG_TYPE): + ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE); case ERR_ARG_2_WRONG_TYPE: - Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE); + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(ERR_ARG_2_WRONG_TYPE): + ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE); case ERR_ARG_3_WRONG_TYPE: - Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE); + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + /* fall through */ + case CODE_MAP(ERR_ARG_3_WRONG_TYPE): + ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE); + + default: + { + if (!CODE_MAPPED_P(Which_Way)) + { + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + } + else + { + Which_Way = CODE_UNMAP(Which_Way); + } + Pop_Return_Error(Which_Way); + } } Do_Expression: @@ -1169,7 +1270,7 @@ external_assignment_return: Reduces_To_Nth(IN_PACKAGE_EXPRESSION); } Pop_Return_Error(ERR_BAD_FRAME); - + #ifdef COMPILE_FUTURES case RC_FINISH_GLOBAL_INT: Export_Registers(); @@ -1178,23 +1279,13 @@ external_assignment_return: break; #endif - case RC_GC_CHECK: - if (Get_Integer(Fetch_Expression()) > Space_Before_GC()) - { - Export_Registers(); - Microcode_Termination(TERM_GC_OUT_OF_SPACE); - } - break; - case RC_HALT: Export_Registers(); Microcode_Termination(TERM_TERM_HANDLER); - case RC_INTERNAL_APPLY: - -Internal_Apply: -/* Branch here to perform a function application. +/* Internal_Apply, the core of the application mechanism. + 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): @@ -1226,6 +1317,9 @@ Internal_Apply: /* Interpret(), continued */ + case RC_INTERNAL_APPLY: +Internal_Apply: + if (Microcode_Does_Stepping && Trapping && (Fetch_Apply_Trapper() != NIL)) { @@ -1233,7 +1327,7 @@ Internal_Apply: Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); Top_Of_Stack() = Fetch_Apply_Trapper(); - Push(STACK_FRAME_HEADER+Count); + Push(STACK_FRAME_HEADER + Count); Stop_Trapping(); } @@ -1346,32 +1440,31 @@ Perform_Application: case TC_PRIMITIVE: { - long nargs; - fast long primitive_code; + fast long nargs; - primitive_code = OBJECT_DATUM(Function); - if (primitive_code > MAX_PRIMITIVE) + if (!IMPLEMENTED_PRIMITIVE_P(Function)) { Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); } - /* Note that the test below will fail for lexpr primitives. */ + /* Note that the first test below will fail for lexpr primitives. */ - nargs = (OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER)) - - (STACK_ENV_FIRST_ARG - 1)); - if (nargs != PRIMITIVE_ARITY(primitive_code)) + nargs = ((OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER))) - + (STACK_ENV_FIRST_ARG - 1)); + if (nargs != PRIMITIVE_ARITY(Function)) { - if (PRIMITIVE_ARITY(primitive_code) != LEXPR_PRIMITIVE_ARITY) + if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY) { Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); } Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs); } + Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); Store_Expression(Function); Export_Regs_Before_Primitive(); - Metering_Apply_Primitive(Val, primitive_code); + Metering_Apply_Primitive(Val, Function); Import_Regs_After_Primitive(); Pop_Primitive_Frame(nargs); @@ -1531,12 +1624,9 @@ return_from_compiled_code: /* This error code means that compiled code attempted to call an unimplemented primitive. */ - extern void Back_Out_Of_Primitive(); - Export_Registers(); - Back_Out_Of_Primitive(); - Import_Registers(); - goto Repeat_Dispatch; + BACK_OUT_AFTER_PRIMITIVE(); + Pop_Return_Error( ERR_UNIMPLEMENTED_PRIMITIVE); } case ERR_EXECUTE_MANIFEST_VECTOR: @@ -1639,14 +1729,15 @@ return_from_compiled_code: case RC_NORMAL_GC_DONE: End_GC_Hook(); + if (GC_Space_Needed < 0) + { + /* Paranoia */ + + GC_Space_Needed = 0; + } if (GC_Check(GC_Space_Needed)) - { fprintf(stderr, - "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n", - Free); - fprintf(stderr, - "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n", - MemTop, GC_Space_Needed); - Microcode_Termination(TERM_NO_SPACE); + { + Microcode_Termination(TERM_GC_OUT_OF_SPACE); } GC_Space_Needed = 0; Val = Fetch_Expression(); @@ -1669,32 +1760,30 @@ Primitive_Internal_Apply: Push(Fetch_Expression()); Push(Fetch_Apply_Trapper()); Push(STACK_FRAME_HEADER + 1 + - PRIMITIVE_N_PARAMETERS(OBJECT_DATUM(Fetch_Expression()))); + PRIMITIVE_N_PARAMETERS(Fetch_Expression())); Pushed(); Stop_Trapping(); goto Apply_Non_Trapping; } + /* NOTE: This code must match the code in the TC_PRIMITIVE case of Internal_Apply. - This code is simpler because it need not deal with lexpr - primitives. + This code is simpler because: + 1) The arity was checked at syntax time. + 2) We don't have to deal with "lexpr" primitives. + 3) We don't need to worry about unimplemented primitives because + unimplemented primitives will cause an error at invocation. */ - { - fast long primitive_code; - primitive_code = OBJECT_DATUM(Fetch_Expression()); - if (primitive_code > MAX_PRIMITIVE) - { - Push(Fetch_Expression()); - Push(STACK_FRAME_HEADER + PRIMITIVE_N_PARAMETERS(primitive_code)); - Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); - } + { + fast Pointer primitive; + primitive = Fetch_Expression(); Export_Regs_Before_Primitive(); - Metering_Apply_Primitive(Val, primitive_code); + Metering_Apply_Primitive(Val, primitive); Import_Regs_After_Primitive(); - Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive_code)); + Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive)); if (Must_Report_References()) { Store_Expression(Val); @@ -1729,7 +1818,9 @@ Primitive_Internal_Apply: /* Interpret(), continued */ case RC_PCOMB3_DO_1: - { Pointer Temp; + { + Pointer Temp; + Temp = Pop(); /* Value of arg. 3 */ Restore_Env(); Push(Temp); /* Save arg. 3 again */ @@ -1752,12 +1843,15 @@ Primitive_Internal_Apply: /* Interpret(), continued */ case RC_PURIFY_GC_1: - { Pointer GC_Daemon_Proc, Result; + { + Pointer GC_Daemon_Proc, Result; + Export_Registers(); Result = Purify_Pass_2(Fetch_Expression()); Import_Registers(); if (Result == NIL) - { /* The object does not fit in Constant space. + { + /* The object does not fit in Constant space. There is no need to run the daemons, and we should let the runtime system know what happened. */ @@ -1765,8 +1859,9 @@ Primitive_Internal_Apply: break; } GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc==NIL) - { Val = TRUTH; + if (GC_Daemon_Proc == NIL) + { + Val = TRUTH; break; } Store_Expression(NIL); @@ -1831,10 +1926,13 @@ Primitive_Internal_Apply: /* Interpret(), continued */ case RC_RESTORE_HISTORY: - { Pointer Stacklet; + { + Pointer Stacklet; + Export_Registers(); if (! Restore_History(Fetch_Expression())) - { Import_Registers(); + { + Import_Registers(); Save_Cont(); Will_Push(CONTINUATION_SIZE); Store_Expression(Val); diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index 4ebfd5b30..69862fb77 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.26 1987/10/09 16:12:57 jinx Rel $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.27 1987/12/04 22:18:23 jinx Rel $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -49,14 +49,17 @@ MIT in each case. */ #ifndef b32 /* Portable versions */ #define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH) -#define ADDRESS_MASK ((1<