From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 9/9] procedure-properties for RTL functions Date: Tue, 4 Jun 2013 16:44:10 +0200 Message-ID: <1370357050-26337-10-git-send-email-wingo@pobox.com> References: <1370357050-26337-1-git-send-email-wingo@pobox.com> NNTP-Posting-Host: plane.gmane.org X-Trace: ger.gmane.org 1370357780 12283 80.91.229.3 (4 Jun 2013 14:56:20 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:56:20 +0000 (UTC) Cc: Andy Wingo To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Jun 04 16:56:20 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Ujsep-0001jU-Uk for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:56:20 +0200 Original-Received: from localhost ([::1]:58481 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Ujsep-0002zP-HZ for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:56:19 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:58834) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Ujsef-0002y8-3G for guile-devel@gnu.org; Tue, 04 Jun 2013 10:56:15 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTs-00021h-Sp for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:15 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:59109 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTs-00021c-LE for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:00 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 5CC99C833; Tue, 4 Jun 2013 10:45:00 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:date:message-id:in-reply-to:references; s=sasl; bh=bBU9 GKWXrHGhbUs3MUQ11n+SWKw=; b=O1TPHCp7xY4lsHfmP2NpRa+64lagI+BNsNUG jaujEiAfR+ZdpHVqbmromHyZ1O9kDo+r8GhvibakHe51K8TYxdMZMzb3d7TzWVZ6 WR+enK7vxPHcBDSrOp6aQD/zlgIlzuhqtFyZHQFn7S09mwHPOe4mXsY0OLqLB+yS ElYD+2I= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:date:message-id:in-reply-to:references; q=dns; s=sasl; b= pvWGXLX1GryIoObZT+6B5j+u9fmdn26a2WP6n3l54sW5cL45JWMeyTt36M06kvYD keSc5SKJ1t5O4x7Mk+cnZviJ4ltc4YvuPgN/vl9D2R8E+cYugalVT6NIx4RDt+HT yHW1m8Xu1ebiQNFKQoBFkSk1CU71dcHZ8SG3iByO5Ug= Original-Received: from a-pb-sasl-quonix.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 522FCC832; Tue, 4 Jun 2013 10:45:00 -0400 (EDT) Original-Received: from localhost.localdomain (unknown [88.5.174.195]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTPSA id 0A812C830; Tue, 4 Jun 2013 10:44:57 -0400 (EDT) X-Mailer: git-send-email 1.7.10.4 In-Reply-To: <1370357050-26337-1-git-send-email-wingo@pobox.com> X-Pobox-Relay-ID: 54B57572-CD25-11E2-9D98-9F710E5B5709-02397024!a-pb-sasl-quonix.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 X-Received-From: 208.72.237.25 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16466 Archived-At: * 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 (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