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 5/9] (system vm debug) can read arity information Date: Tue, 4 Jun 2013 16:44:06 +0200 Message-ID: <1370357050-26337-6-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 1370357125 3992 80.91.229.3 (4 Jun 2013 14:45:25 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:45:25 +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:26 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 1UjsUD-00013l-5q for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:45:21 +0200 Original-Received: from localhost ([::1]:52503 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsUC-0007FL-Pn for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:45:20 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55239) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTp-0006fX-Ol for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:06 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTj-0001x0-9r for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:57 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:58700 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTj-0001wq-3k for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:51 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id C6580C81D; Tue, 4 Jun 2013 10:44:50 -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=VSVD 0ZpyA4x/ALWw3KMkRQZhDYg=; b=vtHjrek82pIwwxqzObutILI2tZJTz8b8WkRh RoDtMZ8o3W2Jnx0KBRnGuXY5hf4vbiNmektCMillO55/F6qjsiY2tm6DnD31xPbG cBJ5s1nVBTfrwRT3RmovezDYqZo65FH2LB4fmw4cu6aZfRmTa0LN0Org5SKP3bib Ld/rVMs= 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= Z90ha23M+e2ThvHBCUjW/rWsfJQJuxiFb/8K+vGDCap3ZwqONbGyzGP+EUOs+pIA hedYLDlRaQIWGhCTb5fHtZZ8YfeiLE0udA14Qv9aqPBNHS9ktJa5Xx2oNPyM6A4c 4IK2uZWyGzH2biCfS3E9xiNATlDunW1QOr0KaUT41r8= 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 BF087C81C; Tue, 4 Jun 2013 10:44:50 -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 9CFE9C818; Tue, 4 Jun 2013 10:44:48 -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: 4F1BE664-CD25-11E2-B3DE-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:16464 Archived-At: * module/system/vm/assembler.scm (write-arity-headers): Fill in the prefix. * module/system/vm/debug.scm (): New object, for reading arities. Unlike in the assembler, this one only holds on to a couple of pointers, and doesn't even load in argument names. Unlike the arity lists in (system vm program), it can load in names. Very early days but it does seem to work. (find-program-arities, arity-arguments-alist): New higher-level interfaces. --- module/system/vm/assembler.scm | 5 +- module/system/vm/debug.scm | 174 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 177 insertions(+), 2 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 342b3dc..7718574 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1073,7 +1073,10 @@ (length (arity-opt arity)))) (let lp ((metas metas) (pos arities-prefix-len) (offsets '())) (match metas - (() (values pos (reverse offsets))) + (() + ;; Fill in the prefix. + (bytevector-u32-set! bv 0 pos endianness) + (values pos (reverse offsets))) ((meta . metas) (match (meta-arities meta) (() (lp metas pos offsets)) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index d7d62da..724f2b4 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -36,8 +36,20 @@ program-debug-info-u32-offset program-debug-info-u32-offset-end + arity? + arity-low-pc + arity-high-pc + arity-nreq + arity-nopt + arity-has-rest? + arity-allow-other-keys? + arity-has-keyword-args? + arity-is-case-lambda? + find-debug-context - find-program-debug-info)) + find-program-debug-info + arity-arguments-alist + find-program-arities)) (define-record-type (make-debug-context elf base text-base) @@ -135,3 +147,163 @@ (elf-symbol-value sym) (elf-symbol-size sym)))) (else #f))) + +(define-record-type + (make-arity context base header-offset) + arity? + (context arity-context) + (base arity-base) + (header-offset arity-header-offset)) + +(define arities-prefix-len 4) +(define arity-header-len (* 6 4)) + +;;; struct arity_header { +;;; uint32_t low_pc; +;;; uint32_t high_pc; +;;; uint32_t offset; +;;; uint32_t flags; +;;; uint32_t nreq; +;;; uint32_t nopt; +;;; } + +(define (arity-low-pc* bv header-pos) + (bytevector-u32-native-ref bv (+ header-pos (* 0 4)))) +(define (arity-high-pc* bv header-pos) + (bytevector-u32-native-ref bv (+ header-pos (* 1 4)))) +(define (arity-offset* bv header-pos) + (bytevector-u32-native-ref bv (+ header-pos (* 2 4)))) +(define (arity-flags* bv header-pos) + (bytevector-u32-native-ref bv (+ header-pos (* 3 4)))) +(define (arity-nreq* bv header-pos) + (bytevector-u32-native-ref bv (+ header-pos (* 4 4)))) +(define (arity-nopt* bv header-pos) + (bytevector-u32-native-ref bv (+ header-pos (* 5 4)))) + +;;; #x1: has-rest? +;;; #x2: allow-other-keys? +;;; #x4: has-keyword-args? +;;; #x8: is-case-lambda? + +(define (has-rest? flags) (not (zero? (logand flags (ash 1 0))))) +(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1))))) +(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2))))) +(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3))))) + +(define (arity-nreq arity) + (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity))) + (arity-header-offset arity))) + +(define (arity-nopt arity) + (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity))) + (arity-header-offset arity))) + +(define (arity-flags arity) + (arity-flags* (elf-bytes (debug-context-elf (arity-context arity))) + (arity-header-offset arity))) + +(define (arity-has-rest? arity) (has-rest? (arity-flags arity))) +(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity))) +(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity))) +(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity))) + +(define (arity-load-symbol arity) + (let ((elf (debug-context-elf (arity-context arity)))) + (cond + ((elf-section-by-name elf ".guile.arities") + => + (lambda (sec) + (let* ((strtab (elf-section elf (elf-section-link sec))) + (bv (elf-bytes elf)) + (strtab-offset (elf-section-offset strtab))) + (lambda (n) + (string->symbol (string-table-ref bv (+ strtab-offset n))))))) + (else (error "couldn't find arities section"))))) + +(define (arity-arguments-alist arity) + (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) + (%load-symbol (arity-load-symbol arity)) + (header (arity-header-offset arity)) + (link-offset (arity-offset* bv header)) + (link (+ (arity-base arity) link-offset)) + (flags (arity-flags* bv header)) + (nreq (arity-nreq* bv header)) + (nopt (arity-nopt* bv header))) + (define (load-symbol idx) + (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4))))) + (define (load-symbols skip n) + (let lp ((n n) (out '())) + (if (zero? n) + out + (lp (1- n) + (cons (load-symbol (+ skip (1- n))) out))))) + (define (unpack-scm n) + (pointer->scm (make-pointer n))) + (define (load-non-immediate idx) + (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4))))) + (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))) + (and (not (is-case-lambda? flags)) + `((required . ,(load-symbols 0 nreq)) + (optional . ,(load-symbols nreq nopt)) + (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt)))) + (keyword . ,(if (has-keyword-args? flags) + (load-non-immediate + (+ nreq nopt (if (has-rest? flags) 1 0))) + '())) + (allow-other-keys? . ,(allow-other-keys? flags)))))) + +(define (find-first-arity context base addr) + (let* ((bv (elf-bytes (debug-context-elf context))) + (text-offset (- addr + (debug-context-text-base context) + (debug-context-base context))) + (headers-start (+ base arities-prefix-len)) + (headers-end (+ base (bytevector-u32-native-ref bv base)))) + ;; FIXME: This is linear search. Change to binary search. + (let lp ((pos headers-start)) + (cond + ((>= pos headers-end) #f) + ((< text-offset (arity-low-pc* bv pos)) + (lp (+ pos arity-header-len))) + ((< (arity-high-pc* bv pos) text-offset) + #f) + (else + (make-arity context base pos)))))) + +(define (read-sub-arities context base outer-header-offset) + (let* ((bv (elf-bytes (debug-context-elf context))) + (headers-end (+ base (bytevector-u32-native-ref bv base))) + (low-pc (arity-low-pc* bv outer-header-offset)) + (high-pc (arity-high-pc* bv outer-header-offset))) + (let lp ((pos (+ outer-header-offset arity-header-len)) (out '())) + (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc)) + (lp (+ pos arity-header-len) + (cons (make-arity context base pos) out)) + (reverse out))))) + +(define* (find-program-arities addr #:optional + (context (find-debug-context addr))) + (and=> + (elf-section-by-name (debug-context-elf context) ".guile.arities") + (lambda (sec) + (let* ((base (elf-section-offset sec)) + (first (find-first-arity context base addr))) + ;; FIXME: Handle case-lambda arities. + (cond + ((not first) '()) + ((arity-is-case-lambda? first) + (read-sub-arities context base (arity-header-offset first))) + (else (list first))))))) + +(define* (program-minimum-arity addr #:optional + (context (find-debug-context addr))) + (and=> + (elf-section-by-name (debug-context-elf context) ".guile.arities") + (lambda (sec) + (let* ((base (elf-section-offset sec)) + (first (find-first-arity context base addr))) + (if (arity-is-case-lambda? first) + (list 0 0 #t) ;; FIXME: be more precise. + (list (arity-nreq first) + (arity-nopt first) + (arity-has-rest? first))))))) -- 1.7.10.4