301 lines
10 KiB
Scheme
301 lines
10 KiB
Scheme
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|||
|
|
|
|||
|
|
; This is file struct.scm.
|
|||
|
|
|
|||
|
|
; This file defines a level of abstraction for storage somewhat higher
|
|||
|
|
; than that of d-vectors and b-vectors: pairs, symbols, and other datatypes.
|
|||
|
|
|
|||
|
|
; An ugly and unsafe macro for defining VM data structures.
|
|||
|
|
;
|
|||
|
|
; (DEFINE-PRIMITIVE-DATA-TYPE <name> <type> <immutable?> <constructor-name>
|
|||
|
|
; <slot>*)
|
|||
|
|
; <slot> ::= (<accessor-name>) | (<accessor-name> <modifier-name>)
|
|||
|
|
;
|
|||
|
|
; (define-primitive-data-type pair N #f cons (car set-car!) (cdr))
|
|||
|
|
; =>
|
|||
|
|
; (begin
|
|||
|
|
; (define (cons a b) (d-vector ...))
|
|||
|
|
; (define pair? (stob-predicate ...))
|
|||
|
|
; (define pair-size 3)
|
|||
|
|
; (define (car x) (d-vector-ref x 0))
|
|||
|
|
; (define (set-car! x val) (d-vector-set! x 0 val))
|
|||
|
|
; (define (cdr x) (d-vector-ref x 1))
|
|||
|
|
|
|||
|
|
(define-syntax define-primitive-data-type
|
|||
|
|
(lambda (exp rename compare)
|
|||
|
|
(destructure (((d-p-d-t name type immutable? make . body) exp))
|
|||
|
|
(define (concatenate-symbol . syms)
|
|||
|
|
(string->symbol (apply string-append (map symbol->string syms))))
|
|||
|
|
(let* ((pred (concatenate-symbol name '?))
|
|||
|
|
(size (concatenate-symbol name '- 'size))
|
|||
|
|
(shorten (lambda (l1 l2) (map (lambda (x1 x2) x2 x1) l1 l2)))
|
|||
|
|
(vars (shorten `(a b c d e f g) body)))
|
|||
|
|
`(begin (define ,make
|
|||
|
|
(let ((type (enum stob ,type)))
|
|||
|
|
(lambda (,@vars key)
|
|||
|
|
,(if immutable?
|
|||
|
|
`(immutable-d-vector type key ,@vars)
|
|||
|
|
`(d-vector type key ,@vars)))))
|
|||
|
|
(define ,pred (stob-predicate (enum stob ,type)))
|
|||
|
|
(define ,size (+ ,(length body) 1))
|
|||
|
|
,@(do ((s body (cdr s))
|
|||
|
|
(i 0 (+ i 1))
|
|||
|
|
(d '() (let* ((slot (car s))
|
|||
|
|
(d (cons `(define (,(car slot) x)
|
|||
|
|
(d-vector-ref x ,i))
|
|||
|
|
d)))
|
|||
|
|
(if (null? (cdr slot))
|
|||
|
|
d
|
|||
|
|
(cons `(define (,(cadr slot) x val)
|
|||
|
|
(d-vector-set! x ,i val))
|
|||
|
|
d)))))
|
|||
|
|
((null? s) (reverse d))))))))
|
|||
|
|
|
|||
|
|
; This is a front for DEFINE-PRIMITIVE-DATA-TYPE that gets the names from
|
|||
|
|
; STOB-DATA (which is defined in arch.scm). This ensures that the run-time
|
|||
|
|
; code, the VM, and the linker agree on what these structures look like.
|
|||
|
|
;
|
|||
|
|
; SCHEME? is #T if the data structure is a Scheme structure, in which case
|
|||
|
|
; the names defined by the form all have VM- prepended.
|
|||
|
|
|
|||
|
|
(define-syntax define-shared-primitive-data-type
|
|||
|
|
(lambda (exp rename compare)
|
|||
|
|
(let ((name (cadr exp))
|
|||
|
|
(scheme? (if (null? (cddr exp)) #f (car (cddr exp))))
|
|||
|
|
(immutable? (if (or (null? (cddr exp))
|
|||
|
|
(null? (cdddr exp)))
|
|||
|
|
#f
|
|||
|
|
(cadr (cddr exp)))))
|
|||
|
|
(define (concatenate-symbol . syms)
|
|||
|
|
(string->symbol (apply string-append (map symbol->string syms))))
|
|||
|
|
(let ((data (cddr (assq name stob-data)))
|
|||
|
|
(fixup (lambda (n)
|
|||
|
|
(if scheme? (concatenate-symbol 'vm- n) n))))
|
|||
|
|
`(define-primitive-data-type
|
|||
|
|
,(fixup name)
|
|||
|
|
,name
|
|||
|
|
,immutable?
|
|||
|
|
,(fixup (car data))
|
|||
|
|
. ,(map (lambda (p)
|
|||
|
|
(cons (fixup (car p))
|
|||
|
|
(if (not (cadr p))
|
|||
|
|
'()
|
|||
|
|
(list (fixup (cadr p))))))
|
|||
|
|
(cdr data)))))))
|
|||
|
|
|
|||
|
|
; A d-vector macro version of the VECTOR procedure.
|
|||
|
|
; This is only used in the expansion of DEFINE-PRIMITIVE-DATA-TYPE.
|
|||
|
|
|
|||
|
|
(define-syntax d-vector
|
|||
|
|
(lambda (exp rename compare)
|
|||
|
|
(destructure (((d-v type key . args) exp))
|
|||
|
|
`(let ((v (make-d-vector ,type ,(length args) key)))
|
|||
|
|
,@(do ((a args (cdr a))
|
|||
|
|
(i 0 (+ i 1))
|
|||
|
|
(z '() (cons `(d-vector-set! v ,i ,(car a)) z)))
|
|||
|
|
((null? a) (reverse z)))
|
|||
|
|
v))))
|
|||
|
|
|
|||
|
|
(define-syntax immutable-d-vector
|
|||
|
|
(syntax-rules ()
|
|||
|
|
((immutable-d-vector stuff ...)
|
|||
|
|
(let ((vec (d-vector stuff ...)))
|
|||
|
|
(make-immutable! vec)
|
|||
|
|
vec))))
|
|||
|
|
|
|||
|
|
; A simpler macro for defining types of vectors. Again SCHEME? being #T
|
|||
|
|
; causes VM- to be prepended to the defined names.
|
|||
|
|
|
|||
|
|
(define-syntax define-vector-data-type
|
|||
|
|
(lambda (exp rename compare)
|
|||
|
|
(let ((name (cadr exp))
|
|||
|
|
(scheme? (cddr exp)))
|
|||
|
|
(define (concatenate-symbol . syms)
|
|||
|
|
(string->symbol (apply string-append (map symbol->string syms))))
|
|||
|
|
(let* ((type `(enum stob ,name))
|
|||
|
|
(fix (if (not (null? scheme?))
|
|||
|
|
'vm-
|
|||
|
|
(string->symbol "")))
|
|||
|
|
(pred (concatenate-symbol fix name '?))
|
|||
|
|
(make (concatenate-symbol fix 'make- name))
|
|||
|
|
(size (concatenate-symbol fix name '- 'size))
|
|||
|
|
(length (concatenate-symbol fix name '- 'length))
|
|||
|
|
(ref (concatenate-symbol fix name '- 'ref))
|
|||
|
|
(set (concatenate-symbol fix name '- 'set!)))
|
|||
|
|
`(begin (define ,make (stob-maker ,type make-d-vector))
|
|||
|
|
(define ,pred (stob-predicate ,type))
|
|||
|
|
(define (,size len) (+ len 1))
|
|||
|
|
(define ,length d-vector-length)
|
|||
|
|
(define ,ref d-vector-ref)
|
|||
|
|
(define ,set d-vector-set!))))))
|
|||
|
|
|
|||
|
|
(define (stob-maker type maker)
|
|||
|
|
(lambda (length key)
|
|||
|
|
(maker type length key)))
|
|||
|
|
|
|||
|
|
(define (stob-predicate type)
|
|||
|
|
(lambda (obj) (stob-of-type? obj type)))
|
|||
|
|
|
|||
|
|
; data for these comes from STOB-DATA in arch.scm
|
|||
|
|
|
|||
|
|
(define-shared-primitive-data-type pair #t)
|
|||
|
|
(define-shared-primitive-data-type symbol #t #t)
|
|||
|
|
(define-shared-primitive-data-type closure #f #t)
|
|||
|
|
(define-shared-primitive-data-type location)
|
|||
|
|
(define-shared-primitive-data-type weak-pointer)
|
|||
|
|
(define-shared-primitive-data-type external)
|
|||
|
|
|
|||
|
|
; The one currently unshared data structure.
|
|||
|
|
|
|||
|
|
(define-primitive-data-type port port #f make-port
|
|||
|
|
(port-mode set-port-mode!)
|
|||
|
|
(port-index set-port-index!)
|
|||
|
|
(peeked-char set-peeked-char!)
|
|||
|
|
(port-id set-port-id!)) ; setter needed by the post-GC code
|
|||
|
|
|
|||
|
|
; Vectors and so on
|
|||
|
|
|
|||
|
|
(define-vector-data-type vector #t)
|
|||
|
|
(define-vector-data-type record)
|
|||
|
|
(define-vector-data-type extended-number)
|
|||
|
|
(define-vector-data-type continuation)
|
|||
|
|
(define-vector-data-type template)
|
|||
|
|
|
|||
|
|
(define (vm-vector-fill! v val)
|
|||
|
|
(do ((i 0 (+ i 1)))
|
|||
|
|
((= i (vm-vector-length v)) v)
|
|||
|
|
(vm-vector-set! v i val)))
|
|||
|
|
|
|||
|
|
(define (continuation-cont c) (continuation-ref c 0))
|
|||
|
|
(define (continuation-pc c) (continuation-ref c 1))
|
|||
|
|
(define (continuation-template c) (continuation-ref c 2))
|
|||
|
|
(define (continuation-env c) (continuation-ref c 3))
|
|||
|
|
|
|||
|
|
(define (set-continuation-cont! c val) (continuation-set! c 0 val))
|
|||
|
|
(define (set-continuation-pc! c val) (continuation-set! c 1 val))
|
|||
|
|
(define (set-continuation-template! c val) (continuation-set! c 2 val))
|
|||
|
|
(define (set-continuation-env! c val) (continuation-set! c 3 val))
|
|||
|
|
|
|||
|
|
(define continuation-cells 4)
|
|||
|
|
|
|||
|
|
(define (template-code tem) (template-ref tem 0))
|
|||
|
|
(define (template-name tem) (template-ref tem 1))
|
|||
|
|
|
|||
|
|
; The VM needs a few templates for various obscure purposes.
|
|||
|
|
|
|||
|
|
(define (make-template-containing-ops op1 op2)
|
|||
|
|
(let ((temp (make-template 2 universal-key))
|
|||
|
|
(code (make-code-vector 2 universal-key)))
|
|||
|
|
(template-set! temp 0 code)
|
|||
|
|
(code-vector-set! code 0 op1)
|
|||
|
|
(code-vector-set! code 1 op2)
|
|||
|
|
temp))
|
|||
|
|
|
|||
|
|
(define (op-template-size op-count)
|
|||
|
|
(+ (template-size 2) (code-vector-size op-count)))
|
|||
|
|
|
|||
|
|
; Code vectors
|
|||
|
|
|
|||
|
|
(define make-code-vector (stob-maker (enum stob code-vector) make-b-vector))
|
|||
|
|
(define code-vector? (stob-predicate (enum stob code-vector)))
|
|||
|
|
(define code-vector-length b-vector-length)
|
|||
|
|
(define code-vector-ref b-vector-ref)
|
|||
|
|
(define code-vector-set! b-vector-set!)
|
|||
|
|
|
|||
|
|
(define (code-vector-size len)
|
|||
|
|
(+ 1 (bytes->cells len)))
|
|||
|
|
|
|||
|
|
; Strings are presented as being one character shorter than they really
|
|||
|
|
; are to hide the null character at the end.
|
|||
|
|
|
|||
|
|
(define vm-make-string (stob-maker (enum stob string)
|
|||
|
|
(lambda (type len key)
|
|||
|
|
(make-b-vector type (+ len 1) key))))
|
|||
|
|
(define vm-string? (stob-predicate (enum stob string)))
|
|||
|
|
(define vm-string-length (lambda (x) (- (b-vector-length x) 1)))
|
|||
|
|
(define vm-string-ref (lambda (s i) (ascii->char (b-vector-ref s i))))
|
|||
|
|
(define vm-string-set! (lambda (s i c) (b-vector-set! s i (char->ascii c))))
|
|||
|
|
|
|||
|
|
(define (vm-string-size length)
|
|||
|
|
(+ 1 (bytes->cells (+ 1 length))))
|
|||
|
|
|
|||
|
|
(define (enter-string string) ; used by VMIO on startup
|
|||
|
|
(let ((z (string-length string)))
|
|||
|
|
(let ((v (vm-make-string z universal-key)))
|
|||
|
|
(do ((i 0 (+ i 1)))
|
|||
|
|
((>= i z) v)
|
|||
|
|
(vm-string-set! v i (string-ref string i))))))
|
|||
|
|
|
|||
|
|
(define (extract-string string) ; used by OPEN, WRITE-STRING, SUSPEND
|
|||
|
|
(let ((z (vm-string-length string)))
|
|||
|
|
(let ((v (make-string z)))
|
|||
|
|
(do ((i 0 (+ i 1)))
|
|||
|
|
((>= i z) v)
|
|||
|
|
(string-set! v i (vm-string-ref string i))))))
|
|||
|
|
|
|||
|
|
(define (write-vm-string string port)
|
|||
|
|
(write-bytes (address-after-header string)
|
|||
|
|
(vm-string-length string)
|
|||
|
|
port))
|
|||
|
|
|
|||
|
|
(define vm-string=? stob-equal?)
|
|||
|
|
|
|||
|
|
; Hashing
|
|||
|
|
|
|||
|
|
; The hash function used here is to take the sum of the ascii values
|
|||
|
|
; of the characters in the string, modulo the symbol table size.
|
|||
|
|
;
|
|||
|
|
; This hash function was also compared against some others, e.g.
|
|||
|
|
; adding in the length as well, and taking only the odd or only the
|
|||
|
|
; even characters. It fared about the same as adding the length, and
|
|||
|
|
; much better than examining only every other character.
|
|||
|
|
;
|
|||
|
|
; Perhaps a hash function that is sensitive to the positions of the
|
|||
|
|
; characters should be tried? (Consider CADDR, CDADR, CDDAR.)
|
|||
|
|
;
|
|||
|
|
; Of course, if we switched to rehashing, a prime modulus would be
|
|||
|
|
; important.
|
|||
|
|
|
|||
|
|
(define (vm-string-hash s)
|
|||
|
|
(let ((n (vm-string-length s)))
|
|||
|
|
(do ((i 0 (+ i 1))
|
|||
|
|
(h 0 (+ h (char->ascii (vm-string-ref s i)))))
|
|||
|
|
((>= i n) h))))
|
|||
|
|
|
|||
|
|
; Symbol table and environment lookup
|
|||
|
|
|
|||
|
|
(define (table-searcher hash match? make-new)
|
|||
|
|
;; In FX terms, this procedure has type
|
|||
|
|
;; (poly (t1 t2 t3)
|
|||
|
|
;; (proc ((proc (t1) int) ;hash
|
|||
|
|
;; (proc (t1 t2) bool) ;match?
|
|||
|
|
;; (proc (t1) t2)) ;make-new
|
|||
|
|
;; (proc (t1 (vector-of (list-of t2)))
|
|||
|
|
;; t2)))
|
|||
|
|
;; For the symbol table, t1 = string, t2 = t3 = symbol.
|
|||
|
|
(lambda (obj table key)
|
|||
|
|
(let* ((index (bitwise-and (hash obj) (- (vm-vector-length table) 1)))
|
|||
|
|
(bucket (vm-vector-ref table index)))
|
|||
|
|
(let loop ((b bucket))
|
|||
|
|
(cond ((vm-eq? b null)
|
|||
|
|
(let ((new (make-new obj key)))
|
|||
|
|
(vm-vector-set! table index (vm-cons new bucket key))
|
|||
|
|
new))
|
|||
|
|
((match? obj (vm-car b)) (vm-car b))
|
|||
|
|
(else (loop (vm-cdr b))))))))
|
|||
|
|
|
|||
|
|
(define intern
|
|||
|
|
(table-searcher vm-string-hash
|
|||
|
|
(lambda (string sym)
|
|||
|
|
(vm-string=? string (vm-symbol->string sym)))
|
|||
|
|
(lambda (string key)
|
|||
|
|
(let ((sym (vm-make-symbol string key)))
|
|||
|
|
(make-immutable! sym)
|
|||
|
|
sym))))
|
|||
|
|
|
|||
|
|
(define add-to-symbol-table
|
|||
|
|
(table-searcher (lambda (sym) (vm-string-hash (vm-symbol->string sym)))
|
|||
|
|
vm-eq?
|
|||
|
|
(lambda (sym key) sym)))
|
|||
|
|
|