123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303 |
- ; Part of Scheme 48 1.9. See file COPYING for notices and license.
- ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Marcus Crestani
- ; This is file transport.scm.
- ; System builder for bootstrapping and debugging.
- ; Things that have to be written out:
- ; Made by the compiler
- ; closures
- ; templates
- ; code-vectors
- ; locations
- ; Quoted data
- ; symbols
- ; pairs
- ; vectors
- ; strings
- ; booleans
- ; characters
- ; Convert THING to the Scheme 48 virtual machine's representation and
- ; return it. Locations and symbols may have multiple references in
- ; the image. Their transported addresses are kept in a table.
- (define (transport thing . stuff)
- (let transport ((thing thing))
- (cond ((immediate? thing)
- (transport-immediate thing))
- ((closure? thing)
- (transport-closure thing))
- ((code-vector? thing)
- (allocate-b-vector thing code-vector-length))
- ((location? thing)
- (let ((address (table-ref *locations* thing)))
- (cond (address address)
- (else
- (let ((desc (transport-location thing)))
- (table-set! *locations* thing desc)
- desc)))))
- ((symbol? thing)
- (let ((address (table-ref *symbols* thing)))
- (cond (address address)
- (else
- (let ((desc (transport-symbol thing)))
- (table-set! *symbols* thing desc)
- desc)))))
- ((pair? thing)
- (transport-pair thing))
- ((template? thing)
- (transport-template thing))
- ((vector? thing)
- (transport-vector thing))
- ((string? thing)
- (transport-string thing))
- (else
- (assertion-violation 'transport
- "cannot transport object" thing stuff))))) ; DELETEME stuff
- ; Transport the things that are not allocated from the heap.
- (define (transport-immediate thing)
- (cond ((integer? thing)
- (make-descriptor (enum tag fixnum) thing))
- ((char? thing)
- (make-immediate (enum imm char) (char->ascii thing)))
- ((eq? thing '())
- vm-null)
- ((eq? thing #f)
- vm-false)
- ((eq? thing #t)
- vm-true)
- ((eq? thing (unspecific))
- vm-unspecific)
- (else
- (assertion-violation 'transport-immediate "cannot transport literal" thing))))
- ;==============================================================================
- ; The heap is a list of transported stored objects, each of which is either a
- ; string, a code-vector, or a vector of length N+1 representing a stored object
- ; with N cells. The last slot of the vector is the object's header.
- (define *heap* '())
- (define *hp* 0) ; Current heap-pointer (in a-units)
- (define *symbols* #f) ; Table of already-transported symbols
- (define *locations* #f) ; Table of already-transported locations
- ; We need to preserve sharing of vectors because `syntax-rules' relies on it.
- (define *vector-alist* #f) ; Table of already-transported vectors
- (define (initialize-memory)
- (set! *hp* 0)
- (set! *heap* '())
- (set! *symbols* (make-table))
- (set! *locations* (make-table location-id))
- (set! *vector-alist* '()))
- ; Allocate a new stored object in the heap. DATA is whatever data is
- ; associated with the object, LEN is the length of the object (not
- ; including the header) in bytes. A pointer to the new object is
- ; returned.
- (define (allocate-stob data len)
- (let ((addr (+ *hp* (cells->a-units 1)))) ; move past header
- (set! *hp* (+ addr (bytes->a-units len)))
- (set! *heap* (cons data *heap*))
- (make-stob-descriptor addr)))
- ; Allocate a new stored object that contains descriptors. This
- ; creates a vector to hold the header and the object's tranported
- ; contents and allocates a stob in the heap. Returns a pair
- ; containing the stob-pointer and the vector.
- (define (allocate-d-vector type cells immutable?)
- (let* ((vec (make-vector (+ cells 1) 0))
- (ptr (allocate-stob vec (cells->bytes cells)))
- (hdr (make-header type (cells->bytes cells))))
- (vector-set! vec cells (if immutable? (make-header-immutable hdr) hdr))
- (cons ptr vec)))
- ; Allocate a new stored object that contains data. VEC is either a
- ; code-vector or a string.
- (define (allocate-b-vector vec length)
- (let ((len (cells->bytes (bytes->cells (length vec)))))
- (allocate-stob vec len)))
- ;==============================================================================
- ; Transport an object with two slots. ALLOCATE-D-VECTOR allocates the
- ; storage and then the two values are transported.
- (define (transport-two-slot type accessor1 offset1 accessor2 offset2
- immutable?)
- (lambda (thing)
- (let* ((data (allocate-d-vector type 2 immutable?))
- (descriptor (car data))
- (vector (cdr data)))
- (vector-set! vector offset1 (transport (accessor1 thing)))
- (vector-set! vector offset2 (transport (accessor2 thing)))
- descriptor)))
- ; Closures and pairs are transported using TRANSPORT-TWO-SLOT.
- (define transport-closure
- (transport-two-slot (enum stob closure)
- closure-template closure-template-offset
- closure-env closure-env-offset
- #f))
- (define transport-pair
- (transport-two-slot (enum stob pair)
- car car-offset
- cdr cdr-offset
- #t)) ; *** ?
- ; Transporting a location requires some care so as to avoid calling CONTENTS
- ; when the location is unbound.
- (define (transport-location loc)
- (let* ((data (allocate-d-vector (enum stob location) 2 #f))
- (descriptor (car data))
- (vector (cdr data)))
- (vector-set! vector
- location-contents-offset
- (if (location-defined? loc)
- (transport (contents loc))
- vm-unbound))
- (vector-set! vector
- location-id-offset
- (transport (location-id loc)))
- descriptor))
- ; The characters on the linker system may not be the same as those of Scheme 48
- (define (transport-string string)
- (allocate-b-vector string
- (lambda (x)
- (scalar-value-units->bytes (string-length x)))))
- ; Symbols have two slots, the string containing the symbol's name and a slot
- ; used in building the symbol table.
- ; Characters in the symbol name are made to be lower case.
- (define (transport-symbol symbol)
- (let* ((data (allocate-d-vector (enum stob symbol) 2 #t))
- (descriptor (car data))
- (vector (cdr data)))
- (vector-set! vector
- 0
- (transport-string (symbol-case-converter (symbol->string symbol))))
- (vector-set! vector
- 1
- (transport #f))
- descriptor))
- (define (string-case-converter string)
- (let ((new (make-string (string-length string) #\x)))
- (do ((i 0 (+ i 1)))
- ((>= i (string-length new))
- new)
- (string-set! new i (preferred-case (string-ref string i))))))
- ;(define preferred-case ;Copied from rts/read.scm
- ; (if (char=? (string-ref (symbol->string 't) 0) #\T)
- ; char-upcase
- ; char-downcase))
- (define preferred-case char-downcase)
- (define symbol-case-converter
- (if (char=? (string-ref (symbol->string 't) 0)
- (preferred-case #\t))
- (lambda (string) string)
- string-case-converter))
- ; Templates and vectors have an arbitrary number of slots but are otherwise
- ; the same as pairs and closures.
- (define (transport-template template)
- (transport-vector-like template
- (enum stob template)
- (template-length template)
- template-ref
- #f))
- (define (transport-vector vector)
- (transport-vector-like vector
- (enum stob vector)
- (vector-length vector)
- vector-ref
- #t)) ;***
- (define (transport-vector-like vector type length ref immutable?)
- (cond
- ((assq vector *vector-alist*)
- => cdr)
- (else
- (let* ((data (allocate-d-vector type length immutable?))
- (descriptor (car data))
- (new (cdr data)))
- (do ((i 0 (+ i 1)))
- ((>= i length))
- (vector-set! new i (transport (ref vector i) vector type)))
- (set! *vector-alist* (cons (cons vector descriptor) *vector-alist*))
- descriptor))))
- ;==============================================================================
- ; Writing the heap out to a port.
- (define (write-heap port)
- (do ((heap (reverse *heap*) (cdr heap)))
- ((null? heap))
- (write-heap-stob (car heap) port)))
- ; Dispatch on the type of THING and call WRITE-STOB.
- (define (write-heap-stob thing port)
- (cond ((string? thing)
- (let* ((len (string-length thing))
- (byte-len (scalar-value-units->bytes len)))
- (write-stob (make-header-immutable ; ***
- (make-header (enum stob string) byte-len))
- thing len string-ref write-char-scalar-value port)
- (align-port byte-len port)))
- ((code-vector? thing)
- (let ((len (code-vector-length thing)))
- (write-stob (make-header-immutable ; ***
- (make-header (enum stob byte-vector) len))
- thing len code-vector-ref write-byte port)
- (align-port len port)))
- ((vector? thing)
- (let ((len (vector-length thing)))
- (write-stob (vector-ref thing (- len 1))
- thing (- len 1) vector-ref write-descriptor port)))
- (else
- (assertion-violation 'write-heap-stob "do not know how to write stob" thing))))
- ; Write out a transported STOB to PORT. HEADER is the header, LENGTH is the
- ; number of objects the STOB contains, ACCESSOR and WRITER access the contents
- ; and write them to the heap.
- (define (write-stob header contents length accessor writer port)
- (write-descriptor header port)
- (do ((i 0 (+ i 1)))
- ((>= i length))
- (writer (accessor contents i) port)))
- (define (write-char-scalar-value char port)
- (write-scalar-value (char->ascii char) ; ASCII is a subset of Unicode code points
- port))
- ; Write out zeros to align the port on a four-byte boundary.
- (define (align-port len port)
- (let ((count (- (cells->bytes (bytes->cells len)) len)))
- (do ((count count (- count 1)))
- ((<= count 0))
- (write-byte 0 port))))
|