1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, David Frese, Mike Sperber
; Code shared by both GCs for the GC package.
; We can't put it in a separate package because of circular
; dependencies.
; Tracing continuations
(define (trace-continuation contents-pointer size)
(let* ((code (continuation-code contents-pointer))
(pc (continuation-pc contents-pointer))
(code-pointer (address+ (address-after-header code)
(extract-fixnum pc)))
(mask-size (fetch-byte (address+ code-pointer gc-mask-size-offset))))
(if (= mask-size 0)
(s48-trace-locations! contents-pointer
(address+ contents-pointer size))
(let ((data-pointer (address+ contents-pointer
continuation-registers-size)))
(s48-trace-locations! contents-pointer data-pointer)
(s48-trace-continuation-contents! data-pointer
code-pointer
mask-size))))
(unspecific))
; The extra values added when a continuation is moved to the heap are not
; included in the continuation's mask.
(define continuation-registers-size
(cells->a-units continuation-cells))
; Exported for use by the stack code.
(define (s48-trace-continuation-contents! contents-pointer
code-pointer
mask-size)
(let ((mask-pointer (address+ code-pointer (+ gc-mask-offset 1))))
(let byte-loop ((mask-ptr (address- mask-pointer mask-size))
(trace-ptr contents-pointer))
(if (not (address= mask-ptr mask-pointer))
(let bit-loop ((mask (fetch-byte mask-ptr)) (ptr trace-ptr))
(if (= mask 0)
(byte-loop (address+ mask-ptr 1)
(address+ trace-ptr (cells->a-units 8)))
(begin
(if (odd? mask)
;; can't use s48-trace-value here:
;; `s48-trace-locations!' triggers the write barrier
(s48-trace-locations! ptr (address1+ ptr)))
(bit-loop (arithmetic-shift-right mask 1)
(address1+ ptr)))))
(unspecific)))))
(define (odd? x)
(= (bitwise-and x 1)
1))
(define (continuation-code contents-pointer)
(fetch (address+ contents-pointer
(cells->a-units continuation-code-index))))
(define (continuation-pc contents-pointer)
(fetch (address+ contents-pointer
(cells->a-units continuation-pc-index))))
(define (continuation-header? x)
(= (header-type x)
(enum stob continuation)))
|
