329 lines
10 KiB
Scheme
329 lines
10 KiB
Scheme
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Write-image and read-image
|
||
|
|
|
||
|
|
(define (s48-image-writing-okay?)
|
||
|
|
(not (have-static-areas?)))
|
||
|
|
|
||
|
|
(define *status* (enum errors no-errors))
|
||
|
|
|
||
|
|
(define-syntax write-check
|
||
|
|
(syntax-rules ()
|
||
|
|
((write-check exp)
|
||
|
|
(if (eq? *status* (enum errors no-errors))
|
||
|
|
(set! *status* exp)))))
|
||
|
|
|
||
|
|
(define (write-heap-integer n port)
|
||
|
|
(write-check (write-integer n port))
|
||
|
|
(write-check (write-char #\newline port)))
|
||
|
|
|
||
|
|
(define (s48-write-image resume-proc port)
|
||
|
|
(begin-writing-image)
|
||
|
|
(let ((resume-proc (s48-trace-value resume-proc))
|
||
|
|
(exported-bindings (s48-trace-value (s48-exported-bindings))))
|
||
|
|
(s48-do-gc)
|
||
|
|
(s48-mark-traced-channels-closed!)
|
||
|
|
(let ((symbols (s48-copy-symbol-table))
|
||
|
|
(imported-bindings (s48-cleaned-imported-bindings))
|
||
|
|
(resumer-records (find-resumer-records)))
|
||
|
|
(if (vm-eq? false resumer-records)
|
||
|
|
(begin
|
||
|
|
(abort-collection)
|
||
|
|
(enum errors out-of-memory))
|
||
|
|
(let ((status (really-write-image port resume-proc
|
||
|
|
symbols
|
||
|
|
imported-bindings
|
||
|
|
exported-bindings
|
||
|
|
resumer-records)))
|
||
|
|
(abort-collection)
|
||
|
|
status)))))
|
||
|
|
|
||
|
|
(define (really-write-image port restart-proc
|
||
|
|
symbols imported-bindings exported-bindings
|
||
|
|
resumer-records)
|
||
|
|
(set! *status* (enum errors no-errors))
|
||
|
|
(write-check (write-char #\newline port))
|
||
|
|
(write-check (write-page port))
|
||
|
|
(write-check (write-char #\newline port))
|
||
|
|
(write-check (write-string architecture-version port))
|
||
|
|
(write-check (write-char #\newline port))
|
||
|
|
(write-heap-integer bytes-per-cell port)
|
||
|
|
(write-heap-integer (a-units->cells (address->integer (heap-start))) port)
|
||
|
|
(write-heap-integer (a-units->cells (address->integer (heap-pointer))) port)
|
||
|
|
(write-heap-integer symbols port)
|
||
|
|
(write-heap-integer imported-bindings port)
|
||
|
|
(write-heap-integer exported-bindings port)
|
||
|
|
(write-heap-integer resumer-records port)
|
||
|
|
(write-heap-integer restart-proc port)
|
||
|
|
(write-check (write-page port))
|
||
|
|
(store! (heap-pointer) 1) ; used to detect endianess of image
|
||
|
|
(write-check (write-block port
|
||
|
|
(heap-pointer)
|
||
|
|
(address-difference (address1+ (heap-pointer)) (heap-pointer))))
|
||
|
|
(write-check (write-block port
|
||
|
|
(heap-start)
|
||
|
|
(address-difference (heap-pointer) (heap-start))))
|
||
|
|
*status*)
|
||
|
|
|
||
|
|
; Make sure the image file is okay and return the size of the heap it
|
||
|
|
; contains.
|
||
|
|
|
||
|
|
(define *eof?* #f)
|
||
|
|
|
||
|
|
(define-syntax read-check
|
||
|
|
(syntax-rules ()
|
||
|
|
((read-check exp)
|
||
|
|
(read-check exp -1))
|
||
|
|
((read-check exp losing-value)
|
||
|
|
(let ((lose losing-value))
|
||
|
|
(if *eof?*
|
||
|
|
lose
|
||
|
|
(receive (thing eof? status)
|
||
|
|
exp
|
||
|
|
(cond (eof?
|
||
|
|
(set! *eof?* #t)
|
||
|
|
lose)
|
||
|
|
((eq? *status* (enum errors no-errors))
|
||
|
|
thing)
|
||
|
|
(else
|
||
|
|
(set! *eof?* #t)
|
||
|
|
(set! *status* status)
|
||
|
|
lose))))))))
|
||
|
|
|
||
|
|
; Read in the ASCII portion of the image and make sure that it is compatible
|
||
|
|
; with this version of the VM.
|
||
|
|
|
||
|
|
(define (s48-check-image-header filename)
|
||
|
|
(receive (port status)
|
||
|
|
(open-input-file filename)
|
||
|
|
(cond ((error? status)
|
||
|
|
(error-message "Can't open heap image file")
|
||
|
|
(error-message (error-string status))
|
||
|
|
-1)
|
||
|
|
(else
|
||
|
|
(set! *status* (enum errors no-errors))
|
||
|
|
(set! *eof?* #f)
|
||
|
|
(read-check (read-page port))
|
||
|
|
(read-check (read-newline port)) ; version starts on next line
|
||
|
|
(let* ((same-version? (read-check (check-image-version port) #f))
|
||
|
|
(old-bytes-per-cell (read-check (read-integer port))))
|
||
|
|
(set! *old-begin*
|
||
|
|
(integer->address
|
||
|
|
(cells->a-units (read-check (read-integer port)))))
|
||
|
|
(set! *old-hp*
|
||
|
|
(integer->address
|
||
|
|
(cells->a-units (read-check (read-integer port)))))
|
||
|
|
(set! *symbols* (read-check (read-integer port)))
|
||
|
|
(set! *imported-bindings* (read-check (read-integer port)))
|
||
|
|
(set! *exported-bindings* (read-check (read-integer port)))
|
||
|
|
(set! *resumer-records* (read-check (read-integer port)))
|
||
|
|
(set! *startup-procedure* (read-check (read-integer port)))
|
||
|
|
(set! *image-port* port)
|
||
|
|
(read-check (read-page port)) ; read to beginning of heap
|
||
|
|
(cond ((error? *status*)
|
||
|
|
(read-lost "Error reading from image file" port))
|
||
|
|
(*eof?* ; has to come after *status* check
|
||
|
|
(set! *status* (enum errors parse-error))
|
||
|
|
(read-lost "Premature EOF when reading image file" port))
|
||
|
|
((not same-version?)
|
||
|
|
(read-lost "Format of image is incompatible with this version of system" port))
|
||
|
|
((not (= old-bytes-per-cell bytes-per-cell))
|
||
|
|
(read-lost "Incompatible bytes-per-cell in image" port))
|
||
|
|
(else
|
||
|
|
(address-difference *old-hp* *old-begin*))))))))
|
||
|
|
|
||
|
|
(define (read-page port)
|
||
|
|
(read-this-character page-character port))
|
||
|
|
|
||
|
|
(define (read-newline port)
|
||
|
|
(read-this-character #\newline port))
|
||
|
|
|
||
|
|
(define (read-this-character char port)
|
||
|
|
(let loop ()
|
||
|
|
(receive (ch eof? status)
|
||
|
|
(read-char port)
|
||
|
|
(cond ((or eof? (error? status))
|
||
|
|
(values -1 eof? status))
|
||
|
|
((char=? char ch)
|
||
|
|
(values -1 #f status))
|
||
|
|
(else
|
||
|
|
(loop))))))
|
||
|
|
|
||
|
|
(define (check-image-version port)
|
||
|
|
(let ((len (string-length architecture-version)))
|
||
|
|
(let loop ((i 0))
|
||
|
|
(receive (ch eof? status)
|
||
|
|
(read-char port)
|
||
|
|
(cond ((or eof? (error? status))
|
||
|
|
(values #f eof? status))
|
||
|
|
((= i len)
|
||
|
|
(values (char=? #\newline ch) #f status))
|
||
|
|
((char=? ch (string-ref architecture-version i))
|
||
|
|
(loop (+ i 1)))
|
||
|
|
(else
|
||
|
|
(values #f #f status)))))))
|
||
|
|
|
||
|
|
(define *image-port*)
|
||
|
|
(define *old-begin*)
|
||
|
|
(define *old-hp*)
|
||
|
|
|
||
|
|
;----------------
|
||
|
|
; Values provided by the image file.
|
||
|
|
|
||
|
|
(define *startup-procedure*)
|
||
|
|
(define *symbols*)
|
||
|
|
(define *imported-bindings*)
|
||
|
|
(define *exported-bindings*)
|
||
|
|
(define *resumer-records*)
|
||
|
|
|
||
|
|
(define *initializing?* #t)
|
||
|
|
|
||
|
|
; Save initial values across any GC's.
|
||
|
|
|
||
|
|
(define (s48-initializing-gc-root)
|
||
|
|
(if *initializing?*
|
||
|
|
(begin
|
||
|
|
(set! *startup-procedure* (s48-trace-value *startup-procedure*))
|
||
|
|
(set! *symbols* (s48-trace-value *symbols*))
|
||
|
|
(set! *imported-bindings* (s48-trace-value *imported-bindings*))
|
||
|
|
(set! *exported-bindings* (s48-trace-value *exported-bindings*))
|
||
|
|
(set! *resumer-records* (s48-trace-value *resumer-records*)))))
|
||
|
|
|
||
|
|
; For the outside world.
|
||
|
|
|
||
|
|
(define (s48-startup-procedure) *startup-procedure*)
|
||
|
|
(define (s48-initial-symbols) *symbols*)
|
||
|
|
(define (s48-initial-imported-bindings) *imported-bindings*)
|
||
|
|
(define (s48-initial-exported-bindings) *exported-bindings*)
|
||
|
|
(define (s48-resumer-records) *resumer-records*)
|
||
|
|
|
||
|
|
(define (s48-initialization-complete!)
|
||
|
|
(set! *initializing?* #f))
|
||
|
|
|
||
|
|
; For resuming static images.
|
||
|
|
|
||
|
|
(define (s48-set-image-values! startup-proc symbols imports exports records)
|
||
|
|
(set! *startup-procedure* startup-proc)
|
||
|
|
(set! *symbols* symbols)
|
||
|
|
(set! *imported-bindings* imports)
|
||
|
|
(set! *exported-bindings* exports)
|
||
|
|
(set! *resumer-records* records))
|
||
|
|
|
||
|
|
;----------------
|
||
|
|
|
||
|
|
(define (s48-read-image)
|
||
|
|
(let ((port *image-port*))
|
||
|
|
(receive (okay? string)
|
||
|
|
(image-read-block port (cells->a-units 1))
|
||
|
|
(cond ((not okay?)
|
||
|
|
(read-lost string port))
|
||
|
|
((= (fetch (heap-pointer)) 1)
|
||
|
|
(really-read-image port #f))
|
||
|
|
(else
|
||
|
|
(reverse-descriptor-byte-order! (heap-pointer))
|
||
|
|
(if (= (fetch (heap-pointer)) 1)
|
||
|
|
(really-read-image port #t)
|
||
|
|
(read-lost "Unable to correct byte order" port)))))))
|
||
|
|
|
||
|
|
(define (really-read-image port reverse?)
|
||
|
|
(let* ((delta (address-difference (heap-pointer) *old-begin*))
|
||
|
|
(new-hp (address+ *old-hp* delta))
|
||
|
|
(new-limit (heap-limit))
|
||
|
|
(start (heap-pointer)))
|
||
|
|
(if (address>= new-hp new-limit)
|
||
|
|
(read-lost "Heap not big enough to restore this image" port)
|
||
|
|
(receive (okay? string)
|
||
|
|
(image-read-block port (address-difference *old-hp* *old-begin*))
|
||
|
|
(receive (ch eof? status)
|
||
|
|
(read-char port)
|
||
|
|
(cond ((not okay?)
|
||
|
|
(read-lost string port))
|
||
|
|
((error? status)
|
||
|
|
(read-lost "Error reading from image file" port))
|
||
|
|
((not eof?)
|
||
|
|
(read-lost "Image file has extraneous data after image" port))
|
||
|
|
((error? (close-input-port port))
|
||
|
|
(read-lost "Error closing image file" port))
|
||
|
|
(else
|
||
|
|
(if reverse?
|
||
|
|
(reverse-byte-order! start new-hp))
|
||
|
|
(if (not (= delta 0))
|
||
|
|
(relocate-image delta start new-hp))
|
||
|
|
(set-heap-pointer! new-hp)
|
||
|
|
(set! *startup-procedure* (adjust *startup-procedure* delta))
|
||
|
|
(set! *symbols* (adjust *symbols* delta))
|
||
|
|
(set! *imported-bindings* (adjust *imported-bindings* delta))
|
||
|
|
(set! *exported-bindings* (adjust *exported-bindings* delta))
|
||
|
|
(set! *resumer-records* (adjust *resumer-records* delta))
|
||
|
|
0)))))))
|
||
|
|
|
||
|
|
(define (image-read-block port need)
|
||
|
|
(receive (got eof? status)
|
||
|
|
(read-block port (heap-pointer) need)
|
||
|
|
(cond ((error? status)
|
||
|
|
(set! *status* status)
|
||
|
|
(values #f "Error reading from image file"))
|
||
|
|
(eof?
|
||
|
|
(values #f "Premature EOF when reading image file"))
|
||
|
|
((< got need)
|
||
|
|
(values #f "Read returned too few bytes"))
|
||
|
|
(else
|
||
|
|
(values #t "")))))
|
||
|
|
|
||
|
|
(define (read-lost message port)
|
||
|
|
(error-message message)
|
||
|
|
(if (error? *status*)
|
||
|
|
(error-message (error-string *status*)))
|
||
|
|
(if (error? (close-input-port port))
|
||
|
|
(error-message "Error closing image file"))
|
||
|
|
-1)
|
||
|
|
|
||
|
|
; ABCD => DCBA
|
||
|
|
|
||
|
|
; memory intensive, but independent of Scheme's integer size
|
||
|
|
|
||
|
|
(define (reverse-descriptor-byte-order! addr)
|
||
|
|
(let ((x (fetch-byte addr)))
|
||
|
|
(store-byte! addr (fetch-byte (address+ addr 3)))
|
||
|
|
(store-byte! (address+ addr 3) x))
|
||
|
|
(let ((x (fetch-byte (address+ addr 1))))
|
||
|
|
(store-byte! (address+ addr 1) (fetch-byte (address+ addr 2)))
|
||
|
|
(store-byte! (address+ addr 2) x)))
|
||
|
|
|
||
|
|
(define (reverse-byte-order! start end)
|
||
|
|
(error-message "Correcting byte order of resumed image.")
|
||
|
|
(let loop ((ptr start))
|
||
|
|
(if (address< ptr end)
|
||
|
|
(begin
|
||
|
|
(reverse-descriptor-byte-order! ptr)
|
||
|
|
(loop (let ((value (fetch ptr))
|
||
|
|
(next (address1+ ptr)))
|
||
|
|
(if (b-vector-header? value)
|
||
|
|
(address+ next (header-length-in-a-units value))
|
||
|
|
next)))))))
|
||
|
|
|
||
|
|
(define (adjust descriptor delta)
|
||
|
|
(if (stob? descriptor)
|
||
|
|
(address->stob-descriptor
|
||
|
|
(address+ (address-after-header descriptor) delta))
|
||
|
|
descriptor))
|
||
|
|
|
||
|
|
(define (relocate-image delta start end)
|
||
|
|
(let loop ((ptr start))
|
||
|
|
(if (address< ptr end)
|
||
|
|
(let ((d (adjust (fetch ptr) delta)))
|
||
|
|
(store! ptr d)
|
||
|
|
(loop (if (b-vector-header? d)
|
||
|
|
(address+ (address1+ ptr) (header-length-in-a-units d))
|
||
|
|
(address1+ ptr)))))))
|
||
|
|
|
||
|
|
; The page character is used to mark the ends of the user and prelude sections
|
||
|
|
; of image files.
|
||
|
|
|
||
|
|
(define page-character (ascii->char 12))
|
||
|
|
|
||
|
|
(define (write-page port)
|
||
|
|
(write-char page-character port))
|
||
|
|
|