[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-g9b4c3ab
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-g9b4c3ab |
|
Date: |
Thu, 21 Nov 2013 16:54:06 +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=9b4c3ab5fa293310a7853d99768426b7dba4005b
The branch, master has been updated
via 9b4c3ab5fa293310a7853d99768426b7dba4005b (commit)
via 796e54a74ce30a22d4a49aa9f63001c572bc2481 (commit)
via b44f5451f89f33d85e1601de72317460614c4193 (commit)
via 44ece399074281dec3bd69ab76a20dec2b0d4bfc (commit)
via 59f85eedc27fb82522fcd2788b4ab25409481630 (commit)
via 5515edc5f21e042ade15cf508300c496ce2f4818 (commit)
via 050a40db5b0b09f0b00d4d68aac67827c7f9b1ac (commit)
via 0bca90aac9a209b2ae06281b00d5c3b9939d605e (commit)
via a3da449801895e3f61aa2e085e7f4ff27c0f202c (commit)
via a222cbc9d147c0649b5b4621579de977a690b213 (commit)
via 972275eee5326b4628f207996e14e0040fb94256 (commit)
via 6b4ba76d05bf229b45d9f2be189cce29f46e3111 (commit)
via 3583665aa0c07011c985092776fc9db0d610466c (commit)
via e08caa5620ded01fc303169b8e8d81c11e78d4ac (commit)
via 89b235afd34482f2e7d2af553f43d0744895ee83 (commit)
via eadd9eb4c9f658c9a6081d1b644c7c472d241061 (commit)
via f593117165ceb7bf287e15b3c01a217140c19421 (commit)
from 473d56373341b0224aa43c3149564ae7f2e20471 (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 9b4c3ab5fa293310a7853d99768426b7dba4005b
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:52:00 2013 +0100
Engine takes struct scm_vm* as argument
* libguile/vm-engine.c:
* libguile/vm.c (scm_c_vm_run): VM engine now takes struct scm_vm* as
argument, not SCM vm.
commit 796e54a74ce30a22d4a49aa9f63001c572bc2481
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:50:33 2013 +0100
One more SCM vm user: continuations.
* libguile/continuations.c:
* libguile/continuations.h (struct scm_t_contregs): Rename SCM vm member
to struct scm_vm *vp.
(scm_i_make_continuation): Take vp instead of vm.
(scm_i_contregs_vp): Rename from scm_i_contregs_vm, return vp.
* libguile/vm-engine.c (continuation-call, call/cc): Fix remaining SCM
vm user.
* libguile/vm.c (vm_return_to_continuation): Adapt prototype.
commit b44f5451f89f33d85e1601de72317460614c4193
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:36:22 2013 +0100
Remove last use of SCM vm in VM
* libguile/control.h:
* libguile/control.c (reify_partial_continuation, scm_c_abort): Take
struct scm_vm *vp as an arg.
* libguile/dynstack.h: Remove control.h include.
* libguile/vm.c (vm_abort): Take struct scm_vm *vp as an arg.
* libguile/vm-engine.c (abort): Adapt to vm_abort change.
commit 44ece399074281dec3bd69ab76a20dec2b0d4bfc
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:28:34 2013 +0100
Remove use of SCM vm in compose-continuation
* libguile/vm.c (vm_reinstate_partial_continuation): Take struct scm_vm
argument instead of SCM.
* libguile/vm-engine.c (compose-continuation): Adapt.
commit 59f85eedc27fb82522fcd2788b4ab25409481630
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:24:48 2013 +0100
Dispatch hooks use "vp" rather than "vm"
* libguile/vm.c (vm_dispatch_hook):
(vm_dispatch_apply_hook):
(vm_dispatch_push_continuation_hook):
(vm_dispatch_pop_continuation_hook):
(vm_dispatch_next_hook):
(vm_dispatch_abort_hook):
(vm_dispatch_restore_continuation_hook): Use scm_vm pointer instead of
Scheme vm object.
commit 5515edc5f21e042ade15cf508300c496ce2f4818
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:21:37 2013 +0100
Heap frame "stack holders" are raw scm_vm / scm_vm_cont pointers
* libguile/frames.h (struct scm_frame): stack_holder is a void*.
* libguile/frames.c (scm_i_frame_stack_base, scm_i_frame_offset): Expect
stack_holder to be the raw struct scm_vm or scm_vm_cont.
* libguile/continuations.c (scm_i_continuation_to_frame):
* libguile/stacks.c (scm_make_stack)
* libguile/vm.c (vm_dispatch_hook): Adapt creators.
commit 050a40db5b0b09f0b00d4d68aac67827c7f9b1ac
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 17:13:18 2013 +0100
Heap frames have a "frame kind" bit
* libguile/frames.h (enum scm_vm_frame_kind, SCM_VM_FRAME_KIND)
(scm_c_make_frame): Add a "frame kind" bit to the first word. This
will allow the "stack holder" to be a non-SCM object.
* libguile/continuations.c (scm_i_continuation_to_frame):
* libguile/frames.c (scm_c_make_frame, scm_frame_previous)
* libguile/stacks.c (scm_make_stack):
* libguile/vm.c (vm_dispatch_hook): Adapt frame creators to set the
frame kind bit.
commit 0bca90aac9a209b2ae06281b00d5c3b9939d605e
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 12:12:38 2013 +0100
The dynamic stack records SP and FP values as offsets
* libguile/dynstack.h:
* libguile/dynstack.c (PROMPT_FP, PROMPT_SP):
(scm_dynstack_push_prompt, scm_dynstack_find_prompt): Prompts on the
dynstack are recorded as offsets from the base stack address in this
thread.
* libguile/control.c (scm_c_abort):
* libguile/eval.c (eval):
* libguile/stacks.c (find_prompt, narrow_stack):
* libguile/throw.c (pre_init_catch):
* libguile/vm-engine.c (prompt): Adapt.
commit a3da449801895e3f61aa2e085e7f4ff27c0f202c
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 16:51:04 2013 +0100
Reorder struct scm_vm fields.
* libguile/vm.h (struct scm_vm): Reorder fields, perhaps for better
locality.
commit a222cbc9d147c0649b5b4621579de977a690b213
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 16:45:03 2013 +0100
No more VM objects visible to Scheme
* libguile/vm.h:
* libguile/vm.c (scm_the_vm): Don't expose to Scheme.
(scm_vm_p): Remove, as it is not needed.
* module/system/vm/vm.scm: Remove the-vm and vm? exports.
* doc/ref/api-coverage.texi (Code Coverage):
* test-suite/tests/coverage.test:
* module/system/vm/coverage.scm (with-code-coverage): Don't take a VM
argument. Adapt documentation and tests.
* module/ice-9/command-line.scm: Remove the-vm autoload.
* module/system/vm/trace.scm (trace-calls-to-procedure):
(trace-calls-in-procedure):
(trace-instructions-in-procedure):
(call-with-trace): Remove #:vm kwarg, and adapt to trap changes.
* module/system/vm/trap-state.scm (the-trap-state): Rework to use a
parameter underneath instead of a weak key on (the-vm).
* module/system/vm/traps.scm (new-disabled-trap):
(new-enabled-trap): Remove vm argument.
(trap-at-procedure-call):
(trap-in-procedure):
(trap-instructions-in-procedure):
(trap-at-procedure-ip-in-range):
(trap-at-source-location):
(trap-frame-finish):
(trap-in-dynamic-extent):
(trap-calls-in-dynamic-extent):
(trap-instructions-in-dynamic-extent):
(trap-calls-to-procedure):
(trap-matching-instructions): Remove vm keyword arguments.
* test-suite/tests/control.test ("unwind"): Adapt test.
* test-suite/tests/eval.test (test-suite): Remove the-vm import.
commit 972275eee5326b4628f207996e14e0040fb94256
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 16:10:41 2013 +0100
VM accessors take VM as implicit argument, not explicit argument
* libguile/vm.h:
* libguile/vm.c:
(scm_vm_apply_hook, scm_vm_push_continuation_hook,
scm_vm_pop_continuation_hook, scm_vm_abort_continuation_hook,
scm_vm_restore_continuation_hook, scm_vm_next_hook,
scm_vm_trace_level, scm_set_vm_trace_level_x, scm_vm_engine,
scm_set_vm_engine_x, scm_c_set_vm_engine_x): The VM argument is now
implicit: the VM for the current thread.
* doc/ref/api-debug.texi (VM Hooks): Try to adapt.
* module/ice-9/command-line.scm:
* module/statprof.scm:
* module/system/vm/coverage.scm:
* module/system/vm/trace.scm:
* module/system/vm/trap-state.scm:
* module/system/vm/traps.scm:
* test-suite/tests/control.test:
* test-suite/tests/eval.test: Adapt users that set hooks or ensure that
we have a debug engine.
commit 6b4ba76d05bf229b45d9f2be189cce29f46e3111
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 15:41:27 2013 +0100
Change eval.c to use scm_c_vm_run instead of scm_call_with_vm.
* libguile/eval.c (scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3)
(scm_map, scm_for_each, scm_apply): Change to prefer scm_apply_0, and
to have it call vm_run instead of call_with_vm.
(eval): Use scm_apply_0 and scm_call_0.
* libguile/srfi-1.c (scm_srfi1_count): Use scm_apply_0.
commit 3583665aa0c07011c985092776fc9db0d610466c
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 15:02:36 2013 +0100
Remove unused vm:ip, vm:sp, vm:fp
* libguile/vm.h:
* libguile/vm.c (scm_vm_ip, scm_vm_fp, scm_vm_sp): Remove unused
functions.
* module/system/vm/vm.scm: Remove exports.
commit e08caa5620ded01fc303169b8e8d81c11e78d4ac
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 14:59:58 2013 +0100
Remove make-vm; there will be one vm per thread now.
* libguile/vm.h:
* libguile/vm.c (scm_make_vm): Remove.
* module/system/vm/vm.scm: Remove make-vm export.
* test-suite/tests/control.test ("the-vm"):
* test-suite/tests/coverage.test (%test-vm):
* test-suite/tests/eval.test ("stack overflow"): Adapt tests.
commit 89b235afd34482f2e7d2af553f43d0744895ee83
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 11:20:19 2013 +0100
Scheme frame objects hold relative stack offsets
* libguile/frames.h: Wrap the C interface to VM frames in
BUILDING_LIBGUILE. Change VM frames to record relative offsets into a
stack held by some other object, so that if the stack moves they will
remain valid.
* libguile/frames.c (scm_c_make_frame): Remove offset argument.
(scm_i_frame_offset): Instead, compute the offset from the stack
holder.
(scm_i_frame_stack_base): New helper.
(scm_frame_previous): Adapt.
* libguile/stacks.c (scm_make_stack)
* libguile/vm.c (vm_dispatch_hook):
* libguile/continuations.c (scm_i_continuation_to_frame): Adapt.
commit eadd9eb4c9f658c9a6081d1b644c7c472d241061
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 10:23:35 2013 +0100
Prepare for moveable stacks in the VM.
* libguile/vm-engine.c (CHECK_OVERFLOW, ALLOC_FRAME, vm_engine): Prepare
for moveable stacks.
commit f593117165ceb7bf287e15b3c01a217140c19421
Author: Andy Wingo <address@hidden>
Date: Thu Nov 21 10:07:58 2013 +0100
CHECK_OVERFLOW tweak
* libguile/vm-engine.c (CHECK_OVERFLOW): Now that we aren't checking for
overflow on every push, fetch the stack limit from the vm instead of a
local.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-coverage.texi | 12 +-
doc/ref/api-debug.texi | 24 ++--
libguile/continuations.c | 19 ++--
libguile/continuations.h | 8 +-
libguile/control.c | 41 +++---
libguile/control.h | 4 +-
libguile/dynstack.c | 24 ++--
libguile/dynstack.h | 9 +-
libguile/eval.c | 72 ++++++-----
libguile/frames.c | 70 +++++++++--
libguile/frames.h | 41 +++++--
libguile/srfi-1.c | 4 +-
libguile/stacks.c | 23 ++--
libguile/throw.c | 4 +-
libguile/vm-engine.c | 47 +++++---
libguile/vm.c | 257 +++++++++++----------------------------
libguile/vm.h | 35 ++---
module/ice-9/command-line.scm | 4 +-
module/statprof.scm | 16 +--
module/system/vm/coverage.scm | 17 ++--
module/system/vm/trace.scm | 25 ++--
module/system/vm/trap-state.scm | 20 ++--
module/system/vm/traps.scm | 131 +++++++++-----------
module/system/vm/vm.scm | 7 +-
test-suite/tests/control.test | 16 +--
test-suite/tests/coverage.test | 34 +++---
test-suite/tests/eval.test | 7 +-
27 files changed, 459 insertions(+), 512 deletions(-)
diff --git a/doc/ref/api-coverage.texi b/doc/ref/api-coverage.texi
index 6809977..5081d34 100644
--- a/doc/ref/api-coverage.texi
+++ b/doc/ref/api-coverage.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010 Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -14,10 +14,10 @@ part of the code is @dfn{covered} by the test suite. The
@code{(system vm
coverage)} module provides tools to gather code coverage data and to present
them, as detailed below.
address@hidden {Scheme Procedure} with-code-coverage vm thunk
-Run @var{thunk}, a zero-argument procedure, using @var{vm}; instrument @var{vm}
-to collect code coverage data. Return code coverage data and the values
-returned by @var{thunk}.
address@hidden {Scheme Procedure} with-code-coverage thunk
+Run @var{thunk}, a zero-argument procedure, while instrumenting Guile's
+virtual machine to collect code coverage data. Return code coverage
+data and the values returned by @var{thunk}.
@end deffn
@deffn {Scheme Procedure} coverage-data? obj
@@ -43,7 +43,7 @@ Here's an example use:
(system vm vm))
(call-with-values (lambda ()
- (with-code-coverage (the-vm)
+ (with-code-coverage
(lambda ()
(do-something-tricky))))
(lambda (data result)
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 4e1b822..32f32ca 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -716,7 +716,7 @@ a thunk, gives us the following:
@lisp
scheme@@(guile-user)> (use-modules (system vm vm))
scheme@@(guile-user)> (debug-set! stack 10000)
-scheme@@(guile-user)> (let lp () (call-with-vm (the-vm) lp))
+scheme@@(guile-user)> (let lp () (call-with-vm lp))
ERROR: In procedure call-with-vm:
ERROR: Stack overflow
@end lisp
@@ -816,28 +816,28 @@ The interface to hooks is provided by the @code{(system
vm vm)} module:
@end example
@noindent
-The result of calling @code{the-vm} is usually passed as the @var{vm}
-argument to all of these procedures.
+All of these functions implicitly act on the VM for the current thread
+only.
address@hidden {Scheme Procedure} vm-next-hook vm
address@hidden {Scheme Procedure} vm-next-hook
The hook that will be fired before an instruction is retired (and
executed).
@end deffn
address@hidden {Scheme Procedure} vm-push-continuation-hook vm
address@hidden {Scheme Procedure} vm-push-continuation-hook
The hook that will be fired after preparing a new frame. Fires just
before applying a procedure in a non-tail context, just before the
corresponding apply-hook.
@end deffn
address@hidden {Scheme Procedure} vm-pop-continuation-hook vm
address@hidden {Scheme Procedure} vm-pop-continuation-hook
The hook that will be fired before returning from a frame.
This hook fires with a variable number of arguments, corresponding to
the values that the frame returns to its continuation.
@end deffn
address@hidden {Scheme Procedure} vm-apply-hook vm
address@hidden {Scheme Procedure} vm-apply-hook
The hook that will be fired before a procedure is applied. The frame's
procedure will have already been set to the new procedure.
@@ -848,7 +848,7 @@ whereas a tail call will run without having fired a
push-continuation
hook.
@end deffn
address@hidden {Scheme Procedure} vm-abort-continuation-hook vm
address@hidden {Scheme Procedure} vm-abort-continuation-hook
The hook that will be called after aborting to a
prompt. @xref{Prompts}.
@@ -857,7 +857,7 @@ of arguments, corresponding to the values that returned to
the
continuation.
@end deffn
address@hidden {Scheme Procedure} vm-restore-continuation-hook vm
address@hidden {Scheme Procedure} vm-restore-continuation-hook
The hook that will be called after restoring an undelimited
continuation. Unfortunately it's not currently possible to introspect on
the values that were given to the continuation.
@@ -875,12 +875,12 @@ level temporarily set to 0. That way the hooks don't
fire while you're
handling a hook. The trace level is restored to whatever it was once the hook
procedure finishes.
address@hidden {Scheme Procedure} vm-trace-level vm
address@hidden {Scheme Procedure} vm-trace-level
Retrieve the ``trace level'' of the VM. If positive, the trace hooks
associated with @var{vm} will be run. The initial trace level is 0.
@end deffn
address@hidden {Scheme Procedure} set-vm-trace-level! vm level
address@hidden {Scheme Procedure} set-vm-trace-level! level
Set the ``trace level'' of the VM.
@end deffn
@@ -1178,7 +1178,7 @@ procedure calls and returns within the thunk.
@deffn {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @
[#:instructions?=#f] @
- [#:width=80] [#:vm=(the-vm)]
+ [#:width=80]
Call @var{thunk}, tracing all execution within its dynamic extent.
If @var{calls?} is true, Guile will print a brief report at each
diff --git a/libguile/continuations.c b/libguile/continuations.c
index cb586e3..1d67761 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -116,7 +116,7 @@ continuation_print (SCM obj, SCM port, scm_print_state
*state SCM_UNUSED)
placed on the VM stack). */
#define FUNC_NAME "scm_i_make_continuation"
SCM
-scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
+scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM cont;
@@ -137,7 +137,7 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
#endif
continuation->offset = continuation->stack - src;
memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
- continuation->vm = vm;
+ continuation->vp = vp;
continuation->vm_cont = vm_cont;
SCM_NEWSMOB (cont, tc16_continuation, continuation);
@@ -177,20 +177,19 @@ scm_i_continuation_to_frame (SCM continuation)
if (scm_is_true (cont->vm_cont))
{
struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
- return scm_c_make_frame (cont->vm_cont,
- data->fp + data->reloc,
- data->sp + data->reloc,
- data->ra,
- data->reloc);
+ return scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, data,
+ (data->fp + data->reloc) - data->stack_base,
+ (data->sp + data->reloc) - data->stack_base,
+ data->ra);
}
else
return SCM_BOOL_F;
}
-SCM
-scm_i_contregs_vm (SCM contregs)
+struct scm_vm *
+scm_i_contregs_vp (SCM contregs)
{
- return SCM_CONTREGS (contregs)->vm;
+ return SCM_CONTREGS (contregs)->vp;
}
SCM
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 868a256..7d5e0db 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -51,7 +51,7 @@ typedef struct
#endif /* __ia64__ */
size_t num_stack_items; /* size of the saved stack. */
SCM root; /* continuation root identifier. */
- SCM vm; /* vm */
+ struct scm_vm *vp; /* vm */
SCM vm_cont; /* vm's stack and regs */
/* The offset from the live stack location to this copy. This is
@@ -70,12 +70,14 @@ typedef struct
-SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
+SCM_INTERNAL SCM scm_i_make_continuation (int *first,
+ struct scm_vm *vp,
+ SCM vm_cont);
SCM_INTERNAL void scm_i_check_continuation (SCM cont);
SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
-SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
+SCM_INTERNAL struct scm_vm* scm_i_contregs_vp (SCM contregs);
SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
diff --git a/libguile/control.c b/libguile/control.c
index 0ef8e23..4f7cc78 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -78,7 +78,7 @@ make_partial_continuation (SCM vm_cont)
}
static SCM
-reify_partial_continuation (SCM vm,
+reify_partial_continuation (struct scm_vm *vp,
SCM *saved_fp,
SCM *saved_sp,
scm_t_uint32 *saved_ip,
@@ -103,7 +103,7 @@ reify_partial_continuation (SCM vm,
could determine the stack bottom in O(1) time, but that's no longer
the case, since the thunk application doesn't occur where the
prompt is saved. */
- for (bottom_fp = SCM_VM_DATA (vm)->fp;
+ for (bottom_fp = vp->fp;
SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp;
bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp));
@@ -112,9 +112,9 @@ reify_partial_continuation (SCM vm,
/* Capture from the top of the thunk application frame up to the end. */
vm_cont = scm_i_vm_capture_stack (&SCM_FRAME_LOCAL (bottom_fp, 0),
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip,
+ vp->fp,
+ vp->sp,
+ vp->ip,
dynstack,
flags);
@@ -122,24 +122,29 @@ reify_partial_continuation (SCM vm,
}
void
-scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
+scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
scm_i_jmp_buf *current_registers)
{
SCM cont;
scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
scm_t_bits *prompt;
scm_t_dynstack_prompt_flags flags;
+ scm_t_ptrdiff fp_offset, sp_offset;
SCM *fp, *sp;
scm_t_uint32 *ip;
scm_i_jmp_buf *registers;
size_t i;
prompt = scm_dynstack_find_prompt (dynstack, tag,
- &flags, &fp, &sp, &ip, ®isters);
+ &flags, &fp_offset, &sp_offset, &ip,
+ ®isters);
if (!prompt)
scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
+ fp = vp->stack_base + fp_offset;
+ sp = vp->stack_base + sp_offset;
+
/* Only reify if the continuation referenced in the handler. */
if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
cont = SCM_BOOL_F;
@@ -148,32 +153,28 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
scm_t_dynstack *captured;
captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
- cont = reify_partial_continuation (vm, fp, sp, ip, registers, captured,
+ cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured,
current_registers);
}
/* Unwind. */
scm_dynstack_unwind (dynstack, prompt);
- /* Unwinding may have changed the current thread's VM, so use the
- new one. */
- vm = scm_the_vm ();
-
/* Restore VM regs */
- SCM_VM_DATA (vm)->fp = fp;
- SCM_VM_DATA (vm)->sp = sp;
- SCM_VM_DATA (vm)->ip = ip;
+ vp->fp = fp;
+ vp->sp = sp;
+ vp->ip = ip;
/* Since we're jumping down, we should always have enough space. */
- if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
+ if (vp->sp + n + 1 >= vp->stack_limit)
abort ();
/* Push vals */
- *(++(SCM_VM_DATA (vm)->sp)) = cont;
+ *(++(vp->sp)) = cont;
for (i = 0; i < n; i++)
- *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
+ *(++(vp->sp)) = argv[i];
if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
- *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for
continuation */
+ *(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
/* Jump! */
SCM_I_LONGJMP (*registers, 1);
@@ -197,7 +198,7 @@ SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*",
2, 0, 0,
for (i = 0; i < n; i++, args = scm_cdr (args))
argv[i] = scm_car (args);
- scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
+ scm_c_abort (SCM_VM_DATA (scm_the_vm ()), tag, n, argv, NULL);
/* 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...
diff --git a/libguile/control.h b/libguile/control.h
index db383cf..b9a7e23 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -19,10 +19,12 @@
#ifndef SCM_CONTROL_H
#define SCM_CONTROL_H
+#include "libguile/vm.h"
+
SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM vm);
-SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
+SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
scm_i_jmp_buf *registers) SCM_NORETURN;
SCM_INTERNAL SCM scm_abort_to_prompt_star (SCM tag, SCM args) SCM_NORETURN;
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index 2d8895e..9235ec4 100644
--- a/libguile/dynstack.c
+++ b/libguile/dynstack.c
@@ -36,8 +36,8 @@
#define PROMPT_WORDS 5
#define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
-#define PROMPT_FP(top) ((SCM *) ((top)[1]))
-#define PROMPT_SP(top) ((SCM *) ((top)[2]))
+#define PROMPT_FP(top) ((scm_t_ptrdiff) ((top)[1]))
+#define PROMPT_SP(top) ((scm_t_ptrdiff) ((top)[2]))
#define PROMPT_IP(top) ((scm_t_uint32 *) ((top)[3]))
#define PROMPT_JMPBUF(top) ((scm_i_jmp_buf *) ((top)[4]))
@@ -186,16 +186,16 @@ void
scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
scm_t_dynstack_prompt_flags flags,
SCM key,
- SCM *fp, SCM *sp, scm_t_uint32 *ip,
- scm_i_jmp_buf *registers)
+ scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
+ scm_t_uint32 *ip, scm_i_jmp_buf *registers)
{
scm_t_bits *words;
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags,
PROMPT_WORDS);
words[0] = SCM_UNPACK (key);
- words[1] = (scm_t_bits) fp;
- words[2] = (scm_t_bits) sp;
+ words[1] = (scm_t_bits) fp_offset;
+ words[2] = (scm_t_bits) sp_offset;
words[3] = (scm_t_bits) ip;
words[4] = (scm_t_bits) registers;
}
@@ -442,8 +442,8 @@ scm_dynstack_unwind_fork (scm_t_dynstack *dynstack,
scm_t_dynstack *branch)
scm_t_bits*
scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key,
scm_t_dynstack_prompt_flags *flags,
- SCM **fp, SCM **sp, scm_t_uint32 **ip,
- scm_i_jmp_buf **registers)
+ scm_t_ptrdiff *fp_offset, scm_t_ptrdiff *sp_offset,
+ scm_t_uint32 **ip, scm_i_jmp_buf **registers)
{
scm_t_bits *walk;
@@ -457,10 +457,10 @@ scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM
key,
{
if (flags)
*flags = SCM_DYNSTACK_TAG_FLAGS (tag);
- if (fp)
- *fp = PROMPT_FP (walk);
- if (sp)
- *sp = PROMPT_SP (walk);
+ if (fp_offset)
+ *fp_offset = PROMPT_FP (walk);
+ if (sp_offset)
+ *sp_offset = PROMPT_SP (walk);
if (ip)
*ip = PROMPT_IP (walk);
if (registers)
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index fe5bb54..7b31ace 100644
--- a/libguile/dynstack.h
+++ b/libguile/dynstack.h
@@ -24,7 +24,6 @@
#include "libguile/__scm.h"
-#include "libguile/control.h"
@@ -155,7 +154,9 @@ SCM_INTERNAL void scm_dynstack_push_fluid (scm_t_dynstack *,
SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
scm_t_dynstack_prompt_flags,
SCM key,
- SCM *fp, SCM *sp, scm_t_uint32 *ip,
+ scm_t_ptrdiff fp_offset,
+ scm_t_ptrdiff sp_offset,
+ scm_t_uint32 *ip,
scm_i_jmp_buf *registers);
SCM_INTERNAL void scm_dynstack_push_dynwind (scm_t_dynstack *,
SCM enter, SCM leave);
@@ -191,7 +192,9 @@ SCM_INTERNAL void scm_dynstack_unwind_fluid (scm_t_dynstack
*dynstack,
SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
scm_t_dynstack_prompt_flags
*,
- SCM **, SCM **,
scm_t_uint32 **,
+ scm_t_ptrdiff *,
+ scm_t_ptrdiff *,
+ scm_t_uint32 **,
scm_i_jmp_buf **);
SCM_INTERNAL void scm_dynstack_wind_prompt (scm_t_dynstack *, scm_t_bits *,
diff --git a/libguile/eval.c b/libguile/eval.c
index 1572c87..7b09d84 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -312,7 +312,7 @@ eval (SCM x, SCM env)
goto loop;
}
else
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
@@ -348,7 +348,7 @@ eval (SCM x, SCM env)
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
- v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
+ v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
@@ -449,14 +449,14 @@ eval (SCM x, SCM env)
vm = scm_the_vm ();
/* Push the prompt onto the dynamic stack. */
- scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
- SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
- | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
- k,
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip,
- ®isters);
+ scm_dynstack_push_prompt
+ (&SCM_I_CURRENT_THREAD->dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY |
SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+ k,
+ SCM_VM_DATA (vm)->fp - SCM_VM_DATA (vm)->stack_base,
+ SCM_VM_DATA (vm)->sp - SCM_VM_DATA (vm)->stack_base,
+ SCM_VM_DATA (vm)->ip,
+ ®isters);
if (SCM_I_SETJMP (registers))
{
@@ -586,26 +586,40 @@ scm_call (SCM proc, ...)
SCM
scm_apply_0 (SCM proc, SCM args)
{
- return scm_apply (proc, args, SCM_EOL);
+ SCM *argv;
+ int i, nargs;
+
+ nargs = scm_ilength (args);
+ if (SCM_UNLIKELY (nargs < 0))
+ scm_wrong_type_arg_msg ("apply", 2, args, "list");
+
+ /* FIXME: Use vm_builtin_apply instead of alloca. */
+ argv = alloca (nargs * sizeof(SCM));
+ for (i = 0; i < nargs; i++)
+ {
+ argv[i] = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
}
SCM
scm_apply_1 (SCM proc, SCM arg1, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons (arg1, args));
}
SCM
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
{
- return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
}
SCM
scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
- SCM_EOL);
+ return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
}
@@ -618,8 +632,8 @@ scm_map (SCM proc, SCM arg1, SCM args)
var = scm_private_variable (scm_the_root_module (),
scm_from_latin1_symbol ("map"));
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
@@ -631,8 +645,8 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
var = scm_private_variable (scm_the_root_module (),
scm_from_latin1_symbol ("for-each"));
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
@@ -694,24 +708,18 @@ static SCM f_apply;
/* Apply a function to a list of arguments.
- This function is exported to the Scheme level as taking two
- required arguments and a tail argument, as if it were:
+ This function's interface is a bit wonly. It takes two required
+ arguments and a tail argument, as if it were:
+
(lambda (proc arg1 . args) ...)
- Thus, if you just have a list of arguments to pass to a procedure,
- pass the list as ARG1, and '() for ARGS. If you have some fixed
- args, pass the first as ARG1, then cons any remaining fixed args
- onto the front of your argument list, and pass that as ARGS. */
+
+ Usually you want to use scm_apply_0 or one of its cousins. */
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{
- /* Fix things up so that args contains all args. */
- if (scm_is_null (args))
- args = arg1;
- else
- args = scm_cons_star (arg1, args);
-
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc,
+ scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
}
static void
diff --git a/libguile/frames.c b/libguile/frames.c
index 776ded5..b0f451f 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -24,6 +24,7 @@
#include <string.h>
#include "_scm.h"
#include "frames.h"
+#include "vm.h"
#include <verify.h>
/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
@@ -36,17 +37,17 @@ verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
(((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
SCM
-scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint32 *ip, scm_t_ptrdiff offset)
+scm_c_make_frame (enum scm_vm_frame_kind frame_kind, void *stack_holder,
+ scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
+ scm_t_uint32 *ip)
{
struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
"vmframe");
p->stack_holder = stack_holder;
- p->fp = fp;
- p->sp = sp;
+ p->fp_offset = fp_offset;
+ p->sp_offset = sp_offset;
p->ip = ip;
- p->offset = offset;
- return scm_cell (scm_tc7_frame, (scm_t_bits)p);
+ return scm_cell (scm_tc7_frame | (frame_kind << 8), (scm_t_bits)p);
}
void
@@ -60,6 +61,54 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state
*pstate)
scm_puts_unlocked (">", port);
}
+SCM*
+scm_i_frame_stack_base (SCM frame)
+#define FUNC_NAME "frame-stack-base"
+{
+ void *stack_holder;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ switch (SCM_VM_FRAME_KIND (frame))
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) stack_holder)->stack_base;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return ((struct scm_vm *) stack_holder)->stack_base;
+
+ default:
+ abort ();
+ }
+}
+#undef FUNC_NAME
+
+scm_t_ptrdiff
+scm_i_frame_offset (SCM frame)
+#define FUNC_NAME "frame-offset"
+{
+ void *stack_holder;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ switch (SCM_VM_FRAME_KIND (frame))
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) stack_holder)->reloc;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return 0;
+
+ default:
+ abort ();
+ }
+}
+#undef FUNC_NAME
+
/* Scheme interface */
@@ -244,12 +293,13 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
if (new_fp)
{
+ SCM *stack_base = scm_i_frame_stack_base (frame);
new_fp = RELOC (frame, new_fp);
new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
- frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
- new_fp, new_sp,
- SCM_FRAME_RETURN_ADDRESS (this_fp),
- SCM_VM_FRAME_OFFSET (frame));
+ frame = scm_c_make_frame (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_STACK_HOLDER (frame),
+ new_fp - stack_base, new_sp - stack_base,
+ SCM_FRAME_RETURN_ADDRESS (this_fp));
proc = scm_frame_procedure (frame);
if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
diff --git a/libguile/frames.h b/libguile/frames.h
index d425b94..e48bb48 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -136,26 +136,43 @@ struct scm_vm_frame
* Heap frames
*/
+#ifdef BUILDING_LIBGUILE
+
struct scm_frame
{
- SCM stack_holder;
- SCM *fp;
- SCM *sp;
+ void *stack_holder;
+ scm_t_ptrdiff fp_offset;
+ scm_t_ptrdiff sp_offset;
scm_t_uint32 *ip;
- scm_t_ptrdiff offset;
};
+enum scm_vm_frame_kind
+ {
+ SCM_VM_FRAME_KIND_VM,
+ SCM_VM_FRAME_KIND_CONT
+ };
+
#define SCM_VM_FRAME_P(x) (SCM_HAS_TYP7 (x, scm_tc7_frame))
-#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_CELL_WORD_1 (x))
-#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
-#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
-#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
-#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA(f)->ip
-#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
+#define SCM_VM_FRAME_KIND(x) ((enum scm_vm_frame_kind) (SCM_CELL_WORD_0 (x)
>> 8))
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame *)SCM_CELL_WORD_1 (x))
+#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA (f)->stack_holder
+#define SCM_VM_FRAME_FP_OFFSET(f) SCM_VM_FRAME_DATA (f)->fp_offset
+#define SCM_VM_FRAME_SP_OFFSET(f) SCM_VM_FRAME_DATA (f)->sp_offset
+#define SCM_VM_FRAME_FP(f) (SCM_VM_FRAME_FP_OFFSET (f) +
scm_i_frame_stack_base (f))
+#define SCM_VM_FRAME_SP(f) (SCM_VM_FRAME_SP_OFFSET (f) +
scm_i_frame_stack_base (f))
+#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA (f)->ip
+#define SCM_VM_FRAME_OFFSET(f) scm_i_frame_offset (f)
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
-SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint32 *ip, scm_t_ptrdiff offset);
+SCM_INTERNAL SCM* scm_i_frame_stack_base (SCM frame);
+SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame);
+
+SCM_INTERNAL SCM scm_c_make_frame (enum scm_vm_frame_kind vm_frame_kind,
+ void *stack_holder, scm_t_ptrdiff fp_offset,
+ scm_t_ptrdiff sp_offset, scm_t_uint32 *ip);
+
+#endif
+
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 54c7e2a..aaa3efe 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -1,7 +1,7 @@
/* srfi-1.c --- SRFI-1 procedures for Guile
*
* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
- * 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -258,7 +258,7 @@ SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
}
- count += scm_is_true (scm_apply (pred, args, SCM_EOL));
+ count += scm_is_true (scm_apply_0 (pred, args));
}
}
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 20b67ef..360b35f 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -95,17 +95,17 @@ stack_depth (SCM frame)
* encountered.
*/
-static SCM*
+static scm_t_ptrdiff
find_prompt (SCM key)
{
- SCM *fp;
+ scm_t_ptrdiff fp_offset;
if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
- NULL, &fp, NULL, NULL, NULL))
+ NULL, &fp_offset, NULL, NULL, NULL))
scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
scm_list_1 (key));
- return fp;
+ return fp_offset;
}
static void
@@ -144,9 +144,9 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
else
{
/* Cut until the given prompt tag is seen. */
- SCM *fp = find_prompt (inner_cut);
+ scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
for (; len; len--, frame = scm_frame_previous (frame))
- if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
break;
}
@@ -178,12 +178,12 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
else
{
/* Cut until the given prompt tag is seen. */
- SCM *fp = find_prompt (outer_cut);
+ scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
while (len)
{
frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
- if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
break;
}
}
@@ -258,9 +258,10 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
cont = scm_i_capture_current_stack ();
c = SCM_VM_CONT_DATA (cont);
- frame = scm_c_make_frame (cont, c->fp + c->reloc,
- c->sp + c->reloc, c->ra,
- c->reloc);
+ frame = scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, c,
+ (c->fp + c->reloc) - c->stack_base,
+ (c->sp + c->reloc) - c->stack_base,
+ c->ra);
}
else if (SCM_VM_FRAME_P (obj))
frame = obj;
diff --git a/libguile/throw.c b/libguile/throw.c
index bd7a984..e68f428 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -477,8 +477,8 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM
pre_unwind_handler)
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
| SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
sym_pre_init_catch_tag,
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp,
+ SCM_VM_DATA (vm)->fp - SCM_VM_DATA
(vm)->stack_base,
+ SCM_VM_DATA (vm)->sp - SCM_VM_DATA
(vm)->stack_base,
SCM_VM_DATA (vm)->ip,
®isters);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 20a5ee0..b507511 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -111,8 +111,8 @@
#else
#define RUN_HOOK(exp)
#endif
-#define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vm))
-#define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vm, arg))
+#define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vp))
+#define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vp, arg))
#define APPLY_HOOK() \
RUN_HOOK0 (apply)
@@ -168,10 +168,18 @@
#define SYNC_ALL() /* FP already saved */ \
SYNC_IP()
-#define CHECK_OVERFLOW(sp) \
- do { \
- if (SCM_UNLIKELY ((sp) >= stack_limit)) \
- vm_error_stack_overflow (vp); \
+/* After advancing vp->sp, but before writing any stack slots, check
+ that it is actually in bounds. If it is not in bounds, currently we
+ signal an error. In the future we may expand the stack instead,
+ possibly by moving it elsewhere, therefore no pointer into the stack
+ besides FP is valid across a CHECK_OVERFLOW call. Be careful! */
+#define CHECK_OVERFLOW() \
+ do { \
+ if (SCM_UNLIKELY (vp->sp >= vp->stack_limit)) \
+ { \
+ vm_error_stack_overflow (vp); \
+ CACHE_REGISTER(); \
+ } \
} while (0)
/* Reserve stack space for a frame. Will check that there is sufficient
@@ -179,8 +187,8 @@
preparing the new frame and setting the fp and ip. */
#define ALLOC_FRAME(n) \
do { \
- SCM *new_sp = vp->sp = LOCAL_ADDRESS (n - 1); \
- CHECK_OVERFLOW (new_sp); \
+ vp->sp = LOCAL_ADDRESS (n - 1); \
+ CHECK_OVERFLOW (); \
} while (0)
/* Reset the current frame to hold N locals. Used when we know that no
@@ -416,7 +424,7 @@
((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
static SCM
-VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
+VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, size_t nargs_)
{
/* Instruction pointer: A pointer to the opcode that is currently
running. */
@@ -431,8 +439,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
register scm_t_uint32 op;
/* Cached variables. */
- struct scm_vm *vp = SCM_VM_DATA (vm);
- SCM *stack_limit = vp->stack_limit; /* stack limit address */
scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
scm_i_jmp_buf registers; /* used for prompts */
@@ -480,12 +486,15 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
/* Initialization */
{
SCM *base;
+ ptrdiff_t base_frame_size;
/* Check that we have enough space: 3 words for the boot
continuation, 3 + nargs for the procedure application, and 3 for
setting up a new frame. */
- base = vp->sp + 1;
- CHECK_OVERFLOW (vp->sp + 3 + 3 + nargs_ + 3);
+ base_frame_size = 3 + 3 + nargs_ + 3;
+ vp->sp += base_frame_size;
+ CHECK_OVERFLOW ();
+ base = vp->sp + 1 - base_frame_size;
/* Since it's possible to receive the arguments on the stack itself,
and indeed the regular VM invokes us that way, shuffle up the
@@ -884,7 +893,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SYNC_IP ();
scm_i_check_continuation (contregs);
- vm_return_to_continuation (scm_i_contregs_vm (contregs),
+ vm_return_to_continuation (scm_i_contregs_vp (contregs),
scm_i_contregs_vm_cont (contregs),
FRAME_LOCALS_COUNT_FROM (1),
LOCAL_ADDRESS (1));
@@ -913,7 +922,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SYNC_IP ();
VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
vm_error_continuation_not_rewindable (vmcont));
- vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT_FROM
(1),
+ vm_reinstate_partial_continuation (vp, vmcont, FRAME_LOCALS_COUNT_FROM
(1),
LOCAL_ADDRESS (1),
¤t_thread->dynstack,
®isters);
@@ -993,7 +1002,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
copying out to the heap; and likewise, the setjmp(®isters)
code already has the non-local return handler. But oh
well! */
- cont = scm_i_make_continuation (&first, vm, vm_cont);
+ cont = scm_i_make_continuation (&first, vp, vm_cont);
if (first)
{
@@ -1033,7 +1042,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
it continues with the next instruction. */
ip++;
SYNC_IP ();
- vm_abort (vm, LOCAL_REF (1), nlocals - 2, LOCAL_ADDRESS (2),
+ vm_abort (vp, LOCAL_REF (1), nlocals - 2, LOCAL_ADDRESS (2),
SCM_EOL, LOCAL_ADDRESS (0), ®isters);
/* vm_abort should not return */
@@ -2040,8 +2049,8 @@ VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
scm_dynstack_push_prompt (¤t_thread->dynstack, flags,
LOCAL_REF (tag),
- fp,
- LOCAL_ADDRESS (proc_slot),
+ fp - vp->stack_base,
+ LOCAL_ADDRESS (proc_slot) - vp->stack_base,
ip + offset,
®isters);
NEXT (3);
diff --git a/libguile/vm.c b/libguile/vm.c
index b1b5941..c761872 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -112,21 +112,19 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM
*sp, scm_t_uint32 *ra,
}
static void
-vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
+vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
{
- struct scm_vm *vp;
struct scm_vm_cont *cp;
SCM *argv_copy;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
- vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
if (vp->stack_size < cp->stack_size + n + 3)
scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
- scm_list_2 (vm, cont));
+ scm_list_1 (cont));
vp->sp = cp->sp;
vp->fp = cp->fp;
@@ -168,23 +166,21 @@ scm_i_capture_current_stack (void)
0);
}
-static void vm_dispatch_apply_hook (SCM vm) SCM_NOINLINE;
-static void vm_dispatch_push_continuation_hook (SCM vm) SCM_NOINLINE;
-static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp)
SCM_NOINLINE;
-static void vm_dispatch_next_hook (SCM vm) SCM_NOINLINE;
-static void vm_dispatch_abort_hook (SCM vm) SCM_NOINLINE;
-static void vm_dispatch_restore_continuation_hook (SCM vm) SCM_NOINLINE;
+static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_push_continuation_hook (struct scm_vm *vp)
SCM_NOINLINE;
+static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp)
SCM_NOINLINE;
+static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp)
SCM_NOINLINE;
static void
-vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
+vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
{
- struct scm_vm *vp;
SCM hook;
struct scm_frame c_frame;
scm_t_cell *frame;
int saved_trace_level;
- vp = SCM_VM_DATA (vm);
hook = vp->hooks[hook_num];
if (SCM_LIKELY (scm_is_false (hook))
@@ -202,17 +198,16 @@ vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
while the stack frame represented by the frame object is visible, so it
seems reasonable to limit the lifetime of frame objects. */
- c_frame.stack_holder = vm;
- c_frame.fp = vp->fp;
- c_frame.sp = vp->sp;
+ c_frame.stack_holder = vp;
+ c_frame.fp_offset = vp->fp - vp->stack_base;
+ c_frame.sp_offset = vp->sp - vp->stack_base;
c_frame.ip = vp->ip;
- c_frame.offset = 0;
/* Arrange for FRAME to be 8-byte aligned, like any other cell. */
frame = alloca (sizeof (*frame) + 8);
frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
- frame->word_0 = SCM_PACK (scm_tc7_frame);
+ frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8));
frame->word_1 = SCM_PACK_POINTER (&c_frame);
if (n == 0)
@@ -243,43 +238,43 @@ vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
}
static void
-vm_dispatch_apply_hook (SCM vm)
+vm_dispatch_apply_hook (struct scm_vm *vp)
{
- return vm_dispatch_hook (vm, SCM_VM_APPLY_HOOK, NULL, 0);
+ return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0);
}
-static void vm_dispatch_push_continuation_hook (SCM vm)
+static void vm_dispatch_push_continuation_hook (struct scm_vm *vp)
{
- return vm_dispatch_hook (vm, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
+ return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
}
-static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp)
+static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- return vm_dispatch_hook (vm, SCM_VM_POP_CONTINUATION_HOOK,
+ return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK,
&SCM_FRAME_LOCAL (old_fp, 1),
SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
}
-static void vm_dispatch_next_hook (SCM vm)
+static void vm_dispatch_next_hook (struct scm_vm *vp)
{
- return vm_dispatch_hook (vm, SCM_VM_NEXT_HOOK, NULL, 0);
+ return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0);
}
-static void vm_dispatch_abort_hook (SCM vm)
+static void vm_dispatch_abort_hook (struct scm_vm *vp)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- return vm_dispatch_hook (vm, SCM_VM_ABORT_CONTINUATION_HOOK,
+ return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK,
&SCM_FRAME_LOCAL (vp->fp, 1),
SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
}
-static void vm_dispatch_restore_continuation_hook (SCM vm)
+static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp)
{
- return vm_dispatch_hook (vm, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0);
+ return vm_dispatch_hook (vp, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0);
}
static void
-vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+vm_abort (struct scm_vm *vp, SCM tag,
+ size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
scm_i_jmp_buf *current_registers) SCM_NORETURN;
static void
-vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+vm_abort (struct scm_vm *vp, SCM tag,
+ size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
scm_i_jmp_buf *current_registers)
{
size_t i;
@@ -298,17 +293,17 @@ vm_abort (SCM vm, SCM tag, size_t nstack, SCM
*stack_args, SCM tail, SCM *sp,
argv[i] = scm_car (tail);
/* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
- SCM_VM_DATA (vm)->sp = sp;
+ vp->sp = sp;
- scm_c_abort (vm, tag, nstack + tail_len, argv, current_registers);
+ scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers);
}
static void
-vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv,
+vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
+ size_t n, SCM *argv,
scm_t_dynstack *dynstack,
scm_i_jmp_buf *registers)
{
- struct scm_vm *vp;
struct scm_vm_cont *cp;
SCM *argv_copy, *base;
scm_t_ptrdiff reloc;
@@ -317,7 +312,6 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t
n, SCM *argv,
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_LOCALS_ADDRESS (vp->fp);
reloc = cp->reloc + (base - cp->stack_base);
@@ -328,7 +322,7 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t
n, SCM *argv,
if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
scm_misc_error ("vm-engine",
"not enough space to instate partial continuation",
- scm_list_2 (vm, cont));
+ scm_list_1 (cont));
memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
@@ -743,7 +737,8 @@ initialize_default_stack_size (void)
#undef VM_USE_HOOKS
#undef VM_NAME
-typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs);
+typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp,
+ SCM program, SCM *argv, size_t nargs);
static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
{ vm_regular_engine, vm_debug_engine };
@@ -828,15 +823,11 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
SCM_CHECK_STACK;
- return vm_engines[vp->engine](vm, program, argv, nargs);
+ return vm_engines[vp->engine](vp, program, argv, nargs);
}
-/* Scheme interface */
-
-SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
- (void),
- "Return the current thread's VM.")
-#define FUNC_NAME s_scm_the_vm
+SCM
+scm_the_vm (void)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
@@ -845,69 +836,20 @@ SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
return t->vm;
}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_vm_p
-{
- return scm_from_bool (SCM_VM_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
- (void),
- "")
-#define FUNC_NAME s_scm_make_vm,
-{
- return make_vm ();
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_ip
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_sp
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
-}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fp
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
-}
-#undef FUNC_NAME
+/* Scheme interface */
#define VM_DEFINE_HOOK(n) \
{ \
struct scm_vm *vp; \
- SCM_VALIDATE_VM (1, vm); \
- vp = SCM_VM_DATA (vm); \
+ vp = SCM_VM_DATA (scm_the_vm ()); \
if (scm_is_false (vp->hooks[n])) \
vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
return vp->hooks[n]; \
}
-SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_apply_hook
{
@@ -915,8 +857,8 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0,
0,
- (SCM vm),
+SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0,
0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_push_continuation_hook
{
@@ -924,8 +866,8 @@ SCM_DEFINE (scm_vm_push_continuation_hook,
"vm-push-continuation-hook", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_pop_continuation_hook
{
@@ -933,8 +875,8 @@ SCM_DEFINE (scm_vm_pop_continuation_hook,
"vm-pop-continuation-hook", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_next_hook
{
@@ -942,8 +884,8 @@ SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1,
0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0,
0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_abort_continuation_hook
{
@@ -951,8 +893,8 @@ SCM_DEFINE (scm_vm_abort_continuation_hook,
"vm-abort-continuation-hook", 1, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook",
1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook",
0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_restore_continuation_hook
{
@@ -960,23 +902,21 @@ SCM_DEFINE (scm_vm_restore_continuation_hook,
"vm-restore-continuation-hook", 1,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_trace_level
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_int (SCM_VM_DATA (vm)->trace_level);
+ return scm_from_int (SCM_VM_DATA (scm_the_vm ())->trace_level);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
- (SCM vm, SCM level),
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
+ (SCM level),
"")
#define FUNC_NAME s_scm_set_vm_trace_level_x
{
- SCM_VALIDATE_VM (1, vm);
- SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+ SCM_VM_DATA (scm_the_vm ())->trace_level = scm_to_int (level);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1013,36 +953,33 @@ vm_engine_to_symbol (int engine, const char *FUNC_NAME)
}
}
-SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_engine
{
- SCM_VALIDATE_VM (1, vm);
- return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
+ return vm_engine_to_symbol (SCM_VM_DATA (scm_the_vm ())->engine, FUNC_NAME);
}
#undef FUNC_NAME
void
-scm_c_set_vm_engine_x (SCM vm, int engine)
+scm_c_set_vm_engine_x (int engine)
#define FUNC_NAME "set-vm-engine!"
{
- SCM_VALIDATE_VM (1, vm);
-
if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
- SCM_VM_DATA (vm)->engine = engine;
+ SCM_VM_DATA (scm_the_vm ())->engine = engine;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
- (SCM vm, SCM engine),
+SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0,
+ (SCM engine),
"")
#define FUNC_NAME s_scm_set_vm_engine_x
{
- scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
+ scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1069,63 +1006,15 @@ SCM_DEFINE (scm_set_default_vm_engine_x,
"set-default-vm-engine!", 1, 0, 0,
}
#undef FUNC_NAME
-static void reinstate_vm (SCM vm)
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- t->vm = vm;
-}
-
-SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
- (SCM vm, SCM proc, SCM args),
+/* FIXME: This function makes no sense, but we keep it to make sure we
+ have a way of switching to the debug or regular VM. */
+SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
+ (SCM proc, SCM args),
"Apply @var{proc} to @var{args} in a dynamic extent in which\n"
- "@var{vm} is the current VM.\n\n"
- "As an implementation restriction, if @var{vm} is not the same\n"
- "as the current thread's VM, continuations captured within the\n"
- "call to @var{proc} may not be reinstated once control leaves\n"
- "@var{proc}.")
+ "@var{vm} is the current VM.")
#define FUNC_NAME s_scm_call_with_vm
{
- SCM prev_vm, ret;
- SCM *argv;
- int i, nargs;
- scm_t_wind_flags flags;
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROC (2, proc);
-
- nargs = scm_ilength (args);
- if (SCM_UNLIKELY (nargs < 0))
- scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
-
- argv = alloca (nargs * sizeof(SCM));
- for (i = 0; i < nargs; i++)
- {
- argv[i] = SCM_CAR (args);
- args = SCM_CDR (args);
- }
-
- prev_vm = t->vm;
-
- /* Reentry can happen via invokation of a saved continuation, but
- continuations only save the state of the VM that they are in at
- capture-time, which might be different from this one. So, in the
- case that the VMs are different, set up a non-rewindable frame to
- prevent reinstating an incomplete continuation. */
- flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
- if (flags)
- {
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
- t->vm = vm;
- }
-
- ret = scm_c_vm_run (vm, proc, argv, nargs);
-
- if (flags)
- scm_dynwind_end ();
-
- return ret;
+ return scm_apply_0 (proc, args);
}
#undef FUNC_NAME
diff --git a/libguile/vm.h b/libguile/vm.h
index bb07454..0b1a941 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -45,9 +45,9 @@ struct scm_vm {
size_t stack_size; /* stack size */
SCM *stack_base; /* stack base address */
SCM *stack_limit; /* stack limit address */
- int engine; /* which vm engine we're using */
- SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
int trace_level; /* traces enabled if trace_level > 0 */
+ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
+ int engine; /* which vm engine we're using */
};
SCM_API SCM scm_the_vm_fluid;
@@ -57,27 +57,20 @@ SCM_API SCM scm_the_vm_fluid;
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
SCM_API SCM scm_the_vm (void);
-SCM_API SCM scm_make_vm (void);
-
-SCM_API SCM scm_the_vm (void);
-SCM_API SCM scm_call_with_vm (SCM vm, SCM proc, SCM args);
-
-SCM_API SCM scm_vm_p (SCM obj);
-SCM_API SCM scm_vm_ip (SCM vm);
-SCM_API SCM scm_vm_sp (SCM vm);
-SCM_API SCM scm_vm_fp (SCM vm);
-SCM_API SCM scm_vm_apply_hook (SCM vm);
-SCM_API SCM scm_vm_push_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_pop_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_abort_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_restore_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_next_hook (SCM vm);
-SCM_API SCM scm_vm_trace_level (SCM vm);
-SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
-SCM_API SCM scm_vm_engine (SCM vm);
-SCM_API SCM scm_set_vm_engine_x (SCM vm, SCM engine);
+SCM_API SCM scm_call_with_vm (SCM proc, SCM args);
+
+SCM_API SCM scm_vm_apply_hook (void);
+SCM_API SCM scm_vm_push_continuation_hook (void);
+SCM_API SCM scm_vm_pop_continuation_hook (void);
+SCM_API SCM scm_vm_abort_continuation_hook (void);
+SCM_API SCM scm_vm_restore_continuation_hook (void);
+SCM_API SCM scm_vm_next_hook (void);
+SCM_API SCM scm_vm_trace_level (void);
+SCM_API SCM scm_set_vm_trace_level_x (SCM level);
+SCM_API SCM scm_vm_engine (void);
+SCM_API SCM scm_set_vm_engine_x (SCM engine);
SCM_API SCM scm_set_default_vm_engine_x (SCM engine);
-SCM_API void scm_c_set_vm_engine_x (SCM vm, int engine);
+SCM_API void scm_c_set_vm_engine_x (int engine);
SCM_API void scm_c_set_default_vm_engine_x (int engine);
#define SCM_F_VM_CONT_PARTIAL 0x1
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index bd19316..7da0a6b 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -32,7 +32,7 @@
;;;
(define-module (ice-9 command-line)
- #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
+ #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!)
#:export (compile-shell-switches
version-etc
*GPLv3+*
@@ -422,7 +422,7 @@ If FILE begins with `-' the -s switch is mandatory.
(and interactive? (not turn-off-debugging?)))
(begin
(set-default-vm-engine! 'debug)
- (set-vm-engine! (the-vm) 'debug)))
+ (set-vm-engine! 'debug)))
;; Return this value.
`(;; It would be nice not to load up (ice-9 control), but the
diff --git a/module/statprof.scm b/module/statprof.scm
index 7ef4430..7c3a339 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -295,8 +295,7 @@
;; confuse guile wrt re-enabling the trap when
;; count-call finishes.
(if %count-calls?
- (set-vm-trace-level! (the-vm)
- (1- (vm-trace-level (the-vm)))))
+ (set-vm-trace-level! (1- (vm-trace-level))))
(accumulate-time stop-time)))
(setitimer ITIMER_PROF
@@ -308,8 +307,7 @@
(begin
(set! last-start-time (get-internal-run-time))
(if %count-calls?
- (set-vm-trace-level! (the-vm)
- (1+ (vm-trace-level (the-vm)))))))))
+ (set-vm-trace-level! (1+ (vm-trace-level))))))))
(set! inside-profiler? #f))
@@ -357,8 +355,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
(car sampling-frequency)
(cdr sampling-frequency)))
(if %count-calls?
- (add-hook! (vm-apply-hook (the-vm)) count-call))
- (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+ (add-hook! (vm-apply-hook) count-call))
+ (set-vm-trace-level! (1+ (vm-trace-level)))
#t)))
;; Do not call this from statprof internal functions -- user only.
@@ -371,9 +369,9 @@ than @code{statprof-stop}, @code{#f} otherwise."
(begin
(set! gc-time-taken
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
- (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
+ (set-vm-trace-level! (1- (vm-trace-level)))
(if %count-calls?
- (remove-hook! (vm-apply-hook (the-vm)) count-call))
+ (remove-hook! (vm-apply-hook) count-call))
;; I believe that we need to do this before getting the time
;; (unless we want to make things even more complicated).
(set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
@@ -754,7 +752,7 @@ whole call tree, for later analysis. Use
@code{statprof-fetch-stacks} or
(set! last-start-time (get-internal-run-time))
(set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
(add-hook! after-gc-hook gc-callback)
- (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+ (set-vm-trace-level! (1+ (vm-trace-level)))
#t)))
(define (stop)
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index ea66ce1..f47e33f 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -50,9 +50,10 @@
;;; Gathering coverage data.
;;;
-(define (with-code-coverage vm thunk)
- "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect
code
-coverage data. Return code coverage data and the values returned by THUNK."
+(define (with-code-coverage thunk)
+ "Run THUNK, a zero-argument procedure, while instrumenting Guile's VM to
+collect code coverage data. Return code coverage data and the values returned
+by THUNK."
(define ip-counts
;; A table mapping instruction pointers to the number of times they were
@@ -69,16 +70,16 @@ coverage data. Return code coverage data and the values
returned by THUNK."
;; VM is different from the current one, continuations will not be
;; resumable.
(call-with-values (lambda ()
- (let ((level (vm-trace-level vm))
- (hook (vm-next-hook vm)))
+ (let ((level (vm-trace-level))
+ (hook (vm-next-hook)))
(dynamic-wind
(lambda ()
- (set-vm-trace-level! vm (+ level 1))
+ (set-vm-trace-level! (+ level 1))
(add-hook! hook collect!))
(lambda ()
- (call-with-vm vm thunk))
+ (call-with-vm thunk))
(lambda ()
- (set-vm-trace-level! vm level)
+ (set-vm-trace-level! level)
(remove-hook! hook collect!)))))
(lambda args
(apply values (make-coverage-data ip-counts) args))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 0135b39..30acba4 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -67,57 +67,54 @@
(format #f "~v:@y" width val))
values))))))
-(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-calls-to-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
(define (return-handler frame depth . values)
(print-return frame depth width prefix max-indent values))
- (trap-calls-to-procedure proc apply-handler return-handler
- #:vm vm))
+ (trap-calls-to-procedure proc apply-handler return-handler))
-(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-calls-in-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
(define (return-handler frame depth . values)
(print-return frame depth width prefix max-indent values))
- (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:vm vm))
+ (trap-calls-in-dynamic-extent proc apply-handler return-handler))
-(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-instructions-in-procedure proc #:key (width 80)
(max-indent (- width 40)))
(define (trace-next frame)
;; FIXME: We could disassemble this instruction here.
(let ((ip (frame-instruction-pointer frame)))
(format #t "0x~x\n" ip)))
- (trap-instructions-in-dynamic-extent proc trace-next
- #:vm vm))
+ (trap-instructions-in-dynamic-extent proc trace-next))
;; Note that because this procedure manipulates the VM trace level
;; directly, it doesn't compose well with traps at the REPL.
;;
(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
- (width 80) (vm (the-vm)) (max-indent (- width 40)))
+ (width 80) (max-indent (- width 40)))
(let ((call-trap #f)
(inst-trap #f))
(dynamic-wind
(lambda ()
(if calls?
(set! call-trap
- (trace-calls-in-procedure thunk #:vm vm #:width width
+ (trace-calls-in-procedure thunk #:width width
#:max-indent max-indent)))
(if instructions?
(set! inst-trap
- (trace-instructions-in-procedure thunk #:vm vm #:width width
+ (trace-instructions-in-procedure thunk #:width width
#:max-indent max-indent)))
- (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+ (set-vm-trace-level! (1+ (vm-trace-level))))
thunk
(lambda ()
- (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (set-vm-trace-level! (1- (vm-trace-level)))
(if call-trap (call-trap))
(if inst-trap (inst-trap))
(set! call-trap #f)
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index e334c01..464740b 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -146,19 +146,19 @@
;;;
-;;; VM-local trap states
+;;; Per-thread trap states
;;;
-(define *trap-states* (make-weak-key-hash-table))
+;; FIXME: This should be thread-local -- not something you can inherit
+;; from a dynamic state.
-(define (trap-state-for-vm vm)
- (or (hashq-ref *trap-states* vm)
- (let ((ts (make-trap-state)))
- (hashq-set! *trap-states* vm ts)
- (trap-state-for-vm vm))))
+(define %trap-state (make-parameter #f))
(define (the-trap-state)
- (trap-state-for-vm (the-vm)))
+ (or (%trap-state)
+ (let ((ts (make-trap-state)))
+ (%trap-state ts)
+ ts)))
@@ -173,11 +173,11 @@
(lambda ()
;; Don't enable hooks if the handler is #f.
(if handler
- (set-vm-trace-level! (the-vm) (trap-state->trace-level
trap-state))))
+ (set-vm-trace-level! (trap-state->trace-level trap-state))))
thunk
(lambda ()
(if handler
- (set-vm-trace-level! (the-vm) 0))))))
+ (set-vm-trace-level! 0))))))
(define* (list-traps #:optional (trap-state (the-trap-state)))
(map trap-wrapper-index (trap-state-wrappers trap-state)))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 2d1a09a..7fab208 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -83,7 +83,7 @@
(if (not (predicate? arg))
(error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
-(define (new-disabled-trap vm enable disable)
+(define (new-disabled-trap enable disable)
(let ((enabled? #f))
(define-syntax disabled?
(identifier-syntax
@@ -104,8 +104,8 @@
enable-trap))
-(define (new-enabled-trap vm frame enable disable)
- ((new-disabled-trap vm enable disable) frame))
+(define (new-enabled-trap frame enable disable)
+ ((new-disabled-trap enable disable) frame))
;; Returns an absolute IP.
(define (program-last-ip prog)
@@ -126,8 +126,7 @@
;; A basic trap, fires when a procedure is called.
;;
-(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
- (closure? #f)
+(define* (trap-at-procedure-call proc handler #:key (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check handler procedure?)
@@ -137,11 +136,11 @@
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; A more complicated trap, traps when control enters a procedure.
;;
@@ -158,8 +157,7 @@
;; * An abort.
;;
(define* (trap-in-procedure proc enter-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
@@ -208,29 +206,28 @@
(enter-proc frame)))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook)
- (add-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) restore-hook)
+ (add-hook! (vm-apply-hook) apply-hook)
+ (add-hook! (vm-push-continuation-hook) push-cont-hook)
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook)
+ (add-hook! (vm-restore-continuation-hook) restore-hook)
(if (and frame (our-frame? frame))
(enter-proc frame)))
(lambda (frame)
(if in-proc?
(exit-proc frame))
- (remove-hook! (vm-apply-hook vm) apply-hook)
- (remove-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) restore-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)
+ (remove-hook! (vm-push-continuation-hook) push-cont-hook)
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)
+ (remove-hook! (vm-restore-continuation-hook) restore-hook)))))
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -242,15 +239,15 @@
(next-handler frame)))
(define (enter frame)
- (add-hook! (vm-next-hook vm) next-hook)
+ (add-hook! (vm-next-hook) next-hook)
(if frame (next-hook frame)))
(define (exit frame)
(exit-handler frame)
- (remove-hook! (vm-next-hook vm) next-hook))
+ (remove-hook! (vm-next-hook) next-hook))
(trap-in-procedure proc enter exit
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (non-negative-integer? x)
@@ -277,8 +274,7 @@
;; trap-at-procedure-ip-in-range.
;;
(define* (trap-at-procedure-ip-in-range proc range handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -311,7 +307,7 @@
(set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (program-sources-by-line proc file)
@@ -375,8 +371,7 @@
;; trap-at-source-location. The parameter `user-line' is one-indexed, as
;; a user counts lines, instead of zero-indexed, as Guile counts lines.
;;
-(define* (trap-at-source-location file user-line handler
- #:key current-frame (vm (the-vm)))
+(define* (trap-at-source-location file user-line handler #:key current-frame)
(arg-check file string?)
(arg-check user-line positive-integer?)
(arg-check handler procedure?)
@@ -385,7 +380,7 @@
(lambda () (source-closures-or-procedures file (1- user-line)))
(lambda (procs closures?)
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(set! traps
(map
@@ -393,7 +388,6 @@
(let ((range (source->ip-range proc file (1- user-line))))
(trap-at-procedure-ip-in-range proc range handler
#:current-frame
current-frame
- #:vm vm
#:closure? closures?)))
procs))
(if (null? traps)
@@ -408,8 +402,7 @@
;; do useful things during the dynamic extent of a procedure's
;; application. First, a trap for when a frame returns.
;;
-(define* (trap-frame-finish frame return-handler abort-handler
- #:key (vm (the-vm)))
+(define (trap-frame-finish frame return-handler abort-handler)
(arg-check frame frame?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
@@ -427,25 +420,24 @@
(apply abort-handler frame values))))
(new-enabled-trap
- vm frame
+ frame
(lambda (frame)
(if (not fp)
(error "return-or-abort traps may only be enabled once"))
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) abort-hook))
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook)
+ (add-hook! (vm-restore-continuation-hook) abort-hook))
(lambda (frame)
(set! fp #f)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)
+ (remove-hook! (vm-restore-continuation-hook) abort-hook)))))
;; A more traditional dynamic-wind trap. Perhaps this should not be
;; based on the above trap-frame-finish?
;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler
abort-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
@@ -467,25 +459,23 @@
(begin
(enter-handler frame)
(set! exit-trap
- (trap-frame-finish frame return-hook abort-hook
- #:vm vm)))))
+ (trap-frame-finish frame return-hook abort-hook)))))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
(if exit-trap
(abort-hook frame))
(set! exit-trap #f)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; Trapping all procedure calls within a dynamic extent, recording the
;; depth of the call stack relative to the original procedure.
;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -505,14 +495,14 @@
;; FIXME: recalc depth on abort
(define (enter frame)
- (add-hook! (vm-push-continuation-hook vm) trace-push)
- (add-hook! (vm-pop-continuation-hook vm) trace-pop)
- (add-hook! (vm-apply-hook vm) trace-apply))
+ (add-hook! (vm-push-continuation-hook) trace-push)
+ (add-hook! (vm-pop-continuation-hook) trace-pop)
+ (add-hook! (vm-apply-hook) trace-apply))
(define (leave frame)
- (remove-hook! (vm-push-continuation-hook vm) trace-push)
- (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
- (remove-hook! (vm-apply-hook vm) trace-apply))
+ (remove-hook! (vm-push-continuation-hook) trace-push)
+ (remove-hook! (vm-pop-continuation-hook) trace-pop)
+ (remove-hook! (vm-apply-hook) trace-apply))
(define (return frame)
(leave frame))
@@ -521,14 +511,13 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent.
;;
(define* (trap-instructions-in-dynamic-extent proc next-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -538,10 +527,10 @@
(next-handler frame))
(define (enter frame)
- (add-hook! (vm-next-hook vm) trace-next))
+ (add-hook! (vm-next-hook) trace-next))
(define (leave frame)
- (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-next-hook) trace-next))
(define (return frame)
(leave frame))
@@ -550,13 +539,12 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call
depth.
;;
-(define* (trap-calls-to-procedure proc apply-handler return-handler
- #:key (vm (the-vm)))
+(define (trap-calls-to-procedure proc apply-handler return-handler)
(arg-check proc procedure?)
(arg-check apply-handler procedure?)
(arg-check return-handler procedure?)
@@ -584,7 +572,7 @@
(frame-finished frame))
(set! finish-trap
- (trap-frame-finish frame return-hook abort-hook #:vm vm))
+ (trap-frame-finish frame return-hook abort-hook))
(set! pending-finish-traps
(cons finish-trap pending-finish-traps))))))
@@ -613,12 +601,11 @@
(with-pending-finish-enablers (trap frame))))
(with-pending-finish-disablers
- (trap-at-procedure-call proc apply-hook #:vm vm))))
+ (trap-at-procedure-call proc apply-hook))))
;; Trap when the source location changes.
;;
-(define* (trap-matching-instructions frame-pred handler
- #:key (vm (the-vm)))
+(define (trap-matching-instructions frame-pred handler)
(arg-check frame-pred procedure?)
(arg-check handler procedure?)
(let ()
@@ -627,8 +614,8 @@
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-next-hook vm) next-hook))
+ (add-hook! (vm-next-hook) next-hook))
(lambda (frame)
- (remove-hook! (vm-next-hook vm) next-hook)))))
+ (remove-hook! (vm-next-hook) next-hook)))))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 0d6f5cc..ffed907 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -1,6 +1,6 @@
;;; Guile VM core
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -19,10 +19,7 @@
;;; Code:
(define-module (system vm vm)
- #:export (vm?
- make-vm the-vm call-with-vm
- vm:ip vm:sp vm:fp
-
+ #:export (call-with-vm
vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine!
vm-push-continuation-hook vm-pop-continuation-hook
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 5b292c4..52ce6b1 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -360,22 +360,18 @@
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
(abort-to-prompt 'does-not-exist)))
-(with-test-prefix/c&e "the-vm"
+(with-test-prefix/c&e "unwind"
- (pass-if "unwind changes VMs"
- (let ((new-vm (make-vm))
- (prev-vm (the-vm))
- (proc (lambda (x y)
+ (pass-if "unwind through call-with-vm"
+ (let ((proc (lambda (x y)
(expt x y)))
(call (lambda (p x y)
(p x y))))
(catch 'foo
(lambda ()
- (call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
- (lambda (key vm)
- (and (eq? key 'foo)
- (eq? vm new-vm)
- (eq? (the-vm) prev-vm)))))))
+ (call-with-vm (lambda () (throw 'foo))))
+ (lambda (key)
+ (eq? key 'foo))))))
;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 7a7a6c5..33b839a 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -33,8 +33,6 @@
(read-enable 'positions)
(compile (read input))))))
-(define %test-vm (make-vm))
-
(define test-procedure
(compile '(lambda (x)
(if (> x 2)
@@ -48,7 +46,7 @@
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
(+ x y)) ;; 1")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(= 3 result)
@@ -63,7 +61,7 @@
(display x) ;; 3
(+ x y)))) ;; 4")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(let-values (((instr exec)
@@ -78,7 +76,7 @@
(+ (/ x y) ;; 1
(* x y))) ;; 2")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "bar.scm")))
(and (pair? counts)
@@ -101,7 +99,7 @@
((= x 0) #t) ;; 7
((< x 0) 'never))))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 77)))))
(let ((counts (line-execution-counts data "fooz.scm")))
(and (pair? counts)
@@ -125,7 +123,7 @@
(+ x y)) ;; 4
(+ x y))) ;; 5")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
@@ -148,7 +146,7 @@
(not (even? (1- x)))))) ;; 4
even?)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 0)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
@@ -166,7 +164,7 @@
((x) (+ x 3)) ;; 1
((x y) (+ x y))) ;; 2")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(+ (proc 1) (proc 2 3))))))
(let ((counts (line-execution-counts data "cl.scm")))
@@ -179,7 +177,7 @@
(let ((proc (code "one-liner.scm"
"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 451 1884)))))
(let ((counts (line-execution-counts data "one-liner.scm")))
(equal? counts '((0 . 1))))))))
@@ -190,7 +188,7 @@
(pass-if "several times"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (+ (proc 1 2) (proc 2 3))))))
(and (coverage-data? data)
(= 3 result)
@@ -199,7 +197,7 @@
(pass-if "case-lambda"
(let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(+ (proc 1) (proc 2 3))))))
(and (coverage-data? data)
@@ -209,7 +207,7 @@
(pass-if "never"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
@@ -220,14 +218,14 @@
(proc (lambda args (length args)))
(b (make-struct <box> 0 proc)))
(let-values (((data result)
- (with-code-coverage %test-vm b)))
+ (with-code-coverage b)))
(and (coverage-data? data)
(= 0 result)
(= (procedure-execution-count data proc) 1)))))
(pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
- ;; test makes sure that they get to use %TEST-VM.
+ ;; test makes sure that their calls are traced.
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
(call (false-if-exception ; can we resolve `scm_call_2'?
(pointer->procedure '*
@@ -236,7 +234,7 @@
'(* * *)))))
(if call
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(call (make-pointer (object-address proc))
(make-pointer (object-address 1))
@@ -248,7 +246,7 @@
(pass-if "called from eval"
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(eval '(test-procedure 123) (current-module))))))
(and (coverage-data? data)
@@ -261,7 +259,7 @@
(pass-if "source files are listed as expected"
(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((files (map basename (instrumented-source-files data))))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 8930cf2..2e0a767 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -18,7 +18,7 @@
(define-module (test-suite test-eval)
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
- :use-module ((system vm vm) :select (make-vm call-with-vm))
+ :use-module ((system vm vm) :select (call-with-vm))
:use-module (ice-9 documentation)
:use-module (ice-9 local-eval))
@@ -437,9 +437,8 @@
;; FIXME: this test does not test what it is intending to test
(pass-if-exception "exception raised"
exception:vm-error
- (let ((vm (make-vm))
- (thunk (let loop () (cons 's (loop)))))
- (call-with-vm vm thunk))))
+ (let ((thunk (let loop () (cons 's (loop)))))
+ (call-with-vm thunk))))
;;;
;;; docstrings
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-g9b4c3ab,
Andy Wingo <=