From: Guillermo J. Rozas Date: Tue, 27 Oct 1992 22:00:13 +0000 (+0000) Subject: Add a mechanism for primitives to apply compiled procedures without X-Git-Tag: 20090517-FFI~8816 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f75e6f2e6d0a3bf8e55c2abf704368617004e63;p=mit-scheme.git Add a mechanism for primitives to apply compiled procedures without aborting to the interpreter (canonicalizing context). --- diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 81dcd41d8..783e07b69 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.52 1992/10/27 01:25:22 jinx Exp $ +$Id: cmpint.c,v 1.53 1992/10/27 22:00:04 jinx Exp $ Copyright (c) 1989-1992 Massachusetts Institute of Technology @@ -236,7 +236,8 @@ extern C_UTILITY SCHEME_OBJECT EXFUN (compiled_block_environment, (SCHEME_OBJECT block)), EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)), * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)); + EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)), + EXFUN (apply_compiled_from_primitive, (int)); extern C_UTILITY void EXFUN (compiler_initialize, (long fasl_p)), @@ -269,6 +270,8 @@ extern C_TO_SCHEME long EXFUN (comp_error_restart, (void)); extern utility_table_entry utility_table[]; + +static SCHEME_OBJECT apply_in_interpreter; /* These definitions reflect the indices into the table above. */ @@ -290,6 +293,7 @@ extern utility_table_entry utility_table[]; #define TRAMPOLINE_K_4_2 0xf #define TRAMPOLINE_K_4_1 0x10 #define TRAMPOLINE_K_4_0 0x11 +#define TRAMPOLINE_K_APPLY_IN_INTERPRETER 0x3a #define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED @@ -544,12 +548,12 @@ DEFUN_VOID (enter_compiled_expression) return (C_to_interface (compiled_entry_address)); } - + C_TO_SCHEME long DEFUN_VOID (apply_compiled_procedure) { SCHEME_OBJECT nactuals, procedure; - instruction *procedure_entry; + instruction * procedure_entry; long result; nactuals = (STACK_POP ()); @@ -582,6 +586,70 @@ DEFUN_VOID (return_to_compiled_code) return (C_to_interface (compiled_entry_address)); } +C_UTILITY SCHEME_OBJECT +DEFUN (apply_compiled_from_primitive, (arity), int arity) +{ + SCHEME_OBJECT frame_size, procedure; + long result; + + frame_size = (STACK_POP ()); + procedure = (STACK_POP ()); + + switch (OBJECT_TYPE (procedure)) + { + case TC_ENTITY: + { + SCHEME_OBJECT data, operator; + long nactuals = (OBJECT_DATUM (frame_size)); + + data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && (nactuals < (VECTOR_LENGTH (data))) + && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals))) + && ((VECTOR_REF (data, 0)) + == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG)))) + procedure = (VECTOR_REF (data, nactuals)); + else + { + operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); + if (!COMPILED_CODE_ADDRESS_P (operator)) + break; + STACK_PUSH (procedure); + frame_size += 1; + procedure = operator; + } + /* fall through */ + } + + case TC_COMPILED_ENTRY: + { + result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)), + ((instruction *) + (OBJECT_ADDRESS (procedure)))); + if (result == PRIM_DONE) + { + STACK_PUSH (procedure); + Stack_Pointer = (STACK_LOC (- arity)); + return (SHARP_F); + } + else + break; + } + + case TC_PRIMITIVE: + /* For now, fall through */ + + default: + break; + } + + STACK_PUSH (procedure); + STACK_PUSH (frame_size); + STACK_PUSH (apply_in_interpreter); + Stack_Pointer = (STACK_LOC (- arity)); + return (SHARP_F); +} + /* SCHEME_UTILITYs @@ -605,6 +673,22 @@ DEFUN (comutil_return_to_interpreter, RETURN_TO_C (PRIM_DONE); } +/* + This is an alternate way for code to return to the + Scheme interpreter. + It is invoked by a trampoline, which passes the address of the + trampoline storage block (empty) to it. + */ + +SCHEME_UTILITY struct utility_result +DEFUN (comutil_apply_in_interpreter, + (tramp_data, ignore_2, ignore_3, ignore_4), + SCHEME_OBJECT * tramp_data + AND long ignore_2 AND long ignore_3 AND long ignore_4) +{ + RETURN_TO_C (PRIM_APPLY); +} + /* comutil_primitive_apply is used to invoked a C primitive. Note that some C primitives (the so called interpreter hooks) @@ -2262,6 +2346,21 @@ DEFUN (store_uuo_link, # define TC_TRAMPOLINE_HEADER TC_MANIFEST_VECTOR #endif +static void +DEFUN (fill_trampoline, + (block, entry_point, fmt_word, kind), + SCHEME_OBJECT * block + AND instruction * entry_point + AND format_word fmt_word + AND long kind) +{ + (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word; + (COMPILED_ENTRY_OFFSET_WORD (entry_point)) = + (MAKE_OFFSET_WORD (entry_point, block, false)); + STORE_TRAMPOLINE_ENTRY (entry_point, kind); + return; +} + static long DEFUN (make_trampoline, (slot, fmt_word, kind, size, value1, value2, value3), @@ -2271,8 +2370,8 @@ DEFUN (make_trampoline, AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2 AND SCHEME_OBJECT value3) { - SCHEME_OBJECT * block, * local_free; instruction * entry_point; + SCHEME_OBJECT * ptr; if (GC_Check (TRAMPOLINE_SIZE + size)) { @@ -2280,27 +2379,22 @@ DEFUN (make_trampoline, return (PRIM_INTERRUPT); } - local_free = Free; + ptr = Free; Free += (TRAMPOLINE_SIZE + size); - block = local_free; - local_free[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, + ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, ((TRAMPOLINE_SIZE - 1) + size))); - local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - TRAMPOLINE_ENTRY_SIZE)); - entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (local_free))); - local_free = (TRAMPOLINE_STORAGE (entry_point)); - (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word; - (COMPILED_ENTRY_OFFSET_WORD (entry_point)) = - (MAKE_OFFSET_WORD (entry_point, block, false)); - STORE_TRAMPOLINE_ENTRY (entry_point, kind); - + ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, + TRAMPOLINE_ENTRY_SIZE)); + entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr))); + fill_trampoline (ptr, entry_point, fmt_word, kind); + *slot = (ENTRY_TO_OBJECT (entry_point)); + ptr = (TRAMPOLINE_STORAGE (entry_point)); if ((--size) >= 0) - *local_free++ = value1; + *ptr++ = value1; if ((--size) >= 0) - *local_free++ = value2; + *ptr++ = value2; if ((--size) >= 0) - *local_free++ = value3; - *slot = (ENTRY_TO_OBJECT (entry_point)); + *ptr++ = value3; return (PRIM_DONE); } @@ -2630,7 +2724,8 @@ utility_table_entry utility_table[] = UTE(comutil_primitive_error), /* 0x36 */ UTE(comutil_quotient), /* 0x37 */ UTE(comutil_remainder), /* 0x38 */ - UTE(comutil_modulo) /* 0x39 */ + UTE(comutil_modulo), /* 0x39 */ + UTE(comutil_apply_in_interpreter) /* 0x3a */ }; /* Initialization */ @@ -2686,6 +2781,8 @@ SCHEME_OBJECT static void DEFUN_VOID (compiler_reset_internal) { + long len; + SCHEME_OBJECT * block; /* Other stuff can be placed here. */ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL); @@ -2693,10 +2790,14 @@ DEFUN_VOID (compiler_reset_internal) ASM_RESET_HOOK(); + block = (OBJECT_ADDRESS (compiler_utilities)); + len = (OBJECT_DATUM (block[0])); return_to_interpreter = - (ENTRY_TO_OBJECT (TRAMPOLINE_ENTRY_POINT - (OBJECT_ADDRESS (compiler_utilities)))); - + (ENTRY_TO_OBJECT (((char *) block) + + ((unsigned long) (block [len - 1])))); + apply_in_interpreter = + (ENTRY_TO_OBJECT (((char *) block) + + ((unsigned long) (block [len])))); return; } @@ -2707,7 +2808,8 @@ DEFUN (compiler_reset, { /* Called after a disk restore */ - if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK) + if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK) + || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)) { extern void EXFUN (compiler_reset_error, (void)); @@ -2726,28 +2828,40 @@ DEFUN (compiler_initialize, (fasl_p), long fasl_p) { /* Start-up of whole interpreter */ - long code; - SCHEME_OBJECT trampoline, *block; - compiler_processor_type = COMPILER_PROCESSOR_TYPE; compiler_interface_version = COMPILER_INTERFACE_VERSION; if (fasl_p) { + long len; + instruction * tramp1, * tramp2; + SCHEME_OBJECT * block; extern SCHEME_OBJECT * EXFUN (copy_to_constant_space, (SCHEME_OBJECT *, long)); - code = (make_trampoline (&trampoline, - ((format_word) FORMAT_WORD_RETURN), - TRAMPOLINE_K_RETURN, - 0, SHARP_F, SHARP_F, SHARP_F)); - if (code != PRIM_DONE) + len = ((2 * TRAMPOLINE_ENTRY_SIZE) + 3); + if (GC_Check (len)) { fprintf (stderr, "compiler_initialize: Not enough space!\n"); Microcode_Termination (TERM_NO_SPACE); } - block = (compiled_entry_to_block_address (trampoline)); - block = (copy_to_constant_space (block, (1 + (OBJECT_DATUM (block[0]))))); + + block = Free; + Free += len; + block[0] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (len - 1))); + tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block - 1))); + tramp2 = ((instruction *) + (((char *) tramp1) + + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT))))); + fill_trampoline (block, tramp1, + ((format_word) FORMAT_WORD_RETURN), + TRAMPOLINE_K_RETURN); + fill_trampoline (block, tramp2, + ((format_word) FORMAT_WORD_RETURN), + TRAMPOLINE_K_APPLY_IN_INTERPRETER); + block[len - 2] = (((char *) tramp1) - ((char *) block)); + block[len - 1] = (((char *) tramp2) - ((char *) block)); + block = (copy_to_constant_space (block, len)); compiler_utilities = (MAKE_CC_BLOCK (block)); compiler_reset_internal (); } @@ -2810,7 +2924,8 @@ extern SCHEME_OBJECT EXFUN (compiled_block_environment, (SCHEME_OBJECT block)), EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)), * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)); + EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)), + EXFUN (apply_compiled_from_primitive, (int)); extern void EXFUN (compiler_reset, (SCHEME_OBJECT new_block)), @@ -2847,6 +2962,13 @@ DEFUN_VOID (return_to_compiled_code) return (ERR_INAPPLICABLE_CONTINUATION); } +SCHEME_OBJECT +DEFUN (apply_compiled_from_primitive, (arity), int arity) +{ + signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION); + /*NOTREACHED*/ +} + /* Bad entry points. */ long diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index 61cc7a69f..3ffad1ef0 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hooks.c,v 9.45 1992/09/18 05:53:31 jinx Exp $ +$Id: hooks.c,v 9.46 1992/10/27 22:00:13 jinx Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -40,17 +40,18 @@ MIT in each case. */ #include "winder.h" #include "history.h" +#define APPLY_AVOID_CANONICALIZATION + DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) { SCHEME_OBJECT procedure; SCHEME_OBJECT argument_list; fast long number_of_args; -#ifdef LOSING_PARALLEL_PROCESSOR - SCHEME_OBJECT * saved_stack_pointer; -#endif PRIMITIVE_HEADER (2); + procedure = (ARG_REF (1)); argument_list = (ARG_REF (2)); +#ifndef APPLY_AVOID_CANONICALIZATION /* Since this primitive must pop its own frame off and push a new frame on the stack, it has to be careful. Its own stack frame is needed if an error or GC is required. So these checks are done @@ -62,37 +63,58 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) list into a linear (vector-like) form, so as to avoid the overhead of traversing the list twice. Unfortunately, the overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed) - is sufficiently high that it probably makes up for the time saved. */ + is sufficiently high that it probably makes up for the time saved. + */ PRIMITIVE_CANONICALIZE_CONTEXT (); +#endif /* APPLY_AVOID_CANONICALIZATION */ { - fast SCHEME_OBJECT scan_list; + fast SCHEME_OBJECT scan_list, scan_list_trail; TOUCH_IN_PRIMITIVE (argument_list, scan_list); - number_of_args = 0; - while (PAIR_P (scan_list)) + if (! (PAIR_P (scan_list))) + number_of_args = 0; + else + { + number_of_args = 1; + scan_list_trail = scan_list; + TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list); + while (true) { - number_of_args += 1; + if (scan_list == scan_list_trail) + error_bad_range_arg (2); + if (! (PAIR_P (scan_list))) + break; + TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list); + if (scan_list == scan_list_trail) + error_bad_range_arg (2); + if (! (PAIR_P (scan_list))) + { + number_of_args += 1; + break; + } TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list); + scan_list_trail = (PAIR_CDR (scan_list_trail)); + number_of_args += 2; } + } if (scan_list != EMPTY_LIST) error_wrong_type_arg (2); } + #ifdef USE_STACKLETS /* This is conservative: if the number of arguments is large enough the Will_Push below may try to allocate space on the heap for the stack frame. */ Primitive_GC_If_Needed (New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1)); -#endif +#endif /* USE_STACKLETS */ + POP_PRIMITIVE_FRAME (2); + Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1); -#ifdef LOSING_PARALLEL_PROCESSOR - saved_stack_pointer = Stack_Pointer; -#endif { fast long i; fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args)); fast SCHEME_OBJECT scan_list; - Stack_Pointer = scan_stack; TOUCH_IN_PRIMITIVE (argument_list, scan_list); for (i = number_of_args; (i > 0); i -= 1) { @@ -102,7 +124,9 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) /* Check for abominable case of someone bashing the arg list. */ if (! (PAIR_P (scan_list))) { - Stack_Pointer = saved_stack_pointer; + /* Re-push the primitive's frame. */ + STACK_PUSH (argument_list); + STACK_PUSH (procedure); error_bad_range_arg (2); } #endif @@ -110,9 +134,19 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list); } } + Stack_Pointer = (STACK_LOC (- number_of_args)); STACK_PUSH (procedure); STACK_PUSH (STACK_FRAME_HEADER + number_of_args); Pushed (); + +#ifdef APPLY_AVOID_CANONICALIZATION + if (COMPILED_CODE_ADDRESS_P (STACK_REF (number_of_args + 2))) + { + extern SCHEME_OBJECT EXFUN (apply_compiled_from_primitive, (int)); + return (apply_compiled_from_primitive (2)); + } +#endif /* APPLY_AVOID_CANONICALIZATION */ + PRIMITIVE_ABORT (PRIM_APPLY); /*NOTREACHED*/ } diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index c6ad5a865..25e5c54de 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: version.h,v 11.121 1992/09/26 02:55:06 cph Exp $ +$Id: version.h,v 11.122 1992/10/27 21:59:55 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 121 +#define SUBVERSION 122 #endif diff --git a/v8/src/microcode/cmpint.c b/v8/src/microcode/cmpint.c index 81dcd41d8..783e07b69 100644 --- a/v8/src/microcode/cmpint.c +++ b/v8/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.52 1992/10/27 01:25:22 jinx Exp $ +$Id: cmpint.c,v 1.53 1992/10/27 22:00:04 jinx Exp $ Copyright (c) 1989-1992 Massachusetts Institute of Technology @@ -236,7 +236,8 @@ extern C_UTILITY SCHEME_OBJECT EXFUN (compiled_block_environment, (SCHEME_OBJECT block)), EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)), * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)); + EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)), + EXFUN (apply_compiled_from_primitive, (int)); extern C_UTILITY void EXFUN (compiler_initialize, (long fasl_p)), @@ -269,6 +270,8 @@ extern C_TO_SCHEME long EXFUN (comp_error_restart, (void)); extern utility_table_entry utility_table[]; + +static SCHEME_OBJECT apply_in_interpreter; /* These definitions reflect the indices into the table above. */ @@ -290,6 +293,7 @@ extern utility_table_entry utility_table[]; #define TRAMPOLINE_K_4_2 0xf #define TRAMPOLINE_K_4_1 0x10 #define TRAMPOLINE_K_4_0 0x11 +#define TRAMPOLINE_K_APPLY_IN_INTERPRETER 0x3a #define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED @@ -544,12 +548,12 @@ DEFUN_VOID (enter_compiled_expression) return (C_to_interface (compiled_entry_address)); } - + C_TO_SCHEME long DEFUN_VOID (apply_compiled_procedure) { SCHEME_OBJECT nactuals, procedure; - instruction *procedure_entry; + instruction * procedure_entry; long result; nactuals = (STACK_POP ()); @@ -582,6 +586,70 @@ DEFUN_VOID (return_to_compiled_code) return (C_to_interface (compiled_entry_address)); } +C_UTILITY SCHEME_OBJECT +DEFUN (apply_compiled_from_primitive, (arity), int arity) +{ + SCHEME_OBJECT frame_size, procedure; + long result; + + frame_size = (STACK_POP ()); + procedure = (STACK_POP ()); + + switch (OBJECT_TYPE (procedure)) + { + case TC_ENTITY: + { + SCHEME_OBJECT data, operator; + long nactuals = (OBJECT_DATUM (frame_size)); + + data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && (nactuals < (VECTOR_LENGTH (data))) + && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals))) + && ((VECTOR_REF (data, 0)) + == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG)))) + procedure = (VECTOR_REF (data, nactuals)); + else + { + operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); + if (!COMPILED_CODE_ADDRESS_P (operator)) + break; + STACK_PUSH (procedure); + frame_size += 1; + procedure = operator; + } + /* fall through */ + } + + case TC_COMPILED_ENTRY: + { + result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)), + ((instruction *) + (OBJECT_ADDRESS (procedure)))); + if (result == PRIM_DONE) + { + STACK_PUSH (procedure); + Stack_Pointer = (STACK_LOC (- arity)); + return (SHARP_F); + } + else + break; + } + + case TC_PRIMITIVE: + /* For now, fall through */ + + default: + break; + } + + STACK_PUSH (procedure); + STACK_PUSH (frame_size); + STACK_PUSH (apply_in_interpreter); + Stack_Pointer = (STACK_LOC (- arity)); + return (SHARP_F); +} + /* SCHEME_UTILITYs @@ -605,6 +673,22 @@ DEFUN (comutil_return_to_interpreter, RETURN_TO_C (PRIM_DONE); } +/* + This is an alternate way for code to return to the + Scheme interpreter. + It is invoked by a trampoline, which passes the address of the + trampoline storage block (empty) to it. + */ + +SCHEME_UTILITY struct utility_result +DEFUN (comutil_apply_in_interpreter, + (tramp_data, ignore_2, ignore_3, ignore_4), + SCHEME_OBJECT * tramp_data + AND long ignore_2 AND long ignore_3 AND long ignore_4) +{ + RETURN_TO_C (PRIM_APPLY); +} + /* comutil_primitive_apply is used to invoked a C primitive. Note that some C primitives (the so called interpreter hooks) @@ -2262,6 +2346,21 @@ DEFUN (store_uuo_link, # define TC_TRAMPOLINE_HEADER TC_MANIFEST_VECTOR #endif +static void +DEFUN (fill_trampoline, + (block, entry_point, fmt_word, kind), + SCHEME_OBJECT * block + AND instruction * entry_point + AND format_word fmt_word + AND long kind) +{ + (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word; + (COMPILED_ENTRY_OFFSET_WORD (entry_point)) = + (MAKE_OFFSET_WORD (entry_point, block, false)); + STORE_TRAMPOLINE_ENTRY (entry_point, kind); + return; +} + static long DEFUN (make_trampoline, (slot, fmt_word, kind, size, value1, value2, value3), @@ -2271,8 +2370,8 @@ DEFUN (make_trampoline, AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2 AND SCHEME_OBJECT value3) { - SCHEME_OBJECT * block, * local_free; instruction * entry_point; + SCHEME_OBJECT * ptr; if (GC_Check (TRAMPOLINE_SIZE + size)) { @@ -2280,27 +2379,22 @@ DEFUN (make_trampoline, return (PRIM_INTERRUPT); } - local_free = Free; + ptr = Free; Free += (TRAMPOLINE_SIZE + size); - block = local_free; - local_free[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, + ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, ((TRAMPOLINE_SIZE - 1) + size))); - local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - TRAMPOLINE_ENTRY_SIZE)); - entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (local_free))); - local_free = (TRAMPOLINE_STORAGE (entry_point)); - (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word; - (COMPILED_ENTRY_OFFSET_WORD (entry_point)) = - (MAKE_OFFSET_WORD (entry_point, block, false)); - STORE_TRAMPOLINE_ENTRY (entry_point, kind); - + ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, + TRAMPOLINE_ENTRY_SIZE)); + entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr))); + fill_trampoline (ptr, entry_point, fmt_word, kind); + *slot = (ENTRY_TO_OBJECT (entry_point)); + ptr = (TRAMPOLINE_STORAGE (entry_point)); if ((--size) >= 0) - *local_free++ = value1; + *ptr++ = value1; if ((--size) >= 0) - *local_free++ = value2; + *ptr++ = value2; if ((--size) >= 0) - *local_free++ = value3; - *slot = (ENTRY_TO_OBJECT (entry_point)); + *ptr++ = value3; return (PRIM_DONE); } @@ -2630,7 +2724,8 @@ utility_table_entry utility_table[] = UTE(comutil_primitive_error), /* 0x36 */ UTE(comutil_quotient), /* 0x37 */ UTE(comutil_remainder), /* 0x38 */ - UTE(comutil_modulo) /* 0x39 */ + UTE(comutil_modulo), /* 0x39 */ + UTE(comutil_apply_in_interpreter) /* 0x3a */ }; /* Initialization */ @@ -2686,6 +2781,8 @@ SCHEME_OBJECT static void DEFUN_VOID (compiler_reset_internal) { + long len; + SCHEME_OBJECT * block; /* Other stuff can be placed here. */ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL); @@ -2693,10 +2790,14 @@ DEFUN_VOID (compiler_reset_internal) ASM_RESET_HOOK(); + block = (OBJECT_ADDRESS (compiler_utilities)); + len = (OBJECT_DATUM (block[0])); return_to_interpreter = - (ENTRY_TO_OBJECT (TRAMPOLINE_ENTRY_POINT - (OBJECT_ADDRESS (compiler_utilities)))); - + (ENTRY_TO_OBJECT (((char *) block) + + ((unsigned long) (block [len - 1])))); + apply_in_interpreter = + (ENTRY_TO_OBJECT (((char *) block) + + ((unsigned long) (block [len])))); return; } @@ -2707,7 +2808,8 @@ DEFUN (compiler_reset, { /* Called after a disk restore */ - if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK) + if (((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK) + || ((OBJECT_TYPE (MEMORY_REF (new_block, 0))) != TC_MANIFEST_NM_VECTOR)) { extern void EXFUN (compiler_reset_error, (void)); @@ -2726,28 +2828,40 @@ DEFUN (compiler_initialize, (fasl_p), long fasl_p) { /* Start-up of whole interpreter */ - long code; - SCHEME_OBJECT trampoline, *block; - compiler_processor_type = COMPILER_PROCESSOR_TYPE; compiler_interface_version = COMPILER_INTERFACE_VERSION; if (fasl_p) { + long len; + instruction * tramp1, * tramp2; + SCHEME_OBJECT * block; extern SCHEME_OBJECT * EXFUN (copy_to_constant_space, (SCHEME_OBJECT *, long)); - code = (make_trampoline (&trampoline, - ((format_word) FORMAT_WORD_RETURN), - TRAMPOLINE_K_RETURN, - 0, SHARP_F, SHARP_F, SHARP_F)); - if (code != PRIM_DONE) + len = ((2 * TRAMPOLINE_ENTRY_SIZE) + 3); + if (GC_Check (len)) { fprintf (stderr, "compiler_initialize: Not enough space!\n"); Microcode_Termination (TERM_NO_SPACE); } - block = (compiled_entry_to_block_address (trampoline)); - block = (copy_to_constant_space (block, (1 + (OBJECT_DATUM (block[0]))))); + + block = Free; + Free += len; + block[0] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (len - 1))); + tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block - 1))); + tramp2 = ((instruction *) + (((char *) tramp1) + + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT))))); + fill_trampoline (block, tramp1, + ((format_word) FORMAT_WORD_RETURN), + TRAMPOLINE_K_RETURN); + fill_trampoline (block, tramp2, + ((format_word) FORMAT_WORD_RETURN), + TRAMPOLINE_K_APPLY_IN_INTERPRETER); + block[len - 2] = (((char *) tramp1) - ((char *) block)); + block[len - 1] = (((char *) tramp2) - ((char *) block)); + block = (copy_to_constant_space (block, len)); compiler_utilities = (MAKE_CC_BLOCK (block)); compiler_reset_internal (); } @@ -2810,7 +2924,8 @@ extern SCHEME_OBJECT EXFUN (compiled_block_environment, (SCHEME_OBJECT block)), EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)), * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)); + EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)), + EXFUN (apply_compiled_from_primitive, (int)); extern void EXFUN (compiler_reset, (SCHEME_OBJECT new_block)), @@ -2847,6 +2962,13 @@ DEFUN_VOID (return_to_compiled_code) return (ERR_INAPPLICABLE_CONTINUATION); } +SCHEME_OBJECT +DEFUN (apply_compiled_from_primitive, (arity), int arity) +{ + signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION); + /*NOTREACHED*/ +} + /* Bad entry points. */ long diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index c6ad5a865..25e5c54de 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: version.h,v 11.121 1992/09/26 02:55:06 cph Exp $ +$Id: version.h,v 11.122 1992/10/27 21:59:55 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 121 +#define SUBVERSION 122 #endif