; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  Copyright ( c ) 1993 - 1999 by   and   . See file COPYING .

; This manages external roots that can be registered and unregistered in a
  stack - like fashion .   It also provides the GC interface for the C FFI .

;----------------
  Stack of external roots implemented as a list .

(define *external-root-stack* null-address)

(define *external-root-stack-base* null-address)

; Format of a roots frame:
; 0: number of addresses in the frame, n
;    This may be negative---the frame then serves as a marker.
  1 : address of previous frame
  2 : location address of object 0
  3 : location address of object 1
; ...
; n+1: location address of object n-1

(define (frame-next frame)
  (fetch-address (address1+ frame)))

(define (frame-length frame)
  (fetch frame))

(define (frame-ref frame index)
  (fetch-address (address+ frame (cells->a-units (+ index 2)))))

; Fetch an address.

(define (fetch-address address)
  (integer->address (fetch address)))

;----------------
; Pushing and popping frames

; You call this with the number of roots to be registered and a frame
; which must contain space for n+2 pointers.

(define (s48-push-gc-roots! frame n)
  (store! frame n)
  (store! (address1+ frame)
	  (address->integer *external-root-stack*))
  (set! *external-root-stack* frame))

; We aren't allowed to pop past the current base.

(define (s48-pop-gc-roots!)
  (if (address= *external-root-stack* *external-root-stack-base*)
      #f
      (begin
	(set! *external-root-stack* (frame-next *external-root-stack*))
	#t)))

; We set the base before we jump to a C procedure from Scheme.  When it returns
; we check that everything that was pushed has been popped.  The caller saves
; the old base for us.

(define (s48-set-gc-roots-base!)
  (let ((old-base *external-root-stack-base*))
    (set! *external-root-stack-base* *external-root-stack*)
    old-base))

(define (s48-release-gc-roots-base! old-base)
  (let ((okay? (address= *external-root-stack*
			 *external-root-stack-base*)))
    (set! *external-root-stack-base* old-base)
    okay?))

;----------------
; This is for permanent roots, such as external global variables.
; We keep these in a simple list.

(define *permanent-external-roots* null-address)

(define (s48-register-gc-root! loc-addr)
  (let ((frame (allocate-memory (cells->bytes 2))))
    (if (null-address? frame)
	(error "out of memory registering a global root"))
    (store! frame (address->integer *permanent-external-roots*))
    (store! (address1+ frame) (address->integer loc-addr))
    (set! *permanent-external-roots* frame)))

(define (permanent-root-pointer address)
  (fetch-address (address1+ address)))

(define (permanent-root-next address)
  (fetch-address address))

; This is exported and used to (attempt to) recover from user errors.

(define (s48-set-gc-roots-marker! marker)
  (set! *external-root-stack* marker))

;----------------
; Tracing
;
; We just walk down each list.

(add-gc-root!
  (lambda () 
    (trace-external-root-stack)
    (trace-permanent-external-roots)))

(define (trace-external-root-stack)
  (let loop ((frame *external-root-stack*))
    (if (not (null-address? frame))
	(let ((length (frame-length frame)))
	  (do ((i 0 (+ i 1)))
	      ((= i length))
	    (trace-cell (frame-ref frame i))) 
	  (loop (frame-next frame))))))

(define (trace-permanent-external-roots)
  (let loop ((frame *permanent-external-roots*))
    (if (not (null-address? frame))
	(begin
	  (trace-cell (permanent-root-pointer frame))
	  (loop (permanent-root-next frame))))))

  Trace the contents of a cell .

(define (trace-cell cell)
  (store! cell (s48-trace-value (fetch cell))))

;----------------
; The point to all this is, in part, to be able to allocate space while
; outside the VM.

(define (s48-allocate-stob type size)
  (make-b-vector type size (ensure-space size)))

 -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
 This manages external roots that can be registered and unregistered in a
----------------
 Format of a roots frame:
 0: number of addresses in the frame, n
    This may be negative---the frame then serves as a marker.
 ...
 n+1: location address of object n-1
 Fetch an address.
----------------
 Pushing and popping frames
 You call this with the number of roots to be registered and a frame
 which must contain space for n+2 pointers.
 We aren't allowed to pop past the current base.
 We set the base before we jump to a C procedure from Scheme.  When it returns
 we check that everything that was pushed has been popped.  The caller saves
 the old base for us.
----------------
 This is for permanent roots, such as external global variables.
 We keep these in a simple list.
 This is exported and used to (attempt to) recover from user errors.
----------------
 Tracing

 We just walk down each list.
----------------
 The point to all this is, in part, to be able to allocate space while
 outside the VM.
  Copyright ( c ) 1993 - 1999 by   and   . See file COPYING .

  stack - like fashion .   It also provides the GC interface for the C FFI .

  Stack of external roots implemented as a list .

(define *external-root-stack* null-address)

(define *external-root-stack-base* null-address)

  1 : address of previous frame
  2 : location address of object 0
  3 : location address of object 1

(define (frame-next frame)
  (fetch-address (address1+ frame)))

(define (frame-length frame)
  (fetch frame))

(define (frame-ref frame index)
  (fetch-address (address+ frame (cells->a-units (+ index 2)))))


(define (fetch-address address)
  (integer->address (fetch address)))



(define (s48-push-gc-roots! frame n)
  (store! frame n)
  (store! (address1+ frame)
	  (address->integer *external-root-stack*))
  (set! *external-root-stack* frame))


(define (s48-pop-gc-roots!)
  (if (address= *external-root-stack* *external-root-stack-base*)
      #f
      (begin
	(set! *external-root-stack* (frame-next *external-root-stack*))
	#t)))


(define (s48-set-gc-roots-base!)
  (let ((old-base *external-root-stack-base*))
    (set! *external-root-stack-base* *external-root-stack*)
    old-base))

(define (s48-release-gc-roots-base! old-base)
  (let ((okay? (address= *external-root-stack*
			 *external-root-stack-base*)))
    (set! *external-root-stack-base* old-base)
    okay?))


(define *permanent-external-roots* null-address)

(define (s48-register-gc-root! loc-addr)
  (let ((frame (allocate-memory (cells->bytes 2))))
    (if (null-address? frame)
	(error "out of memory registering a global root"))
    (store! frame (address->integer *permanent-external-roots*))
    (store! (address1+ frame) (address->integer loc-addr))
    (set! *permanent-external-roots* frame)))

(define (permanent-root-pointer address)
  (fetch-address (address1+ address)))

(define (permanent-root-next address)
  (fetch-address address))


(define (s48-set-gc-roots-marker! marker)
  (set! *external-root-stack* marker))


(add-gc-root!
  (lambda () 
    (trace-external-root-stack)
    (trace-permanent-external-roots)))

(define (trace-external-root-stack)
  (let loop ((frame *external-root-stack*))
    (if (not (null-address? frame))
	(let ((length (frame-length frame)))
	  (do ((i 0 (+ i 1)))
	      ((= i length))
	    (trace-cell (frame-ref frame i))) 
	  (loop (frame-next frame))))))

(define (trace-permanent-external-roots)
  (let loop ((frame *permanent-external-roots*))
    (if (not (null-address? frame))
	(begin
	  (trace-cell (permanent-root-pointer frame))
	  (loop (permanent-root-next frame))))))

  Trace the contents of a cell .

(define (trace-cell cell)
  (store! cell (s48-trace-value (fetch cell))))


(define (s48-allocate-stob type size)
  (make-b-vector type size (ensure-space size)))
