224 lines
6.6 KiB
Scheme
224 lines
6.6 KiB
Scheme
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
|
|
;(define-syntax assert
|
|
; (lambda ignore
|
|
; ''assert))
|
|
|
|
(define debugging? #t)
|
|
|
|
; ,bench
|
|
; ,load rts/defenum.scm
|
|
; ,for-syntax ,load my-vm/for-syntax.scm
|
|
; ,load my-vm/s48-prescheme.scm my-vm/util.scm my-vm/memory.scm
|
|
; ,load my-vm/arch.scm my-vm/data.scm my-vm/struct.scm
|
|
; ,load link/s48-features.scm link/read-image.scm
|
|
; ,load-into extended-numbers misc/bigbit.scm
|
|
|
|
(define (resume filename arg)
|
|
(call-startup-procedure (extract (read-image filename)) arg))
|
|
|
|
(define (call-startup-procedure proc arg)
|
|
(proc arg (current-input-port) (current-output-port)))
|
|
|
|
(define level 14)
|
|
|
|
(define (read-image filename)
|
|
(call-with-input-file filename
|
|
(lambda (port)
|
|
(read-page port) ; read past any user cruft at the beginning of the file
|
|
(let* ((old-level (read-number port))
|
|
(old-bytes-per-cell (read-number port))
|
|
(old-begin (cells->a-units (read-number port)))
|
|
(old-hp (cells->a-units (read-number port)))
|
|
(startup-proc (read-number port)))
|
|
(read-page port)
|
|
(if (not (= old-level level))
|
|
(error "format of image is incompatible with this version of system"
|
|
old-level level))
|
|
(if (not (= old-bytes-per-cell bytes-per-cell))
|
|
(error "incompatible bytes-per-cell"
|
|
old-bytes-per-cell bytes-per-cell))
|
|
|
|
;; ***CHANGED***
|
|
(create-memory (a-units->cells (- (addr1+ old-hp) old-begin))
|
|
quiescent)
|
|
(set! *hp* 0)
|
|
|
|
(let* ((delta (- *hp* old-begin))
|
|
(new-hp (+ old-hp delta)))
|
|
(let ((reverse? (check-image-byte-order port)))
|
|
(read-block port *memory* *hp* (- old-hp old-begin))
|
|
(if reverse?
|
|
(reverse-byte-order new-hp))
|
|
(if (= delta 0)
|
|
(set! *hp* new-hp)
|
|
(relocate-image delta new-hp))
|
|
(set! *extracted* (make-vector (a-units->cells *memory-end*) #f))
|
|
(adjust startup-proc delta)))))))
|
|
|
|
(define (check-image-byte-order port)
|
|
(read-block port *memory* *hp* (cells->a-units 1))
|
|
(cond ((= (fetch *hp*) 1)
|
|
#f)
|
|
(else
|
|
(reverse-descriptor-byte-order! *hp*)
|
|
(if (= (fetch *hp*) 1)
|
|
#t
|
|
(begin (error "unable to correct byte order" (fetch *hp*))
|
|
#f)))))
|
|
|
|
(define *hp* 0)
|
|
|
|
(define *extracted* #f)
|
|
|
|
(define (extract obj)
|
|
(cond ((vm-fixnum? obj) (extract-vm-fixnum obj))
|
|
((stob? obj)
|
|
(let ((index (a-units->cells (address-after-header obj))))
|
|
(or (vector-ref *extracted* index)
|
|
(extract-stored-object obj
|
|
(lambda (new)
|
|
(vector-set! *extracted* index new)
|
|
new)))))
|
|
((vm-char? obj) (extract-char obj))
|
|
((vm-eq? obj null) '())
|
|
((vm-eq? obj false) #f)
|
|
((vm-eq? obj true) #t)
|
|
((vm-eq? obj vm-unspecific) (if #f 0))
|
|
((vm-eq? obj unbound-marker) '<unbound>)
|
|
((vm-eq? obj unassigned-marker) '<unassigned>)
|
|
(else (error "random descriptor" obj))))
|
|
|
|
(define (extract-stored-object old store-new!)
|
|
((vector-ref stored-object-extractors (header-type (stob-header old)))
|
|
old store-new!))
|
|
|
|
(define stored-object-extractors
|
|
(make-vector stob-count (lambda rest (apply error "no extractor" rest))))
|
|
|
|
(define (define-extractor which proc)
|
|
(vector-set! stored-object-extractors which proc))
|
|
|
|
(define-extractor stob/pair
|
|
(lambda (old store-new!)
|
|
(let ((new (cons #f #f)))
|
|
(store-new! new)
|
|
(set-car! new (extract (vm-car old)))
|
|
(set-cdr! new (extract (vm-cdr old)))
|
|
new)))
|
|
|
|
(define-extractor stob/vm-closure
|
|
(lambda (old store-new!)
|
|
(store-new! (make-closure (extract (vm-closure-template old))
|
|
(extract (vm-closure-env old))))))
|
|
|
|
(define-extractor stob/symbol
|
|
(lambda (obj store-new!)
|
|
(store-new! (string->symbol (extract (vm-symbol->string obj))))))
|
|
|
|
(define-extractor stob/vm-location
|
|
(lambda (obj store-new!)
|
|
(let ((new (store-new! (make-undefined-location
|
|
(+ 10000
|
|
(extract (vm-location-id obj))))))
|
|
(val (vm-contents obj)))
|
|
(if (not (vm-eq? val unbound-marker))
|
|
(begin (set-location-defined?! new #t)
|
|
(if (not (vm-eq? val unassigned-marker))
|
|
(set-contents! new (extract val)))))
|
|
new)))
|
|
|
|
(define-extractor stob/string
|
|
(lambda (obj store-new!)
|
|
(store-new! (extract-string obj))))
|
|
|
|
(define-extractor stob/vm-code-vector
|
|
(lambda (obj store-new!)
|
|
(store-new! (extract-code-vector obj))))
|
|
|
|
(define-extractor stob/vector
|
|
(lambda (obj store-new!)
|
|
(let* ((z (vm-vector-length obj))
|
|
(v (make-vector z)))
|
|
(store-new! v)
|
|
(do ((i 0 (+ i 1)))
|
|
((= i z) v)
|
|
(vector-set! v i (extract (vm-vector-ref obj i)))))))
|
|
|
|
;(define-extractor stob/record
|
|
; (lambda (obj store-new!)
|
|
; (let* ((z (vm-record-length obj))
|
|
; (v (make-record z)))
|
|
; (store-new! v)
|
|
; (do ((i 0 (+ i 1)))
|
|
; ((= i z) v)
|
|
; (record-set! v i (extract (vm-record-ref obj i)))))))
|
|
|
|
(define-extractor stob/port
|
|
(lambda (obj store-new!)
|
|
(store-new!
|
|
(case (extract-vm-fixnum (port-index obj))
|
|
((0) (current-input-port))
|
|
((1) (current-output-port))
|
|
(else (error "unextractable port" obj))))))
|
|
|
|
|
|
|
|
(define (extract-code-vector x)
|
|
(let ((z (vm-code-vector-length x)))
|
|
(let ((v (make-code-vector z 0)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i z) v)
|
|
(code-vector-set! v i (vm-code-vector-ref x i))))))
|
|
|
|
|
|
|
|
; Various things copied from vm/gc.scm
|
|
|
|
(define (store-next! descriptor)
|
|
(store! *hp* descriptor)
|
|
(set! *hp* (addr1+ *hp*)))
|
|
|
|
(define (reverse-descriptor-byte-order! addr)
|
|
(let ((x (fetch-byte addr)))
|
|
(store-byte! addr (fetch-byte (addr+ addr 3)))
|
|
(store-byte! (addr+ addr 3) x))
|
|
(let ((x (fetch-byte (addr+ addr 1))))
|
|
(store-byte! (addr+ addr 1) (fetch-byte (addr+ addr 2)))
|
|
(store-byte! (addr+ addr 2) x)))
|
|
|
|
(define (reverse-byte-order end)
|
|
(write-string "Correcting byte order of resumed image."
|
|
(current-output-port))
|
|
(newline (current-output-port))
|
|
(let loop ((ptr *hp*))
|
|
(reverse-descriptor-byte-order! ptr)
|
|
(let ((value (fetch ptr)))
|
|
(if (addr< ptr end)
|
|
(loop (if (b-vector-header? value)
|
|
(addr+ (addr1+ ptr) (header-a-units value))
|
|
(addr1+ ptr)))))))
|
|
|
|
(define (adjust descriptor delta)
|
|
(if (stob? descriptor)
|
|
(make-stob-descriptor (addr+ (address-after-header descriptor) delta))
|
|
descriptor))
|
|
|
|
(define (relocate-image delta new-hp)
|
|
(let loop ()
|
|
(cond ((addr< *hp* new-hp)
|
|
(let ((d (adjust (fetch *hp*) delta)))
|
|
(store-next! d)
|
|
(cond ;;((eq? d the-primitive-header)
|
|
;; Read symbolic label name.
|
|
;;(store-next!
|
|
;; (label->fixnum (name->label (read port)))))
|
|
((b-vector-header? d)
|
|
(set! *hp* (addr+ *hp*
|
|
(cells->bytes
|
|
(bytes->cells
|
|
(header-length-in-bytes d)))))))
|
|
(loop))))))
|