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 4/9] RTL assembler writes arities information into separate section. Date: Tue, 4 Jun 2013 16:44:05 +0200 Message-ID: <1370357050-26337-5-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 1370357107 3771 80.91.229.3 (4 Jun 2013 14:45:07 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:45:07 +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:45:07 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 1UjsTx-0000lL-Ke for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:45:05 +0200 Original-Received: from localhost ([::1]:51943 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTx-0006rW-8W for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:45:05 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55195) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTl-0006Xb-RF for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:01 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTh-0001w5-0y for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:53 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:58595 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTg-0001vz-Ph for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:48 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 7CA97C817; Tue, 4 Jun 2013 10:44:48 -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=VhUc gb22PfeLpIHApZISojP6LyQ=; b=obQQWJAYIy5HT5Xc7SUE7AWk93g2Zj5OmuDW 14Jv821Ze0JYVZEBw/e2yM32vCfteIzPukG4tB+9E84Tw+BAHP4yJjlgEsEb/hjs M8GZbg9dXcOlcYpK9kVM7hGFzRTxl19Vsph8q2uhx2T84AMfH5HOkLr1JvnAF5dQ +12J22g= 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= k1kNtv3MQTNMfZ+Dplx6V9N6JDCaUO13W/gksavF2l2mWWor4vHQsNa6UEtV7eD8 7VNTZuTJrllb+9DhWpgC2Pe5nqHy5jBwoEmOncc2z9zpao9mRNrLvF4YvZY6qsNU Y7aIYKywNsMoT/4E+MfYH2aIuzRvzINfrAhFoLYCB+U= 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 70E2FC816; Tue, 4 Jun 2013 10:44:48 -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 2AAF0C815; Tue, 4 Jun 2013 10:44:46 -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: 4DABB5DE-CD25-11E2-9AAB-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:16461 Archived-At: * module/system/vm/assembler.scm: Write arities into a .guile.arities section and associated .guile.arities.strtab. --- module/system/vm/assembler.scm | 201 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 200 insertions(+), 1 deletion(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 47f31ed..342b3dc 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -968,6 +968,202 @@ (linker-object-section strtab))) strtab)))) +;;; The .guile.arities section describes the arities that a function can +;;; have. It is in two parts: a sorted array of headers describing +;;; basic arities, and an array of links out to a string table (and in +;;; the case of keyword arguments, to the data section) for argument +;;; names. The whole thing is prefixed by a uint32 indicating the +;;; offset of the end of the headers array. +;;; +;;; The arity headers array is a packed array of structures of the form: +;;; +;;; struct arity_header { +;;; uint32_t low_pc; +;;; uint32_t high_pc; +;;; uint32_t offset; +;;; uint32_t flags; +;;; uint32_t nreq; +;;; uint32_t nopt; +;;; } +;;; +;;; All of the offsets and addresses are 32 bits. We can expand in the +;;; future to use 64-bit offsets if appropriate, but there are other +;;; aspects of RTL that constrain us to a total image that fits in 32 +;;; bits, so for the moment we'll simplify the problem space. +;;; +;;; The following flags values are defined: +;;; +;;; #x1: has-rest? +;;; #x2: allow-other-keys? +;;; #x4: has-keyword-args? +;;; #x8: is-case-lambda? +;;; +;;; Functions with a single arity specify their number of required and +;;; optional arguments in nreq and nopt, and do not have the +;;; is-case-lambda? flag set. Their "offset" member links to an array +;;; of pointers into the associated .guile.arities.strtab string table, +;;; identifying the argument names. This offset is relative to the +;;; start of the .guile.arities section. Links for required arguments +;;; are first, in order, as uint32 values. Next follow the optionals, +;;; then the rest link if has-rest? is set, then a link to the "keyword +;;; indices" literal if has-keyword-args? is set. Unlike the other +;;; links, the kw-indices link points into the data section, and is +;;; relative to the ELF image as a whole. +;;; +;;; Functions with no arities have no arities information present in the +;;; .guile.arities section. +;;; +;;; Functions with multiple arities are preceded by a header with +;;; is-case-lambda? set. All other fields are 0, except low-pc and +;;; high-pc which should be the bounds of the whole function. Headers +;;; for the individual arities follow. In this way the whole headers +;;; array is sorted in increasing low-pc order, and case-lambda clauses +;;; are contained within the [low-pc, high-pc] of the case-lambda +;;; header. + +;; Length of the prefix to the arities section, in bytes. +(define arities-prefix-len 4) + +;; Length of an arity header, in bytes. +(define arity-header-len (* 6 4)) + +;; The offset of "offset" within arity header, in bytes. +(define arity-header-offset-offset (* 2 4)) + +(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys? + has-keyword-args? is-case-lambda?) + (logior (if has-rest? (ash 1 0) 0) + (if allow-other-keys? (ash 1 1) 0) + (if has-keyword-args? (ash 1 2) 0) + (if is-case-lambda? (ash 1 3) 0))) + +(define (meta-arities-size meta) + (define (lambda-size arity) + (+ arity-header-len + (* 4 ;; name pointers + (+ (length (arity-req arity)) + (length (arity-opt arity)) + (if (arity-rest arity) 1 0) + (if (pair? (arity-kw-indices arity)) 1 0))))) + (define (case-lambda-size arities) + (fold + + arity-header-len ;; case-lambda header + (map lambda-size arities))) ;; the cases + (match (meta-arities meta) + (() 0) + ((arity) (lambda-size arity)) + (arities (case-lambda-size arities)))) + +(define (write-arity-headers metas bv endianness) + (define (write-arity-header* pos low-pc high-pc flags nreq nopt) + (bytevector-u32-set! bv pos low-pc endianness) + (bytevector-u32-set! bv (+ pos 4) high-pc endianness) + (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset + (bytevector-u32-set! bv (+ pos 12) flags endianness) + (bytevector-u32-set! bv (+ pos 16) nreq endianness) + (bytevector-u32-set! bv (+ pos 20) nopt endianness)) + (define (write-arity-header pos arity) + (write-arity-header* pos (arity-low-pc arity) + (arity-high-pc arity) + (pack-arity-flags (arity-rest arity) + (arity-allow-other-keys? arity) + (pair? (arity-kw-indices arity)) + #f) + (length (arity-req arity)) + (length (arity-opt arity)))) + (let lp ((metas metas) (pos arities-prefix-len) (offsets '())) + (match metas + (() (values pos (reverse offsets))) + ((meta . metas) + (match (meta-arities meta) + (() (lp metas pos offsets)) + ((arity) + (write-arity-header pos arity) + (lp metas + (+ pos arity-header-len) + (acons arity (+ pos arity-header-offset-offset) offsets))) + (arities + ;; Write a case-lambda header, then individual arities. + ;; The case-lambda header's offset link is 0. + (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta) + (pack-arity-flags #f #f #f #t) 0 0) + (let lp* ((arities arities) (pos (+ pos arity-header-len)) + (offsets offsets)) + (match arities + (() (lp metas pos offsets)) + ((arity . arities) + (write-arity-header pos arity) + (lp* arities + (+ pos arity-header-len) + (acons arity + (+ pos arity-header-offset-offset) + offsets))))))))))) + +(define (write-arity-links asm bv pos arity-offset-pairs intern-string!) + (define (write-symbol sym pos) + (bytevector-u32-set! bv pos (intern-string! sym) (asm-endianness asm)) + (+ pos 4)) + (define (write-kw-indices pos kw-indices) + ;; FIXME: Assert that kw-indices is already interned. + (make-linker-reloc 'abs32/1 pos 0 + (intern-constant asm kw-indices))) + (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '())) + (match pairs + (() + (unless (= pos (bytevector-length bv)) + (error "expected to fully fill the bytevector" + pos (bytevector-length bv))) + relocs) + (((arity . offset) . pairs) + (bytevector-u32-set! bv offset pos (asm-endianness asm)) + (let ((pos (fold write-symbol + pos + (append (arity-req arity) + (arity-opt arity) + (cond + ((arity-rest arity) => list) + (else '())))))) + (match (arity-kw-indices arity) + (() (lp pos pairs relocs)) + (kw-indices + (lp (+ pos 4) + pairs + (cons (write-kw-indices pos kw-indices) relocs))))))))) + +(define (link-arities asm) + (let* ((endianness (asm-endianness asm)) + (metas (reverse (asm-meta asm))) + (size (fold (lambda (meta size) + (+ size (meta-arities-size meta))) + arities-prefix-len + metas)) + (strtab (make-string-table)) + (bv (make-bytevector size 0))) + (define (intern-string! name) + (call-with-values + (lambda () (string-table-intern strtab (symbol->string name))) + (lambda (table idx) + (set! strtab table) + idx))) + (let ((kw-indices-relocs + (call-with-values + (lambda () + (write-arity-headers metas bv endianness)) + (lambda (pos arity-offset-pairs) + (write-arity-links asm bv pos arity-offset-pairs + intern-string!))))) + (let ((strtab (make-object asm '.guile.arities.strtab + (link-string-table strtab) + '() '() + #:type SHT_STRTAB #:flags 0))) + (values (make-object asm '.guile.arities + bv + kw-indices-relocs '() + #:type SHT_PROGBITS #:flags 0 + #:link (elf-section-index + (linker-object-section strtab))) + strtab))))) + (define (link-objects asm) (let*-values (((ro rw rw-init) (link-constants asm)) ;; Link text object after constants, so that the @@ -975,10 +1171,13 @@ ((text) (link-text-object asm)) ((dt) (link-dynamic-section asm text ro rw rw-init)) ((symtab strtab) (link-symtab (linker-object-section text) asm)) + ((arities arities-strtab) (link-arities asm)) ;; This needs to be linked last, because linking other ;; sections adds entries to the string table. ((shstrtab) (link-shstrtab asm))) - (filter identity (list text ro rw dt symtab strtab shstrtab)))) + (filter identity + (list text ro rw dt symtab strtab arities arities-strtab + shstrtab)))) (define (link-assembly asm) (link-elf (link-objects asm))) -- 1.7.10.4