[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-12-32-g8d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-32-g8d033f4 |
|
Date: |
Thu, 16 Sep 2010 11:34:14 +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=8d033f4839b6d935367cc647564b2068a006ca30
The branch, master has been updated
via 8d033f4839b6d935367cc647564b2068a006ca30 (commit)
via 839eb61cde38c0cbd68c3dee92298dd5922ab2b2 (commit)
via 8ad2fadc4967200f8c455d86277db4823bf4d679 (commit)
via f312025167c5a93aacae69aef63be2fdc6bed7c6 (commit)
via c45d4d775d47bd80650e9888bf47815a03b04332 (commit)
via 7c42238610dbf5780d9aeb12ca799c83f9f6167e (commit)
from f1ee6d54d219056c62d87a8e4a6b199162c946e8 (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 8d033f4839b6d935367cc647564b2068a006ca30
Author: Andy Wingo <address@hidden>
Date: Thu Sep 16 13:04:57 2010 +0200
instruction tracing tweak
* module/system/vm/trace.scm (vm-trace): No need to output the opcode
number, and display the ip as a decimal, not a hexidecimal.
commit 839eb61cde38c0cbd68c3dee92298dd5922ab2b2
Author: Andy Wingo <address@hidden>
Date: Thu Sep 16 12:58:59 2010 +0200
only trace instructions inside the thunk
* module/system/vm/trace.scm (vm-trace): Only trace instructions when
we're in the dynamic extent of the thunk.
commit 8ad2fadc4967200f8c455d86277db4823bf4d679
Author: Andy Wingo <address@hidden>
Date: Thu Sep 16 12:52:17 2010 +0200
update vm hooks doc
* doc/ref/api-evaluation.texi (VM Behaviour): Half-hearted doc update.
commit f312025167c5a93aacae69aef63be2fdc6bed7c6
Author: Andy Wingo <address@hidden>
Date: Thu Sep 16 12:48:41 2010 +0200
add vm-abort-continuation-hook, vm-restore-continuation-hook
* libguile/vm-i-system.c (call_cc, tail_call_cc): Call the new
RESTORE_CONTINUATION_HOOK when a continuation is restored.
(prompt): Call the new ABORT_CONTINUATION_HOOK when entering the abort
handler's continuation.
* libguile/vm-engine.h (ABORT_CONTINUATION_HOOK)
(RESTORE_CONTINUATION_HOOK):
* libguile/vm.h (SCM_VM_ABORT_CONTINUATION_HOOK)
(SCM_VM_RESTORE_CONTINUATION_HOOK):
* libguile/vm.c: (scm_vm_abort_continuation_hook): New hook, called when
entering an abort handler.
(scm_vm_restore_continuation_hook): New hook, called after returning
to a continuation.
* module/system/vm/vm.scm: Add hooks to export list.
commit c45d4d775d47bd80650e9888bf47815a03b04332
Author: Andy Wingo <address@hidden>
Date: Thu Sep 16 12:14:55 2010 +0200
trim our set of vm hooks
* libguile/vm.h (SCM_VM_PUSH_CONTINUATION_HOOK)
(SCM_VM_POP_CONTINUATION_HOOK): New hooks, to replace
enter/exit/return.
(SCM_VM_BOOT_HOOK, SCM_VM_HALT_HOOK, SCM_VM_BREAK_HOOK): Remove these
useless hooks.
* libguile/vm.c (scm_vm_push_continuation_hook)
(scm_vm_pop_continuation_hook): New accessors.
* libguile/vm-i-system.c: Remove boot, halt, break, enter, exit, and
return hooks. Also remove the break instruction. Instead now when we
push a new continuation onto the stack we call PUSH_CONTINUATION_HOOK,
and when we pop via a return we call POP_CONTINUATION_HOOK. APPLY_HOOK
is now decoupled from continuation pushes and pops.
* libguile/vm-engine.h:
* libguile/vm-engine.c: Adapt for hooks.
* module/system/vm/trace.scm (vm-trace): Adapt for hooks. Also revive
the #:instructions? #t mode.
* module/system/vm/vm.scm: Adapt exports for new set of hooks.
commit 7c42238610dbf5780d9aeb12ca799c83f9f6167e
Author: Andy Wingo <address@hidden>
Date: Thu Sep 16 12:03:10 2010 +0200
remove unused (system vm profile)
* module/Makefile.am:
* module/system/vm/profile.scm: Remove (system vm profile). We use
statprof.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-evaluation.texi | 14 ++---
libguile/vm-engine.c | 1 -
libguile/vm-engine.h | 20 ++++---
libguile/vm-i-system.c | 43 ++++++++-------
libguile/vm.c | 54 ++++++------------
libguile/vm.h | 30 +++++------
module/Makefile.am | 2 +-
module/system/vm/profile.scm | 64 ----------------------
module/system/vm/trace.scm | 122 ++++++++++++++++++++++--------------------
module/system/vm/vm.scm | 6 ++-
10 files changed, 141 insertions(+), 215 deletions(-)
delete mode 100644 module/system/vm/profile.scm
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 211649b..2e7d9dd 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -875,14 +875,12 @@ virtual machine's predefined hooks:
@deffn {Scheme Procedure} vm-next-hook vm
@deffnx {Scheme Procedure} vm-apply-hook vm
address@hidden {Scheme Procedure} vm-boot-hook vm
address@hidden {Scheme Procedure} vm-return-hook vm
address@hidden {Scheme Procedure} vm-break-hook vm
address@hidden {Scheme Procedure} vm-exit-hook vm
address@hidden {Scheme Procedure} vm-halt-hook vm
address@hidden {Scheme Procedure} vm-enter-hook vm
-Accessors to a virtual machine's hooks. Usually you pass
address@hidden(the-vm)} as the @var{vm}.
address@hidden {Scheme Procedure} vm-push-continuation-hook vm
address@hidden {Scheme Procedure} vm-pop-continuation-hook vm
address@hidden {Scheme Procedure} vm-abort-continuation-hook vm
address@hidden {Scheme Procedure} vm-restore-continuation-hook vm
+Accessors to a virtual machine's hooks. Usually you pass @code{(the-vm)}
+as the @var{vm}.
@end deffn
@deffn {Scheme Procedure} vm-trace-level vm
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index ff41ce4..5b38060 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -104,7 +104,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
}
/* Let's go! */
- BOOT_HOOK ();
NEXT;
#ifndef HAVE_LABELS_AS_VALUES
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 836648c..ad226dc 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -224,14 +224,18 @@
#define RUN_HOOK1(h, x)
#endif
-#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK)
-#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK)
-#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK)
-#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK)
-#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK)
-#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK)
-#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK)
-#define RETURN_HOOK(n) RUN_HOOK1 (SCM_VM_RETURN_HOOK, SCM_I_MAKINUM (n))
+#define APPLY_HOOK() \
+ RUN_HOOK (SCM_VM_APPLY_HOOK)
+#define PUSH_CONTINUATION_HOOK() \
+ RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
+#define POP_CONTINUATION_HOOK(n) \
+ RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
+#define NEXT_HOOK() \
+ RUN_HOOK (SCM_VM_NEXT_HOOK)
+#define ABORT_CONTINUATION_HOOK() \
+ RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK)
+#define RESTORE_CONTINUATION_HOOK() \
+ RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)
#define VM_HANDLE_INTERRUPTS \
SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 9ba287d..05c632c 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -31,7 +31,6 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
{
- HALT_HOOK ();
nvalues = SCM_I_INUM (*sp--);
NULLSTACK (1);
if (nvalues == 1)
@@ -62,12 +61,6 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
goto vm_done;
}
-VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
-{
- BREAK_HOOK ();
- NEXT;
-}
-
VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
{
DROP ();
@@ -779,7 +772,7 @@ VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
ip = SCM_C_OBJCODE_BASE (bp);
- ENTER_HOOK ();
+ PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
NEXT;
}
@@ -818,8 +811,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
CHECK_STACK_LEAK ();
#endif
- EXIT_HOOK ();
-
/* switch programs */
CACHE_PROGRAM ();
/* shuffle down the program and the arguments */
@@ -832,7 +823,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
ip = SCM_C_OBJCODE_BASE (bp);
- ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
@@ -1083,7 +1073,7 @@ VM_DEFINE_INSTRUCTION (61, mv_call, "mv-call", 4, -1, 1)
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
ip = SCM_C_OBJCODE_BASE (bp);
- ENTER_HOOK ();
+ PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
NEXT;
}
@@ -1152,12 +1142,17 @@ VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
}
else
{
- /* otherwise, the vm continuation was reinstated, and
- scm_i_vm_return_to_continuation pushed on one value. So pull our regs
- back down from the vp, and march on to the next instruction. */
+ /* Otherwise, the vm continuation was reinstated, and
+ vm_return_to_continuation pushed on one value. We know only one
+ value was returned because we are in value context -- the
+ previous block jumped to vm_call, not vm_mv_call, after all.
+
+ So, pull our regs back down from the vp, and march on to the
+ next instruction. */
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
+ RESTORE_CONTINUATION_HOOK ();
NEXT;
}
}
@@ -1187,10 +1182,17 @@ VM_DEFINE_INSTRUCTION (65, tail_call_cc,
"tail-call/cc", 0, 1, 1)
else
{
/* Otherwise, cache regs and NEXT, as above. Invoking the continuation
- does a return from the frame, either to the RA or MVRA. */
+ does a return from the frame, either to the RA or
+ MVRA. */
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
+ /* Unfortunately we don't know whether we are at the RA, and thus
+ have one value without an nvalues marker, or we are at the
+ MVRA and thus have multiple values and the nvalues
+ marker. Instead of adding heuristics here, we will let hook
+ client code do that. */
+ RESTORE_CONTINUATION_HOOK ();
NEXT;
}
}
@@ -1198,8 +1200,7 @@ VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc",
0, 1, 1)
VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
{
vm_return:
- EXIT_HOOK ();
- RETURN_HOOK (1);
+ POP_CONTINUATION_HOOK (1);
VM_HANDLE_INTERRUPTS;
@@ -1238,8 +1239,7 @@ VM_DEFINE_INSTRUCTION (67, return_values,
"return/values", 1, -1, -1)
that perhaps it might be used without declaration. Fooey to that, I say.
*/
nvalues = FETCH ();
vm_return_values:
- EXIT_HOOK ();
- RETURN_HOOK (nvalues);
+ POP_CONTINUATION_HOOK (nvalues);
VM_HANDLE_INTERRUPTS;
@@ -1517,6 +1517,9 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
+ /* The stack contains the values returned to this prompt, along
+ with a number-of-values marker -- like an MV return. */
+ ABORT_CONTINUATION_HOOK ();
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 7a250d4..c0237be 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -668,75 +668,57 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
return vp->hooks[n]; \
}
-SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_boot_hook
-{
- VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_halt_hook
-{
- VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_next_hook
+#define FUNC_NAME s_scm_vm_apply_hook
{
- VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0,
0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_break_hook
+#define FUNC_NAME s_scm_vm_push_continuation_hook
{
- VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_enter_hook
+#define FUNC_NAME s_scm_vm_pop_continuation_hook
{
- VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_apply_hook
+#define FUNC_NAME s_scm_vm_next_hook
{
- VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1,
0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_exit_hook
+#define FUNC_NAME s_scm_vm_abort_continuation_hook
{
- VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook",
1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_return_hook
+#define FUNC_NAME s_scm_vm_restore_continuation_hook
{
- VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK);
}
#undef FUNC_NAME
diff --git a/libguile/vm.h b/libguile/vm.h
index 8e22d02..acf43c2 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -22,15 +22,15 @@
#include <libguile.h>
#include <libguile/programs.h>
-#define SCM_VM_BOOT_HOOK 0
-#define SCM_VM_HALT_HOOK 1
-#define SCM_VM_NEXT_HOOK 2
-#define SCM_VM_BREAK_HOOK 3
-#define SCM_VM_ENTER_HOOK 4
-#define SCM_VM_APPLY_HOOK 5
-#define SCM_VM_EXIT_HOOK 6
-#define SCM_VM_RETURN_HOOK 7
-#define SCM_VM_NUM_HOOKS 8
+enum {
+ SCM_VM_APPLY_HOOK,
+ SCM_VM_PUSH_CONTINUATION_HOOK,
+ SCM_VM_POP_CONTINUATION_HOOK,
+ SCM_VM_NEXT_HOOK,
+ SCM_VM_ABORT_CONTINUATION_HOOK,
+ SCM_VM_RESTORE_CONTINUATION_HOOK,
+ SCM_VM_NUM_HOOKS,
+};
struct scm_vm;
@@ -73,14 +73,12 @@ 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_boot_hook (SCM vm);
-SCM_API SCM scm_vm_halt_hook (SCM vm);
-SCM_API SCM scm_vm_next_hook (SCM vm);
-SCM_API SCM scm_vm_break_hook (SCM vm);
-SCM_API SCM scm_vm_enter_hook (SCM vm);
SCM_API SCM scm_vm_apply_hook (SCM vm);
-SCM_API SCM scm_vm_exit_hook (SCM vm);
-SCM_API SCM scm_vm_return_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_option (SCM vm, SCM key);
SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
SCM_API SCM scm_vm_trace_level (SCM vm);
diff --git a/module/Makefile.am b/module/Makefile.am
index ef5b25f..e575168 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -311,13 +311,13 @@ SYSTEM_SOURCES = \
system/vm/frame.scm \
system/vm/instruction.scm \
system/vm/objcode.scm \
- system/vm/profile.scm \
system/vm/program.scm \
system/vm/trace.scm \
system/vm/vm.scm \
system/foreign.scm \
system/xref.scm \
system/repl/debug.scm \
+ system/repl/hook-state.scm \
system/repl/error-handling.scm \
system/repl/common.scm \
system/repl/command.scm \
diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm
deleted file mode 100644
index 6ab418a..0000000
--- a/module/system/vm/profile.scm
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; Guile VM profiler
-
-;; Copyright (C) 2001 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 as published by the Free Software Foundation; either
-;;; version 3 of the License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (system vm profile)
- #:use-module (system vm vm)
- #:use-module (ice-9 format)
- #:export (vm-profile))
-
-(define (vm-profile vm objcode . opts)
- (let ((flag (vm-option vm 'debug)))
- (dynamic-wind
- (lambda ()
- (set-vm-option! vm 'debug #t)
- (set-vm-option! vm 'profile-data '())
- (add-hook! (vm-next-hook vm) profile-next)
- (add-hook! (vm-enter-hook vm) profile-enter)
- (add-hook! (vm-exit-hook vm) profile-exit))
- (lambda ()
- (vm-load vm objcode)
- (print-result vm))
- (lambda ()
- (set-vm-option! vm 'debug flag)
- (remove-hook! (vm-next-hook vm) profile-next)
- (remove-hook! (vm-enter-hook vm) profile-enter)
- (remove-hook! (vm-exit-hook vm) profile-exit)))))
-
-(define (profile-next vm)
- (set-vm-option! vm 'profile-data
- (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))
-
-(define (profile-enter vm)
- #f)
-
-(define (profile-exit vm)
- #f)
-
-(define (print-result vm . opts)
- (do ((data (vm-option vm 'profile-data) (cdr data))
- (summary '() (let ((inst (caar data)))
- (assq-set! summary inst
- (1+ (or (assq-ref summary inst) 0))))))
- ((null? data)
- (display "Count Instruction\n")
- (display "----- -----------\n")
- (for-each (lambda (entry)
- (format #t "address@hidden ~A\n" (cdr entry) (car entry)))
- (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index dca516c..17f6e83 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -22,81 +22,86 @@
#:use-module (system base syntax)
#:use-module (system vm vm)
#:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:use-module (system vm objcode)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm instruction)
#:use-module (ice-9 format)
#:export (vm-trace))
+;; FIXME: this constant needs to go in system vm objcode
+(define *objcode-header-len* 8)
+
(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
(define *call-depth* #f)
(define *saved-call-depth* #f)
- (define (trace-enter frame)
- (cond
- (*call-depth*
- (set! *call-depth* (1+ *call-depth*)))))
+ (define (print-application frame depth)
+ (format (current-error-port) "~a~v:@y\n"
+ (make-string depth #\|)
+ (max (- width depth) 1)
+ (frame-call-representation frame)))
- (define (trace-exit frame)
- (cond
- ((not *call-depth*))
- (else
- (set! *call-depth* (1- *call-depth*)))))
+ (define (print-return frame depth)
+ (let* ((len (frame-num-locals frame))
+ (nvalues (frame-local-ref frame (1- len))))
+ (cond
+ ((= nvalues 1)
+ (format (current-error-port) "~a~v:@y\n"
+ (make-string depth #\|)
+ width (frame-local-ref frame (- len 2))))
+ (else
+ ;; this should work, but there appears to be a bug
+ ;; "~a~d values:~:{ ~v:@y~}\n"
+ (format (current-error-port) "~a~d values:~{ ~a~}\n"
+ (make-string depth #\|)
+ nvalues
+ (let lp ((vals '()) (i 0))
+ (if (= i nvalues)
+ vals
+ (lp (cons (format #f "~v:@y" width
+ (frame-local-ref frame (- len 2 i)))
+ vals)
+ (1+ i)))))))))
+
+ (define (trace-push frame)
+ (if *call-depth*
+ (set! *call-depth* (1+ *call-depth*))))
+
+ (define (trace-pop frame)
+ (if *call-depth*
+ (begin
+ (print-return frame *call-depth*)
+ (set! *call-depth*
+ (if (zero? *call-depth*)
+ #f
+ (1- *call-depth*))))))
(define (trace-apply frame)
(cond
(*call-depth*
- (format (current-error-port) "~a~v:@y\n"
- (make-string (1- *call-depth*) #\|)
- (max (- width *call-depth* 1) 1)
- (frame-call-representation frame)))
+ (print-application frame *call-depth*))
((eq? (frame-procedure frame) thunk)
- (set! *call-depth* 1))))
+ (set! *call-depth* 0))))
- (define (trace-return frame)
- ;; nop, though we could print the return i guess
- (cond
- ((and *call-depth* (< *call-depth* 0))
- ;; leaving the thunk
- (set! *call-depth* #f))
- (*call-depth*
- (let* ((len (frame-num-locals frame))
- (nvalues (frame-local-ref frame (1- len))))
- (cond
- ((= nvalues 1)
- (format (current-error-port) "~a~v:@y\n"
- (make-string *call-depth* #\|)
- width (frame-local-ref frame (- len 2))))
- (else
- ;; this should work, but there appears to be a bug
- ;; "~a~d values:~:{ ~v:@y~}\n"
- (format (current-error-port) "~a~d values:~{ ~a~}\n"
- (make-string *call-depth* #\|)
- nvalues
- (let lp ((vals '()) (i 0))
- (if (= i nvalues)
- vals
- (lp (cons (format #f "~v:@y" width
- (frame-local-ref frame (- len 2 i)))
- vals)
- (1+ i)))))))))))
-
(define (trace-next frame)
- (format #t "0x~8X" (frame-instruction-pointer frame))
- ;; should disassemble the thingy; could print stack, or stack trace,
- ;; ...
- )
-
+ (if *call-depth*
+ (let* ((ip (frame-instruction-pointer frame))
+ (objcode (program-objcode (frame-procedure frame)))
+ (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+ (+ ip *objcode-header-len*))))
+ (format #t "~8d: ~a\n" ip (opcode->instruction opcode)))))
+
(define (vm-trace-on!)
(if calls?
(begin
- (add-hook! (vm-exit-hook vm) trace-exit)
- (add-hook! (vm-enter-hook vm) trace-enter)
- (add-hook! (vm-apply-hook vm) trace-apply)
- (add-hook! (vm-return-hook vm) trace-return)))
-
+ (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)))
+
(if instructions?
(add-hook! (vm-next-hook vm) trace-next))
- ;; boot, halt, and break are the other ones
-
(set-vm-trace-level! vm (1+ (vm-trace-level vm)))
(set! *call-depth* *saved-call-depth*))
@@ -107,11 +112,10 @@
(if calls?
(begin
- (remove-hook! (vm-exit-hook vm) trace-exit)
- (remove-hook! (vm-enter-hook vm) trace-enter)
- (remove-hook! (vm-apply-hook vm) trace-apply)
- (remove-hook! (vm-return-hook vm) trace-return)))
-
+ (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)))
+
(if instructions?
(remove-hook! (vm-next-hook vm) trace-next)))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index c50959b..3fd96f4 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -28,8 +28,10 @@
vms:time vms:clock
vm-trace-level set-vm-trace-level!
- vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
- vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
+ vm-push-continuation-hook vm-pop-continuation-hook
+ vm-apply-hook
+ vm-next-hook
+ vm-abort-continuation-hook vm-restore-continuation-hook))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_vm")
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-32-g8d033f4,
Andy Wingo <=