}
/* Let's go! */
- BOOT_HOOK ();
NEXT;
#ifndef HAVE_LABELS_AS_VALUES
#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 ())
VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
{
- HALT_HOOK ();
nvalues = SCM_I_INUM (*sp--);
NULLSTACK (1);
if (nvalues == 1)
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 ();
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;
}
CHECK_STACK_LEAK ();
#endif
- EXIT_HOOK ();
-
/* switch programs */
CACHE_PROGRAM ();
/* shuffle down the program and the arguments */
ip = SCM_C_OBJCODE_BASE (bp);
- ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
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;
}
VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
{
vm_return:
- EXIT_HOOK ();
- RETURN_HOOK (1);
+ POP_CONTINUATION_HOOK (1);
VM_HANDLE_INTERRUPTS;
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;
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_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_enter_hook
+#define FUNC_NAME s_scm_vm_apply_hook
{
- VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_apply_hook, "vm-apply-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_apply_hook
+#define FUNC_NAME s_scm_vm_push_continuation_hook
{
- VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_exit_hook, "vm-exit-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_exit_hook
+#define FUNC_NAME s_scm_vm_pop_continuation_hook
{
- VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_return_hook
+#define FUNC_NAME s_scm_vm_next_hook
{
- VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+ VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
}
#undef FUNC_NAME
#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;
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);
#: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*))
(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)))
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")
HCoop / bpt / guile.git / commitdiff