[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-31-gcee
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-31-gcee1d22 |
|
Date: |
Mon, 22 Feb 2010 22:03:07 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cee1d22c3c10b1892c82a5758ef69cd6fc9aba31
The branch, master has been updated
via cee1d22c3c10b1892c82a5758ef69cd6fc9aba31 (commit)
via 76e3816281cf6c406ef6f01907ce29401c8ff455 (commit)
via 2d026f04cc581915f62b1f2f3be2f27026ee383e (commit)
via f828ab4f30b974c0f839fb6df9590c16907b7a0a (commit)
via 47ae4ac8f478b09bc33ab05d896826bc8f6dd2f1 (commit)
from 747022e4cb5faef6e0a2c73f046bacd93bb99ab8 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cee1d22c3c10b1892c82a5758ef69cd6fc9aba31
Author: Andy Wingo <address@hidden>
Date: Mon Feb 22 23:00:19 2010 +0100
actually capture partial continuations
* libguile/control.c (cont_objcode): Along with a bunch of boilerplate
that certainly needs to go in some central place, define this
continuation-calling trampoline.
(reify_partial_continuation): New function, returns a procedure that
when called will reinstate a partial continuation.
(scm_c_abort): Take an extra arg, the cookie. Actually reify a
continuation.
(scm_at_abort): Adapt to scm_c_abort change.
* libguile/control.h: Declare scm_c_abort change.
* libguile/vm-i-system.c (partial_cont_call): New instruction.
(call/cc, tail-call/cc): Adapt to scm_i_vm_capture_stack change.
(abort): Pass vm_cookie to abort.
* libguile/vm.h (SCM_F_VM_CONT_PARTIAL, SCM_F_VM_CONT_REWINDABLE): New
flags.
(struct scm_vm_cont): Add flags field.
(SCM_VM_CONT_PARTIAL_P, SCM_VM_CONT_REWINDABLE_P): New predicates.
* libguile/vm.c (scm_i_vm_capture_stack): Rename from
vm_capture_continuation, and make internal instead of static. Take a
flags argument.
(scm_i_vm_capture_continuation): Adapt to scm_i_vm_capture_stack
change.
(vm_abort): Plumb cookie to scm_c_abort.
(vm_reinstate_partial_continuation): New stub.
commit 76e3816281cf6c406ef6f01907ce29401c8ff455
Author: Andy Wingo <address@hidden>
Date: Mon Feb 22 22:41:34 2010 +0100
tweaks to default program printer
* libguile/programs.c (scm_i_program_print): Instead of printing the
address of the objcode, print the address of the program itself. Also
for continuations.
commit 2d026f04cc581915f62b1f2f3be2f27026ee383e
Author: Andy Wingo <address@hidden>
Date: Mon Feb 22 21:53:24 2010 +0100
abort always dispatches to VM bytecode, to detect same-invocation aborts
* libguile/control.h:
* libguile/control.c (scm_c_make_prompt): Take an extra arg, a cookie.
Continuations will be rewindable only if the abort has the same cookie
as the prompt.
(scm_at_abort): Redefine from scm_abort, and instead of taking rest
args, take the abort values as a list directly. Also, don't allow
rewinding, because we won't support rewinding the C stack with
delimited continuations.
* libguile/eval.c (eval): Adapt to scm_c_make_prompt change.
* libguile/vm-engine.c (vm_engine): Use vp->cookie to get a unique value
corresponding to this VM invocation.
* libguile/vm-i-system.c (prompt): Pass the cookie to scm_c_make_prompt.
(abort): Take an additional tail arg.
* libguile/vm.c (vm_abort): Parse out the abort tail arg. This is for
the @abort case, or the (apply abort ...) case.
(make_vm): Initialize the cookie to 0.
* libguile/vm.h (struct scm_vm): Add cookie.
* module/ice-9/boot-9.scm (abort): Define here as a trampoline to
@abort. Needed to make sure that a call to abort dispatches to a VM
opcode, so the cookie will be the same.
* module/language/tree-il.scm (<tree-il>): Add a "tail" field to
<abort>, for the (apply abort ...) case, or (@abort tag args). Should
be #<const ()> in the normal case. Add support throughout.
* module/language/tree-il/analyze.scm (analyze-lexicals): Add abort-tail
support here too.
* module/language/tree-il/compile-glil.scm (flatten): Compile the tail
argument appropriately.
* module/language/tree-il/primitives.scm (*primitive-expand-table*): Fix
@abort and abort cases to pass the tail arg to make-abort.
commit f828ab4f30b974c0f839fb6df9590c16907b7a0a
Author: Andy Wingo <address@hidden>
Date: Mon Feb 22 20:29:10 2010 +0100
prompt and abort inlining
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Add abort.
(*primitive-expand-table*): Fix so that we inline `prompt' and
`abort', and remove obsolete code dealing in `control'.
commit 47ae4ac8f478b09bc33ab05d896826bc8f6dd2f1
Author: Andy Wingo <address@hidden>
Date: Mon Feb 22 20:19:32 2010 +0100
fix <prompt> compilation bug
* module/language/tree-il/analyze.scm (analyze-lexicals): Fix bug
analysing <prompt> expressions.
-----------------------------------------------------------------------
Summary of changes:
libguile/control.c | 149 +++++++++++++++++++++++++-----
libguile/control.h | 8 +-
libguile/eval.c | 2 +-
libguile/programs.c | 4 +-
libguile/vm-engine.c | 2 +
libguile/vm-i-system.c | 30 ++++--
libguile/vm.c | 37 ++++++--
libguile/vm.h | 10 ++
module/ice-9/boot-9.scm | 2 +
module/language/tree-il.scm | 39 +++++----
module/language/tree-il/analyze.scm | 10 +-
module/language/tree-il/compile-glil.scm | 3 +-
module/language/tree-il/primitives.scm | 34 ++++++-
13 files changed, 253 insertions(+), 77 deletions(-)
diff --git a/libguile/control.c b/libguile/control.c
index a243be0..25c9504 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -22,12 +22,15 @@
#include "libguile/_scm.h"
#include "libguile/control.h"
+#include "libguile/objcodes.h"
+#include "libguile/instructions.h"
#include "libguile/vm.h"
SCM
-scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p)
+scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
+ scm_t_int64 vm_cookie)
{
scm_t_bits tag;
SCM ret;
@@ -42,6 +45,7 @@ scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p)
regs->fp = SCM_VM_DATA (vm)->fp;
regs->sp = SCM_VM_DATA (vm)->sp;
regs->ip = SCM_VM_DATA (vm)->ip;
+ regs->cookie = vm_cookie;
SCM_SET_CELL_OBJECT (ret, 1, k);
SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
@@ -50,10 +54,115 @@ scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8
escape_only_p)
return ret;
}
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
+#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
+#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+#define ROUND_UP(len,align) (((len-1)|(align-1))+1)
+#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
+
+#ifdef SCM_ALIGNED
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static const type sym[]
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
+static SCM_ALIGNED (alignment) const type sym[]
+#else
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static type *sym
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
+SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
+ sym = ALIGN_PTR (type, sym, alignment); \
+ memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
+static type *sym = NULL; \
+static const type sym##__unaligned[]
+#endif
+
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+#define SCM_STATIC_OBJCODE(sym) \
+ SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
+ SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
+ { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
+ { SCM_BOOL_F, SCM_PACK (0) } \
+ }; \
+ static const SCM sym = SCM_PACK (sym##__cells); \
+ SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
+
+
+SCM_STATIC_OBJCODE (cont_objcode) = {
+ /* Like in continuations.c, but with partial-cont-call. */
+ OBJCODE_HEADER (8, 19),
+ /* leave args on the stack */
+ /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
+ /* 2 */ scm_op_object_ref, 1, /* push internal winds */
+ /* 4 */ scm_op_object_ref, 2, /* push external winds */
+ /* 6 */ scm_op_partial_cont_call, /* and go! */
+ /* 7 */ scm_op_nop, /* pad to 8 bytes */
+ /* 8 */
+
+ /* We could put some meta-info to say that this proc is a continuation. Not
sure
+ how to do that, though. */
+ META_HEADER (19),
+ /* 0 */ scm_op_make_eol, /* bindings */
+ /* 1 */ scm_op_make_eol, /* sources */
+ /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 7, /* arity: from ip 0 to ip
7 */
+ /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
+ /* 7 */ scm_op_make_int8_0, /* 0 optionals */
+ /* 8 */ scm_op_make_true, /* and a rest arg */
+ /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
+ /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
+ /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
+ /* 18 */ scm_op_return /* and return */
+ /* 19 */
+};
+
+
+static SCM
+reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
+ scm_t_int64 cookie)
+{
+ SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
+ scm_t_uint32 flags;
+
+ /* No need to reify if the continuation is never referenced in the handler.
*/
+ if (SCM_PROMPT_ESCAPE_P (prompt))
+ return SCM_BOOL_F;
+
+ dynwinds = scm_i_dynwinds ();
+ while (!scm_is_eq (dynwinds, extwinds))
+ {
+ intwinds = scm_cons (scm_car (dynwinds), intwinds);
+ dynwinds = scm_cdr (dynwinds);
+ }
+
+ flags = SCM_F_VM_CONT_PARTIAL;
+ if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
+ flags |= SCM_F_VM_CONT_REWINDABLE;
+
+ /* NULL RA and MVRA, as those get set when the cont is reinstated */
+ vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp,
+ SCM_VM_DATA (vm)->fp,
+ SCM_VM_DATA (vm)->sp,
+ NULL, NULL,
+ flags);
+
+ ret = scm_make_program (cont_objcode,
+ scm_vector (scm_list_3 (vm_cont, intwinds,
extwinds)),
+ SCM_BOOL_F);
+ SCM_SET_CELL_WORD_0 (ret,
+ SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
+ return ret;
+}
+
SCM
-scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
+scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
{
- SCM winds, prompt = SCM_BOOL_F;
+ SCM cont, winds, prompt = SCM_BOOL_F;
long delta;
size_t i;
@@ -81,6 +190,8 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
abort ();
}
+ cont = reify_partial_continuation (vm, prompt, winds, cookie);
+
/* Unwind once more, beyond the prompt. */
winds = SCM_CDR (winds), delta++;
@@ -97,7 +208,7 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
abort ();
/* Push vals */
- *(++(SCM_VM_DATA (vm)->sp)) = SCM_BOOL_F; /* the continuation */
+ *(++(SCM_VM_DATA (vm)->sp)) = cont;
for (i = 0; i < n; i++)
*(++(SCM_VM_DATA (vm)->sp)) = argv[i];
*(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation
*/
@@ -109,9 +220,9 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
abort ();
}
-SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM args),
+SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
"Abort to the nearest prompt with tag @var{tag}.")
-#define FUNC_NAME s_scm_abort
+#define FUNC_NAME s_scm_at_abort
{
SCM *argv;
size_t i, n;
@@ -121,25 +232,13 @@ SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM
args),
for (i = 0; i < n; i++, args = scm_cdr (args))
argv[i] = scm_car (args);
- scm_c_abort (scm_the_vm (), tag, n, argv);
-
- /* Oh, what, you're still here? The abort must have been reinstated. OK, pull
- args back from the stack, and keep going... */
-
- {
- SCM vals = SCM_EOL;
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- n = scm_to_size_t (vp->sp[0]);
- for (i = 0; i < n; i++)
- vals = scm_cons (vp->sp[-(i + 1)], vals);
- /* The continuation call did reset the VM's registers, but then these
values
- were pushed on; so we need to pop them ourselves. */
- vp->sp -= n + 1;
- /* FIXME NULLSTACK */
-
- return (scm_is_pair (vals) && scm_is_null (scm_cdr (vals)))
- ? scm_car (vals) : scm_values (vals);
- }
+ scm_c_abort (scm_the_vm (), tag, n, argv, -1);
+
+ /* 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
diff --git a/libguile/control.h b/libguile/control.h
index 3ec9657..160728d 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -37,12 +37,16 @@ struct scm_prompt_registers
scm_t_uint8 *ip;
SCM *sp;
SCM *fp;
+ scm_t_int64 cookie;
scm_i_jmp_buf regs;
};
-SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p);
-SCM_INTERNAL SCM scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
SCM_NORETURN;
+SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
+ scm_t_int64 cookie);
+SCM_INTERNAL SCM scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
+ scm_t_int64 cookie) SCM_NORETURN;
+SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;
SCM_INTERNAL void scm_init_control (void);
diff --git a/libguile/eval.c b/libguile/eval.c
index 1b466de..c82e543 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -429,7 +429,7 @@ eval (SCM x, SCM env)
{
SCM prompt, handler, res;
- prompt = scm_c_make_prompt (scm_the_vm (), eval (CAR (mx), env), 0);
+ prompt = scm_c_make_prompt (scm_the_vm (), eval (CAR (mx), env), 0,
-1);
handler = eval (CDDR (mx), env);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
diff --git a/libguile/programs.c b/libguile/programs.c
index ac35e3c..8ce9fe1 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -83,13 +83,13 @@ scm_i_program_print (SCM program, SCM port, scm_print_state
*pstate)
{
/* twingliness */
scm_puts ("#<continuation ", port);
- scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port);
}
else if (scm_is_false (write_program) || print_error)
{
scm_puts ("#<program ", port);
- scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port);
}
else
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 5d1e1d6..8c188d3 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -47,7 +47,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
+
SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
+ scm_t_int64 vm_cookie = vp->cookie++;
/* Internal variables */
int nvalues = 0;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 7a17001..09293be 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -993,6 +993,17 @@ VM_DEFINE_INSTRUCTION (89, continuation_call,
"continuation-call", 0, -1, 0)
abort ();
}
+VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
+{
+ SCM vmcont, intwinds, extwinds;
+ POP (extwinds);
+ POP (intwinds);
+ POP (vmcont);
+
+ vm_reinstate_partial_continuation (vm, vmcont, intwinds, extwinds);
+ NEXT;
+}
+
VM_DEFINE_INSTRUCTION (59, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
{
SCM x;
@@ -1099,7 +1110,7 @@ VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
SCM proc, vm_cont, cont;
POP (proc);
SYNC_ALL ();
- vm_cont = vm_capture_continuation (vp->stack_base, fp, sp, ip, NULL);
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
@@ -1131,11 +1142,12 @@ VM_DEFINE_INSTRUCTION (65, tail_call_cc,
"tail-call/cc", 0, 1, 1)
SYNC_ALL ();
/* In contrast to call/cc, tail-call/cc captures the continuation without the
stack frame. */
- vm_cont = vm_capture_continuation (vp->stack_base,
- SCM_FRAME_DYNAMIC_LINK (fp),
- SCM_FRAME_LOWER_ADDRESS (fp) - 1,
- SCM_FRAME_RETURN_ADDRESS (fp),
- SCM_FRAME_MV_RETURN_ADDRESS (fp));
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base,
+ SCM_FRAME_DYNAMIC_LINK (fp),
+ SCM_FRAME_LOWER_ADDRESS (fp) - 1,
+ SCM_FRAME_RETURN_ADDRESS (fp),
+ SCM_FRAME_MV_RETURN_ADDRESS (fp),
+ 0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
@@ -1464,7 +1476,7 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
/* Push the prompt onto the dynamic stack. The setjmp itself has to be local
to this procedure. */
/* FIXME: do more error checking */
- prompt = scm_c_make_prompt (vm, k, escape_only_p);
+ prompt = scm_c_make_prompt (vm, k, escape_only_p, vm_cookie);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
{
@@ -1509,9 +1521,9 @@ VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1)
{
unsigned n = FETCH ();
SYNC_REGISTER ();
- if (sp - n - 1 <= SCM_FRAME_UPPER_ADDRESS (fp))
+ if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
goto vm_error_stack_underflow;
- vm_abort (vm, n);
+ vm_abort (vm, n, vm_cookie);
/* vm_abort should not return */
abort ();
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 7433a11..572a710 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -91,9 +91,9 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
continuation root is inside VM code, and call/cc was invoked within that
same
call to vm_run; but that's currently not implemented.
*/
-static SCM
-vm_capture_continuation (SCM *stack_base,
- SCM *fp, SCM *sp, scm_t_uint8 *ra, scm_t_uint8 *mvra)
+SCM
+scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
+ scm_t_uint8 *mvra, scm_t_uint32 flags)
{
struct scm_vm_cont *p;
@@ -116,6 +116,7 @@ vm_capture_continuation (SCM *stack_base,
p->fp = fp;
memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
p->reloc = p->stack_base - stack_base;
+ p->flags = flags;
return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
@@ -178,7 +179,7 @@ SCM
scm_i_vm_capture_continuation (SCM vm)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
- return vm_capture_continuation (vp->stack_base, vp->fp, vp->sp, vp->ip,
NULL);
+ return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL,
0);
}
static void
@@ -201,20 +202,37 @@ vm_dispatch_hook (SCM vm, int hook_num)
vp->trace_level++;
}
-static void vm_abort (SCM vm, size_t n) SCM_NORETURN;
+static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
static void
-vm_abort (SCM vm, size_t n)
+vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
{
size_t i;
- SCM tag, *argv;
+ ssize_t tail_len;
+ SCM tag, tail, *argv;
+ /* FIXME: VM_ENABLE_STACK_NULLING */
+ tail = *(SCM_VM_DATA (vm)->sp--);
+ /* NULLSTACK (1) */
+ tail_len = scm_ilength (tail);
+ if (tail_len < 0)
+ abort ();
tag = SCM_VM_DATA (vm)->sp[-n];
- argv = alloca (n * sizeof (SCM));
+ argv = alloca ((n + tail_len) * sizeof (SCM));
for (i = 0; i < n; i++)
argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
+ for (; i < n + tail_len; i++, tail = scm_cdr (tail))
+ argv[i] = scm_car (tail);
+ /* NULLSTACK (n + 1) */
SCM_VM_DATA (vm)->sp -= n + 1;
- scm_c_abort (vm, tag, n, argv);
+ scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
+}
+
+static void
+vm_reinstate_partial_continuation (SCM vm, SCM vm_cont, SCM intwinds,
+ SCM extwinds)
+{
+ abort ();
}
@@ -386,6 +404,7 @@ make_vm (void)
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
+ vp->cookie = 0;
return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME
diff --git a/libguile/vm.h b/libguile/vm.h
index 17445ea..48e0bb6 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -51,6 +51,7 @@ struct scm_vm {
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
SCM options; /* options */
int trace_level; /* traces enabled if trace_level > 0 */
+ scm_t_int64 cookie; /* used to detect unrewindable continuations */
};
SCM_API SCM scm_the_vm_fluid;
@@ -86,6 +87,9 @@ SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
SCM_API SCM scm_vm_trace_level (SCM vm);
SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
+#define SCM_F_VM_CONT_PARTIAL 0x1
+#define SCM_F_VM_CONT_REWINDABLE 0x2
+
struct scm_vm_cont {
SCM *sp;
SCM *fp;
@@ -93,16 +97,22 @@ struct scm_vm_cont {
scm_t_ptrdiff stack_size;
SCM *stack_base;
scm_t_ptrdiff reloc;
+ scm_t_uint32 flags;
};
#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) ==
scm_tc7_vm_cont)
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT) &
SCM_F_VM_CONT_PARTIAL)
+#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT) &
SCM_F_VM_CONT_REWINDABLE)
SCM_API SCM scm_load_compiled_with_vm (SCM file);
SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
+SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
+ scm_t_uint8 *ra, scm_t_uint8 *mvra,
+ scm_t_uint32 flags);
SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_vm (void);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 6dc2b68..a01e6be 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -404,6 +404,8 @@
;;; Delimited continuations
(define (prompt tag thunk handler)
(@prompt tag (thunk) handler))
+(define (abort tag . args)
+ (@abort tag args))
;;; apply-to-args is functionally redundant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index cfd26bf..8daf49a 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -50,7 +50,7 @@
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body
prompt-handler
- <abort> abort? make-abort abort-src abort-tag abort-args
+ <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
parse-tree-il
unparse-tree-il
@@ -86,7 +86,7 @@
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
- (<abort> tag args))
+ (<abort> tag args tail))
@@ -192,8 +192,8 @@
((prompt ,tag ,body ,handler)
(make-prompt loc (retrans tag) (retrans body) (retrans handler)))
- ((abort ,tag ,type ,args)
- (make-abort loc (retrans tag) type (map retrans args)))
+ ((abort ,tag ,args ,tail)
+ (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
(else
(error "unrecognized tree-il" exp)))))
@@ -276,8 +276,9 @@
((<prompt> tag body handler)
`(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)))
- ((<abort> tag args)
- `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)))))
+ ((<abort> tag args tail)
+ `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
+ ,(unparse-tree-il tail)))))
(define (tree-il->scheme e)
(record-case e
@@ -374,8 +375,9 @@
,(tree-il->scheme handler)))
- ((<abort> tag args)
- `(@abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)))))
+ ((<abort> tag args tail)
+ `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
+ ,(tree-il->scheme tail)))))
(define (tree-il-fold leaf down up seed tree)
@@ -444,8 +446,8 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(up tree
(loop tag (loop body (loop handler
(down tree result))))))
- ((<abort> tag args)
- (up tree (loop tag (loop args (down tree result)))))
+ ((<abort> tag args tail)
+ (up tree (loop tail (loop args (loop tag (down tree result))))))
(else
(leaf tree result))))))
@@ -518,9 +520,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
- ((<abort> tag args)
- (let*-values (((seed ...) (foldts tag seed ...)))
- (fold-values foldts args seed ...)))
+ ((<abort> tag args tail)
+ (let*-values (((seed ...) (foldts tag seed ...))
+ ((seed ...) (fold-values foldts args seed
...)))
+ (foldts tail seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))))
@@ -599,9 +602,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (prompt-body x) (lp body))
(set! (prompt-handler x) (lp handler)))
- ((<abort> tag args)
+ ((<abort> tag args tail)
(set! (abort-tag x) (lp tag))
- (set! (abort-args x) (map lp args)))
+ (set! (abort-args x) (map lp args))
+ (set! (abort-tail x) (lp tail)))
(else #f))
@@ -681,9 +685,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (prompt-body x) (lp body))
(set! (prompt-handler x) (lp handler)))
- ((<abort> tag args)
+ ((<abort> tag args tail)
(set! (abort-tag x) (lp tag))
- (set! (abort-args x) (map lp args)))
+ (set! (abort-args x) (map lp args))
+ (set! (abort-tail x) (lp tail)))
(else #f))
x)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index c5f6cb9..0c3cbf8 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -349,10 +349,10 @@
(lset-union eq? (step fluid) (step exp)))
((<prompt> tag body handler)
- (lset-union eq? (step tag) (step handler)))
+ (lset-union eq? (step tag) (step body) (step handler)))
- ((<abort> tag args)
- (apply lset-union eq? (step tag) (map step args)))
+ ((<abort> tag args tail)
+ (apply lset-union eq? (step tag) (step tail) (map step args)))
(else '())))
@@ -525,8 +525,8 @@
(and cont-var (zero? (hashq-ref refcounts cont-var 0))))
(max (recur tag) (recur body) (recur handler))))
- ((<abort> tag args)
- (apply max (recur tag) (map recur args)))
+ ((<abort> tag args tail)
+ (apply max (recur tag) (recur tail) (map recur args)))
(else n)))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index bfe6f05..7030430 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1111,9 +1111,10 @@
(and (eq? context 'drop) (not RA)))
(emit-label POST))))
- ((<abort> src tag args)
+ ((<abort> src tag args tail)
(comp-push tag)
(for-each comp-push args)
+ (comp-push tail)
(emit-code src (make-glil-call 'abort (length args)))
;; so, the abort can actually return. if it does, the values will be on
;; the stack, then the MV marker, just as in an MV context.
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index b783396..43e53f4 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -63,7 +63,7 @@
fluid-ref fluid-set!
- @prompt prompt
+ @prompt prompt @abort abort
struct? struct-vtable make-struct struct-ref struct-set!
@@ -454,14 +454,36 @@
(else #f)))
(hashq-set! *primitive-expand-table*
- 'control
+ 'prompt
(case-lambda
- ((src tag . args)
- (make-abort src tag args))
+ ((src tag thunk handler)
+ ;; Sigh. Until the inliner does its job, manually inline
+ ;; (let ((h (lambda ...))) (prompt k x h))
+ (cond
+ ((lambda? handler)
+ (let ((args-sym (gensym)))
+ (make-prompt
+ src tag (make-application #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-application #f (make-primitive-ref #f 'apply)
+ (list handler
+ (make-lexical-ref #f 'args
args-sym)))
+ #f))))
+ (else #f)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@abort
+ (case-lambda
+ ((src tag tail-args)
+ (make-abort src tag '() tail-args))
(else #f)))
(hashq-set! *primitive-expand-table*
- '@control
+ 'abort
(case-lambda
((src tag . args)
- (make-abort src tag args))
+ (make-abort src tag args (make-const #f '())))
(else #f)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-8-31-gcee1d22,
Andy Wingo <=