Remove frame-local-ref, frame-local-set!

* libguile/frames.h (scm_frame_num_locals, scm_frame_local_ref)
  (scm_frame_local_set_x): Remove.  As long as we are changing the
  interface in a backward-incompatible way, we might as well remove
  these.
* libguile/frames.c (scm_frame_num_locals, scm_frame_local_ref)
  (scm_frame_local_set_x, scm_init_frames_builtins, scm_init_frames):
  Arrange to make frame-local-ref et al private to frames.scm.

* module/system/vm/frame.scm: Load scm_init_frames_builtins extensions.
  (frame-instruction-pointer-or-primitive-procedure-name): New public
  function.
  (frame-binding-ref, frame-binding-set!): Allow binding objects as
  vars.

* module/system/repl/debug.scm (print-locals): Pass binding directly to
  frame-binding-ref.

* module/statprof.scm (sample-stack-procs, count-call): Use new
  frame-instruction-pointer-or-primitive-procedure-name function.

libguile/frames.c

@@ -222,9 +222,9 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
+static const char s_scm_frame_num_locals[] = "frame-num-locals";
-	    (SCM frame),
+static SCM
-	    "")
+scm_frame_num_locals (SCM frame)
 #define FUNC_NAME s_scm_frame_num_locals
 {
   union scm_vm_stack_element *fp, *sp;
@@ -262,9 +262,9 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos)
   return 0;  /* Not reached.  */
 }
 
-SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0,
+static const char s_scm_frame_local_ref[] = "frame-local-ref";
-	    (SCM frame, SCM index, SCM representation),
+static SCM
-	    "")
+scm_frame_local_ref (SCM frame, SCM index, SCM representation)
 #define FUNC_NAME s_scm_frame_local_ref
 {
   union scm_vm_stack_element *fp, *sp;
@@ -300,10 +300,9 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0,
 }
 #undef FUNC_NAME
 
-/* Need same not-yet-active frame logic here as in frame-num-locals */
+static const char s_scm_frame_local_set_x[] = "frame-local-set!";
-SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0,
+static SCM
-	    (SCM frame, SCM index, SCM val, SCM representation),
+scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation)
-	    "")
 #define FUNC_NAME s_scm_frame_local_set_x
 {
   union scm_vm_stack_element *fp, *sp;
@@ -449,12 +448,28 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 #undef FUNC_NAME
 
 
+static void
+scm_init_frames_builtins (void *unused)
+{
+  scm_c_define_gsubr (s_scm_frame_num_locals, 1, 0, 0,
+                      (scm_t_subr) scm_frame_num_locals);
+  scm_c_define_gsubr (s_scm_frame_local_ref, 3, 0, 0,
+                      (scm_t_subr) scm_frame_local_ref);
+  scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0,
+                      (scm_t_subr) scm_frame_local_set_x);
+}
+
 void
 scm_init_frames (void)
 {
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/frames.x"
 #endif
+
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_frames_builtins",
+                            scm_init_frames_builtins,
+                            NULL);
 }
 
 /*

libguile/frames.h

@@ -162,10 +162,6 @@ 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);
-SCM_API SCM scm_frame_num_locals (SCM frame);
-SCM_API SCM scm_frame_local_ref (SCM frame, SCM index, SCM representation);
-SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val,
-                                   SCM representation);
 SCM_API SCM scm_frame_address (SCM frame);
 SCM_API SCM scm_frame_stack_pointer (SCM frame);
 SCM_API SCM scm_frame_instruction_pointer (SCM frame);

module/statprof.scm

@@ -329,13 +329,8 @@
       (set-buffer! state buffer)
       (set-buffer-pos! state (1+ pos)))
      (else
-      (let ((ip (frame-instruction-pointer frame)))
+      (write-sample-and-continue
-        (write-sample-and-continue
+       (frame-instruction-pointer-or-primitive-procedure-name frame))))))
-         (if (primitive-code? ip)
-             ;; Grovel and get the primitive name from the gsubr, which
-             ;; we know to be in slot 0.
-             (procedure-name (frame-local-ref frame 0 'scm))
-             ip)))))))
 
 (define (reset-sigprof-timer usecs)
   ;; Guile's setitimer binding is terrible.
@@ -382,10 +377,7 @@
       (accumulate-time state (get-internal-run-time))
 
       ;; We know local 0 is a SCM value: the c
-      (let* ((ip (frame-instruction-pointer frame))
+      (let* ((key (frame-instruction-pointer-or-primitive-procedure-name frame))
-             (key (if (primitive-code? ip)
-                      (procedure-name (frame-local-ref frame 0 'scm))
-                      ip))
              (handle (hashv-create-handle! (call-counts state) key 0)))
         (set-cdr! handle (1+ (cdr handle))))
 

module/system/repl/debug.scm

@@ -115,8 +115,7 @@
       (format port "~aLocal variables:~%" per-line-prefix)
       (for-each
        (lambda (binding)
-         (let ((v (frame-local-ref frame (binding-slot binding)
+         (let ((v (frame-binding-ref frame binding)))
-                                   (binding-representation binding))))
            (display per-line-prefix port)
            (run-hook before-print-hook v)
            (format port "~a = ~v:@y\n" (binding-name binding) width v)))

module/system/vm/frame.scm

@@ -33,6 +33,7 @@
             binding-slot
             binding-representation
 
+            frame-instruction-pointer-or-primitive-procedure-name
             frame-bindings
             frame-lookup-binding
             frame-binding-ref frame-binding-set!
@@ -40,6 +41,10 @@
             frame-environment
             frame-object-binding frame-object-name))
 
+(eval-when (expand compile load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_frames_builtins"))
+
 (define-record-type <binding>
   (make-binding idx name slot representation)
   binding?
@@ -300,14 +305,18 @@
            (lp (cdr bindings))))))
 
 (define (frame-binding-set! frame var val)
-  (let ((binding (or (frame-lookup-binding frame var)
+  (let ((binding (if (binding? var)
-                     (error "variable not bound in frame" var frame))))
+                     var
+                     (or (frame-lookup-binding frame var)
+                         (error "variable not bound in frame" var frame)))))
     (frame-local-set! frame (binding-slot binding) val
                       (binding-representation binding))))
 
 (define (frame-binding-ref frame var)
-  (let ((binding (or (frame-lookup-binding frame var)
+  (let ((binding (if (binding? var)
-                     (error "variable not bound in frame" var frame))))
+                     var
+                     (or (frame-lookup-binding frame var)
+                         (error "variable not bound in frame" var frame)))))
     (frame-local-ref frame (binding-slot binding)
                      (binding-representation binding))))
 
@@ -340,6 +349,16 @@
 (define (frame-arguments frame)
   (cdr (frame-call-representation frame)))
 
+;; Usually the IP is sufficient to identify the procedure being called.
+;; However all primitive applications of the same arity share the same
+;; code.  Perhaps we should change that in the future, but for now we
+;; export this function to avoid having to export frame-local-ref.
+;;
+(define (frame-instruction-pointer-or-primitive-procedure-name frame)
+  (let ((ip (frame-instruction-pointer frame)))
+    (if (primitive-code? ip)
+        (procedure-name (frame-local-ref frame 0 'scm))
+        ip)))
 
 
 ;;;