mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

procedure-properties for RTL functions

Browse source 
* 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...

* test-suite/tests/rtl.test: Add some tests.
This commit is contained in:
Andy Wingo 2013-05-17 22:10:16 +02:00
parent bf8328ec16
commit c4c098e355
7 changed files with 179 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/procprop.c
View file

@ -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;
}

12
libguile/programs.c
View file

@ -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)
{

1
libguile/programs.h
View file

@ -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

65
module/system/vm/assembler.scm
View file

@ -1411,8 +1411,69 @@ it will be added to the GC roots at runtime."
(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))
@ -1425,7 +1486,7 @@ it will be added to the GC roots at runtime."
((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))))

45
module/system/vm/debug.scm
View file

@ -58,7 +58,9 @@
find-program-arities
program-minimum-arity
find-program-docstring))
find-program-docstring
find-program-properties))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@ -364,3 +366,44 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(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))))))))))))

10
module/system/vm/program.scm
View file

@ -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))

52
test-suite/tests/rtl.test
View file

@ -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))))))