From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 1002 invoked by alias); 17 Feb 2014 02:50:45 -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 990 invoked by uid 89); 17 Feb 2014 02:50:44 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=4.3 required=5.0 tests=BAYES_95,FREEMAIL_FROM,RCVD_IN_DNSWL_LOW,SPF_PASS,UNSUBSCRIBE_BODY autolearn=no version=3.3.2 X-HELO: mail-pa0-f53.google.com Received: from mail-pa0-f53.google.com (HELO mail-pa0-f53.google.com) (209.85.220.53) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Mon, 17 Feb 2014 02:50:41 +0000 Received: by mail-pa0-f53.google.com with SMTP id lj1so14674091pab.12 for ; Sun, 16 Feb 2014 18:50:39 -0800 (PST) X-Received: by 10.66.151.205 with SMTP id us13mr7179123pab.93.1392605439094; Sun, 16 Feb 2014 18:50:39 -0800 (PST) Received: from [147.2.147.115] ([203.192.156.9]) by mx.google.com with ESMTPSA id sy2sm40403203pbc.28.2014.02.16.18.50.36 for (version=SSLv3 cipher=RC4-SHA bits=128/128); Sun, 16 Feb 2014 18:50:38 -0800 (PST) Message-ID: <1392605435.7138.51.camel@Renee-desktop.suse> Subject: Re: Blending Guile and GDB together From: Nala Ginrut To: Ludovic =?ISO-8859-1?Q?Court=E8s?= Cc: guile-user@gnu.org, gdb@sourceware.org Date: Mon, 17 Feb 2014 02:50:00 -0000 In-Reply-To: <8738jjvxha.fsf@gnu.org> References: <8738jjvxha.fsf@gnu.org> Content-Type: text/plain; charset="UTF-8" Mime-Version: 1.0 Content-Transfer-Encoding: quoted-printable X-SW-Source: 2014-02/txt/msg00047.txt.bz2 Cheers! On Sun, 2014-02-16 at 17:22 +0100, Ludovic Court=C3=A8s wrote: > Hello! >=20 > As a gift for Guile 2.0=E2=80=99s third birthday [0], here=E2=80=99s a qu= ick hack to > enhance the debugging experience for Guile hackers in GDB! >=20 > 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: >=20 > (gdb) guile (load "scmpp.scm") >=20 > From there on, life in GDB is different. :-) >=20 > The main feature is printing of =E2=80=98SCM=E2=80=99 values. As you kno= w, =E2=80=98SCM=E2=80=99 values > are bit patterns, sometimes with pointers in disguise and so on=E2=80=93t= o the > experienced Guile hacker, =E2=80=9C404=E2=80=9D is synonymous with #t, no= t =E2=80=9Cpage not > found=E2=80=9D. >=20 > So, before: >=20 > --8<---------------cut here---------------start------------->8--- > Breakpoint 1, scm_display (obj=3D0xf04310, port=3D0x6f9f30) at print.c:14= 37 > 1437 { > (gdb) bt > #0 scm_display (obj=3D0xf04310, port=3D0x6f9f30) at print.c:1437 > #1 0x00007ffff7b28ef1 in vm_debug_engine (vm=3D, program= =3D0x6eb240, argv=3D, nargs=3D2) > at vm-i-system.c:855 > #2 0x00007ffff7aaafe3 in scm_primitive_eval (exp=3Dexp@entry=3D0x8e1440)= at eval.c:685 > #3 0x00007ffff7aab043 in scm_eval (exp=3D0x8e1440, module_or_state=3Dmod= ule_or_state@entry=3D0x8a8c60) at eval.c:719 > #4 0x00007ffff7afa26d in scm_shell (argc=3D1, argv=3D0x7fffffffd118) at = script.c:441 > #5 0x00007ffff7ac753d in invoke_main_func (body_data=3D0x7fffffffcfe0) a= t init.c:337 > #6 0x00007ffff7aa14ca in c_body (d=3D0x7fffffffcf20) at continuations.c:= 511 > #7 0x00007ffff7b33ac8 in vm_regular_engine (vm=3D, progra= m=3D0x6f57e0, argv=3D, nargs=3D2) > at vm-i-system.c:855 > #8 0x00007ffff7aaaaa3 in scm_call_4 (proc=3D0x7d2570, arg1=3Darg1@entry= =3D0x404, arg2=3D, arg3=3D,=20 > arg4=3D) at eval.c:507 > --8<---------------cut here---------------end--------------->8--- >=20 > After: >=20 > --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) ((@ = (ice-9 top-repl) top-repl))))) at eval.c:685 > #3 0x00007ffff7aab043 in scm_eval (exp=3D((@ (ice-9 control) %) (begin (= load-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 #f300= b840> # () #f #f # (srfi= srfi-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) interf= ace #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-2= 6) interface #f # () # #f # #f #f #f3075b00> # () #f #f #<= program 824700> (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 #f3083= 0e0>) #f #f # (ice-9 r5rs) interface #f # () # #f # #f #f #f3088120> # () #f #f # (ice-9 session) int= erface #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-hi= story) interface #f # () # #f # #f #f #f309b680>) #f #f # (guile-user) direct= ory #f # () # #f #= #f # () #f #f # (guile-= user) interface #f # () # #f # #f #f #f30b3d20> #f30b3d00>) at eval.c:719 > #4 0x00007ffff7afa26d in scm_shell (argc=3D1, argv=3D0x7fffffffd118) at = script.c:441 > #5 0x00007ffff7ac753d in invoke_main_func (body_data=3D0x7fffffffcfe0) a= t init.c:337 > #6 0x00007ffff7aa14ca in c_body (d=3D0x7fffffffcf20) at continuations.c:= 511 > #7 0x00007ffff7b33ac8 in vm_regular_engine (vm=3D, progra= m=3D#, argv=3D, nargs=3D2) > at vm-i-system.c:855 > #8 0x00007ffff7aaaaa3 in scm_call_4 (proc=3D#, arg1=3Dar= g1@entry=3D#t, arg2=3D, arg3=3D,=20 > arg4=3D) at eval.c:507 > --8<---------------cut here---------------end--------------->8--- >=20 > (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. :-)) >=20 > Traditionally, people would typically type =E2=80=98call scm_write(x, 0x2= 04)=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. >=20 > So scmpp.scm teaches GDB about Guile=E2=80=99s type tagging so that it ca= n print > =E2=80=98SCM=E2=80=99 values. >=20 > 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. >=20 > 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 adjus= t it > to 2.2. >=20 > 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. >=20 > 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. >=20 > There=E2=80=99s also a simple VM stack walker at the end of the file, whi= ch 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. >=20 > Happy hacking, and happy birthday Guile 2.0! >=20 > Thanks, > Ludo=E2=80=99. >=20 > [0] http://lists.gnu.org/archive/html/guile-user/2014-02/msg00008.html >=20 > text/x-scheme-src type attachment (scmpp.scm), "the code!" > ;;; 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-1= 301 USA >=20 > (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)) >=20 > ;;; Commentary: > ;;; > ;;; 'SCM' type tag decoding and more to support Guile debugging in GDB. > ;;; > ;;; Code: >=20 > (define-syntax when-gdb > (lambda (s) > (let ((gdb? (false-if-exception (resolve-interface '(gdb))))) > (syntax-case s () > ((_ body ...) > (if gdb? > #'(begin body ...) > #'(begin))))))) >=20 > (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)))))) >=20 >=20 > (when-gdb (use-modules ((gdb) #:hide (symbol?)) > (gdb printing))) >=20 > (define %word-size > ;; The pointer size. > (sizeof '*)) >=20 > =0C > ;;; > ;;; Memory back-ends. > ;;; >=20 > (define-record-type > (memory-backend peek open) > memory-backend? > (peek memory-backend-peek) > (open memory-backend-open)) >=20 > (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*))))) >=20 > (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))) >=20 > (memory-backend dereference-word open)))) >=20 > (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))) >=20 > (define (open address size) > (define current-address address) >=20 > (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)) >=20 > (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))) >=20 > (memory-backend dereference-word open))) >=20 > (define-inlinable (dereference-word backend address) > "Return the word at ADDRESS, using BACKEND." > (let ((peek (memory-backend-peek backend))) > (peek address))) >=20 > (define-syntax memory-port > (syntax-rules () > "Return an input port to the SIZE bytes at ADDRESS, using BACKEND. W= hen > 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))))) >=20 > (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))) >=20 > =0C > ;;; > ;;; Matching bit patterns and cells. > ;;; >=20 > (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))) >=20 > (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))))) >=20 > (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)))) >=20 > (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 ...)) > ...)))))) >=20 > (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))) >=20 > (define-syntax match-scm > (syntax-rules () > "Match BITS, an integer representation of an 'SCM' value, against > CLAUSES. Each clause must have the form: >=20 > (PATTERN BODY ...) >=20 > 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 bi= nd > the matching bits, possibly with bitwise operations to extract it from BI= TS." > ((_ bits clauses ...) > (let ((bits* bits)) > (match-scm-clauses bits* clauses ...))))) >=20 > =0C > ;;; > ;;; Tags. > ;;; >=20 > ;; Immediate values. > (define %tc2-int 2) > (define %tc3-imm24 4) >=20 > (define %tc3-cons 0) > (define %tc3-int1 %tc2-int) > (define %tc3-int2 (+ %tc2-int 4)) >=20 > (define %tc8-char (+ 8 %tc3-imm24)) > (define %tc8-flag (+ %tc3-imm24 0)) >=20 > ;; 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) >=20 > (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))) >=20 >=20 > ;; "Stringbufs". > (define-record-type > (stringbuf string) > stringbuf? > (string stringbuf-contents)) >=20 > (set-record-type-printer! > (lambda (stringbuf port) > (display "# (write (stringbuf-contents stringbuf) port) > (display "#>" port))) >=20 > ;; Structs. > (define-record-type > (inferior-struct name fields) > inferior-struct? > (name inferior-struct-name) > (fields inferior-struct-fields)) >=20 > (set-record-type-printer! > (lambda (struct port) > (format port "# (inferior-struct-name struct)) > (for-each (lambda (field) > (format port " ~s" field)) > (inferior-struct-fields struct)) > (format port "~x>" (object-address struct)))) >=20 > ;; Fluids. > (define-record-type > (inferior-fluid number value) > inferior-fluid? > (number inferior-fluid-number) > (value inferior-fluid-value)) >=20 > (set-record-type-printer! > (lambda (fluid port) > (match fluid > (($ number) > (format port "#" > number > (object-address fluid)))))) >=20 > ;; 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)) >=20 > (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)))) >=20 > (set-record-type-printer! > (lambda (io port) > (match io > (($ kind sub-kind address) > (format port "#<~a ~:[~*~;~a ~]~x>" > kind sub-kind sub-kind > address))))) >=20 >=20 > (define (type-name-from-descriptor descriptor-array type-number) > "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, o= r #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)) >=20 > (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)) >=20 > (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)) >=20 >=20 > (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) >=20 > (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)))) >=20 > (define %visited-cells > ;; Vhash of already visited cells. Used to detect cycles, typically in > ;; structs. > (make-parameter vlist-null)) >=20 > (define* (cell->object address #:optional (backend %ffi-memory-backend)) > "Return an object representing the object at ADDRESS, reading from memo= ry > 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 (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)))))) >=20 >=20 > (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)))))) >=20 > =0C > ;;; > ;;; GDB pretty-printer registration. > ;;; >=20 > (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)))) >=20 >=20 > (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-= backend)) > #f)))))) >=20 > (define* (register-pretty-printer #:optional objfile) > (prepend-pretty-printer! objfile %scm-pretty-printer)) >=20 > (define (libguile-objfile) > (find (lambda (objfile) > (string-contains (objfile-filename objfile) "libguile-2.0.so")) > (objfiles))) >=20 > (register-pretty-printer)) >=20 > =0C > ;;; > ;;; VM stack walking. > ;;; >=20 > (when-gdb > (export vm-stack-pointer vm-frame-pointer display-vm-frames) >=20 > (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"))))) >=20 > (let loop ((frame (newest-frame))) > (and frame > (if (vm-engine-frame? frame) > frame > (loop (frame-older frame)))))) >=20 > (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")))) >=20 > (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")))) >=20 > (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))))) >=20 > (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-bac= kend)) > (display-objects fp sp) > (loop (+ 1 number) (- fp (* 5 %word-size)) link)))))) >=20 > ;; 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))) >=20 > ;;; Local Variables: > ;;; eval: (put 'match-scm 'scheme-indent-function 1) > ;;; eval: (put 'match-cell 'scheme-indent-function 1) > ;;; End: >=20 > ;;; scmpp.scm ends here