[Guile-commits] 08/41: Add frame-procedure-name

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 39090e677eed54761e0952f2575ddef1504545d3
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 27 12:17:36 2015 +0100

    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.
---
 libguile/frames.c          |   23 +++++++++++++++++++++++
 libguile/frames.h          |    1 +
 module/ice-9/boot-9.scm    |   11 +++++------
 module/system/vm/frame.scm |   26 +++++++++++++++++++++++---
 4 files changed, 52 insertions(+), 9 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index 312d53b..7432f8d 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 bb402ae..241e3f3 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 a5b3422..6da8085 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 8945e58..e9dc2ee 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)