scsh-0.6/scheme/vm/gc-root.scm

136 lines
3.9 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; -*- 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*)))
1999-09-14 08:45:02 -04:00
(define (s48-release-gc-roots-base! old-base old-stack)
1999-09-14 08:45:02 -04:00
(let ((okay? (address= *external-root-stack*
*external-root-stack-base*)))
(set! *external-root-stack-base* old-base)
(set! *external-root-stack* old-stack)
1999-09-14 08:45:02 -04:00
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)))