[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 9/9] procedure-properties for RTL functions
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 9/9] procedure-properties for RTL functions |
|
Date: |
Tue, 4 Jun 2013 16:44:10 +0200 |
* 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.
---
libguile/procprop.c | 2 ++
libguile/programs.c | 12 ++++++++
libguile/programs.h | 1 +
module/system/vm/assembler.scm | 65 ++++++++++++++++++++++++++++++++++++++--
module/system/vm/debug.scm | 47 +++++++++++++++++++++++++++--
module/system/vm/program.scm | 10 +++----
test-suite/tests/rtl.test | 52 ++++++++++++++++++++++++++++++++
7 files changed, 180 insertions(+), 9 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index d7ce09b..2d9e655 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 567708a..d8dd378 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 175059f..e42a76e 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 3fe4692..0e1bbfc 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 c8c2cdd..15c37f4 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -52,7 +52,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)
@@ -332,7 +334,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 +342,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 d719e95..267e373 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 8fcdb63..0e38a8e 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -357,3 +357,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))))))
--
1.7.10.4
- Serialize procedure metadata into ELF for RTL programs, Andy Wingo, 2013/06/04
- [PATCH 2/9] add procedure prelude macro-instructions, Andy Wingo, 2013/06/04
- [PATCH 3/9] Beginnings of tracking of procedure arities in assembler, Andy Wingo, 2013/06/04
- [PATCH 1/9] begin-program takes properties alist, Andy Wingo, 2013/06/04
- [PATCH 4/9] RTL assembler writes arities information into separate section., Andy Wingo, 2013/06/04
- [PATCH 6/9] Wire up ability to print RTL program arities, Andy Wingo, 2013/06/04
- [PATCH 5/9] (system vm debug) can read arity information, Andy Wingo, 2013/06/04
- [PATCH 7/9] Write docstrings into RTL ELF images, Andy Wingo, 2013/06/04
- [PATCH 8/9] procedure-documentation works on RTL procedures, Andy Wingo, 2013/06/04
- [PATCH 9/9] procedure-properties for RTL functions,
Andy Wingo <=