summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-02-24 16:56:45 +0100
committerAndy Wingo <wingo@pobox.com>2010-02-24 16:57:33 +0100
commit078014374c066f03975bd0ef008877c5236c75ec (patch)
treea4279483a20a2c3975d37fb116b30cbd60375d12
parent6d804376e94d17cf013a415c4bd98d632f7a91b9 (diff)
downloadguile-078014374c066f03975bd0ef008877c5236c75ec.tar.gz
partial-cont-call works
* libguile/vm-i-system.c (partial-cont-call): Sync registers before splatting a partial continuation, and cache them back afterwards. * libguile/vm.c (vm_reinstate_partial_continuation): Actually implement, except dynamic-wind.
-rw-r--r--libguile/vm-i-system.c8
-rw-r--r--libguile/vm.c50
2 files changed, 53 insertions, 5 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 09293bef8..2f74a59dc 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -999,8 +999,12 @@ VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
POP (extwinds);
POP (intwinds);
POP (vmcont);
-
- vm_reinstate_partial_continuation (vm, vmcont, intwinds, extwinds);
+ SYNC_REGISTER ();
+ vm_reinstate_partial_continuation (vm, vmcont, intwinds, extwinds,
+ sp + 1 - fp, fp);
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 572a7100a..a5f457013 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -229,10 +229,54 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
}
static void
-vm_reinstate_partial_continuation (SCM vm, SCM vm_cont, SCM intwinds,
- SCM extwinds)
+vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
+ SCM extwinds, size_t n, SCM *argv)
{
- abort ();
+ struct scm_vm *vp;
+ struct scm_vm_cont *cp;
+ SCM *argv_copy, *base;
+ size_t i;
+
+ argv_copy = alloca (n * sizeof(SCM));
+ memcpy (argv_copy, argv, n * sizeof(SCM));
+
+ vp = SCM_VM_DATA (vm);
+ cp = SCM_VM_CONT_DATA (cont);
+ base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
+
+#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
+
+ if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
+ {
+ /* puts ("FIXME: Need to expand"); */
+ abort ();
+ }
+
+ memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
+
+ /* now relocate frame pointers */
+ {
+ SCM *fp;
+ for (fp = RELOC (cp->fp);
+ SCM_FRAME_LOWER_ADDRESS (fp) > base;
+ fp = SCM_FRAME_DYNAMIC_LINK (fp))
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
+ }
+
+ vp->sp = base - 1 + cp->stack_size;
+ vp->fp = RELOC (cp->fp);
+ vp->ip = cp->mvra;
+
+#undef RELOC
+
+ /* now push args. ip is in a MV context. */
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->sp++;
+ *vp->sp = scm_from_size_t (n);
}