[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Add GDB support
|
From: |
Ludovic Courtès |
|
Subject: |
[PATCH] Add GDB support |
|
Date: |
Mon, 17 Feb 2014 23:43:29 +0100 |
|
User-agent: |
Gnus/5.130007 (Ma Gnus v0.7) Emacs/24.3 (gnu/linux) |
Hello Guilers!
I’ve 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
‘scm->object’, which takes an SCM bit pattern and returns the
corresponding Scheme object (so it essentially duplicates the object
when using the FFI back-end, and “transports” it into GDB when using the
GDB back-end.) There’s 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 ‘master’. The stack-walking procedure also needs to be adjusted,
but I’d rather leave that to Andy or Mark for the moment.
WDYT?
Ludo’.
From 5aba4630e070ced07569c084df378375e03e8b27 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
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.
---
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
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -188,6 +188,7 @@ SYSTEM_BASE_SOURCES = \
system/base/lalr.scm \
system/base/message.scm \
system/base/target.scm \
+ system/base/types.scm \
system/base/ck.scm
ICE_9_SOURCES = \
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
new file mode 100644
index 0000000..70f8a2b
--- /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 Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(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>
+ (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. When
+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 (& || = _)
+ ((match-bit-pattern bits ((a || b) & n = c) consequent alternate)
+ (let ((tag (logand bits n)))
+ (if (= tag c)
+ (let ((b tag)
+ (a (logand bits (bitwise-not n))))
+ consequent)
+ alternate)))
+ ((match-bit-pattern bits (x & n = c) consequent alternate)
+ (let ((tag (logand bits n)))
+ (if (= tag c)
+ (let ((x bits))
+ consequent)
+ alternate)))
+ ((match-bit-pattern bits (_ & n = c) consequent alternate)
+ (let ((tag (logand bits n)))
+ (if (= tag c)
+ consequent
+ alternate)))
+ ((match-bit-pattern bits ((a << n) || c) consequent alternate)
+ (let ((tag (bitwise-and bits (- (expt 2 n) 1))))
+ (if (= 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 BITS."
+ ((_ 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>
+ (stringbuf string)
+ stringbuf?
+ (string stringbuf-contents))
+
+(set-record-type-printer! <stringbuf>
+ (lambda (stringbuf port)
+ (display "#<stringbuf " port)
+ (write (stringbuf-contents stringbuf) port)
+ (display "#>" port)))
+
+;; Structs.
+(define-record-type <inferior-struct>
+ (inferior-struct name fields)
+ inferior-struct?
+ (name inferior-struct-name)
+ (fields inferior-struct-fields))
+
+(set-record-type-printer! <inferior-struct>
+ (lambda (struct port)
+ (format port "#<struct ~a"
+ (inferior-struct-name struct))
+ (for-each (lambda (field)
+ (format port " ~s" field))
+ (inferior-struct-fields struct))
+ (format port "~x>" (object-address struct))))
+
+;; Fluids.
+(define-record-type <inferior-fluid>
+ (inferior-fluid number value)
+ inferior-fluid?
+ (number inferior-fluid-number)
+ (value inferior-fluid-value))
+
+(set-record-type-printer! <inferior-fluid>
+ (lambda (fluid port)
+ (match fluid
+ (($ <inferior-fluid> number)
+ (format port "#<fluid ~a ~x>"
+ 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>
+ (%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! <inferior-object>
+ (lambda (io port)
+ (match io
+ (($ <inferior-object> 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 = %tc3-struct))
+ (parameterize ((%visited-cells (vhash-consv address #t
+ (%visited-cells))))
+ (address->inferior-struct address
+ (- vtable-data-address %tc3-struct)
+ backend)))
+ (((_ & #x7f = %tc7-symbol) buf hash props)
+ (match (cell->object buf backend)
+ (($ <stringbuf> string)
+ (string->symbol string))))
+ (((_ & #x7f = %tc7-string) buf start len)
+ (match (cell->object buf backend)
+ (($ <stringbuf> string)
+ (substring string start (+ start len)))))
+ (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
+ (stringbuf (bytevector->string buf "ISO-8859-1")))
+ (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
+ len (bytevector buf (* 4 len)))
+ (stringbuf (bytevector->string buf "UTF-32LE")))
+ (((_ & #x7f = %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 = %tc7-dynamic-state))
+ (inferior-object 'dynamic-state address))
+ ((((flags+type << 8) || %tc7-port))
+ (inferior-port backend (logand flags+type #xff) address))
+ (((_ & #x7f = %tc7-program))
+ (inferior-object 'program address))
+ (((_ & #xffff = %tc16-bignum))
+ (inferior-object 'bignum address))
+ (((_ & #xffff = %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 = %tc7-number) mpi)
+ (inferior-object 'number address))
+ (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
+ (inferior-object 'hash-table address))
+ (((_ & #x7f = %tc7-pointer) address)
+ (make-pointer address))
+ (((_ & #x7f = %tc7-objcode))
+ (inferior-object 'objcode address))
+ (((_ & #x7f = %tc7-vm))
+ (inferior-object 'vm address))
+ (((_ & #x7f = %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 = %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
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = 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
--- /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-1301
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 στρινγ"
+ 'symbol 'λ
+ ;; 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>
+ (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"
+ '(<some-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))))))
--
1.8.4
From 20dc475a6b11291830d09d1281145304efcbdc0e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
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.
---
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
--- 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.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010, 2011, 2012, 2013
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010, 2011, 2012, 2013, 2014
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -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.
-* 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
@node Evaluation Model
@@ -1351,6 +1352,27 @@ This is a stepping trap, used to implement the ``step'',
``next'',
``step-instruction'', and ``next-instruction'' REPL commands.
@end deffn
address@hidden GDB Support
address@hidden GDB Support
+
address@hidden 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
address@hidden 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}).
+
@c Local Variables:
@c TeX-master: "guile.texi"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index dcbdba1..c7ceb16 100644
--- 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,
-## 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 @@ address@hidden@_la_SOURCES = _scm.h \
install-exec-hook:
rm -f $(DESTDIR)$(bindir)/guile-snarf.awk
+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=`pwd`; cd $(DESTDIR)$(libdir); \
+ for file in address@hidden@*; do \
+ case $$file in \
+ *-gdb.scm) ;; \
+ *.la) ;; \
+ *) if test -h $$file; then \
+ continue; \
+ fi; \
+ libname=$$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 = guile-snarf
# and people feel like maintaining them. For now, this is not the case.
noinst_SCRIPTS = guile-snarf-docs
-EXTRA_DIST = 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
+EXTRA_DIST = 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
diff --git a/libguile/libguile-2.0-gdb.scm b/libguile/libguile-2.0-gdb.scm
new file mode 100644
index 0000000..5e1a48c
--- /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 <http://www.gnu.org/licenses/>.
+
+(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 (= TYPE_CODE_ARRAY code)
+ (= 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=? name "SCM"))
+ (make-pretty-printer-worker
+ #f ; display hint
+ (lambda (printer)
+ (scm-value->string value
%gdb-memory-backend))
+ #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) (<= 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-backend))
+ (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
--
1.8.4
pgpGGPVxvSusx.pgp
Description: PGP signature
- [PATCH] Add GDB support,
Ludovic Courtès <=