From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Add GDB support Date: Mon, 17 Feb 2014 23:43:29 +0100 Message-ID: <878ut9bbse.fsf@gnu.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-Trace: ger.gmane.org 1392678577 13850 80.91.229.3 (17 Feb 2014 23:09:37 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 17 Feb 2014 23:09:37 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Feb 18 00:09:47 2014 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 1WFXJq-0007Wo-MW for guile-devel@m.gmane.org; Tue, 18 Feb 2014 00:09:47 +0100 Original-Received: from localhost ([::1]:44685 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WFWwn-0001vK-HA for guile-devel@m.gmane.org; Mon, 17 Feb 2014 17:45:57 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:57572) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WFWue-0007fz-5H for guile-devel@gnu.org; Mon, 17 Feb 2014 17:43:48 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1WFWuZ-0003AI-Nd for guile-devel@gnu.org; Mon, 17 Feb 2014 17:43:44 -0500 Original-Received: from hera.aquilenet.fr ([2a01:474::1]:51090) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WFWuZ-0003A5-3s for guile-devel@gnu.org; Mon, 17 Feb 2014 17:43:39 -0500 Original-Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id 9E4B11CC8; Mon, 17 Feb 2014 23:43:37 +0100 (CET) Original-Received: from hera.aquilenet.fr ([127.0.0.1]) by localhost (hera.aquilenet.fr [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 2RfWk2UZHUwR; Mon, 17 Feb 2014 23:43:37 +0100 (CET) Original-Received: from pluto (LDijon-156-64-49-137.w217-128.abo.wanadoo.fr [217.128.51.137]) by hera.aquilenet.fr (Postfix) with ESMTPSA id 0347F927; Mon, 17 Feb 2014 23:43:34 +0100 (CET) X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 29 =?utf-8?Q?Pluvi=C3=B4se?= an 222 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0xEA52ECF4 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 83C4 F8E5 10A3 3B4C 5BEA D15D 77DD 95E2 EA52 ECF4 X-OS: x86_64-unknown-linux-gnu User-Agent: Gnus/5.130007 (Ma Gnus v0.7) Emacs/24.3 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2a01:474::1 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:16877 Archived-At: --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello Guilers! I=E2=80=99ve polished my potluck dish for inclusion into Guile proper. So the first patch below adds (system base type), which does type tag decoding in a backend-independent manner. The guts of it is =E2=80=98scm->object=E2=80=99, which takes an SCM bit pattern and returns t= he corresponding Scheme object (so it essentially duplicates the object when using the FFI back-end, and =E2=80=9Ctransports=E2=80=9D it into GDB w= hen using the GDB back-end.) There=E2=80=99s a test suite. The second patch adds the GDB-specific part, and installs it in the place where GDB expects it so that the pretty-printer is installed out of the box. This is for 2.0, but I can do the work to adjust the type-tagging stuff for =E2=80=98master=E2=80=99. The stack-walking procedure also needs to be= adjusted, but I=E2=80=99d rather leave that to Andy or Mark for the moment. WDYT? Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=0001-Add-system-base-types.patch Content-Transfer-Encoding: quoted-printable Content-Description: (system base types) From=205aba4630e070ced07569c084df378375e03e8b27 Mon Sep 17 00:00:00 2001 From: =3D?UTF-8?q?Ludovic=3D20Court=3DC3=3DA8s?=3D Date: Mon, 17 Feb 2014 15:59:28 +0100 Subject: [PATCH 1/2] Add (system base types). * module/system/base/types.scm, test-suite/tests/types.test: New files. * module/Makefile.am (SYSTEM_BASE_SOURCES): Add system/base/types.scm. * test-suite/Makefile.am (SCM_TESTS): Add tests/types.test. =2D-- module/Makefile.am | 1 + module/system/base/types.scm | 478 +++++++++++++++++++++++++++++++++++++++= ++++ test-suite/Makefile.am | 1 + test-suite/tests/types.test | 100 +++++++++ 4 files changed, 580 insertions(+) create mode 100644 module/system/base/types.scm create mode 100644 test-suite/tests/types.test diff --git a/module/Makefile.am b/module/Makefile.am index 5f777b6..fb9174b 100644 =2D-- a/module/Makefile.am +++ b/module/Makefile.am @@ -188,6 +188,7 @@ SYSTEM_BASE_SOURCES =3D \ system/base/lalr.scm \ system/base/message.scm \ system/base/target.scm \ + system/base/types.scm \ system/base/ck.scm =20 ICE_9_SOURCES =3D \ diff --git a/module/system/base/types.scm b/module/system/base/types.scm new file mode 100644 index 0000000..70f8a2b =2D-- /dev/null +++ b/module/system/base/types.scm @@ -0,0 +1,478 @@ +;;; 'SCM' type tag decoding. +;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as published = by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Less= er +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public Licen= se +;;; along with this program. If not, see . + +(define-module (system base types) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-60) + #:use-module (ice-9 match) + #:use-module (ice-9 iconv) + #:use-module (ice-9 format) + #:use-module (ice-9 vlist) + #:use-module (system foreign) + #:export (memory-backend + memory-backend? + %ffi-memory-backend + + inferior-object? + inferior-object-kind + inferior-object-sub-kind + inferior-object-address + + inferior-fluid? + inferior-fluid-number + + inferior-struct? + inferior-struct-name + inferior-struct-fields + + scm->object)) + +;;; Commentary: +;;; +;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB. +;;; +;;; Code: + + +;;; +;;; Memory back-ends. +;;; + +(define %word-size + ;; The pointer size. + (sizeof '*)) + +(define-record-type + (memory-backend peek open type-name) + memory-backend? + (peek memory-backend-peek) + (open memory-backend-open) + (type-name memory-backend-type-name)) ; for SMOBs and ports + +(define %ffi-memory-backend + ;; The FFI back-end to access the current process's memory. The main + ;; purpose of this back-end is to allow testing. + (let () + (define (dereference-word address) + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + + (define (open address size) + (define current-address address) + + (define (read-memory! bv index count) + (let* ((ptr (make-pointer current-address)) + (mem (pointer->bytevector ptr count))) + (bytevector-copy! mem 0 bv index count) + (set! current-address (+ current-address count)) + count)) + + (if size + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr size))) + (open-bytevector-input-port bv)) + (let ((port (make-custom-binary-input-port "ffi-memory" + read-memory! + #f #f #f))) + (setvbuf port _IONBF) + port))) + + (memory-backend dereference-word open #f))) + +(define-inlinable (dereference-word backend address) + "Return the word at ADDRESS, using BACKEND." + (let ((peek (memory-backend-peek backend))) + (peek address))) + +(define-syntax memory-port + (syntax-rules () + "Return an input port to the SIZE bytes at ADDRESS, using BACKEND. Wh= en +SIZE is omitted, return an unbounded port to the memory at ADDRESS." + ((_ backend address) + (let ((open (memory-backend-open backend))) + (open address #f))) + ((_ backend address size) + (let ((open (memory-backend-open backend))) + (open address size))))) + +(define (get-word port) + "Read a word from PORT and return it as an integer." + (let ((bv (get-bytevector-n port %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + +(define-inlinable (type-name backend kind number) + "Return the name of the type NUMBER of KIND, where KIND is one of +'smob or 'port, or #f if the information is unavailable." + (let ((proc (memory-backend-type-name backend))) + (and proc (proc kind number)))) + + +;;; +;;; Matching bit patterns and cells. +;;; + +(define-syntax match-cell-words + (syntax-rules (bytevector) + ((_ port ((bytevector name len) rest ...) body) + (let ((name (get-bytevector-n port len)) + (remainder (modulo len %word-size))) + (unless (zero? remainder) + (get-bytevector-n port (- %word-size remainder))) + (match-cell-words port (rest ...) body))) + ((_ port (name rest ...) body) + (let ((name (get-word port))) + (match-cell-words port (rest ...) body))) + ((_ port () body) + body))) + +(define-syntax match-bit-pattern + (syntax-rules (& || =3D _) + ((match-bit-pattern bits ((a || b) & n =3D c) consequent alternate) + (let ((tag (logand bits n))) + (if (=3D tag c) + (let ((b tag) + (a (logand bits (bitwise-not n)))) + consequent) + alternate))) + ((match-bit-pattern bits (x & n =3D c) consequent alternate) + (let ((tag (logand bits n))) + (if (=3D tag c) + (let ((x bits)) + consequent) + alternate))) + ((match-bit-pattern bits (_ & n =3D c) consequent alternate) + (let ((tag (logand bits n))) + (if (=3D tag c) + consequent + alternate))) + ((match-bit-pattern bits ((a << n) || c) consequent alternate) + (let ((tag (bitwise-and bits (- (expt 2 n) 1)))) + (if (=3D tag c) + (let ((a (arithmetic-shift bits (- n)))) + consequent) + alternate))))) + +(define-syntax match-cell-clauses + (syntax-rules () + ((_ port tag (((tag-pattern thing ...) body) rest ...)) + (match-bit-pattern tag tag-pattern + (match-cell-words port (thing ...) body) + (match-cell-clauses port tag (rest ...)))) + ((_ port tag ()) + (inferior-object 'unmatched-tag tag)))) + +(define-syntax match-cell + (syntax-rules () + "Match a cell---i.e., a non-immediate value other than a pair. The +cell's contents are read from PORT." + ((_ port (pattern body ...) ...) + (let ((port* port) + (tag (get-word port))) + (match-cell-clauses port* tag + ((pattern (begin body ...)) + ...)))))) + +(define-syntax match-scm-clauses + (syntax-rules () + ((_ bits + (bit-pattern body ...) + rest ...) + (match-bit-pattern bits bit-pattern + (begin body ...) + (match-scm-clauses bits rest ...))) + ((_ bits) + 'unmatched-scm))) + +(define-syntax match-scm + (syntax-rules () + "Match BITS, an integer representation of an 'SCM' value, against +CLAUSES. Each clause must have the form: + + (PATTERN BODY ...) + +PATTERN is a bit pattern that may specify bitwise operations on BITS to +determine if it matches. TEMPLATE specify the name of the variable to bind +the matching bits, possibly with bitwise operations to extract it from BIT= S." + ((_ bits clauses ...) + (let ((bits* bits)) + (match-scm-clauses bits* clauses ...))))) + + +;;; +;;; Tags---keep in sync with libguile/tags.h! +;;; + +;; Immediate values. +(define %tc2-int 2) +(define %tc3-imm24 4) + +(define %tc3-cons 0) +(define %tc3-int1 %tc2-int) +(define %tc3-int2 (+ %tc2-int 4)) + +(define %tc8-char (+ 8 %tc3-imm24)) +(define %tc8-flag (+ %tc3-imm24 0)) + +;; Cell types. +(define %tc3-struct 1) +(define %tc7-symbol 5) +(define %tc7-vector 13) +(define %tc7-string 21) +(define %tc7-number 23) +(define %tc7-hashtable 29) +(define %tc7-pointer 31) +(define %tc7-fluid 37) +(define %tc7-stringbuf 39) +(define %tc7-dynamic-state 45) +(define %tc7-frame 47) +(define %tc7-objcode 53) +(define %tc7-vm 55) +(define %tc7-vm-continuation 71) +(define %tc7-bytevector 77) +(define %tc7-program 79) +(define %tc7-port 125) +(define %tc7-smob 127) + +(define %tc16-bignum (+ %tc7-number (* 1 256))) +(define %tc16-real (+ %tc7-number (* 2 256))) +(define %tc16-complex (+ %tc7-number (* 3 256))) +(define %tc16-fraction (+ %tc7-number (* 4 256))) + + +;; "Stringbufs". +(define-record-type + (stringbuf string) + stringbuf? + (string stringbuf-contents)) + +(set-record-type-printer! + (lambda (stringbuf port) + (display "#" port))) + +;; Structs. +(define-record-type + (inferior-struct name fields) + inferior-struct? + (name inferior-struct-name) + (fields inferior-struct-fields)) + +(set-record-type-printer! + (lambda (struct port) + (format port "#" (object-address struct)))) + +;; Fluids. +(define-record-type + (inferior-fluid number value) + inferior-fluid? + (number inferior-fluid-number) + (value inferior-fluid-value)) + +(set-record-type-printer! + (lambda (fluid port) + (match fluid + (($ number) + (format port "#" + number + (object-address fluid)))))) + +;; Object type to represent complex objects from the inferior process that +;; cannot be really converted to usable Scheme objects in the current +;; process. +(define-record-type + (%inferior-object kind sub-kind address) + inferior-object? + (kind inferior-object-kind) + (sub-kind inferior-object-sub-kind) + (address inferior-object-address)) + +(define inferior-object + (case-lambda + "Return an object representing an inferior object at ADDRESS, of type +KIND/SUB-KIND." + ((kind address) + (%inferior-object kind #f address)) + ((kind sub-kind address) + (%inferior-object kind sub-kind address)))) + +(set-record-type-printer! + (lambda (io port) + (match io + (($ kind sub-kind address) + (format port "#<~a ~:[~*~;~a ~]~x>" + kind sub-kind sub-kind + address))))) + +(define (inferior-smob backend type-number address) + "Return an object representing the SMOB at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'smob + (or (type-name backend 'smob type-number) type-number) + address)) + +(define (inferior-port backend type-number address) + "Return an object representing the port at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'port + (or (type-name backend 'port type-number) type-number) + address)) + +(define (address->inferior-struct address vtable-data-address backend) + "Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct' +object representing it." + (define %vtable-layout-index 0) + (define %vtable-name-index 5) + + (let* ((layout-address (+ vtable-data-address + (* %vtable-layout-index %word-size))) + (layout-bits (dereference-word backend layout-address)) + (layout (scm->object layout-bits backend)) + (name-address (+ vtable-data-address + (* %vtable-name-index %word-size))) + (name-bits (dereference-word backend name-address)) + (name (scm->object name-bits backend))) + (if ((@ (guile) symbol?) layout) + (let* ((layout (symbol->string layout)) + (len (/ (string-length layout) 2)) + (slots (dereference-word backend (+ address %word-size))) + (port (memory-port backend slots (* len %word-size))) + (fields (get-bytevector-n port (* len %word-size)))) + (inferior-struct name + (map (cut scm->object <> backend) + (bytevector->uint-list fields + (native-endianness) + %word-size)))) + (inferior-object 'invalid-struct address)))) + +(define %visited-cells + ;; Vhash of already visited cells. Used to detect cycles, typically in + ;; structs. + (make-parameter vlist-null)) + +(define* (cell->object address #:optional (backend %ffi-memory-backend)) + "Return an object representing the object at ADDRESS, reading from memory +using BACKEND." + (if (vhash-assv address (%visited-cells)) + (inferior-object 'cycle address) + (let ((port (memory-port backend address))) + (match-cell port + (((vtable-data-address & 7 =3D %tc3-struct)) + (parameterize ((%visited-cells (vhash-consv address #t + (%visited-cells)))) + (address->inferior-struct address + (- vtable-data-address %tc3-struct) + backend))) + (((_ & #x7f =3D %tc7-symbol) buf hash props) + (match (cell->object buf backend) + (($ string) + (string->symbol string)))) + (((_ & #x7f =3D %tc7-string) buf start len) + (match (cell->object buf backend) + (($ string) + (substring string start (+ start len))))) + (((_ & #x047f =3D %tc7-stringbuf) len (bytevector buf len)) + (stringbuf (bytevector->string buf "ISO-8859-1"))) + (((_ & #x047f =3D (bitwise-ior #x400 %tc7-stringbuf)) + len (bytevector buf (* 4 len))) + (stringbuf (bytevector->string buf "UTF-32LE"))) + (((_ & #x7f =3D %tc7-bytevector) len address) + (let ((bv-port (memory-port backend address len))) + (get-bytevector-all bv-port))) + ((((len << 7) || %tc7-vector) weakv-data) + (let* ((len (arithmetic-shift len -1)) + (words (get-bytevector-n port (* len %word-size)))) + (list->vector + (map (cut scm->object <> backend) + (bytevector->uint-list words (native-endianness) + %word-size))))) + ((((n << 8) || %tc7-fluid) init-value) + (inferior-fluid n #f)) ; TODO: show current = value + (((_ & #x7f =3D %tc7-dynamic-state)) + (inferior-object 'dynamic-state address)) + ((((flags+type << 8) || %tc7-port)) + (inferior-port backend (logand flags+type #xff) address)) + (((_ & #x7f =3D %tc7-program)) + (inferior-object 'program address)) + (((_ & #xffff =3D %tc16-bignum)) + (inferior-object 'bignum address)) + (((_ & #xffff =3D %tc16-real) pad) + (let* ((address (+ address (* 2 %word-size))) + (port (memory-port backend address (sizeof double))) + (words (get-bytevector-n port (sizeof double)))) + (bytevector-ieee-double-ref words 0 (native-endianness)))) + (((_ & #x7f =3D %tc7-number) mpi) + (inferior-object 'number address)) + (((_ & #x7f =3D %tc7-hashtable) buckets meta-data unused) + (inferior-object 'hash-table address)) + (((_ & #x7f =3D %tc7-pointer) address) + (make-pointer address)) + (((_ & #x7f =3D %tc7-objcode)) + (inferior-object 'objcode address)) + (((_ & #x7f =3D %tc7-vm)) + (inferior-object 'vm address)) + (((_ & #x7f =3D %tc7-vm-continuation)) + (inferior-object 'vm-continuation address)) + ((((smob-type << 8) || %tc7-smob) word1) + (inferior-smob backend smob-type address)))))) + + +(define* (scm->object bits #:optional (backend %ffi-memory-backend)) + "Return the Scheme object corresponding to BITS, the bits of an 'SCM' +object." + (match-scm bits + (((integer << 2) || %tc2-int) + integer) + ((address & 6 =3D %tc3-cons) + (let* ((type (dereference-word backend address)) + (pair? (not (bit-set? 0 type)))) + (if pair? + (let ((car type) + (cdrloc (+ address %word-size))) + (cons (scm->object car backend) + (scm->object (dereference-word backend cdrloc) backend)= )) + (cell->object address backend)))) + (((char << 8) || %tc8-char) + (integer->char char)) + (((flag << 8) || %tc8-flag) + (case flag + ((0) #f) + ((1) #nil) + ((3) '()) + ((4) #t) + ((8) (if #f #f)) + ((9) (inferior-object 'undefined bits)) + ((10) (eof-object)) + ((11) (inferior-object 'unbound bits)))))) + +;;; Local Variables: +;;; eval: (put 'match-scm 'scheme-indent-function 1) +;;; eval: (put 'match-cell 'scheme-indent-function 1) +;;; End: + +;;; types.scm ends here diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 7578bf5..41feb15 100644 =2D-- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -163,6 +163,7 @@ SCM_TESTS =3D tests/00-initial-env.test \ tests/threads.test \ tests/time.test \ tests/tree-il.test \ + tests/types.test \ tests/version.test \ tests/vlist.test \ tests/weaks.test \ diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test new file mode 100644 index 0000000..a082836 =2D-- /dev/null +++ b/test-suite/tests/types.test @@ -0,0 +1,100 @@ +;;;; types.test --- Type tag decoding. +;;;; +;;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1= 301 USA + +(define-module (test-types) + #:use-module (test-suite lib) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:use-module (system vm vm) + #:use-module (system base types)) + +(define-syntax test-cloneable + (syntax-rules () + "Test whether each simple OBJECT is properly decoded." + ((_ object rest ...) + (begin + (let ((obj object)) + (pass-if-equal (object->string obj) obj + (scm->object (object-address obj)))) + (test-cloneable rest ...))) + ((_) + *unspecified*))) + +;; Test objects that can be directly cloned. +(with-test-prefix "clonable objects" + (test-cloneable + #t #f #nil (if #f #f) (eof-object) + 42 (expt 2 28) 3.14 + "narrow string" "wide =CF=83=CF=84=CF=81=CE=B9=CE=BD=CE=B3" + 'symbol '=CE=BB + ;; NB: keywords are SMOBs. + '(2 . 3) (iota 123) '(1 (two ("three"))) + #(1 2 3) #(foo bar baz) + #vu8(255 254 253) + (make-pointer 123) (make-pointer #xdeadbeef))) + +(define-syntax test-inferior-objects + (syntax-rules () + "Test whether each OBJECT is recognized and wrapped as an +'inferior-object'." + ((_ (object kind sub-kind-pattern) rest ...) + (begin + (let ((obj object)) + (pass-if (object->string obj) + (let ((result (scm->object (object-address obj)))) + (and (inferior-object? result) + (eq? 'kind (inferior-object-kind result)) + (match (inferior-object-sub-kind result) + (sub-kind-pattern #t) + (_ #f)))))) + (test-inferior-objects rest ...))) + ((_) + *unspecified*))) + +(with-test-prefix "opaque objects" + (test-inferior-objects + ((make-guardian) smob (? integer?)) + (#:keyword smob (? integer?)) + ((%make-void-port "w") port (? integer?)) + ((open-input-string "hello") port (? integer?)) + ((lambda () #t) program _) + ((the-vm) vm _) + ((expt 2 70) bignum _)) + + (pass-if "fluid" + (let ((fluid (make-fluid))) + (inferior-fluid? (scm->object (object-address fluid)))))) + +(define-record-type + (some-struct x y z) + some-struct? + (x struct-x) + (y struct-y) + (z struct-z)) + +(with-test-prefix "structs" + + (pass-if-equal "simple struct" + '( a b c) + (let* ((struct (some-struct 'a 'b 'c)) + (result (scm->object (object-address struct)))) + (and (inferior-struct? result) + (cons (inferior-struct-name result) + (inferior-struct-fields result)))))) =2D-=20 1.8.4 --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0002-Add-GDB-extension-to-support-Guile.patch Content-Transfer-Encoding: quoted-printable Content-Description: GDB From=2020dc475a6b11291830d09d1281145304efcbdc0e Mon Sep 17 00:00:00 2001 From: =3D?UTF-8?q?Ludovic=3D20Court=3DC3=3DA8s?=3D Date: Mon, 17 Feb 2014 15:40:34 +0100 Subject: [PATCH 2/2] Add GDB extension to support Guile. * libguile/libguile-2.0-gdb.scm: New file. * libguile/Makefile.am (install-data-local): New target. Based on code from GNU libstdc++. (EXTRA_DIST): Add 'libguile-2.0-gdb.scm'. * doc/ref/api-debug.texi (GDB Support): New section. =2D-- doc/ref/api-debug.texi | 26 ++++++- libguile/Makefile.am | 40 ++++++++-- libguile/libguile-2.0-gdb.scm | 167 ++++++++++++++++++++++++++++++++++++++= ++++ 3 files changed, 224 insertions(+), 9 deletions(-) create mode 100644 libguile/libguile-2.0-gdb.scm diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index f6c706c..be76a51 100644 =2D-- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. =2D@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, = 2011, 2012, 2013 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 20= 11, 2012, 2013, 2014 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. =20 @@ -17,8 +17,9 @@ infrastructure that builds on top of those calls. @menu * Evaluation Model:: Evaluation and the Scheme stack. * Source Properties:: From expressions to source locations. =2D* Programmatic Error Handling:: Debugging when an error occurs. +* Programmatic Error Handling:: Debugging when an error occurs. * Traps:: Breakpoints, tracepoints, oh my! +* GDB Support:: C-level debugging with GDB. @end menu =20 @node Evaluation Model @@ -1351,6 +1352,27 @@ This is a stepping trap, used to implement the ``ste= p'', ``next'', ``step-instruction'', and ``next-instruction'' REPL commands. @end deffn =20 +@node GDB Support +@subsection GDB Support + +@cindex GDB support + +Sometimes, you may find it necessary to debug Guile applications at the +C level. Doing so can be tedious, in particular because the debugger is +oblivious to Guile's @code{SCM} type, and thus unable to display +@code{SCM} values in any meaningful way. + +To address that, Guile comes with an extension of the GNU Debugger (GDB) +that contains a ``pretty-printer'' for @code{SCM} values. That +extension is a @code{.scm} file installed alongside the @file{libguile} +shared library. When GDB 7.8 or later is installed, with support for +extensions written in Guile, the extension is automatically loaded when +debugging a program linked against the @file{libguile} shared library +(@pxref{Auto-loading,,, gdb, Debugging with GDB}). Note that the +directory where @file{libguile} is installed must be among GDB's +auto-loading ``safe directories'' (@pxref{Auto-loading safe path,,, gdb, +Debugging with GDB}). + =20 @c Local Variables: @c TeX-master: "guile.texi" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index dcbdba1..c7ceb16 100644 =2D-- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, =2D## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, = Inc. ## ## This file is part of GUILE. ## @@ -448,6 +448,31 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = =3D _scm.h \ install-exec-hook: rm -f $(DESTDIR)$(bindir)/guile-snarf.awk =20 +install-data-local: libguile-2.0-gdb.scm + @$(MKDIR_P) $(DESTDIR)$(libdir) +## We want to install libguile-2.0-gdb.scm as SOMETHING-gdb.scm. +## SOMETHING is the full name of the final library. We want to ignore +## symlinks, the .la file, and any previous -gdb.py file. This is +## inherently fragile, but there does not seem to be a better option, +## because libtool hides the real names from us. (Trick courtesy of +## GNU libstdc++.) + @here=3D`pwd`; cd $(DESTDIR)$(libdir); \ + for file in libguile-@GUILE_EFFECTIVE_VERSION@*; do \ + case $$file in \ + *-gdb.scm) ;; \ + *.la) ;; \ + *) if test -h $$file; then \ + continue; \ + fi; \ + libname=3D$$file;; \ + esac; \ + done; \ + cd $$here; \ + echo " $(INSTALL_DATA) libguile-2.0-gdb.scm \ +$(DESTDIR)$(libdir)/$$libname-gdb.scm"; \ + $(INSTALL_DATA) libguile-2.0-gdb.scm \ + $(DESTDIR)$(libdir)/$$libname-gdb.scm + ## This is kind of nasty... there are ".c" files that we don't want to ## compile, since they are #included. So instead we list them here. ## Perhaps we can deal with them normally once the merge seems to be @@ -635,12 +660,13 @@ bin_SCRIPTS =3D guile-snarf # and people feel like maintaining them. For now, this is not the case. noinst_SCRIPTS =3D guile-snarf-docs =20 =2DEXTRA_DIST =3D ChangeLog-scm ChangeLog-threads \ =2D ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \ =2D guile-func-name-check \ =2D cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ =2D c-tokenize.lex \ =2D scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map +EXTRA_DIST =3D ChangeLog-scm ChangeLog-threads \ + ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \ + guile-func-name-check \ + cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ + c-tokenize.lex \ + scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \ + libguile-2.0-gdb.scm # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi =20 diff --git a/libguile/libguile-2.0-gdb.scm b/libguile/libguile-2.0-gdb.scm new file mode 100644 index 0000000..5e1a48c =2D-- /dev/null +++ b/libguile/libguile-2.0-gdb.scm @@ -0,0 +1,167 @@ +;;; GDB debugging support for Guile. +;;; +;;; Copyright 2014 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see . + +(define-module (guile-gdb) + #:use-module (system base types) + #:use-module ((gdb) #:hide (symbol?)) + #:use-module (gdb printing) + #:export (%gdb-memory-backend + display-vm-frames)) + +;;; Commentary: +;;; +;;; This file defines GDB extensions to pretty-print 'SCM' objects, and +;;; to walk Guile's virtual machine stack. +;;; +;;; This file is installed under a name that follows the convention that +;;; allows GDB to auto-load it anytime the user is debugging libguile +;;; (info "(gdb) objfile-gdbdotext file"). +;;; +;;; Code: + +(define (type-name-from-descriptor descriptor-array type-number) + "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or= #f +if the information is not available." + (let ((descriptors (lookup-global-symbol descriptor-array))) + (and descriptors + (let ((code (type-code (symbol-type descriptors)))) + (or (=3D TYPE_CODE_ARRAY code) + (=3D TYPE_CODE_PTR code))) + (let* ((type-descr (value-subscript (symbol-value descriptors) + type-number)) + (name (value-field type-descr "name"))) + (value->string name))))) + +(define %gdb-memory-backend + ;; The GDB back-end to access the inferior's memory. + (let ((void* (type-pointer (lookup-type "void")))) + (define (dereference-word address) + ;; Return the word at ADDRESS. + (value->integer + (value-dereference (value-cast (make-value address) + (type-pointer void*))))) + + (define (open address size) + ;; Return a port to the SIZE bytes starting at ADDRESS. + (if size + (open-memory #:start address #:size size) + (open-memory #:start address))) + + (define (type-name kind number) + ;; Return the type name of KIND type NUMBER. + (type-name-from-descriptor (case kind + ((smob) "scm_smobs") + ((port) "scm_ptobs")) + number)) + + (memory-backend dereference-word open type-name))) + + +;;; +;;; GDB pretty-printer registration. +;;; + +(define scm-value->string + (lambda* (value #:optional (backend %gdb-memory-backend)) + "Return a representation of value VALUE as a string." + (object->string (scm->object (value->integer value) backend)))) + +(define %scm-pretty-printer + (make-pretty-printer "SCM" + (lambda (pp value) + (let ((name (type-name (value-type value)))) + (and (and name (string=3D? name "SCM")) + (make-pretty-printer-worker + #f ; display hint + (lambda (printer) + (scm-value->string value %gdb-memory-ba= ckend)) + #f)))))) + +(define* (register-pretty-printer #:optional objfile) + (prepend-pretty-printer! objfile %scm-pretty-printer)) + +(define (libguile-objfile) + (find (lambda (objfile) + (string-contains (objfile-filename objfile) "libguile-2.0.so")) + (objfiles))) + +(register-pretty-printer) + + +;;; +;;; VM stack walking. +;;; + +(define (find-vm-engine-frame) + "Return the bottom-most frame containing a call to the VM engine." + (define (vm-engine-frame? frame) + (let ((sym (frame-function frame))) + (and sym + (member (symbol-name sym) + '("vm_debug_engine" "vm_regular_engine"))))) + + (let loop ((frame (newest-frame))) + (and frame + (if (vm-engine-frame? frame) + frame + (loop (frame-older frame)))))) + +(define (vm-stack-pointer) + "Return the current value of the VM stack pointer or #f." + (let ((frame (find-vm-engine-frame))) + (and frame + (frame-read-var frame "sp")))) + +(define (vm-frame-pointer) + "Return the current value of the VM frame pointer or #f." + (let ((frame (find-vm-engine-frame))) + (and frame + (frame-read-var frame "fp")))) + +(define* (display-vm-frames port) + "Display the VM frames on PORT." + (define (display-objects start end) + ;; Display all the objects (arguments and local variables) located + ;; between START and END. + (let loop ((number 0) + (address start)) + (when (and (> start 0) (<=3D address end)) + (let ((object (dereference-word %gdb-memory-backend address))) + (format port " slot ~a -> ~s~%" + number (scm->object object %gdb-memory-backend))) + (loop (+ 1 number) (+ address %word-size))))) + + (let loop ((number 0) + (sp (value->integer (vm-stack-pointer))) + (fp (value->integer (vm-frame-pointer)))) + (unless (zero? fp) + (let-values (((ra mvra link proc) + (vm-frame fp %gdb-memory-backend))) + (format port "#~a ~s~%" number (scm->object proc %gdb-memory-backe= nd)) + (display-objects fp sp) + (loop (+ 1 number) (- fp (* 5 %word-size)) link))))) + +;; See libguile/frames.h. +(define* (vm-frame fp #:optional (backend %gdb-memory-backend)) + "Return the components of the stack frame at FP." + (let ((caller (dereference-word backend (- fp %word-size))) + (ra (dereference-word backend (- fp (* 2 %word-size)))) + (mvra (dereference-word backend (- fp (* 3 %word-size)))) + (link (dereference-word backend (- fp (* 4 %word-size))))) + (values ra mvra link caller))) + +;;; libguile-2.0-gdb.scm ends here =2D-=20 1.8.4 --=-=-=-- --==-=-= Content-Type: application/pgp-signature -----BEGIN PGP SIGNATURE----- Version: GnuPG v2.0.22 (GNU/Linux) iEYEARECAAYFAlMCkJUACgkQd92V4upS7PQl1wCcDZ/51csx5b0iwp87i4nGX/R6 SdIAoJ6buN7Wci5F83gwXPGZi4IWE+jC =cUwF -----END PGP SIGNATURE----- --==-=-=--