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-vector 13)
 245 (define %tc7-wvect 15)
 246 (define %tc7-string 21)
 247 (define %tc7-number 23)
 248 (define %tc7-hashtable 29)
 249 (define %tc7-pointer 31)
 250 (define %tc7-fluid 37)
 251 (define %tc7-stringbuf 39)
 252 (define %tc7-dynamic-state 45)
 253 (define %tc7-frame 47)
 254 (define %tc7-keyword 53)
 255 (define %tc7-program 69)
 256 (define %tc7-vm-continuation 71)
 257 (define %tc7-bytevector 77)
 258 (define %tc7-weak-set 85)
 259 (define %tc7-weak-table 87)
 260 (define %tc7-array 93)
 261 (define %tc7-bitvector 95)
 262 (define %tc7-port 125)
 263 (define %tc7-smob 127)
 264
 265 (define %tc16-bignum (+ %tc7-number (* 1 256)))
 266 (define %tc16-real (+ %tc7-number (* 2 256)))
 267 (define %tc16-complex (+ %tc7-number (* 3 256)))
 268 (define %tc16-fraction (+ %tc7-number (* 4 256)))
 269
 270
 271 ;; "Stringbufs".
 272 (define-record-type <stringbuf>
 273   (stringbuf string)
 274   stringbuf?
 275   (string stringbuf-contents))
 276
 277 (set-record-type-printer! <stringbuf>
 278                           (lambda (stringbuf port)
 279                             (display "#<stringbuf " port)
 280                             (write (stringbuf-contents stringbuf) port)
 281                             (display "#>" port)))
 282
 283 ;; Structs.
 284 (define-record-type <inferior-struct>
 285   (inferior-struct name fields)
 286   inferior-struct?
 287   (name   inferior-struct-name)
 288   (fields inferior-struct-fields set-inferior-struct-fields!))
 289
 290 (define print-inferior-struct
 291   (let ((%printed-struct (make-parameter vlist-null)))
 292     (lambda (struct port)
 293       (if (vhash-assq struct (%printed-struct))
 294           (format port "#-1#")
 295           (begin
 296             (format port "#<struct ~a"
 297                     (inferior-struct-name struct))
 298             (parameterize ((%printed-struct
 299                             (vhash-consq struct #t (%printed-struct))))
 300               (for-each (lambda (field)
 301                           (if (eq? field struct)
 302                               (display " #0#" port)
 303                               (format port " ~s" field)))
 304                         (inferior-struct-fields struct)))
 305             (format port " ~x>" (object-address struct)))))))
 306
 307 (set-record-type-printer! <inferior-struct> print-inferior-struct)
 308
 309 ;; Fluids.
 310 (define-record-type <inferior-fluid>
 311   (inferior-fluid number value)
 312   inferior-fluid?
 313   (number inferior-fluid-number)
 314   (value  inferior-fluid-value))
 315
 316 (set-record-type-printer! <inferior-fluid>
 317                           (lambda (fluid port)
 318                             (match fluid
 319                               (($ <inferior-fluid> number)
 320                                (format port "#<fluid ~a ~x>"
 321                                        number
 322                                        (object-address fluid))))))
 323
 324 ;; Object type to represent complex objects from the inferior process that
 325 ;; cannot be really converted to usable Scheme objects in the current
 326 ;; process.
 327 (define-record-type <inferior-object>
 328   (%inferior-object kind sub-kind address)
 329   inferior-object?
 330   (kind     inferior-object-kind)
 331   (sub-kind inferior-object-sub-kind)
 332   (address  inferior-object-address))
 333
 334 (define inferior-object
 335   (case-lambda
 336     "Return an object representing an inferior object at ADDRESS, of type
 337 KIND/SUB-KIND."
 338     ((kind address)
 339      (%inferior-object kind #f address))
 340     ((kind sub-kind address)
 341      (%inferior-object kind sub-kind address))))
 342
 343 (set-record-type-printer! <inferior-object>
 344                           (lambda (io port)
 345                             (match io
 346                               (($ <inferior-object> kind sub-kind address)
 347                                (format port "#<~a ~:[~*~;~a ~]~x>"
 348                                        kind sub-kind sub-kind
 349                                        address)))))
 350
 351 (define (inferior-smob backend type-number address)
 352   "Return an object representing the SMOB at ADDRESS whose type is
 353 TYPE-NUMBER."
 354   (inferior-object 'smob
 355                    (or (type-number->name backend 'smob type-number)
 356                        type-number)
 357                    address))
 358
 359 (define (inferior-port backend type-number address)
 360   "Return an object representing the port at ADDRESS whose type is
 361 TYPE-NUMBER."
 362   (inferior-object 'port
 363                    (or (type-number->name backend 'port type-number)
 364                        type-number)
 365                    address))
 366
 367 (define %visited-cells
 368   ;; Vhash of mapping addresses of already visited cells to the
 369   ;; corresponding inferior object.  This is used to detect and represent
 370   ;; cycles.
 371   (make-parameter vlist-null))
 372
 373 (define-syntax visited
 374   (syntax-rules (->)
 375     ((_ (address -> object) body ...)
 376      (parameterize ((%visited-cells (vhash-consv address object
 377                                                  (%visited-cells))))
 378        body ...))))
 379
 380 (define (address->inferior-struct address vtable-data-address backend)
 381   "Read the struct at ADDRESS using BACKEND.  Return an 'inferior-struct'
 382 object representing it."
 383   (define %vtable-layout-index 0)
 384   (define %vtable-name-index 5)
 385
 386   (let* ((layout-address (+ vtable-data-address
 387                             (* %vtable-layout-index %word-size)))
 388          (layout-bits    (dereference-word backend layout-address))
 389          (layout         (scm->object layout-bits backend))
 390          (name-address   (+ vtable-data-address
 391                             (* %vtable-name-index %word-size)))
 392          (name-bits      (dereference-word backend name-address))
 393          (name           (scm->object name-bits backend)))
 394     (if (symbol? layout)
 395         (let* ((layout (symbol->string layout))
 396                (len    (/ (string-length layout) 2))
 397                (slots  (dereference-word backend (+ address %word-size)))
 398                (port   (memory-port backend slots (* len %word-size)))
 399                (fields (get-bytevector-n port (* len %word-size)))
 400                (result (inferior-struct name #f)))
 401
 402           ;; Keep track of RESULT so callees can refer to it if we are
 403           ;; decoding a circular struct.
 404           (visited (address -> result)
 405             (let ((values (map (cut scm->object <> backend)
 406                                (bytevector->uint-list fields
 407                                                       (native-endianness)
 408                                                       %word-size))))
 409               (set-inferior-struct-fields! result values)
 410               result)))
 411         (inferior-object 'invalid-struct address))))
 412
 413 (define* (cell->object address #:optional (backend %ffi-memory-backend))
 414   "Return an object representing the object at ADDRESS, reading from memory
 415 using BACKEND."
 416   (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
 417       (let ((port (memory-port backend address)))
 418         (match-cell port
 419           (((vtable-data-address & 7 = %tc3-struct))
 420            (address->inferior-struct address
 421                                      (- vtable-data-address %tc3-struct)
 422                                      backend))
 423           (((_ & #x7f = %tc7-symbol) buf hash props)
 424            (match (cell->object buf backend)
 425              (($ <stringbuf> string)
 426               (string->symbol string))))
 427           (((_ & #x7f = %tc7-string) buf start len)
 428            (match (cell->object buf backend)
 429              (($ <stringbuf> string)
 430               (substring string start (+ start len)))))
 431           (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
 432            (stringbuf (bytevector->string buf "ISO-8859-1")))
 433           (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
 434             len (bytevector buf (* 4 len)))
 435            (stringbuf (bytevector->string buf (match (native-endianness)
 436                                                 ('little "UTF-32LE")
 437                                                 ('big "UTF-32BE")))))
 438           (((_ & #x7f = %tc7-bytevector) len address)
 439            (let ((bv-port (memory-port backend address len)))
 440              (get-bytevector-all bv-port)))
 441           ((((len << 8) || %tc7-vector))
 442            (let ((words  (get-bytevector-n port (* len %word-size)))
 443                  (vector (make-vector len)))
 444              (visited (address -> vector)
 445                (fold (lambda (element index)
 446                        (vector-set! vector index element)
 447                        (+ 1 index))
 448                      0
 449                      (map (cut scm->object <> backend)
 450                           (bytevector->uint-list words (native-endianness)
 451                                                  %word-size)))
 452                vector)))
 453           (((_ & #x7f = %tc7-wvect))
 454            (inferior-object 'weak-vector address))   ; TODO: show elements
 455           ((((n << 8) || %tc7-fluid) init-value)
 456            (inferior-fluid n #f))                    ; TODO: show current value
 457           (((_ & #x7f = %tc7-dynamic-state))
 458            (inferior-object 'dynamic-state address))
 459           ((((flags+type << 8) || %tc7-port))
 460            (inferior-port backend (logand flags+type #xff) address))
 461           (((_ & #x7f = %tc7-program))
 462            (inferior-object 'program address))
 463           (((_ & #xffff = %tc16-bignum))
 464            (inferior-object 'bignum address))
 465           (((_ & #xffff = %tc16-real) pad)
 466            (let* ((address (+ address (* 2 %word-size)))
 467                   (port    (memory-port backend address (sizeof double)))
 468                   (words   (get-bytevector-n port (sizeof double))))
 469              (bytevector-ieee-double-ref words 0 (native-endianness))))
 470           (((_ & #x7f = %tc7-number) mpi)
 471            (inferior-object 'number address))
 472           (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
 473            (inferior-object 'hash-table address))
 474           (((_ & #x7f = %tc7-pointer) address)
 475            (make-pointer address))
 476           (((_ & #x7f = %tc7-keyword) symbol)
 477            (symbol->keyword (cell->object symbol backend)))
 478           (((_ & #x7f = %tc7-vm-continuation))
 479            (inferior-object 'vm-continuation address))
 480           (((_ & #x7f = %tc7-weak-set))
 481            (inferior-object 'weak-set address))
 482           (((_ & #x7f = %tc7-weak-table))
 483            (inferior-object 'weak-table address))
 484           (((_ & #x7f = %tc7-array))
 485            (inferior-object 'array address))
 486           (((_ & #x7f = %tc7-bitvector))
 487            (inferior-object 'bitvector address))
 488           ((((smob-type << 8) || %tc7-smob) word1)
 489            (inferior-smob backend smob-type address))))))
 490
 491
 492 (define* (scm->object bits #:optional (backend %ffi-memory-backend))
 493   "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
 494 object."
 495   (match-scm bits
 496     (((integer << 2) || %tc2-int)
 497      integer)
 498     ((address & 6 = %tc3-cons)
 499      (let* ((type  (dereference-word backend address))
 500             (pair? (not (bit-set? 0 type))))
 501        (if pair?
 502            (or (and=> (vhash-assv address (%visited-cells)) cdr)
 503                (let ((car    type)
 504                      (cdrloc (+ address %word-size))
 505                      (pair   (cons *unspecified* *unspecified*)))
 506                  (visited (address -> pair)
 507                    (set-car! pair (scm->object car backend))
 508                    (set-cdr! pair
 509                              (scm->object (dereference-word backend cdrloc)
 510                                           backend))
 511                    pair)))
 512            (cell->object address backend))))
 513     (((char << 8) || %tc8-char)
 514      (integer->char char))
 515     (((flag << 8) || %tc8-flag)
 516      (case flag
 517        ((0)  #f)
 518        ((1)  #nil)
 519        ((3)  '())
 520        ((4)  #t)
 521        ((8)  (if #f #f))
 522        ((9)  (inferior-object 'undefined bits))
 523        ((10) (eof-object))
 524        ((11) (inferior-object 'unbound bits))))))
 525
 526 ;;; Local Variables:
 527 ;;; eval: (put 'match-scm 'scheme-indent-function 1)
 528 ;;; eval: (put 'match-cell 'scheme-indent-function 1)
 529 ;;; eval: (put 'visited 'scheme-indent-function 1)
 530 ;;; End:
 531
 532 ;;; types.scm ends here