module/system/base/types.scm

   1 ;;; 'SCM' type tag decoding.
   2 ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
   3 ;;;
   4 ;;; This library is free software; you can redistribute it and/or modify it
   5 ;;; under the terms of the GNU Lesser General Public License as published by
   6 ;;; the Free Software Foundation; either version 3 of the License, or (at
   7 ;;; your option) any later version.
   8 ;;;
   9 ;;; This library is distributed in the hope that it will be useful, but
  10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
  12 ;;; General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public License
  15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17 (define-module (system base types)
  18   #:use-module (rnrs bytevectors)
  19   #:use-module (rnrs io ports)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (srfi srfi-9 gnu)
  23   #:use-module (srfi srfi-11)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (srfi srfi-60)
  26   #:use-module (ice-9 match)
  27   #:use-module (ice-9 iconv)
  28   #:use-module (ice-9 format)
  29   #:use-module (ice-9 vlist)
  30   #:use-module (system foreign)
  31   #:export (%word-size
  32
  33             memory-backend
  34             memory-backend?
  35             %ffi-memory-backend
  36             dereference-word
  37             memory-port
  38             type-number->name
  39
  40             inferior-object?
  41             inferior-object-kind
  42             inferior-object-sub-kind
  43             inferior-object-address
  44
  45             inferior-fluid?
  46             inferior-fluid-number
  47
  48             inferior-struct?
  49             inferior-struct-name
  50             inferior-struct-fields
  51
  52             scm->object))
  53
  54 ;;; Commentary:
  55 ;;;
  56 ;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB.
  57 ;;;
  58 ;;; Code:
  59
  60 \f
  61 ;;;
  62 ;;; Memory back-ends.
  63 ;;;
  64
  65 (define %word-size
  66   ;; The pointer size.
  67   (sizeof '*))
  68
  69 (define-record-type <memory-backend>
  70   (memory-backend peek open type-name)
  71   memory-backend?
  72   (peek      memory-backend-peek)
  73   (open      memory-backend-open)
  74   (type-name memory-backend-type-name))           ; for SMOBs and ports
  75
  76 (define %ffi-memory-backend
  77   ;; The FFI back-end to access the current process's memory.  The main
  78   ;; purpose of this back-end is to allow testing.
  79   (let ()
  80     (define (dereference-word address)
  81       (let* ((ptr (make-pointer address))
  82              (bv  (pointer->bytevector ptr %word-size)))
  83         (bytevector-uint-ref bv 0 (native-endianness) %word-size)))
  84
  85     (define (open address size)
  86       (define current-address address)
  87
  88       (define (read-memory! bv index count)
  89         (let* ((ptr   (make-pointer current-address))
  90                (mem   (pointer->bytevector ptr count)))
  91           (bytevector-copy! mem 0 bv index count)
  92           (set! current-address (+ current-address count))
  93           count))
  94
  95       (if size
  96           (let* ((ptr (make-pointer address))
  97                  (bv  (pointer->bytevector ptr size)))
  98             (open-bytevector-input-port bv))
  99           (let ((port (make-custom-binary-input-port "ffi-memory"
 100                                                      read-memory!
 101                                                      #f #f #f)))
 102             (setvbuf port _IONBF)
 103             port)))
 104
 105     (memory-backend dereference-word open #f)))
 106
 107 (define-inlinable (dereference-word backend address)
 108   "Return the word at ADDRESS, using BACKEND."
 109   (let ((peek (memory-backend-peek backend)))
 110     (peek address)))
 111
 112 (define-syntax memory-port
 113   (syntax-rules ()
 114     "Return an input port to the SIZE bytes at ADDRESS, using BACKEND.  When
 115 SIZE is omitted, return an unbounded port to the memory at ADDRESS."
 116     ((_ backend address)
 117      (let ((open (memory-backend-open backend)))
 118        (open address #f)))
 119     ((_ backend address size)
 120      (let ((open (memory-backend-open backend)))
 121        (open address size)))))
 122
 123 (define (get-word port)
 124   "Read a word from PORT and return it as an integer."
 125   (let ((bv (get-bytevector-n port %word-size)))
 126     (bytevector-uint-ref bv 0 (native-endianness) %word-size)))
 127
 128 (define-inlinable (type-number->name backend kind number)
 129   "Return the name of the type NUMBER of KIND, where KIND is one of
 130 'smob or 'port, or #f if the information is unavailable."
 131   (let ((proc (memory-backend-type-name backend)))
 132     (and proc (proc kind number))))
 133
 134 \f
 135 ;;;
 136 ;;; Matching bit patterns and cells.
 137 ;;;
 138
 139 (define-syntax match-cell-words
 140   (syntax-rules (bytevector)
 141     ((_ port ((bytevector name len) rest ...) body)
 142      (let ((name      (get-bytevector-n port len))
 143            (remainder (modulo len %word-size)))
 144        (unless (zero? remainder)
 145          (get-bytevector-n port (- %word-size remainder)))
 146        (match-cell-words port (rest ...) body)))
 147     ((_ port (name rest ...) body)
 148      (let ((name (get-word port)))
 149        (match-cell-words port (rest ...) body)))
 150     ((_ port () body)
 151      body)))
 152
 153 (define-syntax match-bit-pattern
 154   (syntax-rules (& || = _)
 155     ((match-bit-pattern bits ((a || b) & n = c) consequent alternate)
 156      (let ((tag (logand bits n)))
 157        (if (= tag c)
 158            (let ((b tag)
 159                  (a (logand bits (bitwise-not n))))
 160              consequent)
 161            alternate)))
 162     ((match-bit-pattern bits (x & n = c) consequent alternate)
 163      (let ((tag (logand bits n)))
 164        (if (= tag c)
 165            (let ((x bits))
 166              consequent)
 167            alternate)))
 168     ((match-bit-pattern bits (_ & n = c) consequent alternate)
 169      (let ((tag (logand bits n)))
 170        (if (= tag c)
 171            consequent
 172            alternate)))
 173     ((match-bit-pattern bits ((a << n) || c) consequent alternate)
 174      (let ((tag (bitwise-and bits (- (expt 2 n) 1))))
 175        (if (= tag c)
 176            (let ((a (arithmetic-shift bits (- n))))
 177              consequent)
 178            alternate)))))
 179
 180 (define-syntax match-cell-clauses
 181   (syntax-rules ()
 182     ((_ port tag (((tag-pattern thing ...) body) rest ...))
 183      (match-bit-pattern tag tag-pattern
 184                         (match-cell-words port (thing ...) body)
 185                         (match-cell-clauses port tag (rest ...))))
 186     ((_ port tag ())
 187      (inferior-object 'unmatched-tag tag))))
 188
 189 (define-syntax match-cell
 190   (syntax-rules ()
 191     "Match a cell---i.e., a non-immediate value other than a pair.  The
 192 cell's contents are read from PORT."
 193     ((_ port (pattern body ...) ...)
 194      (let ((port* port)
 195            (tag   (get-word port)))
 196        (match-cell-clauses port* tag
 197                            ((pattern (begin body ...))
 198                             ...))))))
 199
 200 (define-syntax match-scm-clauses
 201   (syntax-rules ()
 202     ((_ bits
 203         (bit-pattern body ...)
 204         rest ...)
 205      (match-bit-pattern bits bit-pattern
 206                         (begin body ...)
 207                         (match-scm-clauses bits rest ...)))
 208     ((_ bits)
 209      'unmatched-scm)))
 210
 211 (define-syntax match-scm
 212   (syntax-rules ()
 213     "Match BITS, an integer representation of an 'SCM' value, against
 214 CLAUSES.  Each clause must have the form:
 215
 216   (PATTERN BODY ...)
 217
 218 PATTERN is a bit pattern that may specify bitwise operations on BITS to
 219 determine if it matches.  TEMPLATE specify the name of the variable to bind
 220 the matching bits, possibly with bitwise operations to extract it from BITS."
 221     ((_ bits clauses ...)
 222      (let ((bits* bits))
 223        (match-scm-clauses bits* clauses ...)))))
 224
 225 \f
 226 ;;;
 227 ;;; Tags---keep in sync with libguile/tags.h!
 228 ;;;
 229
 230 ;; Immediate values.
 231 (define %tc2-int 2)
 232 (define %tc3-imm24 4)
 233
 234 (define %tc3-cons 0)
 235 (define %tc3-int1 %tc2-int)
 236 (define %tc3-int2 (+ %tc2-int 4))
 237
 238 (define %tc8-char (+ 8 %tc3-imm24))
 239 (define %tc8-flag (+ %tc3-imm24 0))
 240
 241 ;; Cell types.
 242 (define %tc3-struct 1)
 243 (define %tc7-symbol 5)
 244 (define %tc7-variable 7)
 245 (define %tc7-vector 13)
 246 (define %tc7-wvect 15)
 247 (define %tc7-string 21)
 248 (define %tc7-number 23)
 249 (define %tc7-hashtable 29)
 250 (define %tc7-pointer 31)
 251 (define %tc7-fluid 37)
 252 (define %tc7-stringbuf 39)
 253 (define %tc7-dynamic-state 45)
 254 (define %tc7-frame 47)
 255 (define %tc7-keyword 53)
 256 (define %tc7-program 69)
 257 (define %tc7-vm-continuation 71)
 258 (define %tc7-bytevector 77)
 259 (define %tc7-weak-set 85)
 260 (define %tc7-weak-table 87)
 261 (define %tc7-array 93)
 262 (define %tc7-bitvector 95)
 263 (define %tc7-port 125)
 264 (define %tc7-smob 127)
 265
 266 (define %tc16-bignum (+ %tc7-number (* 1 256)))
 267 (define %tc16-real (+ %tc7-number (* 2 256)))
 268 (define %tc16-complex (+ %tc7-number (* 3 256)))
 269 (define %tc16-fraction (+ %tc7-number (* 4 256)))
 270
 271
 272 ;; "Stringbufs".
 273 (define-record-type <stringbuf>
 274   (stringbuf string)
 275   stringbuf?
 276   (string stringbuf-contents))
 277
 278 (set-record-type-printer! <stringbuf>
 279                           (lambda (stringbuf port)
 280                             (display "#<stringbuf " port)
 281                             (write (stringbuf-contents stringbuf) port)
 282                             (display "#>" port)))
 283
 284 ;; Structs.
 285 (define-record-type <inferior-struct>
 286   (inferior-struct name fields)
 287   inferior-struct?
 288   (name   inferior-struct-name)
 289   (fields inferior-struct-fields set-inferior-struct-fields!))
 290
 291 (define print-inferior-struct
 292   (let ((%printed-struct (make-parameter vlist-null)))
 293     (lambda (struct port)
 294       (if (vhash-assq struct (%printed-struct))
 295           (format port "#-1#")
 296           (begin
 297             (format port "#<struct ~a"
 298                     (inferior-struct-name struct))
 299             (parameterize ((%printed-struct
 300                             (vhash-consq struct #t (%printed-struct))))
 301               (for-each (lambda (field)
 302                           (if (eq? field struct)
 303                               (display " #0#" port)
 304                               (format port " ~s" field)))
 305                         (inferior-struct-fields struct)))
 306             (format port " ~x>" (object-address struct)))))))
 307
 308 (set-record-type-printer! <inferior-struct> print-inferior-struct)
 309
 310 ;; Fluids.
 311 (define-record-type <inferior-fluid>
 312   (inferior-fluid number value)
 313   inferior-fluid?
 314   (number inferior-fluid-number)
 315   (value  inferior-fluid-value))
 316
 317 (set-record-type-printer! <inferior-fluid>
 318                           (lambda (fluid port)
 319                             (match fluid
 320                               (($ <inferior-fluid> number)
 321                                (format port "#<fluid ~a ~x>"
 322                                        number
 323                                        (object-address fluid))))))
 324
 325 ;; Object type to represent complex objects from the inferior process that
 326 ;; cannot be really converted to usable Scheme objects in the current
 327 ;; process.
 328 (define-record-type <inferior-object>
 329   (%inferior-object kind sub-kind address)
 330   inferior-object?
 331   (kind     inferior-object-kind)
 332   (sub-kind inferior-object-sub-kind)
 333   (address  inferior-object-address))
 334
 335 (define inferior-object
 336   (case-lambda
 337     "Return an object representing an inferior object at ADDRESS, of type
 338 KIND/SUB-KIND."
 339     ((kind address)
 340      (%inferior-object kind #f address))
 341     ((kind sub-kind address)
 342      (%inferior-object kind sub-kind address))))
 343
 344 (set-record-type-printer! <inferior-object>
 345                           (lambda (io port)
 346                             (match io
 347                               (($ <inferior-object> kind sub-kind address)
 348                                (format port "#<~a ~:[~*~;~a ~]~x>"
 349                                        kind sub-kind sub-kind
 350                                        address)))))
 351
 352 (define (inferior-smob backend type-number address)
 353   "Return an object representing the SMOB at ADDRESS whose type is
 354 TYPE-NUMBER."
 355   (inferior-object 'smob
 356                    (or (type-number->name backend 'smob type-number)
 357                        type-number)
 358                    address))
 359
 360 (define (inferior-port backend type-number address)
 361   "Return an object representing the port at ADDRESS whose type is
 362 TYPE-NUMBER."
 363   (inferior-object 'port
 364                    (or (type-number->name backend 'port type-number)
 365                        type-number)
 366                    address))
 367
 368 (define %visited-cells
 369   ;; Vhash of mapping addresses of already visited cells to the
 370   ;; corresponding inferior object.  This is used to detect and represent
 371   ;; cycles.
 372   (make-parameter vlist-null))
 373
 374 (define-syntax visited
 375   (syntax-rules (->)
 376     ((_ (address -> object) body ...)
 377      (parameterize ((%visited-cells (vhash-consv address object
 378                                                  (%visited-cells))))
 379        body ...))))
 380
 381 (define (address->inferior-struct address vtable-data-address backend)
 382   "Read the struct at ADDRESS using BACKEND.  Return an 'inferior-struct'
 383 object representing it."
 384   (define %vtable-layout-index 0)
 385   (define %vtable-name-index 5)
 386
 387   (let* ((layout-address (+ vtable-data-address
 388                             (* %vtable-layout-index %word-size)))
 389          (layout-bits    (dereference-word backend layout-address))
 390          (layout         (scm->object layout-bits backend))
 391          (name-address   (+ vtable-data-address
 392                             (* %vtable-name-index %word-size)))
 393          (name-bits      (dereference-word backend name-address))
 394          (name           (scm->object name-bits backend)))
 395     (if (symbol? layout)
 396         (let* ((layout (symbol->string layout))
 397                (len    (/ (string-length layout) 2))
 398                (slots  (dereference-word backend (+ address %word-size)))
 399                (port   (memory-port backend slots (* len %word-size)))
 400                (fields (get-bytevector-n port (* len %word-size)))
 401                (result (inferior-struct name #f)))
 402
 403           ;; Keep track of RESULT so callees can refer to it if we are
 404           ;; decoding a circular struct.
 405           (visited (address -> result)
 406             (let ((values (map (cut scm->object <> backend)
 407                                (bytevector->uint-list fields
 408                                                       (native-endianness)
 409                                                       %word-size))))
 410               (set-inferior-struct-fields! result values)
 411               result)))
 412         (inferior-object 'invalid-struct address))))
 413
 414 (define* (cell->object address #:optional (backend %ffi-memory-backend))
 415   "Return an object representing the object at ADDRESS, reading from memory
 416 using BACKEND."
 417   (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
 418       (let ((port (memory-port backend address)))
 419         (match-cell port
 420           (((vtable-data-address & 7 = %tc3-struct))
 421            (address->inferior-struct address
 422                                      (- vtable-data-address %tc3-struct)
 423                                      backend))
 424           (((_ & #x7f = %tc7-symbol) buf hash props)
 425            (match (cell->object buf backend)
 426              (($ <stringbuf> string)
 427               (string->symbol string))))
 428           (((_ & #x7f = %tc7-variable) obj)
 429            (inferior-object 'variable address))
 430           (((_ & #x7f = %tc7-string) buf start len)
 431            (match (cell->object buf backend)
 432              (($ <stringbuf> string)
 433               (substring string start (+ start len)))))
 434           (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
 435            (stringbuf (bytevector->string buf "ISO-8859-1")))
 436           (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
 437             len (bytevector buf (* 4 len)))
 438            (stringbuf (bytevector->string buf (match (native-endianness)
 439                                                 ('little "UTF-32LE")
 440                                                 ('big "UTF-32BE")))))
 441           (((_ & #x7f = %tc7-bytevector) len address)
 442            (let ((bv-port (memory-port backend address len)))
 443              (get-bytevector-all bv-port)))
 444           ((((len << 8) || %tc7-vector))
 445            (let ((words  (get-bytevector-n port (* len %word-size)))
 446                  (vector (make-vector len)))
 447              (visited (address -> vector)
 448                (fold (lambda (element index)
 449                        (vector-set! vector index element)
 450                        (+ 1 index))
 451                      0
 452                      (map (cut scm->object <> backend)
 453                           (bytevector->uint-list words (native-endianness)
 454                                                  %word-size)))
 455                vector)))
 456           (((_ & #x7f = %tc7-wvect))
 457            (inferior-object 'weak-vector address))   ; TODO: show elements
 458           ((((n << 8) || %tc7-fluid) init-value)
 459            (inferior-fluid n #f))                    ; TODO: show current value
 460           (((_ & #x7f = %tc7-dynamic-state))
 461            (inferior-object 'dynamic-state address))
 462           ((((flags+type << 8) || %tc7-port))
 463            (inferior-port backend (logand flags+type #xff) address))
 464           (((_ & #x7f = %tc7-program))
 465            (inferior-object 'program address))
 466           (((_ & #xffff = %tc16-bignum))
 467            (inferior-object 'bignum address))
 468           (((_ & #xffff = %tc16-real) pad)
 469            (let* ((address (+ address (* 2 %word-size)))
 470                   (port    (memory-port backend address (sizeof double)))
 471                   (words   (get-bytevector-n port (sizeof double))))
 472              (bytevector-ieee-double-ref words 0 (native-endianness))))
 473           (((_ & #x7f = %tc7-number) mpi)
 474            (inferior-object 'number address))
 475           (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
 476            (inferior-object 'hash-table address))
 477           (((_ & #x7f = %tc7-pointer) address)
 478            (make-pointer address))
 479           (((_ & #x7f = %tc7-keyword) symbol)
 480            (symbol->keyword (cell->object symbol backend)))
 481           (((_ & #x7f = %tc7-vm-continuation))
 482            (inferior-object 'vm-continuation address))
 483           (((_ & #x7f = %tc7-weak-set))
 484            (inferior-object 'weak-set address))
 485           (((_ & #x7f = %tc7-weak-table))
 486            (inferior-object 'weak-table address))
 487           (((_ & #x7f = %tc7-array))
 488            (inferior-object 'array address))
 489           (((_ & #x7f = %tc7-bitvector))
 490            (inferior-object 'bitvector address))
 491           ((((smob-type << 8) || %tc7-smob) word1)
 492            (inferior-smob backend smob-type address))))))
 493
 494
 495 (define* (scm->object bits #:optional (backend %ffi-memory-backend))
 496   "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
 497 object."
 498   (match-scm bits
 499     (((integer << 2) || %tc2-int)
 500      integer)
 501     ((address & 6 = %tc3-cons)
 502      (let* ((type  (dereference-word backend address))
 503             (pair? (not (bit-set? 0 type))))
 504        (if pair?
 505            (or (and=> (vhash-assv address (%visited-cells)) cdr)
 506                (let ((car    type)
 507                      (cdrloc (+ address %word-size))
 508                      (pair   (cons *unspecified* *unspecified*)))
 509                  (visited (address -> pair)
 510                    (set-car! pair (scm->object car backend))
 511                    (set-cdr! pair
 512                              (scm->object (dereference-word backend cdrloc)
 513                                           backend))
 514                    pair)))
 515            (cell->object address backend))))
 516     (((char << 8) || %tc8-char)
 517      (integer->char char))
 518     (((flag << 8) || %tc8-flag)
 519      (case flag
 520        ((0)  #f)
 521        ((1)  #nil)
 522        ((3)  '())
 523        ((4)  #t)
 524        ((8)  (if #f #f))
 525        ((9)  (inferior-object 'undefined bits))
 526        ((10) (eof-object))
 527        ((11) (inferior-object 'unbound bits))))))
 528
 529 ;;; Local Variables:
 530 ;;; eval: (put 'match-scm 'scheme-indent-function 1)
 531 ;;; eval: (put 'match-cell 'scheme-indent-function 1)
 532 ;;; eval: (put 'visited 'scheme-indent-function 1)
 533 ;;; End:
 534
 535 ;;; types.scm ends here