From 1faa37a2c3c1707475d56c8ec136dab266b2b890 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 13 Feb 2008 04:28:27 +0000 Subject: [PATCH] Eliminate three special cases (compiled_with_interrupt_mask, compiled_with_stack_marker, and apply_compiled_from_primitive) that were adding hairy edge cases to gain a small amount of efficiency. --- v7/src/microcode/cmpint.c | 81 +-------------------------------------- v7/src/microcode/cmpint.h | 7 +--- v7/src/microcode/hooks.c | 76 ++++++++++-------------------------- 3 files changed, 23 insertions(+), 141 deletions(-) diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index f50787334..86cb232d8 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.116 2008/02/12 19:10:13 cph Exp $ +$Id: cmpint.c,v 1.117 2008/02/13 04:28:25 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -142,8 +142,6 @@ static SCHEME_OBJECT make_compiler_utilities (void); static void open_stack_gap (unsigned long, unsigned long); static void close_stack_gap (unsigned long, unsigned long); static void recover_from_apply_error (SCHEME_OBJECT, unsigned long); -static void setup_compiled_invocation_from_primitive - (SCHEME_OBJECT, unsigned long); static long link_remaining_sections (link_cc_state_t *); static void start_linking_cc_block (void); static void end_linking_cc_block (link_cc_state_t *); @@ -537,40 +535,6 @@ recover_from_apply_error (SCHEME_OBJECT procedure, unsigned long n_args) guarantee_interp_return (); } -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); - /* Pun: receiver is being invoked as a return address. */ - STACK_PUSH (receiver); -} - -void -compiled_with_stack_marker (SCHEME_OBJECT thunk) -{ - PUSH_REFLECTION (REFLECT_CODE_STACK_MARKER); - setup_compiled_invocation_from_primitive (thunk, 0); - /* Pun: thunk is being invoked as a return address. */ - STACK_PUSH (thunk); -} - -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) - return; - if (code != PRIM_APPLY_INTERRUPT) - PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); - PRIMITIVE_ABORT (code); -} - /* SCHEME_UTILITY procedures Here's a mass of procedures that are called (via @@ -1401,49 +1365,6 @@ 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); - STACK_PUSH (procedure); - } - else - { - STACK_PUSH (procedure); - PUSH_APPLY_FRAME_HEADER (n_args); - PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); - } -} - /* 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 cba56e250..8d9495683 100644 --- a/v7/src/microcode/cmpint.h +++ b/v7/src/microcode/cmpint.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.h,v 10.18 2008/02/11 21:07:21 riastradh Exp $ +$Id: cmpint.h,v 10.19 2008/02/13 04:28:26 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,11 +388,6 @@ 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/hooks.c b/v7/src/microcode/hooks.c index 99b66eae1..ad7923c47 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hooks.c,v 9.71 2008/02/11 21:07:21 riastradh Exp $ +$Id: hooks.c,v 9.72 2008/02/13 04:28:27 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,15 +98,6 @@ 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); @@ -638,30 +629,19 @@ and MARKER2 is data identifying the marker instance.") PRIMITIVE_HEADER (3); { SCHEME_OBJECT thunk = (ARG_REF (1)); -#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*/ - } + 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\ @@ -690,30 +670,16 @@ static void with_new_interrupt_mask (unsigned long new_mask) { SCHEME_OBJECT receiver = (ARG_REF (2)); - -#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); - } + 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 */ -- 2.25.1