From: Chris Hanson Date: Thu, 14 Feb 2008 06:47:37 +0000 (+0000) Subject: Undo previous change that removed primitive apply optimizations. (It X-Git-Tag: 20090517-FFI~315 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=34c4568d12837830b51fa0ae2f293bf89ced8b95;p=mit-scheme.git Undo previous change that removed primitive apply optimizations. (It turns out that my analysis was incomplete and further changes would have been required.) Fix the problem with the apply hacks by introducing a new exception code PRIM_APPLY_ERROR, which provides an alternate path for signaling an error to the interpreter, _without_ backing out of the primitive (since we've already made all the necessary changes to the stack). --- diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 86cb232d8..7cc80156e 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.117 2008/02/13 04:28:25 cph Exp $ +$Id: cmpint.c,v 1.118 2008/02/14 06:47:32 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -153,6 +153,8 @@ static bool link_section_handler (linkage_section_type_t, cache_handler_t **, bool *); static void back_out_of_link_section (link_cc_state_t *); static void restore_link_cc_state (link_cc_state_t *); +static void setup_compiled_invocation_from_primitive + (SCHEME_OBJECT, unsigned long); static long setup_compiled_invocation (SCHEME_OBJECT, unsigned long); static long setup_lexpr_invocation (SCHEME_OBJECT, unsigned long, unsigned long); @@ -1365,6 +1367,84 @@ DEFINE_SCHEME_ENTRY (comp_error_restart) JUMP_TO_CC_ENTRY (STACK_POP ()); } +void +apply_compiled_from_primitive (unsigned long n_args, SCHEME_OBJECT procedure) +{ + while ((OBJECT_TYPE (procedure)) == TC_ENTITY) + { + { + unsigned long frame_size = (n_args + 1); + SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && (frame_size < (VECTOR_LENGTH (data))) + && (CC_ENTRY_P (VECTOR_REF (data, frame_size))) + && ((VECTOR_REF (data, 0)) + == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))) + { + procedure = (VECTOR_REF (data, frame_size)); + continue; + } + } + { + SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); + if (CC_ENTRY_P (operator)) + { + STACK_PUSH (procedure); + n_args += 1; + procedure = operator; + } + } + break; + } + + if (CC_ENTRY_P (procedure)) + setup_compiled_invocation_from_primitive (procedure, n_args); + else + { + STACK_PUSH (procedure); + PUSH_APPLY_FRAME_HEADER (n_args); + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + } +} + +void +compiled_with_interrupt_mask (unsigned long old_mask, + SCHEME_OBJECT receiver, + unsigned long new_mask) +{ + STACK_PUSH (ULONG_TO_FIXNUM (old_mask)); + PUSH_REFLECTION (REFLECT_CODE_RESTORE_INTERRUPT_MASK); + STACK_PUSH (ULONG_TO_FIXNUM (new_mask)); + setup_compiled_invocation_from_primitive (receiver, 1); +} + +void +compiled_with_stack_marker (SCHEME_OBJECT thunk) +{ + PUSH_REFLECTION (REFLECT_CODE_STACK_MARKER); + setup_compiled_invocation_from_primitive (thunk, 0); +} + +static void +setup_compiled_invocation_from_primitive (SCHEME_OBJECT procedure, + unsigned long n_args) +{ + long code = (setup_compiled_invocation (procedure, n_args)); + if (code != PRIM_DONE) + { + if (code != PRIM_APPLY_INTERRUPT) + { + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + prim_apply_error_code = code; + code = PRIM_APPLY_ERROR; + } + PRIMITIVE_ABORT (code); + } + /* Pun: procedure is being invoked as a return address. Assumes + that the primitive is being called from compiled code. */ + STACK_PUSH (procedure); +} + /* Adjust the stack frame for applying a compiled procedure. Returns PRIM_DONE when successful, otherwise sets up the call frame for application by the interpreter and returns the appropriate code. */ diff --git a/v7/src/microcode/cmpint.h b/v7/src/microcode/cmpint.h index 8d9495683..b7c659f39 100644 --- a/v7/src/microcode/cmpint.h +++ b/v7/src/microcode/cmpint.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.h,v 10.19 2008/02/13 04:28:26 cph Exp $ +$Id: cmpint.h,v 10.20 2008/02/14 06:47:33 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -388,6 +388,11 @@ extern void guarantee_interp_return (void); extern long apply_compiled_procedure (void); extern long return_to_compiled_code (void); +extern void apply_compiled_from_primitive (unsigned long, SCHEME_OBJECT); +extern void compiled_with_interrupt_mask + (unsigned long, SCHEME_OBJECT, unsigned long); +extern void compiled_with_stack_marker (SCHEME_OBJECT); + extern void compiler_initialize (bool); extern void compiler_reset (SCHEME_OBJECT); diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h index 7588f7d76..cddb0a985 100644 --- a/v7/src/microcode/const.h +++ b/v7/src/microcode/const.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: const.h,v 9.57 2008/01/30 20:02:11 cph Exp $ +$Id: const.h,v 9.58 2008/02/14 06:47:34 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -69,7 +69,7 @@ USA. #define PRIM_POP_RETURN -7 #define PRIM_TOUCH -8 #define PRIM_APPLY_INTERRUPT -9 -/* #define PRIM_REENTER -10 */ +#define PRIM_APPLY_ERROR -10 #define PRIM_NO_TRAP_POP_RETURN -11 #define ABORT_NAME_TABLE \ diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index ad7923c47..9b70c954a 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hooks.c,v 9.72 2008/02/13 04:28:27 cph Exp $ +$Id: hooks.c,v 9.73 2008/02/14 06:47:35 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -98,6 +98,15 @@ Invokes PROCEDURE on the arguments in ARG-LIST.") stack_pointer = sp; } +#ifdef CC_SUPPORT_P + if (CC_ENTRY_P (STACK_REF (n_args))) + { + apply_compiled_from_primitive (n_args, procedure); + UN_POP_PRIMITIVE_FRAME (2); + PRIMITIVE_RETURN (UNSPECIFIC); + } +#endif + STACK_PUSH (procedure); PUSH_APPLY_FRAME_HEADER (n_args); PRIMITIVE_ABORT (PRIM_APPLY); @@ -629,19 +638,30 @@ and MARKER2 is data identifying the marker instance.") PRIMITIVE_HEADER (3); { SCHEME_OBJECT thunk = (ARG_REF (1)); - canonicalize_primitive_context (); - (void) STACK_POP (); - STACK_PUSH (MAKE_RETURN_CODE (RC_STACK_MARKER)); - Will_Push (STACK_ENV_EXTRA_SLOTS + 1); - STACK_PUSH (thunk); - PUSH_APPLY_FRAME_HEADER (0); - Pushed (); - PRIMITIVE_ABORT (PRIM_APPLY); - /*NOTREACHED*/ +#ifdef CC_SUPPORT_P + if ((CC_ENTRY_P (STACK_REF (3))) && (CC_ENTRY_P (thunk))) + { + (void) STACK_POP (); + compiled_with_stack_marker (thunk); + UN_POP_PRIMITIVE_FRAME (3); + } + else +#endif + { + canonicalize_primitive_context (); + (void) STACK_POP (); + STACK_PUSH (MAKE_RETURN_CODE (RC_STACK_MARKER)); + Will_Push (STACK_ENV_EXTRA_SLOTS + 1); + STACK_PUSH (thunk); + PUSH_APPLY_FRAME_HEADER (0); + Pushed (); + PRIMITIVE_ABORT (PRIM_APPLY); + /*NOTREACHED*/ + } } PRIMITIVE_RETURN (UNSPECIFIC); } - + DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, "(MASK RECEIVER)\n\ Set the interrupt mask to MASK for the duration of the call to RECEIVER.\n\ @@ -670,16 +690,30 @@ static void with_new_interrupt_mask (unsigned long new_mask) { SCHEME_OBJECT receiver = (ARG_REF (2)); - canonicalize_primitive_context (); - POP_PRIMITIVE_FRAME (2); - preserve_interrupt_mask (); - Will_Push (STACK_ENV_EXTRA_SLOTS + 2); - STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK)); - STACK_PUSH (receiver); - PUSH_APPLY_FRAME_HEADER (1); - Pushed (); - SET_INTERRUPT_MASK (new_mask); - PRIMITIVE_ABORT (PRIM_APPLY); + +#ifdef CC_SUPPORT_P + if ((CC_ENTRY_P (STACK_REF (2))) && (CC_ENTRY_P (receiver))) + { + unsigned long current_mask = GET_INT_MASK; + POP_PRIMITIVE_FRAME (2); + compiled_with_interrupt_mask (current_mask, receiver, new_mask); + UN_POP_PRIMITIVE_FRAME (2); + SET_INTERRUPT_MASK (new_mask); + } + else +#endif + { + canonicalize_primitive_context (); + POP_PRIMITIVE_FRAME (2); + preserve_interrupt_mask (); + Will_Push (STACK_ENV_EXTRA_SLOTS + 2); + STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK)); + STACK_PUSH (receiver); + PUSH_APPLY_FRAME_HEADER (1); + Pushed (); + SET_INTERRUPT_MASK (new_mask); + PRIMITIVE_ABORT (PRIM_APPLY); + } } /* History */ diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index b2a7a8c23..247f5f0b8 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.c,v 9.108 2008/01/30 20:02:13 cph Exp $ +$Id: interp.c,v 9.109 2008/02/14 06:47:36 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -250,6 +250,8 @@ abort_to_interpreter_argument (void) { return (interpreter_throw_argument); } + +long prim_apply_error_code; void Interpret (void) @@ -287,6 +289,11 @@ Interpret (void) PREPARE_APPLY_INTERRUPT (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); + case PRIM_APPLY_ERROR: + PROCEED_AFTER_PRIMITIVE (); + Do_Micro_Error (prim_apply_error_code, true); + goto internal_apply; + case PRIM_DO_EXPRESSION: SET_VAL (GET_EXP); PROCEED_AFTER_PRIMITIVE (); diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h index f90d65f1f..a8d157437 100644 --- a/v7/src/microcode/interp.h +++ b/v7/src/microcode/interp.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.h,v 9.55 2008/01/30 20:02:13 cph Exp $ +$Id: interp.h,v 9.56 2008/02/14 06:47:37 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -155,6 +155,7 @@ extern void abort_to_interpreter (int) NORETURN; extern int abort_to_interpreter_argument (void); extern interpreter_state_t interpreter_state; +extern long prim_apply_error_code; extern void bind_interpreter_state (interpreter_state_t); extern void unbind_interpreter_state (interpreter_state_t);