summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/frames.c35
-rw-r--r--libguile/frames.h4
-rw-r--r--module/statprof.scm14
-rw-r--r--module/system/repl/debug.scm3
-rw-r--r--module/system/vm/frame.scm27
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)))
;;;