Simplify code to invoke compiled procedures from primitives. Fix bug

in APPLY that would cause the stack to be munged when errors or
interrupts occur during the invocation setup.

diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c
index c2f86a6b6af51f3e2959c8e2ccedbc986dc19129..bcf75d2070fb2bbb739132e170bbd0a63e2bf433 100644 (file)
--- a/v7/src/microcode/cmpint.c
+++ b/v7/src/microcode/cmpint.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: cmpint.c,v 1.111 2008/01/30 20:02:11 cph Exp $
+$Id: cmpint.c,v 1.112 2008/02/11 21:07:21 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -142,6 +142,8 @@ 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 *);
@@ -543,14 +545,7 @@ compiled_with_interrupt_mask (unsigned long old_mask,
   STACK_PUSH (ULONG_TO_FIXNUM (old_mask));
   PUSH_REFLECTION (REFLECT_CODE_RESTORE_INTERRUPT_MASK);
   STACK_PUSH (ULONG_TO_FIXNUM (new_mask));
-  {
-    long code = (setup_compiled_invocation (receiver, 1));
-    if (code != PRIM_DONE)
-      {
-       PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
-       PRIMITIVE_ABORT (code);
-      }
-  }
+  setup_compiled_invocation_from_primitive (receiver, 1);
   /* Pun: receiver is being invoked as a return address.  */
   STACK_PUSH (receiver);
 }
@@ -559,25 +554,22 @@ void
 compiled_with_stack_marker (SCHEME_OBJECT thunk)
 {
   PUSH_REFLECTION (REFLECT_CODE_STACK_MARKER);
-  {
-    long code = (setup_compiled_invocation (thunk, 0));
-    switch (code)
-      {
-      case PRIM_DONE:
-       /* Pun: thunk is being invoked as a return address.  */
-       STACK_PUSH (thunk);
-       break;
-
-      case PRIM_APPLY_INTERRUPT:
-       PRIMITIVE_ABORT (code);
-       break;
+  setup_compiled_invocation_from_primitive (thunk, 0);
+  /* Pun: thunk is being invoked as a return address.  */
+  STACK_PUSH (thunk);
+}
 
-      default:
+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);
-       PRIMITIVE_ABORT (code);
-       break;
-      }
-  }
+      PRIMITIVE_ABORT (code);
+    }
 }
 \f
 /* SCHEME_UTILITY procedures
@@ -1410,7 +1402,7 @@ DEFINE_SCHEME_ENTRY (comp_error_restart)
   JUMP_TO_CC_ENTRY (STACK_POP ());
 }
 \f
-long
+void
 apply_compiled_from_primitive (unsigned long n_args,
                               SCHEME_OBJECT procedure)
 {
@@ -1443,20 +1435,15 @@ apply_compiled_from_primitive (unsigned long n_args,
 
   if (CC_ENTRY_P (procedure))
     {
-      long code = (setup_compiled_invocation (procedure, n_args));
-      if (code != PRIM_DONE)
-       {
-         PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
-         return (code);
-       }
+      setup_compiled_invocation_from_primitive (procedure, n_args);
       STACK_PUSH (procedure);
-      return (PRIM_DONE);
     }
-
-  STACK_PUSH (procedure);
-  PUSH_APPLY_FRAME_HEADER (n_args);
-  PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
-  return (PRIM_DONE);
+  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

diff --git a/v7/src/microcode/cmpint.h b/v7/src/microcode/cmpint.h
index 4adbca3f68bde141472f9f5ed502c66f1d9c84b8..cba56e25014991c10661bf93a6d593839bebab4e 100644 (file)
--- a/v7/src/microcode/cmpint.h
+++ b/v7/src/microcode/cmpint.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: cmpint.h,v 10.17 2008/01/30 20:02:11 cph Exp $
+$Id: cmpint.h,v 10.18 2008/02/11 21:07:21 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -388,7 +388,7 @@ extern void guarantee_interp_return (void);
 extern long apply_compiled_procedure (void);
 extern long return_to_compiled_code (void);
 
-extern long apply_compiled_from_primitive (unsigned long, SCHEME_OBJECT);
+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);

diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c
index 3945e181d0765dfe3b014ec2fbc8170b1a80033b..99b66eae1ac47dfb3f0aee7050773136f4c931b4 100644 (file)
--- a/v7/src/microcode/hooks.c
+++ b/v7/src/microcode/hooks.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: hooks.c,v 9.70 2008/01/30 20:02:13 cph Exp $
+$Id: hooks.c,v 9.71 2008/02/11 21:07:21 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -101,9 +101,7 @@ Invokes PROCEDURE on the arguments in ARG-LIST.")
 #ifdef CC_SUPPORT_P
     if (CC_ENTRY_P (STACK_REF (n_args)))
       {
-       long code = (apply_compiled_from_primitive (n_args, procedure));
-       if (code != PRIM_DONE)
-         PRIMITIVE_ABORT (code);
+       apply_compiled_from_primitive (n_args, procedure);
        UN_POP_PRIMITIVE_FRAME (2);
        PRIMITIVE_RETURN (UNSPECIFIC);
       }