[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-945-g8506c75

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8506c754edeaa650e17bc694ec5d61717b76f93f

The branch, wip-rtl has been updated
       via  8506c754edeaa650e17bc694ec5d61717b76f93f (commit)
       via  f5ff8be932c51aa2350b3aa5f512e8f075abff03 (commit)
       via  b5eb013084c29bc14ac3a8b3eb2d56a5317b7400 (commit)
       via  23d6998c4682917e4f1680d34e97193feb86dbf1 (commit)
      from  27905236d684c84f93d3857406722aec7a51460e (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 8506c754edeaa650e17bc694ec5d61717b76f93f
Author: Andy Wingo <address@hidden>
Date:   Thu May 16 20:58:54 2013 +0200

    Wire up ability to print RTL program arities
    
    * libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to
      dispatch to scm_i_program_arity.
    
    * libguile/programs.c (scm_i_program_print): Refactor reference to
      write-program.
      (scm_i_rtl_program_minimum_arity): New procedure, dispatches to
      Scheme.
      (scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if
      appropriate.
    
    * module/system/vm/debug.scm (program-minimum-arity): New export.
    
    * module/system/vm/program.scm (rtl-program-minimum-arity): New internal
      function.
      (program-arguments-alists): New helper, implemented also for RTL
      procedures.
      (write-program): Refactor a bit, and call program-arguments-alists.

commit f5ff8be932c51aa2350b3aa5f512e8f075abff03
Author: Andy Wingo <address@hidden>
Date:   Thu May 16 20:28:19 2013 +0200

    Fix circular module dependencies
    
    I don't think this actually caused me problems (how does that work?) but
    it seems a good thing to fix.
    
    * module/system/vm/debug.scm: Don't import (system vm program).  Adapt
      procedures to always expect an addr, not a program.
    
    * module/system/vm/program.scm (rtl-program-name): Pass rtl program addr
      directly.

commit b5eb013084c29bc14ac3a8b3eb2d56a5317b7400
Author: Andy Wingo <address@hidden>
Date:   Thu May 16 18:56:22 2013 +0200

    (system vm debug) can read arity information
    
    * module/system/vm/assembler.scm (write-arity-headers): Fill in the
      prefix.
    
    * module/system/vm/debug.scm (<arity>): New object, for reading
      arities.  Unlike <arity> in the assembler, this one only holds on to a
      couple of pointers, and doesn't even load in argument names.  Unlike
      the arity lists in (system vm program), it can load in names.  Very
      early days but it does seem to work.
      (find-program-arities, arity-arguments-alist): New higher-level
      interfaces.

commit 23d6998c4682917e4f1680d34e97193feb86dbf1
Author: Andy Wingo <address@hidden>
Date:   Thu May 16 17:49:39 2013 +0200

    remove arity nlocals and alternate fields
    
    * module/system/vm/assembler.scm (<arity>): Remove nlocals and alternate
      fields, as they aren't used.  Adapt constructor call.

-----------------------------------------------------------------------

Summary of changes:
 libguile/procprop.c            |   10 +--
 libguile/programs.c            |   30 +++++++-
 module/system/vm/assembler.scm |   11 ++-
 module/system/vm/debug.scm     |  167 ++++++++++++++++++++++++++++++++++++++--
 module/system/vm/program.scm   |   61 ++++++++++-----
 5 files changed, 235 insertions(+), 44 deletions(-)

diff --git a/libguile/procprop.c b/libguile/procprop.c
index 4809702..62476c0 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int 
*rest)
       return 1;
     }
 
-  while (!SCM_PROGRAM_P (proc))
+  while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
     {
       if (SCM_STRUCTP (proc))
         {
@@ -82,14 +82,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int 
*rest)
 
           return 1;
         }
-      else if (SCM_RTL_PROGRAM_P (proc))
-        {
-          *req = 0;
-          *opt = 0;
-          *rest = 1;
-
-          return 1;
-        }
       else
         return 0;
     }
diff --git a/libguile/programs.c b/libguile/programs.c
index d356915..12561b3 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -129,9 +129,8 @@ scm_i_program_print (SCM program, SCM port, scm_print_state 
*pstate)
   static int print_error = 0;
 
   if (scm_is_false (write_program) && scm_module_system_booted_p)
-    write_program = scm_module_local_variable
-      (scm_c_resolve_module ("system vm program"),
-       scm_from_latin1_symbol ("write-program"));
+    write_program = scm_c_private_variable ("system vm program",
+                                            "write-program");
   
   if (SCM_PROGRAM_IS_CONTINUATION (program))
     {
@@ -450,11 +449,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest)
     *req = *opt = *rest = 0;
 }
   
+static int
+scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
+{
+  static SCM rtl_program_minimum_arity = SCM_BOOL_F;
+  SCM l;
+
+  if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
+    rtl_program_minimum_arity =
+        scm_c_private_variable ("system vm debug",
+                                "rtl-program-minimum-arity");
+
+  l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
+  if (scm_is_false (l))
+    return 0;
+
+  *req = scm_to_int (scm_car (l));
+  *opt = scm_to_int (scm_cadr (l));
+  *rest = scm_is_true (scm_caddr (l));
+
+  return 1;
+}
+
 int
 scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
 {
   SCM arities;
   
+  if (SCM_RTL_PROGRAM_P (program))
+    return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
+
   arities = scm_program_arities (program);
   if (!scm_is_pair (arities))
     return 0;
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 79148a9..f39491d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -91,15 +91,13 @@
 ;; Metadata for one <lambda-case>.
 (define-record-type <arity>
   (make-arity req opt rest kw-indices allow-other-keys?
-              nlocals alternate low-pc high-pc)
+              low-pc high-pc)
   arity?
   (req arity-req)
   (opt arity-opt)
   (rest arity-rest)
   (kw-indices arity-kw-indices)
   (allow-other-keys? arity-allow-other-keys?)
-  (nlocals arity-nlocals)
-  (alternate arity-alternate)
   (low-pc arity-low-pc)
   (high-pc arity-high-pc set-arity-high-pc!))
 
@@ -500,7 +498,7 @@
   (check alternate (or #f (? symbol?)) "#f or symbol")
   (let* ((meta (car (asm-meta asm)))
          (arity (make-arity req opt rest kw-indices allow-other-keys?
-                            nlocals alternate (asm-start asm) #f))
+                            (asm-start asm) #f))
          (nreq (length req))
          (nopt (length opt))
          (rest? (->bool rest)))
@@ -1075,7 +1073,10 @@
                          (length (arity-opt arity))))
   (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
     (match metas
-      (() (values pos (reverse offsets)))
+      (()
+       ;; Fill in the prefix.
+       (bytevector-u32-set! bv 0 pos endianness)
+       (values pos (reverse offsets)))
       ((meta . metas)
        (match (meta-arities meta)
          (() (lp metas pos offsets))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 58cb977..c625fb7 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -20,7 +20,6 @@
 
 (define-module (system vm debug)
   #:use-module (system vm elf)
-  #:use-module (system vm program)
   #:use-module (system vm objcode)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
@@ -39,8 +38,20 @@
             program-debug-info-addr
             program-debug-info-u32-offset
             program-debug-info-u32-offset-end
+            find-program-debug-info
 
-            find-program-debug-info))
+            arity?
+            arity-low-pc
+            arity-high-pc
+            arity-nreq
+            arity-nopt
+            arity-has-rest?
+            arity-allow-other-keys?
+            arity-has-keyword-args?
+            arity-is-case-lambda?
+            arity-arguments-alist
+            find-program-arities
+            program-minimum-arity))
 
 (define-record-type <debug-context>
   (make-debug-context elf base text-base)
@@ -86,7 +97,7 @@
         (debug-context-text-base (program-debug-info-context pdi)))
      4))
 
-(define* (find-debug-context #:key program (addr (rtl-program-code program)))
+(define (find-debug-context addr)
   (let* ((bv (find-mapped-elf-image addr))
          (elf (parse-elf bv))
          (base (pointer-address (bytevector->pointer (elf-bytes elf))))
@@ -118,9 +129,8 @@
                       (lp (1+ n)))))))
        (or (bisect) (linear-search))))))
 
-(define* (find-program-debug-info #:key program
-                                  (addr (rtl-program-code program))
-                                  (context (find-debug-context #:addr addr)))
+(define* (find-program-debug-info addr #:optional
+                                  (context (find-debug-context addr)))
   (cond
    ((find-elf-symbol (debug-context-elf context)
                      (- addr
@@ -137,3 +147,148 @@
                                   (elf-symbol-value sym)
                                   (elf-symbol-size sym))))
    (else #f)))
+
+(define-record-type <arity>
+  (make-arity context base header-offset)
+  arity?
+  (context arity-context)
+  (base arity-base)
+  (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;;   struct arity_header {
+;;;     uint32_t low_pc;
+;;;     uint32_t high_pc;
+;;;     uint32_t offset;
+;;;     uint32_t flags;
+;;;     uint32_t nreq;
+;;;     uint32_t nopt;
+;;;   }
+
+(define (arity-low-pc* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;;    #x1: has-rest?
+;;;    #x2: allow-other-keys?
+;;;    #x4: has-keyword-args?
+;;;    #x8: is-case-lambda?
+
+(define (has-rest? flags)         (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags)   (not (zero? (logand flags (ash 1 3)))))
+
+(define (arity-nreq arity)
+  (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+               (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+  (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
+               (arity-header-offset arity)))
+
+(define (arity-flags arity)
+  (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
+                (arity-header-offset arity)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags 
arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags 
arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+  (let ((elf (debug-context-elf (arity-context arity))))
+    (cond
+     ((elf-section-by-name elf ".guile.arities")
+      =>
+      (lambda (sec)
+        (let* ((strtab (elf-section elf (elf-section-link sec)))
+               (bv (elf-bytes elf))
+               (strtab-offset (elf-section-offset strtab)))
+          (lambda (n)
+            (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+     (else (error "couldn't find arities section")))))
+
+(define (arity-arguments-alist arity)
+  (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+         (%load-symbol (arity-load-symbol arity))
+         (header (arity-header-offset arity))
+         (link-offset (arity-offset* bv header))
+         (link (+ (arity-base arity) link-offset))
+         (flags (arity-flags* bv header))
+         (nreq (arity-nreq* bv header))
+         (nopt (arity-nopt* bv header)))
+    (define (load-symbol idx)
+      (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+    (define (load-symbols skip n)
+      (let lp ((n n) (out '()))
+        (if (zero? n)
+            out
+            (lp (1- n)
+                (cons (load-symbol (+ skip (1- n))) out)))))
+    (define (unpack-scm n)
+      (pointer->scm (make-pointer n)))
+    (define (load-non-immediate idx)
+      (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+        (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+    (and (not (is-case-lambda? flags))
+         `((required . ,(load-symbols 0 nreq))
+           (optional . ,(load-symbols nreq nopt))
+           (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
+           (keyword . ,(if (has-keyword-args? flags)
+                           (load-non-immediate
+                            (+ nreq nopt (if (has-rest? flags) 1 0)))
+                           '()))
+           (allow-other-keys? . ,(allow-other-keys? flags))))))
+
+(define (find-first-arity context base addr)
+  (let* ((bv (elf-bytes (debug-context-elf context)))
+         (text-offset (- addr
+                         (debug-context-text-base context)
+                         (debug-context-base context)))
+         (headers-start (+ base arities-prefix-len))
+         (headers-end (+ base (bytevector-u32-native-ref bv base))))
+    ;; FIXME: This is linear search.  Change to binary search.
+    (let lp ((pos headers-start))
+      (cond
+       ((>= pos headers-end) #f)
+       ((< text-offset (arity-low-pc* bv pos))
+        (lp (+ pos arity-header-len)))
+       ((< (arity-high-pc* bv pos) text-offset)
+        #f)
+       (else
+        (make-arity context base pos))))))
+
+(define* (find-program-arities addr #:optional
+                               (context (find-debug-context addr)))
+  (and=>
+   (elf-section-by-name (debug-context-elf context) ".guile.arities")
+   (lambda (sec)
+     (let* ((base (elf-section-offset sec))
+            (first (find-first-arity context base addr)))
+       ;; FIXME: Handle case-lambda arities.
+       (if first (list first) '())))))
+
+(define* (program-minimum-arity addr #:optional
+                                (context (find-debug-context addr)))
+  (and=>
+   (elf-section-by-name (debug-context-elf context) ".guile.arities")
+   (lambda (sec)
+     (let* ((base (elf-section-offset sec))
+            (first (find-first-arity context base addr)))
+       (if (arity-is-case-lambda?)
+           (list 0 0 #t) ;; FIXME: be more precise.
+           (list (arity-nreq arity)
+                 (arity-nopt arity)
+                 (arity-has-rest? arity)))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 2fc3b53..a4bd64e 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -58,9 +58,15 @@
 (define (rtl-program-name program)
   (unless (rtl-program? program)
     (error "shouldn't get here"))
-  (and=> (find-program-debug-info #:program program)
+  (and=> (find-program-debug-info (rtl-program-code program))
          program-debug-info-name))
 
+;; This procedure is called by programs.c.
+(define (rtl-program-minimum-arity program)
+  (unless (rtl-program? program)
+    (error "shouldn't get here"))
+  (program-minimum-arity (rtl-program-code program)))
+
 (define (make-binding name boxed? index start end)
   (list name boxed? index start end))
 (define (binding:name b) (list-ref b 0))
@@ -276,25 +282,38 @@
             1+
             0)))
 
+(define (program-arguments-alists prog)
+  (cond
+   ((rtl-program? prog)
+    (map arity-arguments-alist
+         (find-program-arities (rtl-program-code prog))))
+   ((program? prog)
+    (map (lambda (arity) (arity->arguments-alist prog arity))
+         (or (program-arities prog) '())))
+   (else (error "expected a program" prog))))
+
 (define (write-program prog port)
-  (format port "#<procedure ~a~a>"
-          (or (procedure-name prog)
-              (and=> (and (program? prog) (program-source prog 0))
-                     (lambda (s)
-                       (format #f "~a at ~a:~a:~a"
-                               (number->string (object-address prog) 16)
-                               (or (source:file s)
-                                   (if s "<current input>" "<unknown port>"))
-                               (source:line-for-user s) (source:column s))))
-              (number->string (object-address prog) 16))
-          (let ((arities (and (program? prog) (program-arities prog))))
-            (if (or (not arities) (null? arities))
-                ""
-                (string-append
-                 " " (string-join (map (lambda (a)
-                                         (object->string
-                                          (arguments-alist->lambda-list
-                                           (arity->arguments-alist prog a))))
-                                       arities)
-                                  " | "))))))
+  (define (program-identity-string)
+    (or (procedure-name prog)
+        (and=> (and (program? prog) (program-source prog 0))
+               (lambda (s)
+                 (format #f "~a at ~a:~a:~a"
+                         (number->string (object-address prog) 16)
+                         (or (source:file s)
+                             (if s "<current input>" "<unknown port>"))
+                         (source:line-for-user s) (source:column s))))
+        (number->string (object-address prog) 16)))
 
+  (define (program-formals-string)
+    (let ((arguments (program-arguments-alists prog)))
+      (if (null? arguments)
+          ""
+          (string-append
+           " " (string-join (map (lambda (a)
+                                   (object->string
+                                    (arguments-alist->lambda-list a)))
+                                 arguments)
+                            " | ")))))
+
+  (format port "#<procedure ~a~a>"
+          (program-identity-string) (program-formals-string)))


hooks/post-receive
-- 
GNU Guile