summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/frames.c23
-rw-r--r--libguile/frames.h1
-rw-r--r--module/ice-9/boot-9.scm11
-rw-r--r--module/system/vm/frame.scm26
4 files changed, 52 insertions, 9 deletions
diff --git a/libguile/frames.c b/libguile/frames.c
index 312d53b00..7432f8d84 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -149,6 +149,29 @@ SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
}
#undef FUNC_NAME
+static SCM frame_procedure_name_var;
+
+static void
+init_frame_procedure_name_var (void)
+{
+ frame_procedure_name_var
+ = scm_c_private_lookup ("system vm frame", "frame-procedure-name");
+}
+
+SCM_DEFINE (scm_frame_procedure_name, "frame-procedure-name", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_procedure_name
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_frame_procedure_name_var);
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ return scm_call_1 (scm_variable_ref (frame_procedure_name_var), frame);
+}
+#undef FUNC_NAME
+
static SCM frame_arguments_var;
static void
diff --git a/libguile/frames.h b/libguile/frames.h
index bb402ae71..241e3f3ad 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -157,6 +157,7 @@ SCM_INTERNAL int scm_c_frame_previous (enum scm_vm_frame_kind kind,
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_frame_procedure (SCM frame);
+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);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a5b3422bc..6da8085a0 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -893,12 +893,11 @@ for key @var{k}, then invoke @var{thunk}."
(define (default-printer)
(format port "Throw to key `~a' with args `~s'." key args))
- (if frame
- (let ((proc (frame-procedure frame)))
- (print-location frame port)
- (format port "In procedure ~a:\n"
- (or (false-if-exception (procedure-name proc))
- proc))))
+ (when frame
+ (print-location frame port)
+ (let ((name (false-if-exception (frame-procedure-name frame))))
+ (when name
+ (format port "In procedure ~a:\n" name))))
(print-location frame port)
(catch #t
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 8945e58fb..e9dc2ee33 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -312,6 +312,28 @@
(binding-representation binding))))
+(define* (frame-procedure-name frame #:key
+ (info (find-program-debug-info
+ (frame-instruction-pointer frame))))
+ (cond
+ (info => program-debug-info-name)
+ ;; We can only try to get the name from the closure if we know that
+ ;; slot 0 corresponds to the frame's procedure. This isn't possible
+ ;; to know in general. If the frame has already begun executing and
+ ;; the closure binding is dead, it could have been replaced with any
+ ;; other random value, or an unboxed value. Even if we're catching
+ ;; the frame at its application, before it has started running, if
+ ;; the callee is well-known and has only one free variable, closure
+ ;; optimization could have chosen to represent its closure as that
+ ;; free variable, and that free variable might be some other program,
+ ;; or even an unboxed value. It would be an error to try to get the
+ ;; procedure name of some procedure that doesn't correspond to the
+ ;; one being applied. (Free variables are currently always boxed but
+ ;; that could change in the future.)
+ ((primitive-code? (frame-instruction-pointer frame))
+ (procedure-name (frame-local-ref frame 0 'scm)))
+ (else #f)))
+
;; This function is always called to get some sort of representation of the
;; frame to present to the user, so let's do the logical thing and dispatch to
;; frame-call-representation.
@@ -388,9 +410,7 @@
(else
'())))
(cons
- (or (and=> info program-debug-info-name)
- (and (procedure? closure) (procedure-name closure))
- closure)
+ (frame-procedure-name frame #:info info)
(cond
((find-program-arity ip)
=> (lambda (arity)