diff options
author | Andy Wingo <wingo@pobox.com> | 2010-09-16 12:14:55 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-09-16 12:16:02 +0200 |
commit | c45d4d775d47bd80650e9888bf47815a03b04332 (patch) | |
tree | 69f38925f200a57d7ec3d3d487da7b5f51b50a12 | |
parent | 7c42238610dbf5780d9aeb12ca799c83f9f6167e (diff) | |
download | guile-c45d4d775d47bd80650e9888bf47815a03b04332.tar.gz |
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.
-rw-r--r-- | libguile/vm-engine.c | 1 | ||||
-rw-r--r-- | libguile/vm-engine.h | 16 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 20 | ||||
-rw-r--r-- | libguile/vm.c | 60 | ||||
-rw-r--r-- | libguile/vm.h | 26 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 122 | ||||
-rw-r--r-- | module/system/vm/vm.scm | 5 |
7 files changed, 100 insertions, 150 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index ff41ce4b6..5b38060d3 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 836648c30..dd735a365 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -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 ()) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 9ba287d5a..063270ffd 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; } @@ -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; diff --git a/libguile/vm.c b/libguile/vm.c index 7a250d4f3..fd96d7ec6 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -668,75 +668,39 @@ 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_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 diff --git a/libguile/vm.h b/libguile/vm.h index 8e22d028c..eff6f1807 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -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); diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index dca516cb7..1b64dbeb4 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, - ;; ... - ) - + (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))) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index c50959bcc..53e0604d4 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -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") |