mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-14 23:50:19 +02:00
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.
This commit is contained in:
Andy Wingo
parent
7c42238610
commit
c45d4d775d
7 changed files with 103 additions and 153 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -224,14 +224,14 @@
|
|||
#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 VM_HANDLE_INTERRUPTS \
|
||||
SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -1198,8 +1188,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 +1227,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;
|
||||
|
||||
|
|
|
|||
|
|
@ -668,51 +668,6 @@ 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 vm),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_next_hook
|
||||
{
|
||||
VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_break_hook
|
||||
{
|
||||
VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_enter_hook
|
||||
{
|
||||
VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
"")
|
||||
|
|
@ -722,21 +677,30 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_exit_hook, "vm-exit-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_exit_hook
|
||||
#define FUNC_NAME s_scm_vm_push_continuation_hook
|
||||
{
|
||||
VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
|
||||
VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_return_hook, "vm-return-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_return_hook
|
||||
#define FUNC_NAME s_scm_vm_pop_continuation_hook
|
||||
{
|
||||
VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
|
||||
VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_next_hook
|
||||
{
|
||||
VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -22,15 +22,13 @@
|
|||
#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_NUM_HOOKS,
|
||||
};
|
||||
|
||||
struct scm_vm;
|
||||
|
||||
|
|
@ -73,14 +71,10 @@ 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_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);
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
;; ...
|
||||
)
|
||||
|
||||
(let* ((ip (frame-instruction-pointer frame))
|
||||
(objcode (program-objcode (frame-procedure frame)))
|
||||
(opcode (bytevector-u8-ref (objcode->bytecode objcode)
|
||||
(+ ip *objcode-header-len*)))
|
||||
(inst (opcode->instruction opcode)))
|
||||
(format #t "0x~8X: ~a: ~a\n" ip opcode inst)))
|
||||
|
||||
(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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -28,8 +28,9 @@
|
|||
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))
|
||||
|
||||
(load-extension (string-append "libguile-" (effective-version))
|
||||
"scm_init_vm")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue