scsh-0.5/vm/heap.scm

303 lines
9.3 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

; Allocation
; *hp* is the heap pointer and *limit* is the limit beyond which no
; storage should be allocated. Both of these are addresses (not
; descriptors).
(define check-preallocation? #f)
(define *hp* 0)
(define *limit* 0)
; These are all in address units
(define *newspace-begin* (unassigned))
(define *newspace-end* (unassigned))
(define *oldspace-begin* (unassigned))
(define *oldspace-end* (unassigned))
(define (initialize-heap start size)
(let ((semisize (cells->a-units (quotient size 2))))
(set! *newspace-begin* start)
(set! *newspace-end* (addr+ *newspace-begin* semisize))
(set! *oldspace-begin* *newspace-end*)
(set! *oldspace-end* (addr+ *oldspace-begin* semisize))
(set! *hp* *newspace-begin*)
(set! *limit* *newspace-end*)))
(define (available? cells)
(addr< (addr+ *hp* (cells->a-units cells)) *limit*))
(define (available)
(a-units->cells (addr- *limit* *hp*)))
(define (heap-size)
(- *newspace-end* *newspace-begin*))
(define *heap-key* 0)
(define universal-key 0)
(define *okayed-space* 0)
(define (preallocate-space cells)
(cond (check-preallocation?
(assert (available? cells))
(set! *heap-key* (+ *heap-key* 1))
(set! *okayed-space* cells)
*heap-key*)
(else
universal-key)))
(define (make-stob type len key) ;len is in bytes
(if check-preallocation?
(let ((cells (+ (bytes->cells len) 1)))
(assert (available? cells))
(cond ((not (= key universal-key))
(if (not (and (= key *heap-key*)
(>= *okayed-space* cells)))
(error "invalid heap key" key cells))
(set! *okayed-space* (- *okayed-space* cells))))))
(store! *hp* (make-header type len))
(set! *hp* (addr1+ *hp*))
(let ((new (address->stob-descriptor *hp*)))
(set! *hp* (addr+ *hp* (bytes->a-units len)))
(if (> len 0) ; for B-VECTORs that don't want to use all of the
(store! (addr+ *hp* (cells->bytes -1)) 0)) ; last descriptor
new))
(define *pure-areas* (unassigned))
(define *impure-areas* (unassigned))
(define *pure-sizes* (unassigned))
(define *impure-sizes* (unassigned))
(define *pure-area-count* 0)
(define *impure-area-count* 0)
(define (register-static-areas pure-count pure-areas pure-sizes
impure-count impure-areas impure-sizes)
(set! *pure-area-count* pure-count)
(set! *pure-areas* pure-areas)
(set! *pure-sizes* pure-sizes)
(set! *impure-area-count* impure-count)
(set! *impure-areas* impure-areas)
(set! *impure-sizes* impure-sizes))
(define (walk-areas proc areas sizes count)
(let loop ((i 0))
(cond ((>= i count)
#t)
((proc (vector-ref areas i)
(+ (vector-ref areas i)
(vector-ref sizes i)))
(loop (+ i 1)))
(else
#f))))
(define (walk-pure-areas proc)
(walk-areas proc *pure-areas* *pure-sizes* *pure-area-count*))
(define (walk-impure-areas proc)
(walk-areas proc *impure-areas* *impure-sizes* *impure-area-count*))
; Used to find end of an object
(define (header-a-units h)
(bytes->a-units (header-length-in-bytes h)))
(define (walk-over-type-in-area type proc)
(lambda (start end)
(let loop ((addr start))
(cond ((addr< addr end)
(let ((d (fetch addr)))
(cond ((not (header? d))
(write-string "heap is in an inconsistent state."
(current-output-port))
#f)
((or (not (= type (header-type d)))
(proc (address->stob-descriptor (addr1+ addr))))
(loop (addr1+ (addr+ addr (header-a-units d)))))
(else
#f))))
(else
#t)))))
(define (walk-over-symbols proc)
(let ((proc (walk-over-type-in-area (enum stob symbol) proc))
(start-hp *hp*))
(cond ((and (proc *newspace-begin* *hp*)
(walk-pure-areas proc))
#t)
(else
(set! *hp* start-hp) ; out of space, so undo and give up
#f))))
(define (find-all-xs type)
(let ((proc (walk-over-type-in-area type maybe-push-obj))
(start-hp *hp*))
(store-next! 0) ; reserve space for header
(cond ((and (proc *newspace-begin* start-hp)
(walk-impure-areas proc)
(walk-pure-areas proc))
(let ((size (addr- *hp* (addr1+ start-hp))))
(store! start-hp (make-header (enum stob vector) size) )
(address->stob-descriptor (addr1+ start-hp))))
(else
(set! *hp* start-hp) ; out of space, so undo and give up
false))))
(define (maybe-push-obj thing)
(cond ((available? (cells->a-units 1))
(store-next! thing)
#t)
(else #f)))
;;;; Write-image and read-image
(define level 15)
(define (image-writing-okay?)
(and (= 0 *pure-area-count*)
(= 0 *impure-area-count*)))
(define (write-image port restart-proc)
(write-string "This is a Scheme48 heap image file." port)
(newline port)
(write-page port)
(newline port)
(write-number level port)
(write-number bytes-per-cell port)
(write-number (a-units->cells *newspace-begin*) port)
(write-number (a-units->cells *hp*) port)
(write-number restart-proc port)
(write-page port)
(store! *hp* 1) ; used to detect endianess of image
(write-bytes *hp* (- (addr1+ *hp*) *hp*) port)
(write-bytes *newspace-begin* (- *hp* *newspace-begin*) port)
(- *hp* *newspace-begin*))
; Make sure the image file is okay and return the size of the heap it
; contains.
(define (check-image-header filename)
(call-with-input-file filename
(lambda (port)
(let ((lose (lambda (message)
(let ((out (current-output-port)))
(write-string message out)
(newline out)
-1))))
(cond ((null-port? port)
(lose "Can't open heap image file"))
(else
(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))))
(cond ((not (= old-level level))
(lose "format of image is incompatible with this version of system"))
((not (= old-bytes-per-cell bytes-per-cell))
(lose "incompatible bytes-per-cell in image"))
(else
(- old-hp old-begin))))))))))
(define (read-image filename startup-space)
(call-with-input-file filename
(lambda (port)
(if (null-port? port)
(error "Can't open heap image file"))
(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))
(let* ((delta (- *hp* old-begin))
(new-hp (+ old-hp delta))
(new-limit *newspace-end*)
(start *hp*))
(if (addr>= (+ startup-space new-hp) new-limit)
(error "heap not big enough to restore this image"
new-hp new-limit))
(let ((reverse? (check-image-byte-order port)))
(read-bytes *hp* (- old-hp old-begin) port)
(if reverse?
(reverse-byte-order start new-hp))
(if (not (= delta 0))
(relocate-image delta start new-hp))
(set! *hp* new-hp)
(adjust startup-proc delta)))))))
(define (check-image-byte-order port)
(read-bytes *hp* (cells->a-units 1) port)
(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))))) ; to keep from confusing the type checker
; 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 (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 start end)
(write-string "Correcting byte order of resumed image."
(current-output-port))
(newline (current-output-port))
(let loop ((ptr start))
(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)
(address->stob-descriptor (addr+ (address-after-header descriptor) delta))
descriptor))
(define (relocate-image delta start end)
(let loop ((ptr start))
(if (addr< ptr end)
(let ((d (adjust (fetch ptr) delta)))
(store! ptr d)
(loop (if (b-vector-header? d)
(addr+ (addr1+ ptr) (header-a-units d))
(addr1+ 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))
(define (read-page port)
(let loop ()
(ps-read-char port
(lambda (ch)
(if (not (char=? ch page-character))
(loop)))
(lambda ()
(error "end of file while looking for page break")))))