scsh-0.6/scheme/vm/heap.scm

; 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*))

;----------------

(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)))))