Cheers!
On Sun, 2014-02-16 at 17:22 +0100, Ludovic Courtès wrote:
> Hello!
>
> As a gift for Guile 2.0’s third birthday [0], here’s a quick 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")
>
> From there on, life in GDB is different. :-)
>
> The main feature is printing of ‘SCM’ values. As you know, ‘SCM’ values
> are bit patterns, sometimes with pointers in disguise and so on–to the
> experienced Guile hacker, “404” is synonymous with #t, not “page not
> found”.
>
> So, before:
>
> --8<---------------cut here---------------start------------->8---
> Breakpoint 1, scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437
> 1437 {
> (gdb) bt
> #0 scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437
> #1 0x00007ffff7b28ef1 in vm_debug_engine (vm=<optimized out>,
> program=0x6eb240, argv=<optimized out>, nargs=2)
> at vm-i-system.c:855
> #2 0x00007ffff7aaafe3 in scm_primitive_eval (exp=exp@entry=0x8e1440) at
> eval.c:685
> #3 0x00007ffff7aab043 in scm_eval (exp=0x8e1440,
> module_or_state=module_or_state@entry=0x8a8c60) at eval.c:719
> #4 0x00007ffff7afa26d in scm_shell (argc=1, argv=0x7fffffffd118) at
> script.c:441
> #5 0x00007ffff7ac753d in invoke_main_func (body_data=0x7fffffffcfe0) at
> init.c:337
> #6 0x00007ffff7aa14ca in c_body (d=0x7fffffffcf20) at continuations.c:511
> #7 0x00007ffff7b33ac8 in vm_regular_engine (vm=<optimized out>,
> program=0x6f57e0, argv=<optimized out>, nargs=2)
> at vm-i-system.c:855
> #8 0x00007ffff7aaaaa3 in scm_call_4 (proc=0x7d2570, arg1=arg1@entry=0x404,
> arg2=<optimized out>, arg3=<optimized out>,
> arg4=<optimized out>) 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=("happy" birthday Guile (2 . 0)), port=#<port file
> 6f9f30>) at print.c:1437
> #1 0x00007ffff7b28ef1 in vm_debug_engine (vm=<optimized out>,
> program=#<program 6eb240>, argv=<optimized out>, nargs=2)
> at vm-i-system.c:855
> #2 0x00007ffff7aaafe3 in scm_primitive_eval (
> exp=exp@entry=((@ (ice-9 control) %) (begin (load-user-init) ((@ (ice-9
> top-repl) top-repl))))) at eval.c:685
> #3 0x00007ffff7aab043 in scm_eval (exp=((@ (ice-9 control) %) (begin
> (load-user-init) ((@ (ice-9 top-repl) top-repl)))),
> module_or_state=module_or_state@entry=#<struct module #<hash-table
> 8b5240> (#<struct module #<hash-table 66df80> (#<struct module #<hash-table
> 871ac0> () #f #f #<program 824700> (ice-9 deprecated) interface #f
> #<hash-table 871aa0> () #<hash-table 871a80> #f #<hash-table 871a40> #f #f
> #f300b840> #<struct module #<hash-table 891180> () #f #f #<program 824700>
> (srfi srfi-4) interface #f #<hash-table 891160> () #<hash-table 891140> #f
> #<hash-table 891100> #f #f #f300b0e0>) #f #f #<program 824700> (guile)
> interface #f #<hash-table 846740> () #<hash-table 846720> #f #<hash-table
> 8466e0> #f #<cycle 822ab0> #f3055dc0> #<struct module #<hash-table 883660> ()
> #f #f #<program 824700> (system base compile) interface #f #<hash-table
> 883640> () #<hash-table 883620> #f #<hash-table 8835e0> #f #f #f30554a0>
> #<struct module #<hash-table bb6a00> () #f #f #<program 824700> (ice-9
> readline) interface #f #<hash-table bb69e0> () #<hash-table bb69c0> #f
> #<hash-table bb6980> #f #f #f30626c0> #<struct module #<hash-table b0e580> ()
> #f #f #<program 824700> (ice-9 history) interface #f #<hash-table b0e560> ()
> #<hash-table b0e540> #f #<hash-table b0e500> #f #f #f3063540> #<struct module
> #<hash-table 6b1e20> () #f #f #<program 824700> (srfi srfi-1) interface #f
> #<hash-table 6b1e00> () #<hash-table 6b1de0> #f #<hash-table 6b17a0> #f #f
> #f3066500> #<struct module #<hash-table a7a2a0> () #f #f #<program 824700>
> (srfi srfi-26) interface #f #<hash-table a7a280> () #<hash-table a7a260> #f
> #<hash-table a7a220> #f #f #f3075b00> #<struct module #<hash-table bdd440> ()
> #f #f #<program 824700> (texinfo reflection) interface #f #<hash-table
> bdd420> () #<hash-table bdd400> #f #<hash-table bdd3c0> #f #f #f3075360>
> #<struct module #<hash-table d99ba0> (#<struct module #<hash-table da07a0>
> (#<struct module #<hash-table dbc0a0> () #f #f #<program 824700> (ice-9 null)
> interface #f #<hash-table dbc060> () #<hash-table dbc020> #f #<hash-table
> dbec40> #f #f #f3083560>) #f #f #<program 824700> (ice-9 safe-r5rs) interface
> #f #<hash-table da0780> () #<hash-table da0660> #f #<hash-table da0520> #f #f
> #f30830e0>) #f #f #<program 824700> (ice-9 r5rs) interface #f #<hash-table
> d99ae0> () #<hash-table d99ac0> #f #<hash-table d999e0> #f #f #f3088120>
> #<struct module #<hash-table b47040> () #f #f #<program 824700> (ice-9
> session) interface #f #<hash-table b47020> () #<hash-table b47000> #f
> #<hash-table b57c60> #f #f #f3094160> #<struct module #<hash-table 9819c0> ()
> #f #f #<program 824700> (ice-9 regex) interface #f #<hash-table 9819a0> ()
> #<hash-table 981980> #f #<hash-table 9818c0> #f #f #f30987c0> #<struct module
> #<hash-table de0280> () #f #f #<program 824700> (ice-9 threads) interface #f
> #<hash-table de0140> () #<hash-table de0120> #f #<hash-table de0060> #f #f
> #f309bd20> #<struct module #<hash-table b0e220> () #f #f #<program 824700>
> (value-history) interface #f #<hash-table b0e200> () #<hash-table b0e1e0> #f
> #<hash-table b0e1a0> #f #f #f309b680>) #f #f #<program 824700> (guile-user)
> directory #f #<hash-table 8b5220> () #<hash-table 8b5200> #f #<hash-table
> 8b51c0> #f #<struct module #<hash-table 8b5160> () #f #f #<program 824700>
> (guile-user) interface #f #<hash-table 8b5140> () #<hash-table 8b5120> #f
> #<hash-table 8b50e0> #f #f #f30b3d20> #f30b3d00>) at eval.c:719
> #4 0x00007ffff7afa26d in scm_shell (argc=1, argv=0x7fffffffd118) at
> script.c:441
> #5 0x00007ffff7ac753d in invoke_main_func (body_data=0x7fffffffcfe0) at
> init.c:337
> #6 0x00007ffff7aa14ca in c_body (d=0x7fffffffcf20) at continuations.c:511
> #7 0x00007ffff7b33ac8 in vm_regular_engine (vm=<optimized out>,
> program=#<program 6f57e0>, argv=<optimized out>, nargs=2)
> at vm-i-system.c:855
> #8 0x00007ffff7aaaaa3 in scm_call_4 (proc=#<program 7d2570>,
> arg1=arg1@entry=#t, arg2=<optimized out>, arg3=<optimized out>,
> arg4=<optimized out>) at eval.c:507
> --8<---------------cut here---------------end--------------->8---
>
> (I hear some say: “is this huge dump of ‘module_or_state’ really an
> improvement?” Well, granted, this one is a bit annoying, we’ll 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 ‘call scm_write(x, 0x204)’ to
> print the value of ‘x’. But in addition to being tedious, this won’t
> work on a core file, and can otherwise destabilize the Guile process
> being debugged.
>
> So scmpp.scm teaches GDB about Guile’s type tagging so that it can print
> ‘SCM’ values.
>
> A decade ago or so, an SCM value printer was available in GDB itself
> (with ‘set language scheme’). 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’t 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’s 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 ‘bt’ shows both stacks interleaved.
>
> Happy hacking, and happy birthday Guile 2.0!
>
> Thanks,
> Ludo’.
>
> [0] http://lists.gnu.org/archive/html/guile-user/2014-02/msg00008.html
>
> text/x-scheme-src type attachment (scmpp.scm), "the code!"
> ;;; Copyright (C) 2014 Ludovic Courtès <l...@gnu.org>
> ;;;
> ;;; 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 (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 '*))
>
>
> ;;;
> ;;; Memory back-ends.
> ;;;
>
> (define-record-type <memory-backend>
> (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)))
>
>
> ;;;
> ;;; 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.
> ;;;
>
> ;; 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 (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 (= 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))))
> #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 = %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 (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))
> (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 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))))))
>
>
> ;;;
> ;;; 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=? 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.
> ;;;
>
> (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) (<= 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 %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
