From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Taahir Ahmed Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 3/3] Implement Guile exceptions with C++ exceptions. Date: Tue, 14 Jul 2015 22:40:33 -0500 Message-ID: <2680798.z87ittDu1C@basis> References: <1436897249-18167-1-git-send-email-ahmed.taahir@gmail.com> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset="us-ascii" Content-Transfer-Encoding: 7Bit X-Trace: ger.gmane.org 1437174676 11966 80.91.229.3 (17 Jul 2015 23:11:16 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Fri, 17 Jul 2015 23:11:16 +0000 (UTC) Cc: Taahir Ahmed To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sat Jul 18 01:11:06 2015 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1ZGEmX-0006OZ-1V for guile-devel@m.gmane.org; Sat, 18 Jul 2015 01:11:05 +0200 Original-Received: from localhost ([::1]:46392 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZGEmW-00043e-3K for guile-devel@m.gmane.org; Fri, 17 Jul 2015 19:11:04 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:44799) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZGEmR-00043X-0q for guile-devel@gnu.org; Fri, 17 Jul 2015 19:11:00 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZGEmM-0004hv-GH for guile-devel@gnu.org; Fri, 17 Jul 2015 19:10:58 -0400 Original-Received: from freefriends.org ([96.88.95.60]:34492) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZGEmM-0004g7-6B for guile-devel@gnu.org; Fri, 17 Jul 2015 19:10:54 -0400 X-Envelope-From: karl@freefriends.org Original-Received: from freefriends.org (localhost [127.0.0.1]) by freefriends.org (8.14.9/8.14.9) with ESMTP id t6HNAnL1011970; Fri, 17 Jul 2015 17:10:49 -0600 Original-Received: (from nobody@localhost) by freefriends.org (8.14.9/8.14.9/submit) id t6HNAm9e011969; Fri, 17 Jul 2015 23:10:48 GMT X-Authentication-Warning: frenzy.freefriends.org: nobody set sender to karl@freefriends.org using -f User-Agent: KMail/4.14.8 (Linux/3.18.7-gentoo; KDE/4.14.8; x86_64; ; ) In-Reply-To: <1436897249-18167-1-git-send-email-ahmed.taahir@gmail.com> X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 96.88.95.60 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17769 Archived-At: eh-jmp.{h,cc} contain setjmp/longjmp analogues that use C++ exceptions to unwind the stack. This means that C++ destructors will be called properly in when a guile exception passes through a user code frame. Flow control to resume a continuation remains implemented with setjmp/longjmp, since it appears that in some places the jump travels down the stack. --- libguile/Makefile.am | 1 + libguile/control.c | 6 ++- libguile/eh-jmp.cc | 39 ++++++++++++++ libguile/eh-jmp.h | 23 ++++++++ libguile/eval.c | 35 +++++++++--- libguile/threads.h | 5 -- libguile/throw.c | 34 +++++++++--- libguile/vm-engine.c | 5 +- libguile/vm.c | 57 ++++++++++++++++---- test-suite/standalone/Makefile.am | 7 +++ test-suite/standalone/test-cpp-destructors.cc | 77 +++++++++++++++++++++++++++ 11 files changed, 259 insertions(+), 30 deletions(-) create mode 100644 libguile/eh-jmp.cc create mode 100644 libguile/eh-jmp.h create mode 100644 test-suite/standalone/test-cpp-destructors.cc diff --git a/libguile/Makefile.am b/libguile/Makefile.am index cc88215..f5e746f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -140,6 +140,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ deprecation.c \ dynstack.c \ dynwind.c \ + eh-jmp.cc \ eq.c \ error.c \ eval.c \ diff --git a/libguile/control.c b/libguile/control.c index 347d697..53e3241 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -24,6 +24,7 @@ #include "libguile/_scm.h" #include "libguile/control.h" +#include "libguile/eh-jmp.h" #include "libguile/programs.h" #include "libguile/instructions.h" #include "libguile/vm.h" @@ -37,7 +38,8 @@ -/* Only to be called if the SCM_I_SETJMP returns 1 */ +/* Only to be called if we are returning to a prompt via nonlocal + jump. */ SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp) { @@ -177,7 +179,7 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, *(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */ /* Jump! */ - SCM_I_LONGJMP (*registers, 1); + eh_throw (tag); /* Shouldn't get here */ abort (); diff --git a/libguile/eh-jmp.cc b/libguile/eh-jmp.cc new file mode 100644 index 0000000..f5b7b80 --- /dev/null +++ b/libguile/eh-jmp.cc @@ -0,0 +1,39 @@ +#include "libguile/eh-jmp.h" + +struct prompt_exception +{ + SCM tag; +}; + +int eh_catch (SCM *taglist, tryfn_scm fn, SCM *result, ...) +{ + va_list ap; + va_start (ap, result); + + try + { + *result = fn (ap); + va_end (ap); + return 0; + } + catch (prompt_exception e) + { + va_end(ap); + + for (SCM rest = *taglist; rest != SCM_EOL; rest = scm_cdr (rest)) + { + SCM cur_key = scm_car (rest); + + if (scm_is_eq (cur_key, e.tag)) + return 1; + } + + throw e; + } +} + +void eh_throw(SCM tag) +{ + prompt_exception e = {tag}; + throw e; +} diff --git a/libguile/eh-jmp.h b/libguile/eh-jmp.h new file mode 100644 index 0000000..6730895 --- /dev/null +++ b/libguile/eh-jmp.h @@ -0,0 +1,23 @@ +#ifndef LIBGUILE_EH_JMP_H +#define LIBGUILE_EH_JMP_H + +#include + +#include "libguile/__scm.h" +#include "libguile/_scm.h" +#include "libguile/pairs.h" + +#ifdef __cplusplus +extern "C" { +#endif + +typedef SCM (* tryfn_scm) (va_list); + +int eh_catch (SCM *taglist, tryfn_scm fn, SCM *result, ...); +void eh_throw (SCM taglist) SCM_NORETURN; + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libguile/eval.c b/libguile/eval.c index 735e6c0..c83b7e7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -37,6 +37,7 @@ #include "libguile/debug.h" #include "libguile/deprecation.h" #include "libguile/dynwind.h" +#include "libguile/eh-jmp.h" #include "libguile/eq.h" #include "libguile/expand.h" #include "libguile/feature.h" @@ -238,6 +239,8 @@ truncate_values (SCM x) } #define EVAL1(x, env) (truncate_values (eval ((x), (env)))) +static SCM try_call_with_prompt(va_list ap); + static SCM eval (SCM x, SCM env) { @@ -424,13 +427,14 @@ eval (SCM x, SCM env) case SCM_M_CALL_WITH_PROMPT: { struct scm_vm *vp; - SCM k, res; + SCM tag, res; + SCM taglist; scm_i_jmp_buf registers; /* We need the handler after nonlocal return to the setjmp, so make sure it is volatile. */ volatile SCM handler; - k = EVAL1 (CAR (mx), env); + tag = EVAL1 (CAR (mx), env); handler = EVAL1 (CDDR (mx), env); vp = scm_the_vm (); @@ -438,13 +442,15 @@ eval (SCM x, SCM env) scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack, SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS, - k, + tag, vp->fp - vp->stack_base, vp->sp - vp->stack_base, vp->ip, ®isters); - if (SCM_I_SETJMP (registers)) + taglist = scm_cons (tag, SCM_EOL); + if (eh_catch (&taglist, try_call_with_prompt, &res, mx, env, + &SCM_I_CURRENT_THREAD->dynstack)) { /* The prompt exited nonlocally. */ scm_gc_after_nonlocal_exit (); @@ -453,9 +459,7 @@ eval (SCM x, SCM env) args = scm_i_prompt_pop_abort_args_x (vp); goto apply_proc; } - - res = scm_call_0 (eval (CADR (mx), env)); - scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack); + return res; } @@ -464,6 +468,23 @@ eval (SCM x, SCM env) } } +static SCM +try_call_with_prompt(va_list ap) +{ + SCM res; + SCM mx; + SCM env; + scm_t_dynstack *dynstack; + + mx = va_arg (ap, SCM); + env = va_arg (ap, SCM); + dynstack = va_arg (ap, scm_t_dynstack*); + + res = scm_call_0 (eval (CADR (mx), env)); + scm_dynstack_pop (dynstack); + return res; +} + /* Simple procedure calls diff --git a/libguile/threads.h b/libguile/threads.h index cb61bbc..1c1f0e3 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -115,11 +115,6 @@ typedef struct scm_i_thread { /* For keeping track of the stack and registers. */ struct scm_vm *vp; SCM_STACKITEM *base; - scm_i_jmp_buf regs; -#ifdef __ia64__ - void *register_backing_store_base; - scm_t_contregs *pending_rbs_continuation; -#endif /* Whether this thread is in a critical section. */ int critical_section_level; diff --git a/libguile/throw.c b/libguile/throw.c index bbde5e0..f784df7 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -23,10 +23,12 @@ #endif #include +#include #include #include #include "libguile/_scm.h" #include "libguile/smob.h" +#include "libguile/eh-jmp.h" #include "libguile/eval.h" #include "libguile/eq.h" #include "libguile/control.h" @@ -69,11 +71,34 @@ static SCM throw_var; static SCM exception_handler_fluid; +/* A helper function for eh_tryfn_prompt. Indirectly invoked below in + catch. */ +static SCM +call_helper (va_list ap) +{ + SCM res; + SCM thunk; + scm_t_dynstack *dynstack; + SCM dynamic_state; + + thunk = va_arg (ap, SCM); + dynstack = va_arg (ap, scm_t_dynstack*); + dynamic_state = va_arg (ap, SCM); + + res = scm_call_0 (thunk); + + scm_dynstack_unwind_fluid (dynstack, dynamic_state); + scm_dynstack_pop (dynstack); + + return res; +} + static SCM catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) { struct scm_vm *vp; SCM eh, prompt_tag; + SCM taglist; SCM res; scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; @@ -116,7 +141,9 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh, dynamic_state); - if (SCM_I_SETJMP (registers)) + taglist = scm_cons (prompt_tag, SCM_EOL); + if (eh_catch (&taglist, call_helper, &res, thunk, dynstack, + dynamic_state)) { /* A non-local return. */ SCM args; @@ -133,11 +160,6 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) return scm_apply_0 (handler, args); } - res = scm_call_0 (thunk); - - scm_dynstack_unwind_fluid (dynstack, dynamic_state); - scm_dynstack_pop (dynstack); - return res; } diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 7e752dd..628b951 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -419,7 +419,7 @@ ((scm_t_uintptr) (ptr) % alignof_type (type) == 0) static SCM -VM_NAME (scm_i_thread *thread, struct scm_vm *vp, +VM_NAME (SCM *catch_taglist, scm_i_thread *thread, struct scm_vm *vp, scm_i_jmp_buf *registers, int resume) { /* Instruction pointer: A pointer to the opcode that is currently @@ -2069,6 +2069,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, LOCAL_ADDRESS (proc_slot) - vp->stack_base, ip + offset, registers); + + *catch_taglist = scm_cons (LOCAL_REF (tag), *catch_taglist); + NEXT (3); } diff --git a/libguile/vm.c b/libguile/vm.c index 0e59835..7ac6523 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -39,6 +39,7 @@ #include "_scm.h" #include "control.h" +#include "eh-jmp.h" #include "frames.h" #include "gc-inline.h" #include "instructions.h" @@ -783,7 +784,7 @@ scm_i_call_with_current_continuation (SCM proc) #undef VM_USE_HOOKS #undef VM_NAME -typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp, +typedef SCM (*scm_t_vm_engine) (SCM *taglist, scm_i_thread *current_thread, struct scm_vm *vp, scm_i_jmp_buf *registers, int resume); static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = @@ -1204,6 +1205,26 @@ scm_the_vm (void) return thread_vm (SCM_I_CURRENT_THREAD); } +static SCM +try_call_engine (va_list ap) +{ + scm_t_vm_engine engine; + SCM *taglist; + scm_i_thread *thread; + struct scm_vm *vp; + scm_i_jmp_buf *registers; + int resume; + + engine = va_arg (ap, scm_t_vm_engine); + taglist = va_arg (ap, SCM*); + thread = va_arg (ap, scm_i_thread*); + vp = va_arg (ap, struct scm_vm*); + registers = va_arg (ap, scm_i_jmp_buf*); + resume = va_arg (ap, int); + + return engine (taglist, thread, vp, registers, resume); +} + SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { @@ -1246,16 +1267,34 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) vp->fp = &base[5]; { - int resume = SCM_I_SETJMP (registers); - - if (SCM_UNLIKELY (resume)) + int resume = 0; + SCM res; + scm_t_vm_engine engine; + SCM taglist; + + engine = vm_engines[vp->engine]; + + taglist = SCM_EOL; + + while (1) { - scm_gc_after_nonlocal_exit (); - /* Non-local return. */ - vm_dispatch_abort_hook (vp); + resume = eh_catch(/* Arguments used by eh_catch. */ + &taglist, try_call_engine, &res, + /* Arguments consumed by try_call_engine. */ + engine, + /* Arguments sent to the engine. */ + &taglist, thread, vp, ®isters, resume); + if (resume) + { + scm_gc_after_nonlocal_exit (); + /* Non-local return. */ + vm_dispatch_abort_hook (vp); + } + else + { + return res; + } } - - return vm_engines[vp->engine](thread, vp, ®isters, resume); } } diff --git a/test-suite/standalone/Makefile.am b/test- suite/standalone/Makefile.am index 5138b15..01270f9 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -96,6 +96,13 @@ EXTRA_DIST += test-language.el test-language.js check_SCRIPTS += test-guild-compile TESTS += test-guild-compile +# test-cpp-destructors +test_cpp_destructors_SOURCES = test-cpp-destructors.cc +test_cpp_destructors_CFLAGS = ${test_cflags} +test_cpp_destructors_LDADD = ${LIBGUILE_LDADD} +check_PROGRAMS += test-cpp-destructors +TESTS += test-cpp-destructors + # test-num2integral test_num2integral_SOURCES = test-num2integral.c test_num2integral_CFLAGS = ${test_cflags} diff --git a/test-suite/standalone/test-cpp-destructors.cc b/test- suite/standalone/test-cpp-destructors.cc new file mode 100644 index 0000000..99fbf32 --- /dev/null +++ b/test-suite/standalone/test-cpp-destructors.cc @@ -0,0 +1,77 @@ +// test-cpp-destructors.c + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include + +#include + +// Canary value to track constructor/destructor execution. +// +// 0: constructor has not yet run +// +// 1: constructor has run +// +// 2: destructor has run +static int canary = 0; + +struct miner +{ + miner() + { + canary = 1; + } + + ~miner() + { + canary = 2; + } +}; + +static SCM test_miner(void *data) +{ + miner bob; + + SCM should_be_int = static_cast(data); + int dummy = scm_to_int(should_be_int); + + return SCM_BOOL_T; +} + +static SCM test_miner_handler(void *data, SCM key, SCM args) +{ + // Do nothing. + + return SCM_BOOL_T; +} + +static void tests(void *data, int argc, char **argv) +{ + SCM test_data = scm_from_utf8_string("Ceci n'est pas un int."); + scm_internal_catch( + SCM_BOOL_T, + test_miner, + static_cast(&test_data), + test_miner_handler, + NULL + ); + + // Check if destructor ran. + if(canary != 2) + { + std::cerr << "Destructor was not run by guile exception." << std::endl; + std::exit(1); + } + + std::exit(0); +} + +int main(int argc, char **argv) +{ + scm_boot_guile(argc, argv, tests, NULL); + return 0; +} -- 2.3.6