From 5aba4630e070ced07569c084df378375e03e8b27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 17 Feb 2014 15:59:28 +0100 Subject: [PATCH 1/2] Add (system base types). * module/system/base/types.scm, test-suite/tests/types.test: New files. * module/Makefile.am (SYSTEM_BASE_SOURCES): Add system/base/types.scm. * test-suite/Makefile.am (SCM_TESTS): Add tests/types.test. --- module/Makefile.am | 1 + module/system/base/types.scm | 478 +++++++++++++++++++++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/types.test | 100 +++++++++ 4 files changed, 580 insertions(+) create mode 100644 module/system/base/types.scm create mode 100644 test-suite/tests/types.test diff --git a/module/Makefile.am b/module/Makefile.am index 5f777b6..fb9174b 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -188,6 +188,7 @@ SYSTEM_BASE_SOURCES = \ system/base/lalr.scm \ system/base/message.scm \ system/base/target.scm \ + system/base/types.scm \ system/base/ck.scm ICE_9_SOURCES = \ diff --git a/module/system/base/types.scm b/module/system/base/types.scm new file mode 100644 index 0000000..70f8a2b --- /dev/null +++ b/module/system/base/types.scm @@ -0,0 +1,478 @@ +;;; '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 . + +(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 (memory-backend + memory-backend? + %ffi-memory-backend + + 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: + + +;;; +;;; Memory back-ends. +;;; + +(define %word-size + ;; The pointer size. + (sizeof '*)) + +(define-record-type + (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-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)))) + + +;;; +;;; 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---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 string) + stringbuf? + (string stringbuf-contents)) + +(set-record-type-printer! + (lambda (stringbuf port) + (display "#" port))) + +;; Structs. +(define-record-type + (inferior-struct name fields) + inferior-struct? + (name inferior-struct-name) + (fields inferior-struct-fields)) + +(set-record-type-printer! + (lambda (struct port) + (format port "#" (object-address struct)))) + +;; Fluids. +(define-record-type + (inferior-fluid number value) + inferior-fluid? + (number inferior-fluid-number) + (value inferior-fluid-value)) + +(set-record-type-printer! + (lambda (fluid port) + (match fluid + (($ number) + (format port "#" + 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 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! + (lambda (io port) + (match io + (($ 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-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-name backend 'port 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) + (($ string) + (string->symbol string)))) + (((_ & #x7f = %tc7-string) buf start len) + (match (cell->object buf backend) + (($ 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 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? + (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)))))) + +;;; Local Variables: +;;; eval: (put 'match-scm 'scheme-indent-function 1) +;;; eval: (put 'match-cell 'scheme-indent-function 1) +;;; End: + +;;; types.scm ends here diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 7578bf5..41feb15 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/threads.test \ tests/time.test \ tests/tree-il.test \ + tests/types.test \ tests/version.test \ tests/vlist.test \ tests/weaks.test \ diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test new file mode 100644 index 0000000..a082836 --- /dev/null +++ b/test-suite/tests/types.test @@ -0,0 +1,100 @@ +;;;; types.test --- 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 library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-types) + #:use-module (test-suite lib) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:use-module (system vm vm) + #:use-module (system base types)) + +(define-syntax test-cloneable + (syntax-rules () + "Test whether each simple OBJECT is properly decoded." + ((_ object rest ...) + (begin + (let ((obj object)) + (pass-if-equal (object->string obj) obj + (scm->object (object-address obj)))) + (test-cloneable rest ...))) + ((_) + *unspecified*))) + +;; Test objects that can be directly cloned. +(with-test-prefix "clonable objects" + (test-cloneable + #t #f #nil (if #f #f) (eof-object) + 42 (expt 2 28) 3.14 + "narrow string" "wide στρινγ" + 'symbol 'λ + ;; NB: keywords are SMOBs. + '(2 . 3) (iota 123) '(1 (two ("three"))) + #(1 2 3) #(foo bar baz) + #vu8(255 254 253) + (make-pointer 123) (make-pointer #xdeadbeef))) + +(define-syntax test-inferior-objects + (syntax-rules () + "Test whether each OBJECT is recognized and wrapped as an +'inferior-object'." + ((_ (object kind sub-kind-pattern) rest ...) + (begin + (let ((obj object)) + (pass-if (object->string obj) + (let ((result (scm->object (object-address obj)))) + (and (inferior-object? result) + (eq? 'kind (inferior-object-kind result)) + (match (inferior-object-sub-kind result) + (sub-kind-pattern #t) + (_ #f)))))) + (test-inferior-objects rest ...))) + ((_) + *unspecified*))) + +(with-test-prefix "opaque objects" + (test-inferior-objects + ((make-guardian) smob (? integer?)) + (#:keyword smob (? integer?)) + ((%make-void-port "w") port (? integer?)) + ((open-input-string "hello") port (? integer?)) + ((lambda () #t) program _) + ((the-vm) vm _) + ((expt 2 70) bignum _)) + + (pass-if "fluid" + (let ((fluid (make-fluid))) + (inferior-fluid? (scm->object (object-address fluid)))))) + +(define-record-type + (some-struct x y z) + some-struct? + (x struct-x) + (y struct-y) + (z struct-z)) + +(with-test-prefix "structs" + + (pass-if-equal "simple struct" + '( a b c) + (let* ((struct (some-struct 'a 'b 'c)) + (result (scm->object (object-address struct)))) + (and (inferior-struct? result) + (cons (inferior-struct-name result) + (inferior-struct-fields result)))))) -- 1.8.4