diff options
-rw-r--r-- | libguile/frames.c | 23 | ||||
-rw-r--r-- | libguile/frames.h | 1 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 11 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 26 |
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) |