241 lines
6.7 KiB
Scheme
241 lines
6.7 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
||
|
||
; This is file data.scm.
|
||
; Requires DEFINE-ENUMERATION macro.
|
||
|
||
;;;; Data representations
|
||
|
||
; This implementation of the data representations is particularly
|
||
; tuned for byte-addressable machines with 4 bytes per word.
|
||
; Good representations for other kinds of machines would necessarily
|
||
; look quite different; e.g. on a word-addressed machine you might
|
||
; want to put tag bits in the high end of a word, or even go to some
|
||
; kind of BIBOP system.
|
||
|
||
; Descriptors
|
||
; A descriptor describes a Scheme object.
|
||
; A descriptor is represented as an integer whose low two bits are
|
||
; tag bits. The high bits contain information whose format and
|
||
; meaning are dependent on the tag.
|
||
|
||
(define tag-field-width 2)
|
||
(define data-field-width (- bits-per-cell tag-field-width))
|
||
|
||
(define (make-descriptor tag data)
|
||
(adjoin-bits data tag tag-field-width))
|
||
|
||
(define (descriptor-tag descriptor)
|
||
(low-bits descriptor tag-field-width))
|
||
|
||
(define (descriptor-data descriptor)
|
||
(high-bits descriptor tag-field-width))
|
||
|
||
(define (unsigned-descriptor-data descriptor)
|
||
(unsigned-high-bits descriptor tag-field-width))
|
||
|
||
(define (set-descriptor-tag proto-descriptor tag)
|
||
(assert (= 0 (descriptor-tag proto-descriptor)))
|
||
(+ proto-descriptor tag))
|
||
|
||
(define vm-eq? =)
|
||
|
||
; The four tags are: fixnum, immediate (character, boolean, etc.),
|
||
; header (gives the type and size of a stored object), and stored
|
||
; (pointer into memory).
|
||
; The header and immediate tags could be multiplexed, thus freeing up
|
||
; one of the 4 type codes for some other purpose, but the
|
||
; implementation is simpler if they're not.
|
||
|
||
(define-enumeration tag
|
||
(fixnum
|
||
immediate
|
||
header
|
||
stob))
|
||
|
||
;; (assert (>= (ashl 1 tag-field-width)
|
||
;; (vector-length tag)))
|
||
|
||
(define (fixnum? descriptor)
|
||
(= (descriptor-tag descriptor) (enum tag fixnum)))
|
||
|
||
(define (immediate? descriptor)
|
||
(= (descriptor-tag descriptor) (enum tag immediate)))
|
||
|
||
(define (header? descriptor)
|
||
(= (descriptor-tag descriptor) (enum tag header)))
|
||
|
||
(define (stob? descriptor)
|
||
(= (descriptor-tag descriptor) (enum tag stob)))
|
||
|
||
; Fixnums
|
||
|
||
(define bits-per-fixnum
|
||
(- (if (< bits-per-cell useful-bits-per-word)
|
||
bits-per-cell
|
||
useful-bits-per-word)
|
||
tag-field-width))
|
||
|
||
(define least-fixnum-value (- 0 (ashl 1 (- bits-per-fixnum 1))))
|
||
(define greatest-fixnum-value (- (ashl 1 (- bits-per-fixnum 1)) 1))
|
||
|
||
(define (too-big-for-fixnum? n)
|
||
(> n greatest-fixnum-value))
|
||
|
||
(define (too-small-for-fixnum? n)
|
||
(< n least-fixnum-value))
|
||
|
||
(define (enter-fixnum n)
|
||
(assert (not (or (too-big-for-fixnum? n)
|
||
(too-small-for-fixnum? n))))
|
||
(make-descriptor (enum tag fixnum) n))
|
||
|
||
(define (extract-fixnum p)
|
||
(assert (fixnum? p))
|
||
(descriptor-data p))
|
||
|
||
; These happen to work out, given our representation for fixnums.
|
||
(define vm-= =)
|
||
(define vm-< <)
|
||
|
||
; Immediates
|
||
; The number 8 is chosen to streamline 8-bit-byte-oriented implementations.
|
||
|
||
(define immediate-type-field-width
|
||
(- 8 tag-field-width))
|
||
|
||
(define (make-immediate type info)
|
||
(make-descriptor (enum tag immediate)
|
||
(adjoin-bits info type immediate-type-field-width)))
|
||
|
||
(define (immediate-type imm)
|
||
(assert (immediate? imm))
|
||
(low-bits (descriptor-data imm)
|
||
immediate-type-field-width))
|
||
|
||
(define (immediate-info imm)
|
||
(assert (immediate? imm))
|
||
(high-bits (descriptor-data imm)
|
||
immediate-type-field-width))
|
||
|
||
(define (tag&immediate-type descriptor)
|
||
(low-bits descriptor (+ tag-field-width immediate-type-field-width)))
|
||
|
||
(define (make-tag&immediate-type type)
|
||
(adjoin-bits type (enum tag immediate) tag-field-width))
|
||
|
||
(define-enumeration imm
|
||
(false ; #f
|
||
true ; #t
|
||
char
|
||
unspecific
|
||
undefined
|
||
eof
|
||
null))
|
||
|
||
;; (assert (>= (ashl 1 immediate-type-field-width)
|
||
;; (vector-length imm)))
|
||
|
||
(define (immediate-predicate type)
|
||
(lambda (descriptor)
|
||
;; Check low 8 bits...
|
||
(= (tag&immediate-type descriptor)
|
||
(make-tag&immediate-type type))))
|
||
|
||
(define vm-char? (immediate-predicate (enum imm char)))
|
||
(define undefined? (immediate-predicate (enum imm undefined)))
|
||
|
||
(define true (make-immediate (enum imm true) 0))
|
||
(define false (make-immediate (enum imm false) 0))
|
||
(define eof-object (make-immediate (enum imm eof) 0))
|
||
(define null (make-immediate (enum imm null) 0))
|
||
(define unspecific (make-immediate (enum imm unspecific) 0))
|
||
(define quiescent (make-immediate (enum imm undefined) 0))
|
||
(define unbound-marker (make-immediate (enum imm undefined) 1))
|
||
(define unassigned-marker (make-immediate (enum imm undefined) 2))
|
||
|
||
(define (false? x)
|
||
(vm-eq? x false))
|
||
|
||
(define (enter-boolean b)
|
||
(if b true false))
|
||
|
||
(define (extract-boolean b)
|
||
(assert (vm-boolean? b))
|
||
(if (false? b) #f #t))
|
||
|
||
(define (vm-boolean? x)
|
||
(or (vm-eq? x false)
|
||
(vm-eq? x true)))
|
||
|
||
; Characters
|
||
|
||
(define (enter-char c)
|
||
(make-immediate (enum imm char) (char->ascii c)))
|
||
|
||
(define (extract-char d)
|
||
(assert (vm-char? d))
|
||
(ascii->char (immediate-info d)))
|
||
|
||
; these work given the representations
|
||
(define vm-char=? =)
|
||
(define vm-char<? <)
|
||
|
||
; Headers
|
||
|
||
(define header-type-field-width (- immediate-type-field-width 1))
|
||
|
||
(define header-size-field-width (- data-field-width immediate-type-field-width))
|
||
|
||
; Assumes headers sizes are extracted as unsigned. The +1 is because the
|
||
; size field does not include the header, and the actual size of the object
|
||
; does.
|
||
(define max-stob-size-in-cells
|
||
(bytes->cells (- (ashl 1 header-size-field-width) 1)))
|
||
|
||
(define (make-header type length-in-bytes)
|
||
(make-descriptor (enum tag header)
|
||
(adjoin-bits length-in-bytes
|
||
type
|
||
(+ 1 header-type-field-width))))
|
||
|
||
(define header-immutable-bit-mask
|
||
(adjoin-bits 1 0 (+ header-type-field-width tag-field-width)))
|
||
|
||
(define (make-header-immutable header)
|
||
(bitwise-ior header header-immutable-bit-mask))
|
||
|
||
(define (header-type h)
|
||
(assert (header? h))
|
||
(low-bits (descriptor-data h)
|
||
header-type-field-width))
|
||
|
||
(define (immutable-header? h)
|
||
(assert (header? h))
|
||
(not (= 0 (bitwise-and h header-immutable-bit-mask))))
|
||
|
||
(define (header-length-in-bytes h)
|
||
(assert (header? h))
|
||
(unsigned-high-bits (unsigned-descriptor-data h)
|
||
(+ 1 header-type-field-width)))
|
||
|
||
(define (header-length-in-cells header)
|
||
(bytes->cells (header-length-in-bytes header)))
|
||
|
||
(define (d-vector-header? h)
|
||
(< (header-type h) least-b-vector-type))
|
||
|
||
(define (b-vector-header? h)
|
||
(and (header? h)
|
||
(>= (header-type h) least-b-vector-type)))
|
||
|
||
; Stored objects
|
||
; The data field of a descriptor for a stored object contains the
|
||
; cell number of the first cell after the object's header cell.
|
||
|
||
(define (address->stob-descriptor addr)
|
||
(set-descriptor-tag addr (enum tag stob)))
|
||
|
||
(define (stob-descriptor->address stob)
|
||
(assert (stob? stob))
|
||
(- stob (enum tag stob)))
|