--- /dev/null
+;;; '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 (%word-size
+
+ memory-backend
+ memory-backend?
+ %ffi-memory-backend
+ dereference-word
+ memory-port
+ type-number->name
+
+ 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:
+
+\f
+;;;
+;;; 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-number->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))))
+
+\f
+;;;
+;;; 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 ...)))))
+
+\f
+;;;
+;;; 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-inferior-struct-fields!))
+
+(define print-inferior-struct
+ (let ((%printed-struct (make-parameter vlist-null)))
+ (lambda (struct port)
+ (if (vhash-assq struct (%printed-struct))
+ (format port "#-1#")
+ (begin
+ (format port "#<struct ~a"
+ (inferior-struct-name struct))
+ (parameterize ((%printed-struct
+ (vhash-consq struct #t (%printed-struct))))
+ (for-each (lambda (field)
+ (if (eq? field struct)
+ (display " #0#" port)
+ (format port " ~s" field)))
+ (inferior-struct-fields struct)))
+ (format port " ~x>" (object-address struct)))))))
+
+(set-record-type-printer! <inferior-struct> print-inferior-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-number->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-number->name backend 'port type-number)
+ type-number)
+ address))
+
+(define %visited-cells
+ ;; Vhash of mapping addresses of already visited cells to the
+ ;; corresponding inferior object. This is used to detect and represent
+ ;; cycles.
+ (make-parameter vlist-null))
+
+(define-syntax visited
+ (syntax-rules (->)
+ ((_ (address -> object) body ...)
+ (parameterize ((%visited-cells (vhash-consv address object
+ (%visited-cells))))
+ body ...))))
+
+(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 (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)))
+ (result (inferior-struct name #f)))
+
+ ;; Keep track of RESULT so callees can refer to it if we are
+ ;; decoding a circular struct.
+ (visited (address -> result)
+ (let ((values (map (cut scm->object <> backend)
+ (bytevector->uint-list fields
+ (native-endianness)
+ %word-size))))
+ (set-inferior-struct-fields! result values)
+ result)))
+ (inferior-object 'invalid-struct address))))
+
+(define* (cell->object address #:optional (backend %ffi-memory-backend))
+ "Return an object representing the object at ADDRESS, reading from memory
+using BACKEND."
+ (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
+ (let ((port (memory-port backend address)))
+ (match-cell port
+ (((vtable-data-address & 7 = %tc3-struct))
+ (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)))
+ (vector (make-vector len)))
+ (visited (address -> vector)
+ (fold (lambda (element index)
+ (vector-set! vector index element)
+ (+ 1 index))
+ 0
+ (map (cut scm->object <> backend)
+ (bytevector->uint-list words (native-endianness)
+ %word-size)))
+ vector)))
+ ((((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?
+ (or (and=> (vhash-assv address (%visited-cells)) cdr)
+ (let ((car type)
+ (cdrloc (+ address %word-size))
+ (pair (cons *unspecified* *unspecified*)))
+ (visited (address -> pair)
+ (set-car! pair (scm->object car backend))
+ (set-cdr! pair
+ (scm->object (dereference-word backend cdrloc)
+ backend))
+ pair)))
+ (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)
+;;; eval: (put 'visited 'scheme-indent-function 1)
+;;; End:
+
+;;; types.scm ends here
HCoop / bpt / guile.git / blobdiff