From: Mark Friedman <edu/mit/csail/zurich/markf>
Date: Thu, 18 Jul 1991 16:03:38 +0000 (+0000)
Subject: Changed support for stepper hooks. Return hooks now work more or less
X-Git-Tag: 20090517-FFI~10446
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d1a923fb47ce73381f772c866e16e10cdaf96f28;p=mit-scheme.git

Changed support for stepper hooks. Return hooks now work more or less
like the apply and eval hooks.
---

diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h
index 2a7a064f0..5fd187664 100644
--- a/v7/src/microcode/const.h
+++ b/v7/src/microcode/const.h
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.37 1991/03/21 23:26:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.38 1991/07/18 16:03:38 markf Exp $
  *
  * Named constants used throughout the interpreter
  *
@@ -127,6 +127,7 @@ MIT in each case. */
 #define PRIM_TOUCH			-8
 #define PRIM_APPLY_INTERRUPT		-9
 #define PRIM_REENTER			-10
+#define PRIM_NO_TRAP_POP_RETURN		-11
 
 #define ABORT_NAME_TABLE						\
 {									\
@@ -140,6 +141,7 @@ MIT in each case. */
   /* -8 */	"TOUCH",						\
   /* -9 */	"APPLY-INTERRUPT",					\
   /* -10 */	"REENTER"						\
+  /* -11 */	"NO-TRAP-POP-RETURN"					\
 }
 
 /* Some numbers of parameters which mean something special */
diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c
index 8a98ac9d9..f97b8d7cf 100644
--- a/v7/src/microcode/interp.c
+++ b/v7/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.62 1991/06/22 19:28:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.63 1991/07/18 15:58:12 markf Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -487,6 +487,11 @@ Repeat_Dispatch:
     case CODE_MAP(PRIM_POP_RETURN):
       goto Pop_Return;
 
+    case PRIM_NO_TRAP_POP_RETURN:
+      PROCEED_AFTER_PRIMITIVE();
+    case CODE_MAP(PRIM_NO_TRAP_POP_RETURN):
+      goto Pop_Return_Non_Trapping;
+
     case PRIM_REENTER:
       BACK_OUT_AFTER_PRIMITIVE();
       LOG_FUTURES();
@@ -596,6 +601,7 @@ Do_Expression:
 
   if (Microcode_Does_Stepping &&
       Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
       ((Fetch_Eval_Trapper ()) != SHARP_F))
   {
     Stop_Trapping ();
@@ -942,6 +948,20 @@ lookup_end_restart:
  */
 
 Pop_Return:
+  if (Microcode_Does_Stepping &&
+      Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
+      ((Fetch_Return_Trapper ()) != SHARP_F))
+  {
+    Will_Push(3);
+      Stop_Trapping();
+      STACK_PUSH (Val);
+      STACK_PUSH (Fetch_Return_Trapper());
+      STACK_PUSH (STACK_FRAME_HEADER+1);
+    Pushed();
+    goto Apply_Non_Trapping;
+  }
+Pop_Return_Non_Trapping:
   Pop_Return_Ucode_Hook();
   Restore_Cont();
   if (Consistency_Check &&
@@ -1420,6 +1440,7 @@ Internal_Apply:
 
       if (Microcode_Does_Stepping &&
 	  Trapping &&
+	  (! WITHIN_CRITICAL_SECTION_P()) &&
 	  ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
 	long Count;
@@ -1896,6 +1917,7 @@ return_from_compiled_code:
 Primitive_Internal_Apply:
       if (Microcode_Does_Stepping &&
 	  Trapping &&
+	  (! WITHIN_CRITICAL_SECTION_P()) &&
 	  ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
 	/* Does this work in the stacklet case?
@@ -2140,18 +2162,6 @@ Primitive_Internal_Apply:
       break;			/* We never get here.... */
     }
 
-    case RC_RETURN_TRAP_POINT:
-      Store_Return(Old_Return_Code);
-     Will_Push(CONTINUATION_SIZE+3);
-      Save_Cont();
-      Return_Hook_Address = NULL;
-      Stop_Trapping();
-      STACK_PUSH (Val);
-      STACK_PUSH (Fetch_Return_Trapper());
-      STACK_PUSH (STACK_FRAME_HEADER+1);
-     Pushed();
-      goto Apply_Non_Trapping;
-
     case RC_SEQ_2_DO_2:
       End_Subproblem();
       Restore_Env();
diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h
index 3891a5901..9d2443cf8 100644
--- a/v7/src/microcode/interp.h
+++ b/v7/src/microcode/interp.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.33 1990/06/20 17:41:20 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.34 1991/07/18 15:59:41 markf Exp $
 
 Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -201,11 +201,6 @@ extern int EXFUN (abort_to_interpreter_argument, (void));
 #define Stop_Trapping()							\
 {									\
   Trapping = false;							\
-  if (Return_Hook_Address != NULL)					\
-  {									\
-    *Return_Hook_Address = Old_Return_Code;				\
-  }									\
-  Return_Hook_Address = NULL;						\
 }
 
 /* Primitive utility macros */
diff --git a/v7/src/microcode/step.c b/v7/src/microcode/step.c
index bf89fb12a..17a08a542 100644
--- a/v7/src/microcode/step.c
+++ b/v7/src/microcode/step.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.28 1990/06/20 17:42:08 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.29 1991/07/18 16:01:27 markf Exp $
 
 Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -47,9 +47,8 @@ MIT in each case. */
 */
 
 void
-Install_Traps(Hunk3, Return_Hook_Too)
+Install_Traps (Hunk3)
      SCHEME_OBJECT Hunk3;
-     Boolean Return_Hook_Too;
 {
   SCHEME_OBJECT Eval_Hook, Apply_Hook, Return_Hook;
 
@@ -58,18 +57,9 @@ Install_Traps(Hunk3, Return_Hook_Too)
   Apply_Hook = MEMORY_REF (Hunk3, HUNK_CXR1);
   Return_Hook = MEMORY_REF (Hunk3, HUNK_CXR2);
   Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
-  Trapping = ((Eval_Hook != SHARP_F) | (Apply_Hook != SHARP_F));
-  if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != SHARP_F))
-  {
-    /* Here it is ... gross and ugly.  We know that the top of stack
-       has the existing return code to be clobbered, since it was put
-       there by Save_Cont.
-    */
-    Return_Hook_Address = (STACK_LOC (0));
-    Old_Return_Code = (*Return_Hook_Address);
-    (*Return_Hook_Address) =
-      (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT));
-  }
+  Trapping = ((Eval_Hook != SHARP_F) |
+	      (Apply_Hook != SHARP_F) |
+	      (Return_Hook != SHARP_F));
   return;
 }
 
@@ -83,12 +73,14 @@ Install_Traps(Hunk3, Return_Hook_Too)
 DEFINE_PRIMITIVE ("PRIMITIVE-EVAL-STEP", Prim_eval_step, 3, 3, 0)
 {
   PRIMITIVE_HEADER (3);
+  CHECK_ARG (3, HUNK3_P);
   {
     SCHEME_OBJECT expression = (ARG_REF (1));
     SCHEME_OBJECT environment = (ARG_REF (2));
+    SCHEME_OBJECT hooks = (ARG_REF (3));
     PRIMITIVE_CANONICALIZE_CONTEXT ();
-    Install_Traps ((ARG_REF (3)), false);
     POP_PRIMITIVE_FRAME (3);
+    Install_Traps (hooks);
     Store_Expression (expression);
     Store_Env (environment);
   }
@@ -111,37 +103,40 @@ DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
   PRIMITIVE_CANONICALIZE_CONTEXT ();
   CHECK_ARG (3, HUNK3_P);
   {
-    SCHEME_OBJECT procedure = (ARG_REF (2));
-    SCHEME_OBJECT argument_list = (ARG_REF (3));
+    SCHEME_OBJECT hooks = (ARG_REF (3));
     fast long number_of_args = 0;
     {
-      fast SCHEME_OBJECT scan_list;
-      TOUCH_IN_PRIMITIVE (argument_list, scan_list);
-      while (PAIR_P (scan_list))
-	{
-	  number_of_args += 1;
-	  TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
-	}
-      if (scan_list != EMPTY_LIST)
-	error_wrong_type_arg (2);
-    }
-    Install_Traps ((ARG_REF (3)), true);
-    POP_PRIMITIVE_FRAME (3);
-    {
-      fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
-      fast SCHEME_OBJECT scan_list;
-      fast long i;
-    Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
-      Stack_Pointer = scan_stack;
-      TOUCH_IN_PRIMITIVE (argument_list, scan_list);
-      for (i = number_of_args; (i > 0); i -= 1)
-	{
-	  (*scan_stack++) = (PAIR_CAR (scan_list));
-	  TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
-	}
-      STACK_PUSH (procedure);
-      STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
-    Pushed ();
+      SCHEME_OBJECT procedure = (ARG_REF (1));
+      SCHEME_OBJECT argument_list = (ARG_REF (2));
+      {
+	fast SCHEME_OBJECT scan_list;
+	TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+	while (PAIR_P (scan_list))
+	  {
+	    number_of_args += 1;
+	    TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+	  }
+	if (scan_list != EMPTY_LIST)
+	  error_wrong_type_arg (2);
+      }
+      POP_PRIMITIVE_FRAME (3);
+      Install_Traps (hooks);
+      {
+	fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
+	fast SCHEME_OBJECT scan_list;
+	fast long i;
+	Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
+	Stack_Pointer = scan_stack;
+	TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+	for (i = number_of_args; (i > 0); i -= 1)
+	  {
+	    (*scan_stack++) = (PAIR_CAR (scan_list));
+	    TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+	  }
+	STACK_PUSH (procedure);
+	STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
+	Pushed ();
+      }
     }
   }
   PRIMITIVE_ABORT (PRIM_NO_TRAP_APPLY);
@@ -152,16 +147,20 @@ DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
    Returns VALUE and intalls the eval-trap, apply-trap, and
    return-trap from HUNK3.  If any trap is '(), it is a null trap
    that does a normal EVAL, APPLY or return.
-
-   UGLY ... currently assumes that it is illegal to set a return trap
-   this way, so that we don't run into stack parsing problems.  If
-   this is ever changed, be sure to check for COMPILE_STEPPER flag! */
+*/
 
 DEFINE_PRIMITIVE ("PRIMITIVE-RETURN-STEP", Prim_return_step, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
-  if ((MEMORY_REF ((ARG_REF (2)), HUNK_CXR2)) != SHARP_F)
-    error_bad_range_arg (2);
-  Install_Traps ((ARG_REF (2)), false);
-  PRIMITIVE_RETURN (ARG_REF (1));
+  PRIMITIVE_CANONICALIZE_CONTEXT ();
+  CHECK_ARG (2, HUNK3_P);
+  {
+    SCHEME_OBJECT value = (ARG_REF (1));
+    SCHEME_OBJECT hooks = (ARG_REF (2));
+
+    POP_PRIMITIVE_FRAME (2); 
+    Install_Traps (hooks);
+    Val = (value);
+    PRIMITIVE_ABORT (PRIM_NO_TRAP_POP_RETURN);
+  }
 }
diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h
index 311d3f301..cc08ade8e 100644
--- a/v8/src/microcode/const.h
+++ b/v8/src/microcode/const.h
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.37 1991/03/21 23:26:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.38 1991/07/18 16:03:38 markf Exp $
  *
  * Named constants used throughout the interpreter
  *
@@ -127,6 +127,7 @@ MIT in each case. */
 #define PRIM_TOUCH			-8
 #define PRIM_APPLY_INTERRUPT		-9
 #define PRIM_REENTER			-10
+#define PRIM_NO_TRAP_POP_RETURN		-11
 
 #define ABORT_NAME_TABLE						\
 {									\
@@ -140,6 +141,7 @@ MIT in each case. */
   /* -8 */	"TOUCH",						\
   /* -9 */	"APPLY-INTERRUPT",					\
   /* -10 */	"REENTER"						\
+  /* -11 */	"NO-TRAP-POP-RETURN"					\
 }
 
 /* Some numbers of parameters which mean something special */
diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c
index ce2f202e6..9ae7039e4 100644
--- a/v8/src/microcode/interp.c
+++ b/v8/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.62 1991/06/22 19:28:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.63 1991/07/18 15:58:12 markf Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -487,6 +487,11 @@ Repeat_Dispatch:
     case CODE_MAP(PRIM_POP_RETURN):
       goto Pop_Return;
 
+    case PRIM_NO_TRAP_POP_RETURN:
+      PROCEED_AFTER_PRIMITIVE();
+    case CODE_MAP(PRIM_NO_TRAP_POP_RETURN):
+      goto Pop_Return_Non_Trapping;
+
     case PRIM_REENTER:
       BACK_OUT_AFTER_PRIMITIVE();
       LOG_FUTURES();
@@ -596,6 +601,7 @@ Do_Expression:
 
   if (Microcode_Does_Stepping &&
       Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
       ((Fetch_Eval_Trapper ()) != SHARP_F))
   {
     Stop_Trapping ();
@@ -942,6 +948,20 @@ lookup_end_restart:
  */
 
 Pop_Return:
+  if (Microcode_Does_Stepping &&
+      Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
+      ((Fetch_Return_Trapper ()) != SHARP_F))
+  {
+    Will_Push(3);
+      Stop_Trapping();
+      STACK_PUSH (Val);
+      STACK_PUSH (Fetch_Return_Trapper());
+      STACK_PUSH (STACK_FRAME_HEADER+1);
+    Pushed();
+    goto Apply_Non_Trapping;
+  }
+Pop_Return_Non_Trapping:
   Pop_Return_Ucode_Hook();
   Restore_Cont();
   if (Consistency_Check &&
@@ -1420,6 +1440,7 @@ Internal_Apply:
 
       if (Microcode_Does_Stepping &&
 	  Trapping &&
+	  (! WITHIN_CRITICAL_SECTION_P()) &&
 	  ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
 	long Count;
@@ -1896,6 +1917,7 @@ return_from_compiled_code:
 Primitive_Internal_Apply:
       if (Microcode_Does_Stepping &&
 	  Trapping &&
+	  (! WITHIN_CRITICAL_SECTION_P()) &&
 	  ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
 	/* Does this work in the stacklet case?
@@ -2140,18 +2162,6 @@ Primitive_Internal_Apply:
       break;			/* We never get here.... */
     }
 
-    case RC_RETURN_TRAP_POINT:
-      Store_Return(Old_Return_Code);
-     Will_Push(CONTINUATION_SIZE+3);
-      Save_Cont();
-      Return_Hook_Address = NULL;
-      Stop_Trapping();
-      STACK_PUSH (Val);
-      STACK_PUSH (Fetch_Return_Trapper());
-      STACK_PUSH (STACK_FRAME_HEADER+1);
-     Pushed();
-      goto Apply_Non_Trapping;
-
     case RC_SEQ_2_DO_2:
       End_Subproblem();
       Restore_Env();