510 lines
17 KiB
Scheme
510 lines
17 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
; The stack grows from higher addresses to lower ones.
|
|
; *STACK-BEGIN* and *STACK-END* delimit the stack portion of memory.
|
|
; *STACK* points to the next unused cell on top of the stack.
|
|
; *STACK-LIMIT* is value against which stack requests are checked. There is a
|
|
; buffer area between the limit and the actual end of the stack. The buffer
|
|
; is large enough to contain the default procedure stack requirement plus the
|
|
; space needed to make a call to an exception plus an interrupts plus some
|
|
; slack for safety's sake.
|
|
|
|
; These slots are filled with a funny value so that we can detect overruns.
|
|
|
|
(define stack-warning-limit 30)
|
|
|
|
; The supposedly unused space at the end of the stack is marked with this
|
|
; value so that we can detect incursions.
|
|
|
|
(define stack-marker #xf0f0f0f)
|
|
|
|
; We need at least this amount of space for the stack.
|
|
|
|
(define stack-slack
|
|
(+ default-stack-space
|
|
continuation-stack-size ; *bottom-of-stack*
|
|
(+ continuation-stack-size 13) ; exceptions need at most 14 values
|
|
; (long pole is external exceptions with
|
|
; exception + procedure-name + 10 irritants +
|
|
; saved-exception + stack-block)
|
|
(+ continuation-stack-size 7) ; interrupts need at most 7 values
|
|
; (also from examining the code)
|
|
(+ stack-warning-limit 2))) ; safety
|
|
|
|
; *BOTTOM-OF-STACK* is a continuation that lies a the base of the stack.
|
|
|
|
(define *stack-begin*)
|
|
(define *stack-end*)
|
|
(define *stack*)
|
|
(define *stack-limit*)
|
|
|
|
; Current continuation
|
|
(define *cont*)
|
|
|
|
; For tracking the reason for copying closures and environments (used for
|
|
; debugging and gathering statistics).
|
|
|
|
(define-enumeration copy
|
|
(closure
|
|
overflow
|
|
preserve))
|
|
|
|
; At the bottom of the stack is a special continuation that is never removed.
|
|
; When it is invoked it copies the next continuation out of the heap (if there
|
|
; is any such) and invokes that instead.
|
|
|
|
(define *bottom-of-stack*)
|
|
|
|
; Initialize the stack and related registers. All sizes are in descriptors.
|
|
|
|
(define (initialize-stack+gc start have-size)
|
|
(let ((required-size (+ available-stack-space stack-slack)))
|
|
(receive (start size)
|
|
(if (>= have-size required-size)
|
|
(values start have-size)
|
|
(let ((stack (allocate-memory (cells->a-units required-size))))
|
|
(if (null-address? stack)
|
|
(error "out of memory, unable to continue"))
|
|
(values stack required-size)))
|
|
(set! *stack-begin* start)
|
|
(set! *stack-end* (address+ start (cells->a-units size)))
|
|
(set! *stack-limit* (address+ *stack-begin* (cells->a-units stack-slack)))
|
|
(set! *stack* (the-pointer-before *stack-end*))
|
|
(set! *cont* false)
|
|
(set! *env* quiescent)
|
|
(do ((a start (address1+ a)))
|
|
((address= a *stack-end*))
|
|
(store! a stack-marker))
|
|
(let ((key (ensure-space (op-template-size 2))))
|
|
(push-continuation-on-stack
|
|
(make-template-containing-ops (enum op get-cont-from-heap)
|
|
(enum op return)
|
|
key)
|
|
(enter-fixnum 0)
|
|
0))
|
|
(set! *bottom-of-stack* *cont*))))
|
|
|
|
(define (reset-stack-pointer base-continuation)
|
|
(set! *stack* (the-pointer-before
|
|
(the-pointer-before (address-after-header *bottom-of-stack*))))
|
|
(set-continuation-cont! *bottom-of-stack* base-continuation)
|
|
(set! *cont* *bottom-of-stack*))
|
|
|
|
;----------------
|
|
; Utilities
|
|
|
|
(define (within-stack? p)
|
|
(and (stob? p)
|
|
(>= p (address->integer *stack-begin*))
|
|
(<= p (address->integer *stack-end*))))
|
|
|
|
(define (stack-size)
|
|
(address-difference *stack-end* *stack-begin*))
|
|
|
|
; The stob-overhead is to get room for one vector that is made.
|
|
(define (current-stack-size)
|
|
(+ stob-overhead (a-units->cells (address-difference *stack-end* *stack*))))
|
|
|
|
; Add CELLS cells onto the stack.
|
|
; The stack grows towards negative memory.
|
|
|
|
(define (add-cells-to-stack! cells)
|
|
(set! *stack* (address- *stack* (cells->a-units cells))))
|
|
|
|
(define (the-pointer-before x)
|
|
(address- x (cells->a-units 1)))
|
|
|
|
(define (push x) ; check for overflow is done when continuations are pushed
|
|
(store! *stack* x)
|
|
(add-cells-to-stack! 1))
|
|
|
|
(define (pop)
|
|
(add-cells-to-stack! -1)
|
|
(fetch *stack*))
|
|
|
|
; Use the stack as a vector, with (STACK-REF 0) => current top of stack
|
|
|
|
(define (stack-ref index)
|
|
(fetch (address+ *stack* (cells->a-units (+ 1 index)))))
|
|
|
|
(define (stack-set! index value)
|
|
(store! (address+ *stack* (cells->a-units (+ 1 index))) value))
|
|
|
|
(define (pointer-to-stack-arguments)
|
|
(address+ *stack* (cells->a-units 1)))
|
|
|
|
(define (remove-stack-arguments count)
|
|
(add-cells-to-stack! (- 0 count)))
|
|
|
|
(define (address-at-header stob)
|
|
(address- (address-after-header stob) (cells->a-units 1)))
|
|
|
|
;----------------
|
|
; *STACK-LIMIT* is offset by DEFAULT-STACK-SPACE to make this test faster.
|
|
|
|
(define (ensure-default-procedure-space! ensure-space)
|
|
(if (address< *stack* *stack-limit*)
|
|
(begin
|
|
(copy-stack-into-heap (ensure-space (current-stack-size)))
|
|
(if (address< *stack* *stack-limit*)
|
|
(error "Couldn't get default procedure space (how can this happen?)"))))
|
|
0)
|
|
|
|
; Compiler is not allowed to use more than one stack's worth of space for
|
|
; any given procedure.
|
|
|
|
(define (ensure-stack-space! space ensure-space)
|
|
(if (not (available-on-stack? space))
|
|
(begin
|
|
(copy-stack-into-heap (ensure-space (current-stack-size)))
|
|
(if (not (available-on-stack? space))
|
|
(error "VM's stack is too small (how can this happen?)")))))
|
|
|
|
(define (available-on-stack? space)
|
|
(> (+ (a-units->cells ; space on the stack
|
|
(address-difference *stack* *stack-limit*))
|
|
default-stack-space) ; allow for *stack-limit*'s offset
|
|
space))
|
|
|
|
;----------------
|
|
; Setting the current continuation.
|
|
|
|
; Called when replacing the current continuation with a new one.
|
|
|
|
(define (set-current-continuation! cont)
|
|
(if (continuation? cont)
|
|
(copy-continuation-from-heap! cont)
|
|
(reset-stack-pointer cont)))
|
|
|
|
; Called when returning off of the end of the stack.
|
|
|
|
(define (get-continuation-from-heap)
|
|
(continuation-cont *bottom-of-stack*))
|
|
|
|
; Copy CONT from heap onto stack just above *BOTTOM-OF-STACK*, linking it
|
|
; to *BOTTOM-OF-STACK* and *BOTTOM-OF-STACK* to CONT's continuation.
|
|
|
|
(define (copy-continuation-from-heap! cont)
|
|
(assert (continuation? cont))
|
|
(let* ((top (address- (address-at-header *bottom-of-stack*)
|
|
(cells->a-units (+ 1 (continuation-length cont)))))
|
|
(new-cont (address->stob-descriptor (address1+ top))))
|
|
(add-copy-cont-from-heap-stats cont)
|
|
(set! *stack* (the-pointer-before top))
|
|
(set! *cont* new-cont)
|
|
(copy-memory! (address-at-header cont)
|
|
top
|
|
(cells->bytes (+ 1 (continuation-length cont))))
|
|
(set-continuation-cont! *bottom-of-stack* (continuation-cont new-cont))
|
|
(set-continuation-cont! new-cont *bottom-of-stack*)
|
|
new-cont))
|
|
|
|
(define (push-continuation-on-stack template pc arg-count)
|
|
(add-continuation-stats arg-count)
|
|
(add-cells-to-stack! (+ 1 continuation-cells))
|
|
(store! (address1+ *stack*) (make-continuation-header arg-count))
|
|
(let ((cont (address->stob-descriptor (address2+ *stack*))))
|
|
(set-continuation-pc! cont pc)
|
|
(set-continuation-template! cont template)
|
|
(set-continuation-env! cont *env*)
|
|
(set-continuation-cont! cont *cont*)
|
|
(set! *cont* cont)))
|
|
|
|
(define make-continuation-header
|
|
(let ((type (enum stob continuation)))
|
|
(lambda (arg-count)
|
|
(make-header-immutable
|
|
(make-header type (cells->bytes (+ arg-count continuation-cells)))))))
|
|
|
|
(define (pop-continuation-from-stack set-template!)
|
|
(let ((cont *cont*))
|
|
(set-template! (continuation-template cont)
|
|
(continuation-pc cont))
|
|
(set! *env* (continuation-env cont))
|
|
(set! *cont* (continuation-cont cont))
|
|
(set! *stack* (address+ (address-at-header cont)
|
|
(cells->a-units continuation-cells)))))
|
|
|
|
;----------------
|
|
; Support for multiple-value returns.
|
|
|
|
(define (peek-at-current-continuation)
|
|
(if (= *cont* *bottom-of-stack*)
|
|
(continuation-cont *bottom-of-stack*)
|
|
*cont*))
|
|
|
|
(define (skip-current-continuation!)
|
|
(let ((next (continuation-cont *cont*)))
|
|
(if (= *cont* *bottom-of-stack*)
|
|
(set-continuation-cont! *cont* (continuation-cont next))
|
|
(set! *cont* next))))
|
|
|
|
;----------------
|
|
; Copying the stack into the heap because there is no more room on the
|
|
; stack. This preserves the continuation and then moves any arguments
|
|
; down on top of the current continuation.
|
|
|
|
(define (copy-stack-into-heap key)
|
|
(let ((arg-count (arguments-on-stack))
|
|
(top *stack*))
|
|
(preserve-continuation key (enum copy overflow))
|
|
(really-move-args-above-cont! arg-count top)))
|
|
|
|
(define (arguments-on-stack)
|
|
(do ((p (address1+ *stack*) (address1+ p))
|
|
(i 0 (+ i 1)))
|
|
((header? (fetch p))
|
|
(if (= (fetch p) argument-limit-marker)
|
|
(- i 1) ; marker is one past the original header location
|
|
i))))
|
|
|
|
; This is used by the environment code to mark environments that have been
|
|
; migrated to the heap (their header gets clobbered during the of migration).
|
|
; Any header type that is not normally found on the heap will work.
|
|
|
|
(define argument-limit-marker (make-header (enum stob channel) 0))
|
|
|
|
(define (really-move-args-above-cont! nargs top-of-args)
|
|
(let ((start-loc (the-pointer-before (address-at-header *cont*)))
|
|
(start-arg (address+ top-of-args (cells->a-units nargs))))
|
|
(do ((loc start-loc (the-pointer-before loc))
|
|
(arg start-arg (the-pointer-before arg)))
|
|
((address<= arg top-of-args)
|
|
(set! *stack* loc))
|
|
(store! loc (fetch arg)))))
|
|
|
|
; Copy NARGS arguments from the top of the stack to just above CONT.
|
|
; Used by OP/MOVE-ARGS-AND-CALL to implement tail-recursive calls.
|
|
|
|
(define (move-args-above-cont! nargs)
|
|
(really-move-args-above-cont! nargs *stack*))
|
|
|
|
; Migrating the current continuation into the heap, saving the environment
|
|
; first. The heap space needed is no more than the current stack size.
|
|
|
|
(define current-continuation-size current-stack-size)
|
|
|
|
(define (current-continuation key)
|
|
(preserve-continuation key (enum copy preserve)))
|
|
|
|
(define (preserve-continuation key reason)
|
|
(if (false? *cont*)
|
|
false
|
|
(really-preserve-continuation key reason)))
|
|
|
|
; 1. Preserve the current lexical environment
|
|
; 2. Loop down the continuations copying them into the heap, including their
|
|
; lexical environments
|
|
; 3. Copy the current continuation back onto the stack
|
|
|
|
(define (really-preserve-continuation key reason)
|
|
(preserve-current-env-with-reason key reason)
|
|
(let ((end (continuation-cont *bottom-of-stack*)))
|
|
(let loop ((cont *cont*) (previous *bottom-of-stack*))
|
|
(cond ((vm-eq? cont *bottom-of-stack*)
|
|
(set-continuation-cont! previous end))
|
|
(else
|
|
(if (within-stack? (continuation-env cont))
|
|
(save-env-in-heap (continuation-env cont) cont key reason)
|
|
0) ; for type inferencer (which could use some improvement)
|
|
(let ((new (header+contents->stob
|
|
(stob-header cont)
|
|
(address-after-header cont)
|
|
key)))
|
|
(add-preserve-cont-stats new reason)
|
|
(set-continuation-cont! previous new)
|
|
(loop (continuation-cont new) new))))))
|
|
(set! *cont* *bottom-of-stack*)
|
|
(continuation-cont *bottom-of-stack*))
|
|
|
|
;----------------
|
|
; Tracing the stack for garbage collection - first trace any arguments pushed
|
|
; above the current continuation, then loop down the continuations, tracing
|
|
; each one along with its environment (if the environment has not yet been
|
|
; done).
|
|
|
|
(define *stack-warning?* #t)
|
|
|
|
(define (trace-stack trace-locations! trace-stob-contents! trace-value)
|
|
(if *stack-warning?*
|
|
(do ((a *stack-begin* (address1+ a)))
|
|
((not (= stack-marker (fetch a)))
|
|
(let ((unused (a-units->cells (address-difference a *stack-begin*))))
|
|
(if (< unused stack-warning-limit)
|
|
(begin
|
|
(newline (current-error-port))
|
|
(write-string "[Alert: stack overconsumption ("
|
|
(current-error-port))
|
|
(write-integer unused (current-error-port))
|
|
(write-string "); please inform the Scheme 48 implementors]"
|
|
(current-error-port))
|
|
(newline (current-error-port))
|
|
(set! *stack-warning?* #f)))))))
|
|
(let ((arg-count (arguments-on-stack)))
|
|
(trace-locations! (address1+ *stack*)
|
|
(address+ *stack* (cells->a-units (+ arg-count 1)))))
|
|
(if (within-stack? *env*)
|
|
(trace-env *env* trace-stob-contents!)
|
|
(set! *env* (trace-value *env*)))
|
|
(let loop ((cont *cont*) (last-env 0))
|
|
(let ((env (continuation-env cont)))
|
|
(trace-stob-contents! cont)
|
|
(if (not (vm-eq? env last-env))
|
|
(trace-env env trace-stob-contents!))
|
|
(if (not (vm-eq? cont *bottom-of-stack*))
|
|
(loop (continuation-cont cont) env)))))
|
|
|
|
(define (trace-env env trace-stob-contents!)
|
|
(let loop ((env env))
|
|
(if (within-stack? env)
|
|
(begin
|
|
(trace-stob-contents! env)
|
|
(loop (vm-vector-ref env 0))))))
|
|
|
|
;----------------
|
|
; Error reporting
|
|
|
|
(define (report-continuation-uids current-template out)
|
|
(let ((not-first? (maybe-write-template current-template #f out)))
|
|
(let loop ((cont *cont*) (not-first? not-first?))
|
|
(if (continuation? cont)
|
|
(loop (continuation-cont cont)
|
|
(maybe-write-template (continuation-template cont)
|
|
not-first?
|
|
out))))))
|
|
|
|
(define (maybe-write-template template not-first? out)
|
|
(if (and (fixnum? (template-name template))
|
|
(not (vm-eq? template (continuation-template *bottom-of-stack*))))
|
|
(begin
|
|
(if not-first?
|
|
(write-string " <- " out))
|
|
(write-integer (extract-fixnum (template-name template)) out)
|
|
#t)
|
|
not-first?))
|
|
|
|
;----------------
|
|
; Collecting and printing statistics on stack usage
|
|
|
|
(define collect-statistics? #f)
|
|
|
|
(define *conts* 0)
|
|
(define *conts-slots* 0)
|
|
(define *conts-overflow* 0)
|
|
(define *conts-overflow-slots* 0)
|
|
(define *conts-preserved* 0)
|
|
(define *conts-preserved-slots* 0)
|
|
(define *conts-from-heap* 0)
|
|
(define *conts-from-heap-slots* 0)
|
|
|
|
(define *envs* 0)
|
|
(define *envs-slots* 0)
|
|
(define *envs-closed* 0)
|
|
(define *envs-closed-slots* 0)
|
|
(define *envs-overflow* 0)
|
|
(define *envs-overflow-slots* 0)
|
|
(define *envs-preserved* 0)
|
|
(define *envs-preserved-slots* 0)
|
|
|
|
(define (reset-stack-stats)
|
|
(cond (collect-statistics?
|
|
(set! *conts* 0)
|
|
(set! *conts-slots* 0)
|
|
(set! *conts-overflow* 0)
|
|
(set! *conts-overflow-slots* 0)
|
|
(set! *conts-preserved* 0)
|
|
(set! *conts-preserved-slots* 0)
|
|
(set! *conts-from-heap* 0)
|
|
(set! *conts-from-heap-slots* 0)
|
|
|
|
(set! *envs* 0)
|
|
(set! *envs-slots* 0)
|
|
(set! *envs-closed* 0)
|
|
(set! *envs-closed-slots* 0)
|
|
(set! *envs-overflow* 0)
|
|
(set! *envs-overflow-slots* 0)
|
|
(set! *envs-preserved* 0)
|
|
(set! *envs-preserved-slots* 0)
|
|
)
|
|
(else 0)))
|
|
|
|
(define (print-stack-stats port)
|
|
(if collect-statistics?
|
|
(really-print-stack-stats port)))
|
|
|
|
(define (really-print-stack-stats port)
|
|
(let ((one-record (lambda (name count slots port)
|
|
(newline port)
|
|
(write-string "(" port)
|
|
(write-string name port)
|
|
(write-string " " port)
|
|
;(write-number count port) ; don't have write-number!
|
|
;(write-number slots port)
|
|
(write-string ")" port))))
|
|
(newline port)
|
|
(write-string "(continuations" port)
|
|
(one-record "made" *conts* *conts-slots* port)
|
|
(one-record "overflow" *conts-overflow* *conts-overflow-slots* port)
|
|
(one-record "preserved" *conts-preserved* *conts-preserved-slots* port)
|
|
(one-record "from-heap" *conts-from-heap* *conts-from-heap-slots* port)
|
|
(write-string ")" port)
|
|
|
|
(newline port)
|
|
(write-string "(environments" port)
|
|
(one-record "made" *envs* *envs-slots* port)
|
|
(one-record "closed" *envs-closed* *envs-closed-slots* port)
|
|
(one-record "overflow" *envs-overflow* *envs-overflow-slots* port)
|
|
(one-record "preserved" *envs-preserved* *envs-preserved-slots* port)
|
|
(write-string ")" port)
|
|
(newline port)
|
|
))
|
|
|
|
(define (add-continuation-stats arg-count)
|
|
(cond (collect-statistics?
|
|
(set! *conts* (+ *conts* 1))
|
|
(set! *conts-slots*
|
|
(+ *conts-slots* (+ arg-count continuation-cells))))))
|
|
|
|
|
|
(define (add-env-stats count)
|
|
(cond (collect-statistics?
|
|
(set! *envs* (+ *envs* 1))
|
|
(set! *envs-slots* (+ *envs-slots* (+ count 1))))))
|
|
|
|
(define (add-copy-env-stats env reason)
|
|
(cond ((not collect-statistics?)
|
|
(unspecific))
|
|
((= reason (enum copy closure))
|
|
(set! *envs-closed* (+ *envs-closed* 1))
|
|
(set! *envs-closed-slots*
|
|
(+ *envs-closed-slots* (vm-vector-length env))))
|
|
((= reason (enum copy overflow))
|
|
(set! *envs-overflow* (+ *envs-overflow* 1))
|
|
(set! *envs-overflow-slots*
|
|
(+ *envs-overflow-slots* (vm-vector-length env))))
|
|
((= reason (enum copy preserve))
|
|
(set! *envs-preserved* (+ *envs-preserved* 1))
|
|
(set! *envs-preserved-slots*
|
|
(+ *envs-preserved-slots* (vm-vector-length env))))))
|
|
|
|
(define (add-preserve-cont-stats new reason)
|
|
(cond ((not collect-statistics?)
|
|
(unspecific))
|
|
((= reason (enum copy overflow))
|
|
(set! *conts-overflow* (+ *conts-overflow* 1))
|
|
(set! *conts-overflow-slots*
|
|
(+ *conts-overflow-slots*
|
|
(continuation-length new))))
|
|
((= reason (enum copy preserve))
|
|
(set! *conts-preserved* (+ *conts-preserved* 1))
|
|
(set! *conts-preserved-slots*
|
|
(+ *conts-preserved-slots*
|
|
(continuation-length new))))))
|
|
|
|
(define (add-copy-cont-from-heap-stats cont)
|
|
(cond (collect-statistics?
|
|
(set! *conts-from-heap* (+ *conts-from-heap* 1))
|
|
(set! *conts-from-heap-slots* (+ *conts-from-heap-slots*
|
|
(continuation-length cont))))))
|