/* 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
. */
#if HAVE_CONFIG_H
# include
#endif
#include
#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);
}