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

@@ -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

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);

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)))
+          (when frame
             (print-location frame port)
-                (format port "In procedure ~a:\n"
-                        (or (false-if-exception (procedure-name proc))
-                            proc))))
+            (let ((name (false-if-exception (frame-procedure-name frame))))
+              (when name
+                (format port "In procedure ~a:\n" name))))
 
           (print-location frame port)
           (catch #t

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)