From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 15735 invoked by alias); 16 Feb 2014 16:22:36 -0000 Mailing-List: contact gdb-help@sourceware.org; run by ezmlm Precedence: bulk List-Id: List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-owner@sourceware.org Received: (qmail 15724 invoked by uid 89); 16 Feb 2014 16:22:35 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.1 required=5.0 tests=AWL,BAYES_50,SPF_HELO_PASS,SPF_SOFTFAIL,UNSUBSCRIBE_BODY autolearn=no version=3.3.2 X-HELO: hera.aquilenet.fr Received: from hera.aquilenet.fr (HELO hera.aquilenet.fr) (141.255.128.1) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sun, 16 Feb 2014 16:22:32 +0000 Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id 2CC771787; Sun, 16 Feb 2014 17:22:28 +0100 (CET) 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 fnnM2wi+E2Dn; Sun, 16 Feb 2014 17:22:28 +0100 (CET) Received: from pluto (reverse-83.fdn.fr [80.67.176.83]) by hera.aquilenet.fr (Postfix) with ESMTPSA id BF7DE16C6; Sun, 16 Feb 2014 17:22:26 +0100 (CET) From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) To: guile-user@gnu.org Cc: gdb@sourceware.org, Doug Evans Subject: Blending Guile and GDB together X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 28 =?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 Date: Sun, 16 Feb 2014 16:22:00 -0000 Message-ID: <8738jjvxha.fsf@gnu.org> User-Agent: Gnus/5.130007 (Ma Gnus v0.7) Emacs/24.3 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-SW-Source: 2014-02/txt/msg00043.txt.bz2 --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Content-length: 8611 Hello! As a gift for Guile 2.0=E2=80=99s third birthday [0], here=E2=80=99s a quic= k hack to enhance the debugging experience for Guile hackers in GDB! The attached code is a GDB extension, written in Guile, using the nice Guile API that landed into GDB master last week (thanks, Doug!). Once you have GDB master (7.8) built with Guile support, just type this at the GDB prompt: (gdb) guile (load "scmpp.scm") =46rom there on, life in GDB is different. :-) The main feature is printing of =E2=80=98SCM=E2=80=99 values. As you know,= =E2=80=98SCM=E2=80=99 values are bit patterns, sometimes with pointers in disguise and so on=E2=80=93to = the experienced Guile hacker, =E2=80=9C404=E2=80=9D is synonymous with #t, not = =E2=80=9Cpage not found=E2=80=9D. So, before: --8<---------------cut here---------------start------------->8--- Breakpoint 1, scm_display (obj=3D0xf04310, port=3D0x6f9f30) at print.c:1437 1437 { (gdb) bt #0 scm_display (obj=3D0xf04310, port=3D0x6f9f30) at print.c:1437 #1 0x00007ffff7b28ef1 in vm_debug_engine (vm=3D, program=3D= 0x6eb240, argv=3D, nargs=3D2) at vm-i-system.c:855 #2 0x00007ffff7aaafe3 in scm_primitive_eval (exp=3Dexp@entry=3D0x8e1440) a= t eval.c:685 #3 0x00007ffff7aab043 in scm_eval (exp=3D0x8e1440, module_or_state=3Dmodul= e_or_state@entry=3D0x8a8c60) at eval.c:719 #4 0x00007ffff7afa26d in scm_shell (argc=3D1, argv=3D0x7fffffffd118) at sc= ript.c:441 #5 0x00007ffff7ac753d in invoke_main_func (body_data=3D0x7fffffffcfe0) at = init.c:337 #6 0x00007ffff7aa14ca in c_body (d=3D0x7fffffffcf20) at continuations.c:511 #7 0x00007ffff7b33ac8 in vm_regular_engine (vm=3D, program= =3D0x6f57e0, argv=3D, nargs=3D2) at vm-i-system.c:855 #8 0x00007ffff7aaaaa3 in scm_call_4 (proc=3D0x7d2570, arg1=3Darg1@entry=3D= 0x404, arg2=3D, arg3=3D,=20 arg4=3D) at eval.c:507 --8<---------------cut here---------------end--------------->8--- After: --8<---------------cut here---------------start------------->8--- (gdb) gu (load "scmpp.scm") (gdb) bt #0 scm_display (obj=3D("happy" birthday Guile (2 . 0)), port=3D#) at print.c:1437 #1 0x00007ffff7b28ef1 in vm_debug_engine (vm=3D, program=3D= #, argv=3D, nargs=3D2) at vm-i-system.c:855 #2 0x00007ffff7aaafe3 in scm_primitive_eval ( exp=3Dexp@entry=3D((@ (ice-9 control) %) (begin (load-user-init) ((@ (i= ce-9 top-repl) top-repl))))) at eval.c:685 #3 0x00007ffff7aab043 in scm_eval (exp=3D((@ (ice-9 control) %) (begin (lo= ad-user-init) ((@ (ice-9 top-repl) top-repl)))),=20 module_or_state=3Dmodule_or_state@entry=3D# (# (# () #f #f # (ice-9 deprecated) interface #f # () # #f # #f #f #f300b8= 40> # () #f #f # (srfi s= rfi-4) interface #f # () # #f # #f #f #f300b0e0>) #f #f # (guile) interface #= f # () # #f # #f #= #f3055dc0> # () #f #f # (system base compile) interface #f # () #= #f # #f #f #f30554a0> # () #f #f # (ice-9 readline) interfac= e #f # () # #f # #= f #f #f30626c0> # () #f #f # (ice-9 history) interface #f # () # #f # #f #f #f3063540> # () #f #f # (srfi srfi-1) interface #f # () # #f # #f #f #f3066500> # () #f #f # (srfi srfi-26)= interface #f # () # #f # #f #f #f3075b00> # () #f #f # (texinfo reflection) interface #f # () # #f # #f #f #f3075360> # (# (# () #f #f # (ice-9 null) interface #f = # () # #f # #f #f = #f3083560>) #f #f # (ice-9 safe-r5rs) interface #f # () # #f # #f #f #f30830e= 0>) #f #f # (ice-9 r5rs) interface #f # = () # #f # #f #f #f3088120> # () #f #f # (ice-9 session) inter= face #f # () # #f # #f #f #f3094160> # () #f #f # (ice-9 regex) interface #f # () # #f # #f #f #f30987c0> # () #f #f # (ice-9 threads) interface #f # () # #f # #f #f #f309bd20> = # () #f #f # (value-hist= ory) interface #f # () # #f # #f #f #f309b680>) #f #f # (guile-user) director= y #f # () # #f # #= f # () #f #f # (guile-us= er) interface #f # () # #f # #f #f #f30b3d20> #f30b3d00>) at eval.c:719 #4 0x00007ffff7afa26d in scm_shell (argc=3D1, argv=3D0x7fffffffd118) at sc= ript.c:441 #5 0x00007ffff7ac753d in invoke_main_func (body_data=3D0x7fffffffcfe0) at = init.c:337 #6 0x00007ffff7aa14ca in c_body (d=3D0x7fffffffcf20) at continuations.c:511 #7 0x00007ffff7b33ac8 in vm_regular_engine (vm=3D, program= =3D#, argv=3D, nargs=3D2) at vm-i-system.c:855 #8 0x00007ffff7aaaaa3 in scm_call_4 (proc=3D#, arg1=3Darg1= @entry=3D#t, arg2=3D, arg3=3D,=20 arg4=3D) at eval.c:507 --8<---------------cut here---------------end--------------->8--- (I hear some say: =E2=80=9Cis this huge dump of =E2=80=98module_or_state=E2= =80=99 really an improvement?=E2=80=9D Well, granted, this one is a bit annoying, we=E2=80= =99ll have to think of a way to truncate it, maybe. But it shows that many data types are pretty-printed, including all the structure fields. :-)) Traditionally, people would typically type =E2=80=98call scm_write(x, 0x204= )=E2=80=99 to print the value of =E2=80=98x=E2=80=99. But in addition to being tedious, = this won=E2=80=99t work on a core file, and can otherwise destabilize the Guile process being debugged. So scmpp.scm teaches GDB about Guile=E2=80=99s type tagging so that it can = print =E2=80=98SCM=E2=80=99 values. A decade ago or so, an SCM value printer was available in GDB itself (with =E2=80=98set language scheme=E2=80=99). But that was tricky C code, = and since it was maintained outside of Guile, it inevitably went out of sync. The good thing is that scmpp.scm can be maintained within Guile itself. This one is for Guile 2.0, but it shouldn=E2=80=99t be difficult to adjust = it to 2.2. The printing-value code in scmpp.scm uses a tailored pattern matcher that makes the bit-fiddling code easier to read. Furthermore, it can use one of two back-ends: GDB, or the FFI. The GDB back-end fiddles with values from an inferior process, while the FFI back-end touches values of the running process. The whole point of the FFI back-end is to allow for testing: we can run a test suite for the SCM-decoding code without having to run GDB itself. There=E2=80=99s also a simple VM stack walker at the end of the file, which= is quite handy. When GDB stack filters are supported, we might be able to arrange so that =E2=80=98bt=E2=80=99 shows both stacks interleaved. Happy hacking, and happy birthday Guile 2.0! Thanks, Ludo=E2=80=99. [0] http://lists.gnu.org/archive/html/guile-user/2014-02/msg00008.html --=-=-= Content-Type: text/x-scheme-src; charset=utf-8 Content-Disposition: inline; filename=scmpp.scm Content-Transfer-Encoding: quoted-printable Content-Description: the code! Content-length: 21997 ;;; Copyright (C) 2014 Ludovic Court=C3=A8s ;;; ;;; 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-130= 1 USA (define-module (scm-pretty-printing) #: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)) ;;; Commentary: ;;; ;;; 'SCM' type tag decoding and more to support Guile debugging in GDB. ;;; ;;; Code: (define-syntax when-gdb (lambda (s) (let ((gdb? (false-if-exception (resolve-interface '(gdb))))) (syntax-case s () ((_ body ...) (if gdb? #'(begin body ...) #'(begin))))))) (define-syntax if-gdb (lambda (s) (let ((gdb? (false-if-exception (resolve-interface '(gdb))))) (syntax-case s () ((_ with-gdb without-gdb) (if gdb? #'with-gdb #'without-gdb)))))) (when-gdb (use-modules ((gdb) #:hide (symbol?)) (gdb printing))) (define %word-size ;; The pointer size. (sizeof '*)) =0C ;;; ;;; Memory back-ends. ;;; (define-record-type (memory-backend peek open) memory-backend? (peek memory-backend-peek) (open memory-backend-open)) (when-gdb (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))) (memory-backend dereference-word open)))) (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))) (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))) =0C ;;; ;;; 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 BITS= ." ((_ bits clauses ...) (let ((bits* bits)) (match-scm-clauses bits* clauses ...))))) =0C ;;; ;;; Tags. ;;; ;; 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 (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." (if-gdb (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)))) #f)) (define (inferior-smob type-number address) "Return an object representing the SMOB at ADDRESS whose type is TYPE-NUMBER." (inferior-object 'smob (or (type-name-from-descriptor "scm_smobs" type-number) type-number) address)) (define (inferior-port type-number address) "Return an object representing the port at ADDRESS whose type is TYPE-NUMBER." (inferior-object 'port (or (type-name-from-descriptor "scm_ptobs" 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 v= alue (((_ & #x7f =3D %tc7-dynamic-state)) (inferior-object 'dynamic-state address)) ((((flags+type << 8) || %tc7-port)) (inferior-port (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)) (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 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)))))) =0C ;;; ;;; GDB pretty-printer registration. ;;; (when-gdb (define scm-value->string ;; (compose object->string scm->object value->integer) (lambda* (v #:optional (backend %gdb-memory-backend)) "Return a representation of value V as a string." (object->string (scm->object (value->integer v) 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)) =0C ;;; ;;; VM stack walking. ;;; (when-gdb (export vm-stack-pointer vm-frame-pointer display-vm-frames) (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) (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 %ffi-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))) ;;; Local Variables: ;;; eval: (put 'match-scm 'scheme-indent-function 1) ;;; eval: (put 'match-cell 'scheme-indent-function 1) ;;; End: ;;; scmpp.scm ends here --=-=-=-- --==-=-= Content-Type: application/pgp-signature Content-length: 197 -----BEGIN PGP SIGNATURE----- Version: GnuPG v2.0.22 (GNU/Linux) iEYEARECAAYFAlMA5cEACgkQd92V4upS7PSYpACdHA5VbS8lPBULqdnAuNIeFqrM doEAni5z2lGzasJZTw7UUtM4FLMDtHEe =yamJ -----END PGP SIGNATURE----- --==-=-=--