scsh-0.6/scheme/vm/heap.scm

281 lines
8.7 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Allocation
; s48-*hp* is the heap pointer and s48-*limit* is the limit beyond which no
; storage should be allocated. Both of these are addresses (not
; descriptors).
(define s48-*hp*)
(define s48-*limit*)
(define *oldspace-hp*)
(define *oldspace-limit*)
; These are all in address units
(define *newspace-begin*)
(define *newspace-end*)
(define *oldspace-begin*)
(define *oldspace-end*)
; For the GC (which is in another module)
(define (heap-pointer)
s48-*hp*)
(define (set-heap-pointer! new-hp)
(set! s48-*hp* new-hp))
(define (heap-start)
*newspace-begin*)
(define (heap-limit)
*newspace-end*)
;----------------
(define (s48-initialize-heap start size)
(let ((semisize (cells->a-units (quotient size 2))))
(set! *newspace-begin* start)
(set! *newspace-end* (address+ *newspace-begin* semisize))
(set! s48-*hp* *newspace-begin*)
(set! s48-*limit* *newspace-end*)
(set! *oldspace-begin* *newspace-end*)
(set! *oldspace-end* (address+ *oldspace-begin* semisize))
(set! *oldspace-hp* *oldspace-begin*)
(set! *oldspace-limit* *oldspace-end*)))
; To write images we need to be able to undo the swapping.
(define-syntax swap!
(syntax-rules ()
((swap! a b)
(let ((temp a))
(set! a b)
(set! b temp)))))
(define (swap-spaces)
(swap! s48-*limit* *oldspace-limit*)
(swap! s48-*hp* *oldspace-hp*)
(swap! *newspace-begin* *oldspace-begin*)
(swap! *newspace-end* *oldspace-end*))
(define (s48-newspace<oldspace?)
(address< s48-*limit* *oldspace-limit*))
1999-09-14 08:45:02 -04:00
;----------------
(define (s48-available? cells)
(address< (address+ s48-*hp* (cells->a-units cells)) s48-*limit*))
(define (s48-available)
(a-units->cells (address-difference s48-*limit* s48-*hp*)))
(define (s48-heap-size)
(address-difference *newspace-end* *newspace-begin*))
(define (store-next! descriptor)
(store! s48-*hp* descriptor)
(set! s48-*hp* (address1+ s48-*hp*)))
; Pre-Allocation
;
; Preallocation and keys are used to ensure that for every call to MAKE-STOB
; there is a corresponding call to ENSURE-SPACE to see if there is sufficient
; heap space. ENSURE-SPACE returns a key and MAKE-STOB checks that the
; key it is passed is the most recently allocated key and that the space
; needed is no greater than the argument to ENSURE-SPACE.
;
; Another solution would be to make ENSURE-SPACE and MAKE-STOB a single
; procedure. The difficulty is that ENSURE-SPACE may trigger a garbage
; collection, which in turn requires that all live data be reachable
; from the VM's registers. The VM solves this by only calling ENSURE-SPACE
; at the beginning of an instruction, before any values have been removed
; from the stack or any of the registers. Once the key has been obtained
; the instruction is free to make any number of calls to MAKE-STOB, as long
; as the total heap space required is no more than what was checked for.
;
; There is a flag, CHECK-PREALLOCATION?, that determines whether MAKE-STOB
; actually checks the keys. In the VM as seen by the Pre-Scheme compiler
; this flag is defined to be #f and never set, so all of the key code is
; constant-folded into oblivion.
;
; The main virtue of the keys is not that they can be checked but
; that they exist at all. MAKE-STOB requires a key argument, and
; if there is none available you know that you forgot an ENSURE-SPACE.
; Occasionally I run the VM in Scheme with checking enabled, just
; to see if it all still works.
(define check-preallocation? #f)
(define *heap-key* 0)
(define *okayed-space* 0)
(define (s48-preallocate-space cells)
(cond (check-preallocation?
(assert (s48-available? cells))
(set! *heap-key* (+ *heap-key* 1))
(set! *okayed-space* cells)
*heap-key*)
(else
0)))
(define (s48-allocate-space type len key) ;len is in bytes
(= type 0) ; declaration for type-checker
(if check-preallocation?
(let ((cells (+ (bytes->cells len) 1)))
(assert (s48-available? cells))
(if (not (and (= key *heap-key*)
(>= *okayed-space* cells)))
(error "invalid heap key" key cells))
(set! *okayed-space* (- *okayed-space* cells))))
(let ((new s48-*hp*))
(set! s48-*hp* (address+ s48-*hp* (bytes->a-units len)))
new))
(define (s48-write-barrier stob address value)
(address+ address (+ stob value)) ; for the type checker
(unspecific))
;----------------
; Keeping track of all the areas.
(define *pure-areas*)
(define *impure-areas*)
(define *pure-sizes*)
(define *impure-sizes*)
(define *pure-area-count* 0)
(define *impure-area-count* 0)
(define (have-static-areas?)
(or (< 0 *impure-area-count*)
(< 0 *pure-area-count*)))
(define (s48-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)
(address+ (vector-ref areas i)
(vector-ref sizes i)))
(loop (+ i 1)))
(else
#f))))
(define (walk-pure-areas proc)
(if (< 0 *pure-area-count*)
(walk-areas proc *pure-areas* *pure-sizes* *pure-area-count*)))
(define (walk-impure-areas proc)
(if (< 0 *impure-area-count*)
(walk-areas proc *impure-areas* *impure-sizes* *impure-area-count*)))
;----------------------------------------------------------------
; Finding things in the heap.
(define *finding-type* (enum stob symbol)) ; work around lack of closures
; Call PREDICATE on all objects of type *FINDING-TYPE* found between START and END.
; The objects for which PREDICATE returns #T are pushed onto the heap using STORE-NEXT!.
; Returns #T for success and #F for failure.
(define (collect-type-in-area predicate)
(lambda (start end)
(let ((type *finding-type*))
(let loop ((addr start))
(if (address>= addr end)
#t
(let* ((d (fetch addr))
(next (address+ addr
(+ (cells->a-units stob-overhead)
(header-length-in-a-units d)))))
(cond ((not (header? d))
(write-string "heap is in an inconsistent state."
(current-error-port))
#f)
((not (= type (header-type d)))
(loop next))
(else
(let ((obj (address->stob-descriptor (address1+ addr))))
(cond ((not (predicate obj))
(loop next))
((s48-available? (cells->a-units 1))
(store-next! obj)
(loop next))
(else
#f)))))))))))
; Returns a procedure that will walk the heap calling PREDICATE on every
; object of a particular type. Returns a vector containing all objects
; for which PREDICATE returns #t. If the heap is screwed up or there isn't
; room for the vector we return FALSE.
(define (generic-find-all predicate)
(let ((proc (collect-type-in-area predicate)))
(lambda (type)
(set! *finding-type* type) ; we don't have closures
(let ((start-hp s48-*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 (address-difference s48-*hp* (address1+ start-hp))))
(store! start-hp (make-header (enum stob vector) size) )
(address->stob-descriptor (address1+ start-hp))))
(else
(set! s48-*hp* start-hp) ; out of space, so undo and give up
false))))))
; Find everything with a given type.
(define s48-find-all
(generic-find-all (lambda (thing) #t)))
; Find all records of a given record type (as determined by the first slot
; in each record).
(define s48-find-all-records
(let* ((the-record-type false)
(finder (generic-find-all
(lambda (record)
(vm-eq? (record-type record)
the-record-type)))))
(lambda (record-type)
(set! the-record-type record-type)
(finder (enum stob record)))))
(define find-resumer-records
(let ((finder (generic-find-all
(lambda (record)
(let ((type (record-type record)))
(and (record? type)
(stob? (record-type-resumer type))))))))
(lambda ()
(finder (enum stob record)))))
; Functions for accessing records. Getting these from STRUCT would introduce
; a circular module dependency.
(define (record? x)
(and (stob? x)
(= (header-type (stob-header x))
(enum stob record))))
(define (record-type record)
(record-ref record -1))
(define (record-type-resumer record-type)
(record-ref record-type 0))
(define (record-ref record offset)
(fetch (address+ (address-after-header record)
(cells->a-units (+ offset 1)))))