diff options
Diffstat (limited to 'libguile/control.c')
-rw-r--r-- | libguile/control.c | 163 |
1 files changed, 163 insertions, 0 deletions
diff --git a/libguile/control.c b/libguile/control.c new file mode 100644 index 000000000..5e24bb706 --- /dev/null +++ b/libguile/control.c @@ -0,0 +1,163 @@ +/* Copyright 2010-2013,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <alloca.h> + +#include "dynstack.h" +#include "extensions.h" +#include "frames.h" +#include "gsubr.h" +#include "instructions.h" +#include "jit.h" +#include "list.h" +#include "pairs.h" +#include "programs.h" +#include "threads.h" +#include "version.h" +#include "vm.h" + +#include "control.h" + + + +#define PROMPT_ESCAPE_P(p) \ + (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p)) \ + & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY) + + + + +/* Only to be called if the setjmp returns 1 */ +SCM +scm_i_prompt_pop_abort_args_x (struct scm_vm *vp, + ptrdiff_t saved_stack_depth) +{ + size_t i, n; + ptrdiff_t stack_depth; + SCM vals = SCM_EOL; + + stack_depth = vp->stack_top - vp->sp; + if (stack_depth < saved_stack_depth) + abort (); + n = stack_depth - saved_stack_depth; + + for (i = 0; i < n; i++) + vals = scm_cons (vp->sp[i].as_scm, vals); + + vp->sp += n; + + return vals; +} + + +struct compose_continuation_code +{ + struct scm_jit_function_data data; + uint32_t code[3]; +}; + +struct compose_continuation_code compose_continuation_code = { + { + /* mcode = */ 0, + /* counter = */ 0, + /* start = */ sizeof (struct scm_jit_function_data), + /* end = */ sizeof (struct scm_jit_function_data) + 12 + }, + { + SCM_PACK_OP_24 (instrument_entry, 0), + ((uint32_t) -(sizeof (struct scm_jit_function_data) / 4)), + SCM_PACK_OP_24 (compose_continuation, 0), + } +}; + +SCM +scm_i_make_composable_continuation (SCM vmcont) +{ + scm_t_bits nfree = 1; + scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION; + SCM ret; + + ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); + SCM_SET_CELL_WORD_1 (ret, compose_continuation_code.code); + SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont); + + return ret; +} + +SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0, + (SCM tag, SCM args), + "Abort to the nearest prompt with tag @var{tag}, yielding the\n" + "values in the list, @var{args}.") +#define FUNC_NAME s_scm_abort_to_prompt_star +{ + SCM *tag_and_argv; + size_t i; + long n; + + SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n); + n = n + 1; /* Add space for the tag. */ + tag_and_argv = alloca (sizeof (SCM)*(n+1)); + tag_and_argv[0] = tag; + for (i = 1; i < n; i++, args = scm_cdr (args)) + tag_and_argv[i] = scm_car (args); + + scm_i_vm_abort (tag_and_argv, n); + + /* Oh, what, you're still here? The abort must have been reinstated. Actually, + that's quite impossible, given that we're already in C-land here, so... + abort! */ + + abort (); +} +#undef FUNC_NAME + +static SCM +scm_suspendable_continuation_p (SCM tag) +{ + scm_t_dynstack_prompt_flags flags; + scm_thread *thread = SCM_I_CURRENT_THREAD; + jmp_buf *registers; + + if (scm_dynstack_find_prompt (&thread->dynstack, tag, &flags, + NULL, NULL, NULL, NULL, ®isters)) + return scm_from_bool (registers == thread->vm.registers); + + return SCM_BOOL_F; +} + +static void +scm_init_ice_9_control (void *unused) +{ + scm_c_define_gsubr ("suspendable-continuation?", 1, 0, 0, + scm_suspendable_continuation_p); +} + +void +scm_init_control (void) +{ +#include "control.x" + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_control", scm_init_ice_9_control, + NULL); +} |