diff options
author | Andy Wingo <wingo@pobox.com> | 2015-11-27 12:17:36 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-12-01 11:30:54 +0100 |
commit | 39090e677eed54761e0952f2575ddef1504545d3 (patch) | |
tree | b583cc7c138840531c943af36bfe4be7422df1e9 | |
parent | 8af3423efe1aa4168a097cf9ae11d3c4338894bb (diff) | |
download | guile-39090e677eed54761e0952f2575ddef1504545d3.tar.gz |
Add frame-procedure-name
* libguile/frames.c (frame_procedure_name_var): New static definition.
(init_frame_procedure_name_var): New helper.
(scm_frame_procedure_name): New function that returns the name of the
frame's procedure, as frame-procedure is to be deprecated.
* libguile/frames.h (scm_frame_procedure_name): Export.
* module/ice-9/boot-9.scm (exception-printers): Use frame-procedure-name
instead of procedure-name on frame-procedure.
* module/system/vm/frame.scm (frame-procedure-name): New private
function, implementing scm_frame_procedure_name.
(frame-call-representation): Use frame-procedure-name to get the
procedure name to print.
-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) |