92 lines
2.7 KiB
Scheme
92 lines
2.7 KiB
Scheme
|
|
(define *env* (unassigned))
|
|
|
|
(define (current-env) *env*)
|
|
(define (set-current-env! env) (set! *env* env))
|
|
|
|
; Access to environment slots
|
|
|
|
(define env-ref vm-vector-ref)
|
|
(define env-set! vm-vector-set!)
|
|
(define (env-parent env) (env-ref env 0))
|
|
(define (set-env-parent! env x) (env-set! env 0 x))
|
|
|
|
(define (env-back env back) ;Resembles NTHCDR
|
|
(do ((env env (env-parent env))
|
|
(i back (- i 1)))
|
|
((= i 0) env)))
|
|
|
|
; Making new environments
|
|
|
|
; How much heap space we will need.
|
|
(define (stack-env-space count)
|
|
(+ 2 count))
|
|
|
|
(define (pop-args-into-env count key)
|
|
(check-stack-cons (stack-env-space count) key)
|
|
(push *env*)
|
|
(push (make-header (enum stob vector) (cells->bytes (+ count 1))))
|
|
(add-env-stats count)
|
|
(set! *env* (address->stob-descriptor (addr1+ (addr1+ *stack*)))))
|
|
|
|
; Alternative method for making environments - put the values into the heap.
|
|
|
|
(define (heap-env-space count)
|
|
(+ count 2)) ; header + superior environment
|
|
|
|
(define (pop-args-into-heap-env count key)
|
|
(let ((stob (make-d-vector (enum stob vector) (+ count 1) key)))
|
|
(copy-cells! (addr1+ *stack*)
|
|
(addr+ (cells->a-units 1)
|
|
(address-after-header stob))
|
|
count)
|
|
(stack-add (- 0 count))
|
|
(vm-vector-set! stob 0 *env*)
|
|
(set! *env* stob)))
|
|
|
|
; Migrate the current environment to the heap. Used when creating a closure.
|
|
; CURRENT-ENV-SIZE size is conservative.
|
|
|
|
(define (current-env-size)
|
|
(if (within-stack? *env*)
|
|
(stack-size)
|
|
0))
|
|
|
|
; This is what the interpreter calls when it needs to put the current
|
|
; environment in a closure.
|
|
|
|
(define (preserve-current-env key)
|
|
(preserve-current-env-with-reason key (enum copy closure)))
|
|
|
|
(define (preserve-current-env-with-reason key reason)
|
|
(if (within-stack? *env*)
|
|
(set! *env* (save-env-in-heap *env* *cont* key reason)))
|
|
*env*)
|
|
|
|
; 1) Copy ENV and its ancestors into heap, adding forwarding pointers
|
|
; 2) Go down the continuation chain updating the env pointers
|
|
;
|
|
; This code depends on continuation-cont pointers not crossing environment
|
|
; parent pointers on the stack.
|
|
|
|
(define (save-env-in-heap env cont key reason)
|
|
(let ((top (copy-env env key reason)))
|
|
(let loop ((env top))
|
|
(cond ((within-stack? (env-parent env))
|
|
(let ((new (copy-env (env-parent env) key reason)))
|
|
(set-env-parent! env new)
|
|
(loop new)))))
|
|
(let loop ((cont cont))
|
|
(let ((env (continuation-env cont)))
|
|
(cond ((and (stob? env)
|
|
(stob? (stob-header env)))
|
|
(set-continuation-env! cont (stob-header env))
|
|
(loop (continuation-cont cont))))))
|
|
top))
|
|
|
|
(define (copy-env env key reason)
|
|
(let ((new (copy-stob env key)))
|
|
(add-copy-env-stats env reason)
|
|
(stob-header-set! env new)
|
|
new))
|