[Guile-commits] 07/41: Remove primitive?, add primitive-code?

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8af3423efe1aa4168a097cf9ae11d3c4338894bb
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 27 11:44:11 2015 +0100

    Remove primitive?, add primitive-code?
    
    We need to be able to identify frames that are primitive applications
    without assuming that slot 0 in a frame is an SCM value and without
    assuming that value is the procedure being applied.
    
    * libguile/gsubr.c (scm_i_primitive_code_p): New helper.
      (scm_i_primitive_arity): Use the new helper.
    * libguile/gsubr.h: Declare the new helper.
    
    * libguile/programs.h:
    * libguile/programs.c (scm_program_code_p): New function, replacing
      scm_primitive_p.
      (scm_primitive_call_ip): Fix FUNC_NAME definition.
    
    * module/statprof.scm (sample-stack-procs, count-call): Identify
      primitive frames from the IP, not the frame-procedure.  Avoids the
      assumption that slot 0 in a frame is a SCM value.
      (statprof-proc-call-data): Adapt to primitive-code? change.
    
    * module/system/vm/frame.scm (frame-call-representation): Identify
      primitive frames from the IP, not the closure.  Still more work to do
      here to avoid assuming slot 0 is a procedure.
    
    * module/system/vm/program.scm: Export primitive-code? instead of
      primitive?.
      (program-arguments-alist, program-arguments-alists): Identify
      primitives from the code instead of the flags on the program.  Not
      sure this is a great change, but it does avoid having to define a
      primitive? predicate in Scheme.
---
 libguile/gsubr.c             |   15 +++++++++--
 libguile/gsubr.h             |    1 +
 libguile/programs.c          |   12 +++++---
 libguile/programs.h          |    2 +-
 module/statprof.scm          |   33 ++++++++++++++----------
 module/system/vm/frame.scm   |    2 +-
 module/system/vm/program.scm |   57 +++++++++++++++++++----------------------
 7 files changed, 67 insertions(+), 55 deletions(-)

diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index a3b804b..d80e5dd 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -251,6 +251,17 @@ create_subr (int define, const char *name,
   return ret;
 }
 
+int
+scm_i_primitive_code_p (const scm_t_uint32 *code)
+{
+  if (code < subr_stub_code)
+    return 0;
+  if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
+    return 0;
+
+  return 1;
+}
+
 /* Given a program that is a primitive, determine its minimum arity.
    This is possible because each primitive's code is 4 32-bit words
    long, and they are laid out contiguously in an ordered pattern.  */
@@ -260,9 +271,7 @@ scm_i_primitive_arity (SCM prim, int *req, int *opt, int 
*rest)
   const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
   unsigned idx, nargs, base, next;
 
-  if (code < subr_stub_code)
-    return 0;
-  if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
+  if (!scm_i_primitive_code_p (code))
     return 0;
 
   idx = (code - subr_stub_code) / 4;
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index a9db85e..725de2c 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -54,6 +54,7 @@
 
 
 
+SCM_INTERNAL int scm_i_primitive_code_p (const scm_t_uint32 *code);
 SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int 
*rest);
 SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);
 
diff --git a/libguile/programs.c b/libguile/programs.c
index 64c861a..c03865d 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -144,19 +144,21 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0,
-           (SCM obj),
+SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0,
+           (SCM code),
            "")
-#define FUNC_NAME s_scm_primitive_p
+#define FUNC_NAME s_scm_primitive_code_p
 {
-  return scm_from_bool (SCM_PRIMITIVE_P (obj));
+  const scm_t_uint32 * ptr = (const scm_t_uint32 *) scm_to_uintptr_t (code);
+
+  return scm_from_bool (scm_i_primitive_code_p (ptr));
 }
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
            (SCM prim),
            "")
-#define FUNC_NAME s_scm_primitive_p
+#define FUNC_NAME s_scm_primitive_call_ip
 {
   SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
 
diff --git a/libguile/programs.h b/libguile/programs.h
index d170c1b..c962995 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -58,7 +58,7 @@ scm_i_make_program (const scm_t_uint32 *code)
 SCM_INTERNAL SCM scm_program_p (SCM obj);
 SCM_INTERNAL SCM scm_program_code (SCM program);
 
-SCM_INTERNAL SCM scm_primitive_p (SCM obj);
+SCM_INTERNAL SCM scm_primitive_code_p (SCM code);
 SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim);
 
 SCM_INTERNAL SCM scm_i_program_name (SCM program);
diff --git a/module/statprof.scm b/module/statprof.scm
index e613aad..74b32c0 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -327,10 +327,13 @@
       (set-buffer! state buffer)
       (set-buffer-pos! state (1+ pos)))
      (else
-      (let ((proc (frame-procedure frame)))
-        (write-sample-and-continue (if (primitive? proc)
-                                       (procedure-name proc)
-                                       (frame-instruction-pointer frame))))))))
+      (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)))))))
 
 (define (reset-sigprof-timer usecs)
   ;; Guile's setitimer binding is terrible.
@@ -376,11 +379,11 @@
     (unless (inside-profiler? state)
       (accumulate-time state (get-internal-run-time))
 
-      (let* ((key (let ((proc (frame-procedure frame)))
-                    (cond
-                     ((primitive? proc) (procedure-name proc))
-                     ((program? proc) (program-code proc))
-                     (else proc))))
+      ;; 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))
              (handle (hashv-create-handle! (call-counts state) key 0)))
         (set-cdr! handle (1+ (cdr handle))))
 
@@ -594,11 +597,13 @@ it represents different functions with the same name."
 none is available."
   (when (statprof-active?)
     (error "Can't call statprof-proc-call-data while profiler is running."))
-  (hashv-ref (stack-samples->procedure-data state)
-             (cond
-              ((primitive? proc) (procedure-name proc))
-              ((program? proc) (program-code proc))
-              (else (program-code proc)))))
+  (unless (program? proc)
+    (error "statprof-call-data only works for VM programs"))
+  (let* ((code (program-code proc))
+         (key (if (primitive-code? code)
+                  (procedure-name proc)
+                  code)))
+    (hashv-ref (stack-samples->procedure-data state) key)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Stats
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 38850b6..8945e58 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -402,7 +402,7 @@
                                        (arity-keyword-args arity)
                                        (arity-has-rest? arity)
                                        1))))
-      ((and (primitive? closure)
+      ((and (primitive-code? ip)
             (program-arguments-alist closure ip))
        => (lambda (args)
             (match args
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 59cb8c0..9f5b764 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -44,7 +44,7 @@
 
             print-program
 
-            primitive?))
+            primitive-code?))
 
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_programs")
@@ -195,28 +195,25 @@ of integers."
 ;; the name "program-arguments" is taken by features.c...
 (define* (program-arguments-alist prog #:optional ip)
   "Returns the signature of the given procedure in the form of an association 
list."
-  (cond
-   ((primitive? prog)
-    (match (procedure-minimum-arity prog)
-      (#f #f)
-      ((nreq nopt rest?)
-       (let ((start (primitive-call-ip prog)))
-         ;; Assume that there is only one IP for the call.
-         (and (or (not ip) (= start ip))
-              (arity->arguments-alist
-               prog
-               (list 0 0 nreq nopt rest? '(#f . ()))))))))
-   ((program? prog)
-    (or-map (lambda (arity)
-              (and (or (not ip)
-                       (and (<= (arity-low-pc arity) ip)
-                            (< ip (arity-high-pc arity))))
-                   (arity-arguments-alist arity)))
-            (or (find-program-arities (program-code prog)) '())))
-   (else
-    (let ((arity (program-arity prog ip)))
-      (and arity
-           (arity->arguments-alist prog arity))))))
+  (let ((code (program-code prog)))
+    (cond
+     ((primitive-code? code)
+      (match (procedure-minimum-arity prog)
+        (#f #f)
+        ((nreq nopt rest?)
+         (let ((start (primitive-call-ip prog)))
+           ;; Assume that there is only one IP for the call.
+           (and (or (not ip) (= start ip))
+                (arity->arguments-alist
+                 prog
+                 (list 0 0 nreq nopt rest? '(#f . ()))))))))
+     (else
+      (or-map (lambda (arity)
+                (and (or (not ip)
+                         (and (<= (arity-low-pc arity) ip)
+                              (< ip (arity-high-pc arity))))
+                     (arity-arguments-alist arity)))
+              (or (find-program-arities code) '()))))))
 
 (define* (program-lambda-list prog #:optional ip)
   "Returns the signature of the given procedure in the form of an argument 
list."
@@ -252,14 +249,12 @@ lists."
         (arity->arguments-alist
          prog
          (list 0 0 nreq nopt rest? '(#f . ())))))))
-  (cond
-   ((primitive? prog) (fallback))
-   ((program? prog)
-    (let ((arities (find-program-arities (program-code prog))))
-      (if arities
-          (map arity-arguments-alist arities)
-          (fallback))))
-   (else (error "expected a program" prog))))
+  (let* ((code (program-code prog))
+         (arities (and (not (primitive-code? code))
+                       (find-program-arities code))))
+    (if arities
+        (map arity-arguments-alist arities)
+        (fallback))))
 
 (define* (print-program #:optional program (port (current-output-port))
                         #:key (addr (program-code program))