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 86cb232d85763f335d655dfd7bc78ab7f05e3ab5..7cc80156ec0a9b6497bedb990e9d7327bd1de4f4 100644 (file)
--- 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 ());
 }
 \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);
+  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);
+}
+\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 8d949568360a75cdd0820bf3855204fb3b9313c6..b7c659f399020c4cdc59685dcbd47bd7b2c2a5c0 100644 (file)
--- 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 7588f7d76303c7cbde60d44b440ed463dc3850e3..cddb0a985be6acc9b4962abdbdfa5fec0ec3255c 100644 (file)
--- 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 ad7923c473540620a6d57ef1573a6a760b88c977..9b70c954a68d08ff03007500f6621d2965d44ee8 100644 (file)
--- 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);
 }
-
+\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\
@@ -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);
+    }
 }
 \f
 /* History */

diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c
index b2a7a8c23c39577d01d55f574e2e54ba481b69c5..247f5f0b82697ac1b3edf0e82fe931ed2d33aa5f 100644 (file)
--- 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;
 \f
 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 f90d65f1fa66ed50f76895a9aedc4b394953fa7a..a8d157437f4f45cb7b00d9bbb96a95e732e4730f 100644 (file)
--- 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);