procedure-properties for RTL functionswip-rtl

* module/system/vm/assembler.scm (link-procprops, link-objects): Arrange
  to write procedure property links out to a separate section.

* libguile/procprop.c (scm_procedure_properties):
* libguile/programs.h:
* libguile/programs.c (scm_i_rtl_program_properties):
* module/system/vm/debug.scm (find-program-properties): Wire up
  procedure-properties for RTL procedures.  Yeah!  Fistpumps!  :)

* module/system/vm/debug.scm (find-program-debug-info): Return #f if the
  string is "", as it is if we don't have a name.  Perhaps
  elf-symbol-name should return #f in that case...
  (find-program-docstring): Bugfix: increment by docstr-len.

* test-suite/tests/rtl.test: Add some tests.

7 files changed, 181 insertions, 9 deletions

diff --git a/libguile/procprop.c b/libguile/procprop.c
index d7ce09b95..2d9e6550b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -146,6 +146,8 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
     {
       if (SCM_PROGRAM_P (proc))
         ret = scm_i_program_properties (proc);
+      else if (SCM_RTL_PROGRAM_P (proc))
+        ret = scm_i_rtl_program_properties (proc);
       else
         ret = SCM_EOL;
     }
diff --git a/libguile/programs.c b/libguile/programs.c
index 567708a51..d8dd3783b 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -136,6 +136,18 @@ scm_i_rtl_program_documentation (SCM program)
   return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
 }
 
+SCM
+scm_i_rtl_program_properties (SCM program)
+{
+  static SCM rtl_program_properties = SCM_BOOL_F;
+
+  if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
+    rtl_program_properties =
+      scm_c_private_variable ("system vm program", "rtl-program-properties");
+
+  return scm_call_1 (scm_variable_ref (rtl_program_properties), program);
+}
+
 void
 scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
 {
diff --git a/libguile/programs.h b/libguile/programs.h
index 175059fbc..e42a76e41 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -46,6 +46,7 @@ SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
 
 SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
 SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
 
 /*
  * Programs
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 12aa24d0b..4080110c0 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1222,8 +1222,69 @@
                                    (linker-object-section strtab)))
               strtab))))
 
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values.  Pc and addr are both 32 bits wide.  (Either could change to
+;;; 64 bits if appropriate in the future.)  Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first.  (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+  (define (assoc-remove-one alist key value-pred)
+    (match alist
+      (() '())
+      ((((? (lambda (x) (eq? x key))) . value) . alist)
+       (if (value-pred value)
+           alist
+           (acons key value alist)))
+      (((k . v) . alist)
+       (acons k v (assoc-remove-one alist key value-pred)))))
+  (define (props-without-name-or-docstring meta)
+    (assoc-remove-one
+     (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+     'documentation
+     string?))
+  (define (find-procprops)
+    (filter-map (lambda (meta)
+                  (let ((props (props-without-name-or-docstring meta)))
+                    (and (pair? props)
+                         (cons (meta-low-pc meta) props))))
+                (reverse (asm-meta asm))))
+  (let* ((endianness (asm-endianness asm))
+         (procprops (find-procprops))
+         (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+    (let lp ((procprops procprops) (pos 0) (relocs '()))
+      (match procprops
+        (()
+         (make-object asm '.guile.procprops
+                      bv
+                      relocs '()
+                      #:type SHT_PROGBITS #:flags 0))
+        (((pc . props) . procprops)
+         (bytevector-u32-set! bv pos pc endianness)
+         (lp procprops
+             (+ pos procprops-size)
+             (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+                                      (intern-constant asm props))
+                   relocs)))))))
+
 (define (link-objects asm)
-  (let*-values (((ro rw rw-init) (link-constants asm))
+  (let*-values (;; Link procprops before constants, because it probably
+                ;; interns more constants.
+                ((procprops) (link-procprops asm))
+                ((ro rw rw-init) (link-constants asm))
                 ;; Link text object after constants, so that the
                 ;; constants initializer gets included.
                 ((text) (link-text-object asm))
@@ -1236,7 +1297,7 @@
                 ((shstrtab) (link-shstrtab asm)))
     (filter identity
             (list text ro rw dt symtab strtab arities arities-strtab
-                  docstrs docstrs-strtab shstrtab))))
+                  docstrs docstrs-strtab procprops shstrtab))))
 
 (define (link-assembly asm)
   (link-elf (link-objects asm)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index c6b535997..0e3881080 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -53,7 +53,9 @@
             find-program-arities
             program-minimum-arity
 
-            find-program-docstring))
+            find-program-docstring
+
+            find-program-properties))
 
 (define-record-type <debug-context>
   (make-debug-context elf base text-base)
@@ -146,6 +148,7 @@
                                          ;; stripped somehow.
                                          (lambda (x)
                                            (and (string? x)
+                                                (not (string-null? x))
                                                 (string->symbol x))))
                                   (elf-symbol-value sym)
                                   (elf-symbol-size sym))))
@@ -332,7 +335,7 @@
          (cond
           ((>= pos end) #f)
           ((< text-offset (bytevector-u32-native-ref bv pos))
-           (lp (+ pos arity-header-len)))
+           (lp (+ pos docstr-len)))
           ((> text-offset (bytevector-u32-native-ref bv pos))
            #f)
           (else
@@ -340,3 +343,44 @@
                                       (elf-section-link sec)))
                  (idx (bytevector-u32-native-ref bv (+ pos 4))))
              (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
+
+(define* (find-program-properties addr #:optional
+                                  (context (find-debug-context addr)))
+  (define (add-name-and-docstring props)
+    (define (maybe-acons k v tail)
+      (if v (acons k v tail) tail))
+    (let ((name (and=> (find-program-debug-info addr context)
+                       program-debug-info-name))
+          (docstring (find-program-docstring addr context)))
+      (maybe-acons 'name name
+                   (maybe-acons 'documentation docstring props))))
+  (add-name-and-docstring
+   (cond
+    ((elf-section-by-name (debug-context-elf context) ".guile.procprops")
+     => (lambda (sec)
+          ;; struct procprop {
+          ;;   uint32_t pc;
+          ;;   uint32_t offset;
+          ;; }
+          (define procprop-len 8)
+          (let* ((start (elf-section-offset sec))
+                 (end (+ start (elf-section-size sec)))
+                 (bv (elf-bytes (debug-context-elf context)))
+                 (text-offset (- addr
+                                 (debug-context-text-base context)
+                                 (debug-context-base context))))
+            (define (unpack-scm addr)
+              (pointer->scm (make-pointer addr)))
+            (define (load-non-immediate offset)
+              (unpack-scm (+ (debug-context-base context) offset)))
+            ;; FIXME: This is linear search.  Change to binary search.
+            (let lp ((pos start))
+              (cond
+               ((>= pos end) '())
+               ((< text-offset (bytevector-u32-native-ref bv pos))
+                (lp (+ pos procprop-len)))
+               ((> text-offset (bytevector-u32-native-ref bv pos))
+                '())
+               (else
+                (load-non-immediate
+                 (bytevector-u32-native-ref bv (+ pos 4))))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index d719e954c..267e373c5 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -54,24 +54,24 @@
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_programs")
 
-;; This procedure is called by programs.c.
+;; These procedures are called by programs.c.
 (define (rtl-program-name program)
   (unless (rtl-program? program)
     (error "shouldn't get here"))
   (and=> (find-program-debug-info (rtl-program-code program))
          program-debug-info-name))
-
-;; This procedure is called by programs.c.
 (define (rtl-program-documentation program)
   (unless (rtl-program? program)
     (error "shouldn't get here"))
   (find-program-docstring (rtl-program-code program)))
-
-;; 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 (rtl-program-properties program)
+  (unless (rtl-program? program)
+    (error "shouldn't get here"))
+  (find-program-properties (rtl-program-code program)))
 
 (define (make-binding name boxed? index start end)
   (list name boxed? index start end))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 6b8ce251b..6e377bacc 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -335,3 +335,55 @@
           (return 0)
           (end-arity)
           (end-program))))))
+
+(with-test-prefix "procedure properties"
+  ;; No properties.
+  (pass-if-equal '()
+      (procedure-properties
+       (assemble-program
+        '((begin-program foo ())
+          (begin-standard-arity () 1 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program)))))
+
+  ;; Name and docstring (which actually don't go out to procprops).
+  (pass-if-equal '((name . foo)
+                   (documentation . "qux qux"))
+      (procedure-properties
+       (assemble-program
+        '((begin-program foo ((name . foo) (documentation . "qux qux")))
+          (begin-standard-arity () 1 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program)))))
+
+  ;; A property that actually needs serialization.
+  (pass-if-equal '((name . foo)
+                   (documentation . "qux qux")
+                   (moo . "mooooooooooooo"))
+      (procedure-properties
+       (assemble-program
+        '((begin-program foo ((name . foo)
+                              (documentation . "qux qux")
+                              (moo . "mooooooooooooo")))
+          (begin-standard-arity () 1 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program)))))
+
+  ;; Procedure-name still works in this case.
+  (pass-if-equal 'foo
+      (procedure-name
+       (assemble-program
+        '((begin-program foo ((name . foo)
+                              (documentation . "qux qux")
+                              (moo . "mooooooooooooo")))
+          (begin-standard-arity () 1 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program))))))