[Guile-commits] 06/10: Remove frame-local-ref, frame-local-set!

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 67e8aa85e81af1644eb75893c173a697ae3d687f
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 30 17:47:03 2016 +0100

    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            |   35 +++++++++++++++++++++++++----------
 libguile/frames.h            |    4 ----
 module/statprof.scm          |   14 +++-----------
 module/system/repl/debug.scm |    3 +--
 module/system/vm/frame.scm   |   27 +++++++++++++++++++++++----
 5 files changed, 52 insertions(+), 31 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index e1d7cf8..534720f 100644
--- a/libguile/frames.c
+++ b/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,
-           (SCM frame),
-           "")
+static const char s_scm_frame_num_locals[] = "frame-num-locals";
+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,
-           (SCM frame, SCM index, SCM representation),
-           "")
+static const char s_scm_frame_local_ref[] = "frame-local-ref";
+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 */
-SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0,
-           (SCM frame, SCM index, SCM val, SCM representation),
-           "")
+static const char s_scm_frame_local_set_x[] = "frame-local-set!";
+static SCM
+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);
 }
 
 /*
diff --git a/libguile/frames.h b/libguile/frames.h
index 5aa5499..ef668a9 100644
--- a/libguile/frames.h
+++ b/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);
diff --git a/module/statprof.scm b/module/statprof.scm
index 8fb0951..7a18bb4 100644
--- a/module/statprof.scm
+++ b/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
-         (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)))))))
+      (write-sample-and-continue
+       (frame-instruction-pointer-or-primitive-procedure-name frame))))))
 
 (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))
-             (key (if (primitive-code? ip)
-                      (procedure-name (frame-local-ref frame 0 'scm))
-                      ip))
+      (let* ((key (frame-instruction-pointer-or-primitive-procedure-name 
frame))
              (handle (hashv-create-handle! (call-counts state) key 0)))
         (set-cdr! handle (1+ (cdr handle))))
 
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 18ac10f..4bd9e27 100644
--- a/module/system/repl/debug.scm
+++ b/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)
-                                   (binding-representation binding))))
+         (let ((v (frame-binding-ref frame binding)))
            (display per-line-prefix port)
            (run-hook before-print-hook v)
            (format port "~a = ~v:@y\n" (binding-name binding) width v)))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index ccfc057..15e745d 100644
--- a/module/system/vm/frame.scm
+++ b/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)
-                     (error "variable not bound in frame" var frame))))
+  (let ((binding (if (binding? var)
+                     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)
-                     (error "variable not bound in frame" var frame))))
+  (let ((binding (if (binding? var)
+                     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)))
 
 
 ;;;