From 91db3205cd485b3e77cc2ae062bf927724482d48 Mon Sep 17 00:00:00 2001
From: "Taylor R. Campbell" <net/mumble/campbell>
Date: Mon, 11 Feb 2008 21:07:21 +0000
Subject: [PATCH] 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.

---
 v7/src/microcode/cmpint.c | 65 ++++++++++++++++-----------------------
 v7/src/microcode/cmpint.h |  4 +--
 v7/src/microcode/hooks.c  |  6 ++--
 3 files changed, 30 insertions(+), 45 deletions(-)

diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c
index c2f86a6b6..bcf75d207 100644
--- 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);
+    }
 }
 
 /* SCHEME_UTILITY procedures
@@ -1410,7 +1402,7 @@ DEFINE_SCHEME_ENTRY (comp_error_restart)
   JUMP_TO_CC_ENTRY (STACK_POP ());
 }
 
-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);
+    }
 }
 
 /* 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 4adbca3f6..cba56e250 100644
--- 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 3945e181d..99b66eae1 100644
--- 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);
       }
-- 
2.25.1