[Guile-commits] 03/04: reimplement throw/catch in terms of exns (tmp)

[Andy Wingo]

wingo pushed a commit to branch wip-exceptions
in repository guile.

commit 58196f4ea8a0f320e93e05f324a60923ceff266f
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 10 17:25:38 2019 +0200

    reimplement throw/catch in terms of exns (tmp)
---
 libguile/threads.c |   2 +-
 libguile/throw.c   | 364 ++++++-----------------------------------------------
 libguile/throw.h   |  10 +-
 3 files changed, 43 insertions(+), 333 deletions(-)

diff --git a/libguile/threads.c b/libguile/threads.c
index 86ac5e8..37dfed4 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -823,7 +823,7 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
 
   body_closure = scm_i_make_catch_body_closure (body, body_data);
   handler_closure = handler == NULL ? SCM_UNDEFINED :
-    scm_i_make_catch_handler_closure (handler, handler_data);
+    scm_i_make_catch_handler (handler, handler_data);
 
   return scm_call_with_new_thread (body_closure, handler_closure);
 }
diff --git a/libguile/throw.c b/libguile/throw.c
index 055ad87..f2cdf86 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -34,7 +34,6 @@
 #include "deprecation.h"
 #include "eq.h"
 #include "eval.h"
-#include "fluids.h"
 #include "gsubr.h"
 #include "init.h"
 #include "list.h"
@@ -54,216 +53,39 @@
 #include "throw.h"
 
 
-/* Pleasantly enough, the guts of exception handling are defined in
-   Scheme, in terms of prompt, abort, and the %exception-handler fluid.
-   Check boot-9 for the definitions.
-
-   Still, it's useful to be able to throw unwind-only exceptions from C,
-   for example so that we can recover from stack overflow.  We also need
-   to have an implementation of catch and throw handy before boot time.
-   For that reason we have a parallel implementation of "catch" that
-   uses the same fluids here.  Throws from C still call out to Scheme
-   though, so that pre-unwind handlers can be run.  Getting the dynamic
-   environment right for pre-unwind handlers is tricky, and it's
-   important to have all of the implementation in one place.
-
-   All of these function names and prototypes carry a fair bit of historical
-   baggage. */
-
-
 
 
-static SCM throw_var;
-
-static SCM exception_handler_fluid;
-
-static SCM
-catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
-{
-  SCM eh, prompt_tag;
-  SCM res;
-  scm_thread *t = SCM_I_CURRENT_THREAD;
-  scm_t_dynstack *dynstack = &t->dynstack;
-  scm_t_dynamic_state *dynamic_state = t->dynamic_state;
-  jmp_buf registers;
-  jmp_buf *prev_registers;
-  ptrdiff_t saved_stack_depth;
-  uint8_t *mra = NULL;
-
-  if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag))
-    scm_wrong_type_arg ("catch", 1, tag);
-
-  if (SCM_UNBNDP (handler))
-    handler = SCM_BOOL_F;
-  else if (!scm_is_true (scm_procedure_p (handler)))
-    scm_wrong_type_arg ("catch", 3, handler);
-
-  if (SCM_UNBNDP (pre_unwind_handler))
-    pre_unwind_handler = SCM_BOOL_F;
-  else if (!scm_is_true (scm_procedure_p (pre_unwind_handler)))
-    scm_wrong_type_arg ("catch", 4, pre_unwind_handler);
-
-  prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
-
-  eh = scm_c_make_vector (3, SCM_BOOL_F);
-  scm_c_vector_set_x (eh, 0, tag);
-  scm_c_vector_set_x (eh, 1, prompt_tag);
-  scm_c_vector_set_x (eh, 2, pre_unwind_handler);
-
-  prev_registers = t->vm.registers;
-  saved_stack_depth = t->vm.stack_top - t->vm.sp;
-
-  /* Push the prompt and exception handler onto the dynamic stack. */
-  scm_dynstack_push_prompt (dynstack,
-                            SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
-                            prompt_tag,
-                            t->vm.stack_top - t->vm.fp,
-                            saved_stack_depth,
-                            t->vm.ip,
-                            mra,
-                            &registers);
-  scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
-                           dynamic_state);
-
-  if (setjmp (registers))
-    {
-      /* A non-local return.  */
-      SCM args;
-
-      t->vm.registers = prev_registers;
-      scm_gc_after_nonlocal_exit ();
-
-      /* FIXME: We know where the args will be on the stack; we could
-         avoid consing them.  */
-      args = scm_i_prompt_pop_abort_args_x (&t->vm, saved_stack_depth);
-
-      /* Cdr past the continuation. */
-      args = scm_cdr (args);
-
-      return scm_apply_0 (handler, args);
-    }
-
-  res = scm_call_0 (thunk);
-
-  scm_dynstack_unwind_fluid (dynstack, dynamic_state);
-  scm_dynstack_pop (dynstack);
-
-  return res;
-}
-
-static void
-default_exception_handler (SCM k, SCM args)
-{
-  static int error_printing_error = 0;
-  static int error_printing_fallback = 0;
-
-  if (error_printing_fallback)
-    fprintf (stderr, "\nFailed to print exception.\n");
-  else if (error_printing_error)
-    {
-      fprintf (stderr, "\nError while printing exception:\n");
-      error_printing_fallback = 1;
-      fprintf (stderr, "Key: ");
-      scm_write (k, scm_current_error_port ());
-      fprintf (stderr, ", args: ");
-      scm_write (args, scm_current_error_port ());
-      scm_newline (scm_current_error_port ());
-   }
-  else
-    {
-      fprintf (stderr, "Uncaught exception:\n");
-      error_printing_error = 1;
-      scm_handle_by_message (NULL, k, args);
-    }
-
-  /* Normally we don't get here, because scm_handle_by_message will
-     exit.  */
-  fprintf (stderr, "Aborting.\n");
-  abort ();
-}
-
-/* A version of scm_abort_to_prompt_star that avoids the need to cons
-   "tag" to "args", because we might be out of memory.  */
-static void
-abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
-{
-  SCM *tag_and_argv;
-  size_t i;
-  long n;
-
-  n = scm_ilength (args) + 2;
-  tag_and_argv = alloca (sizeof (SCM)*n);
-  tag_and_argv[0] = prompt_tag;
-  tag_and_argv[1] = tag;
-  for (i = 2; i < n; i++, args = scm_cdr (args))
-    tag_and_argv[i] = scm_car (args);
-
-  scm_i_vm_emergency_abort (tag_and_argv, n);
-  /* Unreachable.  */
-  abort ();
-}
-
-static SCM
-throw_without_pre_unwind (SCM tag, SCM args)
-{
-  size_t depth = 0;
-
-  /* This function is not only the boot implementation of "throw", it is
-     also called in response to resource allocation failures such as
-     stack-overflow or out-of-memory.  For that reason we need to be
-     careful to avoid allocating memory.  */
-  while (1)
-    {
-      SCM eh, catch_key, prompt_tag;
-
-      eh = scm_fluid_ref_star (exception_handler_fluid,
-                               scm_from_size_t (depth++));
-      if (scm_is_false (eh))
-        break;
-
-      catch_key = scm_c_vector_ref (eh, 0);
-      if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag))
-        continue;
+/* "Catch", "throw", and "with-throw-handler" are defined in Scheme, in
+   terms of "with-exception-handler", "with-pre-unwind-exception-handler",
+   and "raise".  */
 
-      if (scm_is_true (scm_c_vector_ref (eh, 2)))
-        {
-          const char *key_chars;
-
-          if (scm_i_is_narrow_symbol (tag))
-            key_chars = scm_i_symbol_chars (tag);
-          else
-            key_chars = "(wide symbol)";
-
-          fprintf (stderr, "Warning: Unwind-only `%s' exception; "
-                   "skipping pre-unwind handler.\n", key_chars);
-        }
-
-      prompt_tag = scm_c_vector_ref (eh, 1);
-      if (scm_is_true (prompt_tag))
-        abort_to_prompt (prompt_tag, tag, args);
-    }
+static SCM catch_var;
+static SCM with_throw_handler_var;
+static SCM throw_var;
 
-  default_exception_handler (tag, args);
-  return SCM_UNSPECIFIED;
-}
 
 SCM
 scm_catch (SCM key, SCM thunk, SCM handler)
 {
-  return catch (key, thunk, handler, SCM_UNDEFINED);
+  return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
 }
 
 SCM
 scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
                                    SCM pre_unwind_handler)
 {
-  return catch (key, thunk, handler, pre_unwind_handler);
+  if (SCM_UNBNDP (pre_unwind_handler))
+    return scm_catch (key, thunk, handler);
+
+  return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
+                     pre_unwind_handler);
 }
 
 SCM
 scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
 {
-  return catch (key, thunk, SCM_UNDEFINED, handler);
+  return scm_call_3 (scm_variable_ref (with_throw_handler_var),
+                     key, thunk, handler);
 }
 
 SCM
@@ -278,52 +100,20 @@ scm_throw (SCM key, SCM args)
 
 /* Now some support for C bodies and catch handlers */
 
-static scm_t_bits tc16_catch_closure;
-
-enum {
-  CATCH_CLOSURE_BODY,
-  CATCH_CLOSURE_HANDLER
-};
-
-SCM
-scm_i_make_catch_body_closure (scm_t_catch_body body, void *body_data)
-{
-  SCM ret;
-  SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
-  SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
-  return ret;
-}
+static scm_t_bits tc16_catch_handler;
 
 SCM
-scm_i_make_catch_handler_closure (scm_t_catch_handler handler,
-                                  void *handler_data)
+scm_i_make_catch_handler (scm_t_catch_handler handler, void *data)
 {
-  SCM ret;
-  SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
-  SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
-  return ret;
+  SCM_RETURN_NEWSMOB2 (ret, tc16_catch_handler, handler, data);
 }
 
 static SCM
-apply_catch_closure (SCM clo, SCM args)
+apply_catch_handler (SCM clo, SCM args)
 {
+  scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
   void *data = (void*)SCM_SMOB_DATA_2 (clo);
-
-  switch (SCM_SMOB_FLAGS (clo))
-    {
-    case CATCH_CLOSURE_BODY:
-      {
-        scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
-        return body (data);
-      }
-    case CATCH_CLOSURE_HANDLER:
-      {
-        scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
-        return handler (data, scm_car (args), scm_cdr (args));
-      }
-    default:
-      abort ();
-    }
+  return handler (data, scm_car (args), scm_cdr (args));
 }
 
 /* TAG is the catch tag.  Typically, this is a symbol, but this
@@ -367,18 +157,18 @@ apply_catch_closure (SCM clo, SCM args)
 
 SCM
 scm_c_catch (SCM tag,
-            scm_t_catch_body body, void *body_data,
+            scm_t_thunk body, void *body_data,
             scm_t_catch_handler handler, void *handler_data,
             scm_t_catch_handler pre_unwind_handler, void 
*pre_unwind_handler_data)
 {
   SCM sbody, shandler, spre_unwind_handler;
   
-  sbody = scm_i_make_catch_body_closure (body, body_data);
-  shandler = scm_i_make_catch_handler_closure (handler, handler_data);
+  sbody = scm_c_make_thunk (body, body_data);
+  shandler = scm_i_make_catch_handler (handler, handler_data);
   if (pre_unwind_handler)
     spre_unwind_handler =
-      scm_i_make_catch_handler_closure (pre_unwind_handler,
-                                        pre_unwind_handler_data);
+      scm_i_make_catch_handler (pre_unwind_handler,
+                                pre_unwind_handler_data);
   else
     spre_unwind_handler = SCM_UNDEFINED;
   
@@ -388,7 +178,7 @@ scm_c_catch (SCM tag,
 
 SCM
 scm_internal_catch (SCM tag,
-                   scm_t_catch_body body, void *body_data,
+                   scm_t_thunk body, void *body_data,
                    scm_t_catch_handler handler, void *handler_data)
 {
   return scm_c_catch (tag,
@@ -400,7 +190,7 @@ scm_internal_catch (SCM tag,
 
 SCM
 scm_c_with_throw_handler (SCM tag,
-                         scm_t_catch_body body,
+                         scm_t_thunk body,
                          void *body_data,
                          scm_t_catch_handler handler,
                          void *handler_data,
@@ -409,16 +199,11 @@ scm_c_with_throw_handler (SCM tag,
   SCM sbody, shandler;
 
   if (lazy_catch_p)
-    scm_c_issue_deprecation_warning
-      ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no 
longer.\n"
-       "supported. Instead the handler will be invoked from within the 
dynamic\n"
-       "context of the corresponding `throw'.\n"
-       "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
-       "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
-       "and adapt it (if necessary) to expect to be within the dynamic 
context\n"
-       "of the throw.");
-
-  sbody = scm_i_make_catch_body_closure (body, body_data);
+    /* Non-zero lazy_catch_p arguments have been deprecated since
+       2010.  */
+    abort ();
+
+  sbody = scm_c_make_thunk (body, body_data);
   shandler = scm_i_make_catch_handler_closure (handler, handler_data);
   
   return scm_with_throw_handler (tag, sbody, shandler);
@@ -490,28 +275,6 @@ scm_handle_by_proc_catching_all (void *handler_data, SCM 
tag, SCM throw_args)
                             scm_handle_by_message_noexit, NULL);
 }
 
-/* Derive the an exit status from the arguments to (quit ...).  */
-int
-scm_exit_status (SCM args)
-{
-  if (scm_is_pair (args))
-    {
-      SCM cqa = SCM_CAR (args);
-      
-      if (scm_is_integer (cqa))
-       return (scm_to_int (cqa));
-      else if (scm_is_false (cqa))
-       return EXIT_FAILURE;
-      else
-        return EXIT_SUCCESS;
-    }
-  else if (scm_is_null (args))
-    return EXIT_SUCCESS;
-  else
-    /* A type error.  Strictly speaking we shouldn't get here.  */
-    return EXIT_FAILURE;
-}
-       
 
 static int
 should_print_backtrace (SCM tag, SCM stack)
@@ -619,66 +382,15 @@ scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
   scm_throw (key, args);
 }
 
-SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
-SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
-
-static SCM stack_overflow_args = SCM_BOOL_F;
-static SCM out_of_memory_args = SCM_BOOL_F;
-
-/* Since these two functions may be called in response to resource
-   exhaustion, we have to avoid allocating memory.  */
-
-void
-scm_report_stack_overflow (void)
-{
-  if (scm_is_false (stack_overflow_args))
-    abort ();
-  throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args);
-
-  /* Not reached.  */
-  abort ();
-}
-
-void
-scm_report_out_of_memory (void)
-{
-  if (scm_is_false (out_of_memory_args))
-    abort ();
-  throw_without_pre_unwind (scm_out_of_memory_key, out_of_memory_args);
-
-  /* Not reached.  */
-  abort ();
-}
-
 void
 scm_init_throw ()
 {
-  tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
-  scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
-
-  exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
-  /* This binding is later removed when the Scheme definitions of catch,
-     throw, and with-throw-handler are created in boot-9.scm.  */
-  scm_c_define ("%exception-handler", exception_handler_fluid);
-
-  throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
-                                                       
throw_without_pre_unwind));
-
-  /* Arguments as if from:
-
-       scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
-
-     We build the arguments manually because we throw without running
-     pre-unwind handlers.  (Pre-unwind handlers could rewind the
-     stack.)  */
-  stack_overflow_args = scm_list_4 (SCM_BOOL_F,
-                                    scm_from_latin1_string ("Stack overflow"),
-                                    SCM_BOOL_F,
-                                    SCM_BOOL_F);
-  out_of_memory_args = scm_list_4 (SCM_BOOL_F,
-                                   scm_from_latin1_string ("Out of memory"),
-                                   SCM_BOOL_F,
-                                   SCM_BOOL_F);
+  tc16_catch_handler = scm_make_smob_type ("catch-handler", 0);
+  scm_set_smob_apply (tc16_catch_handler, apply_catch_handler, 0, 0, 1);
+
+  catch_var = scm_c_define ("catch", SCM_BOOL_F);
+  with_throw_handler_var = scm_c_define ("with-throw-handler", SCM_BOOL_F);
+  throw_var = scm_c_define ("throw", SCM_BOOL_F);
 
 #include "throw.x"
 }
diff --git a/libguile/throw.h b/libguile/throw.h
index ea206f9..4875db8 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -1,7 +1,7 @@
 #ifndef SCM_THROW_H
 #define SCM_THROW_H
 
-/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2018
+/* Copyright 1995-1996,1998,2000,2006,2008,2010,2014,2017-2019
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -23,17 +23,15 @@
 
 
 #include "libguile/scm.h"
+#include "libguile/exceptions.h"
 
 
 
-typedef SCM (*scm_t_catch_body) (void *data);
+typedef scm_t_thunk scm_t_catch_body;
 typedef SCM (*scm_t_catch_handler) (void *data,
                                     SCM tag, SCM throw_args);
 
-SCM_INTERNAL SCM scm_i_make_catch_body_closure (scm_t_catch_body body,
-                                                void *body_data);
-SCM_INTERNAL SCM scm_i_make_catch_handler_closure (scm_t_catch_handler h,
-                                                   void *handler_data);
+SCM_INTERNAL SCM scm_i_make_catch_handler (scm_t_catch_handler h, void *data);
 
 SCM_API SCM scm_c_catch (SCM tag,
                         scm_t_catch_body body,