scsh-0.6/scheme/vm/data.scm

268 lines
7.5 KiB
Scheme

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; 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 (>= (shift-left 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 (shift-left 1 (- bits-per-fixnum 1))))
(define greatest-fixnum-value (- (shift-left 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))
(define (descriptor->fixnum p)
(enter-fixnum (descriptor-data p)))
; These happen to work out, given our representation for fixnums.
(define fixnum= =)
(define fixnum< <)
(define fixnum> >)
(define fixnum<= <=)
(define fixnum>= >=)
(define (fixnum-bitwise-not x)
(bitwise-not (bitwise-ior x 3)))
(define fixnum-bitwise-and bitwise-and)
(define fixnum-bitwise-ior bitwise-ior)
(define fixnum-bitwise-xor bitwise-xor)
;----------------
; 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 (>= (shift-left 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-value (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.
(define max-stob-contents-size-in-cells
(bytes->cells (- (shift-left 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 (header-length-in-a-units h)
(cells->a-units (header-length-in-cells h)))
(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 (address->integer addr) (enum tag stob)))
(define stob-overhead 1) ; header uses up one descriptor
(define (address-after-header stob)
(assert (stob? stob))
(integer->address (- stob (enum tag stob))))
(define (address-at-header stob)
(address- (address-after-header stob) (cells->a-units 1)))
(define (stob-header stob)
(fetch (address-at-header stob)))
(define (stob-header-set! stob header)
(store! (address-at-header stob) header))