136 lines
3.9 KiB
Scheme
136 lines
3.9 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. 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*)
|
|
(values old-base *external-root-stack*)))
|
|
|
|
(define (s48-release-gc-roots-base! old-base old-stack)
|
|
(let ((okay? (address= *external-root-stack*
|
|
*external-root-stack-base*)))
|
|
(set! *external-root-stack-base* old-base)
|
|
(set! *external-root-stack* old-stack)
|
|
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)))
|