123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231 |
- ; Part of Scheme 48 1.9. See file COPYING for notices and license.
- ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
- ;(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 'read-image
- "format of image is incompatible with this version of system"
- old-level level))
- (if (not (= old-bytes-per-cell bytes-per-cell))
- (error 'read-image
- "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 'check-image-byte-order
- "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 'extract "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 'stored-object-extractors "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 'stob/port "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))))))
|