diff options
-rw-r--r-- | libguile/frames.c | 35 | ||||
-rw-r--r-- | libguile/frames.h | 4 | ||||
-rw-r--r-- | module/statprof.scm | 14 | ||||
-rw-r--r-- | module/system/repl/debug.scm | 3 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 27 |
5 files changed, 52 insertions, 31 deletions
diff --git a/libguile/frames.c b/libguile/frames.c index e1d7cf872..534720f4c 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -222,9 +222,9 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, - (SCM frame), - "") +static const char s_scm_frame_num_locals[] = "frame-num-locals"; +static SCM +scm_frame_num_locals (SCM frame) #define FUNC_NAME s_scm_frame_num_locals { union scm_vm_stack_element *fp, *sp; @@ -262,9 +262,9 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos) return 0; /* Not reached. */ } -SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, - (SCM frame, SCM index, SCM representation), - "") +static const char s_scm_frame_local_ref[] = "frame-local-ref"; +static SCM +scm_frame_local_ref (SCM frame, SCM index, SCM representation) #define FUNC_NAME s_scm_frame_local_ref { union scm_vm_stack_element *fp, *sp; @@ -300,10 +300,9 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, } #undef FUNC_NAME -/* Need same not-yet-active frame logic here as in frame-num-locals */ -SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, - (SCM frame, SCM index, SCM val, SCM representation), - "") +static const char s_scm_frame_local_set_x[] = "frame-local-set!"; +static SCM +scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation) #define FUNC_NAME s_scm_frame_local_set_x { union scm_vm_stack_element *fp, *sp; @@ -449,12 +448,28 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, #undef FUNC_NAME +static void +scm_init_frames_builtins (void *unused) +{ + scm_c_define_gsubr (s_scm_frame_num_locals, 1, 0, 0, + (scm_t_subr) scm_frame_num_locals); + scm_c_define_gsubr (s_scm_frame_local_ref, 3, 0, 0, + (scm_t_subr) scm_frame_local_ref); + scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0, + (scm_t_subr) scm_frame_local_set_x); +} + void scm_init_frames (void) { #ifndef SCM_MAGIC_SNARFER #include "libguile/frames.x" #endif + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_frames_builtins", + scm_init_frames_builtins, + NULL); } /* diff --git a/libguile/frames.h b/libguile/frames.h index 5aa5499ba..ef668a9ce 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -162,10 +162,6 @@ SCM_API SCM scm_frame_procedure_name (SCM frame); SCM_API SCM scm_frame_call_representation (SCM frame); SCM_API SCM scm_frame_arguments (SCM frame); SCM_API SCM scm_frame_source (SCM frame); -SCM_API SCM scm_frame_num_locals (SCM frame); -SCM_API SCM scm_frame_local_ref (SCM frame, SCM index, SCM representation); -SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val, - SCM representation); SCM_API SCM scm_frame_address (SCM frame); SCM_API SCM scm_frame_stack_pointer (SCM frame); SCM_API SCM scm_frame_instruction_pointer (SCM frame); diff --git a/module/statprof.scm b/module/statprof.scm index 8fb0951e8..7a18bb420 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -329,13 +329,8 @@ (set-buffer! state buffer) (set-buffer-pos! state (1+ pos))) (else - (let ((ip (frame-instruction-pointer frame))) - (write-sample-and-continue - (if (primitive-code? ip) - ;; Grovel and get the primitive name from the gsubr, which - ;; we know to be in slot 0. - (procedure-name (frame-local-ref frame 0 'scm)) - ip))))))) + (write-sample-and-continue + (frame-instruction-pointer-or-primitive-procedure-name frame)))))) (define (reset-sigprof-timer usecs) ;; Guile's setitimer binding is terrible. @@ -382,10 +377,7 @@ (accumulate-time state (get-internal-run-time)) ;; We know local 0 is a SCM value: the c - (let* ((ip (frame-instruction-pointer frame)) - (key (if (primitive-code? ip) - (procedure-name (frame-local-ref frame 0 'scm)) - ip)) + (let* ((key (frame-instruction-pointer-or-primitive-procedure-name frame)) (handle (hashv-create-handle! (call-counts state) key 0))) (set-cdr! handle (1+ (cdr handle)))) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 18ac10f5b..4bd9e2758 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -115,8 +115,7 @@ (format port "~aLocal variables:~%" per-line-prefix) (for-each (lambda (binding) - (let ((v (frame-local-ref frame (binding-slot binding) - (binding-representation binding)))) + (let ((v (frame-binding-ref frame binding))) (display per-line-prefix port) (run-hook before-print-hook v) (format port "~a = ~v:@y\n" (binding-name binding) width v))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index ccfc05745..15e745d18 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -33,6 +33,7 @@ binding-slot binding-representation + frame-instruction-pointer-or-primitive-procedure-name frame-bindings frame-lookup-binding frame-binding-ref frame-binding-set! @@ -40,6 +41,10 @@ frame-environment frame-object-binding frame-object-name)) +(eval-when (expand compile load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_frames_builtins")) + (define-record-type <binding> (make-binding idx name slot representation) binding? @@ -300,14 +305,18 @@ (lp (cdr bindings)))))) (define (frame-binding-set! frame var val) - (let ((binding (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame)))) + (let ((binding (if (binding? var) + var + (or (frame-lookup-binding frame var) + (error "variable not bound in frame" var frame))))) (frame-local-set! frame (binding-slot binding) val (binding-representation binding)))) (define (frame-binding-ref frame var) - (let ((binding (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame)))) + (let ((binding (if (binding? var) + var + (or (frame-lookup-binding frame var) + (error "variable not bound in frame" var frame))))) (frame-local-ref frame (binding-slot binding) (binding-representation binding)))) @@ -340,6 +349,16 @@ (define (frame-arguments frame) (cdr (frame-call-representation frame))) +;; Usually the IP is sufficient to identify the procedure being called. +;; However all primitive applications of the same arity share the same +;; code. Perhaps we should change that in the future, but for now we +;; export this function to avoid having to export frame-local-ref. +;; +(define (frame-instruction-pointer-or-primitive-procedure-name frame) + (let ((ip (frame-instruction-pointer frame))) + (if (primitive-code? ip) + (procedure-name (frame-local-ref frame 0 'scm)) + ip))) ;;; |