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.

diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c
index f50787334c17ec74a6913837586fef67747841f0..86cb232d85763f335d655dfd7bc78ab7f05e3ab5 100644 (file)
--- 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 ();
 }
 \f
-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);
-}
-\f
 /* 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 ());
 }
 \f
-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);
-    }
-}
-\f
 /* 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 cba56e25014991c10661bf93a6d593839bebab4e..8d949568360a75cdd0820bf3855204fb3b9313c6 100644 (file)
--- 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 99b66eae1ac47dfb3f0aee7050773136f4c931b4..ad7923c473540620a6d57ef1573a6a760b88c977 100644 (file)
--- 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);
 }
-\f
+
 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);
 }
 \f
 /* History */