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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: David Frese, Mike Sperber
; Variables shared by various parts of the BIBOP code
(define *max-heap-size* 0)
(define (s48-max-heap-size)
*max-heap-size*)
(define (s48-set-max-heap-size! size)
(set! *max-heap-size* size))
(define *min-heap-size* 0)
(define (s48-min-heap-size)
*min-heap-size*)
; addresses of the new allocated heap areas
; <= s48_initialize_heap()
(define *new-small-start-addr* null-address)
(define *new-large-start-addr* null-address)
(define *new-weaks-start-addr* null-address)
(define (s48-get-new-small-start-addr) *new-small-start-addr*)
(define (s48-get-new-large-start-addr) *new-large-start-addr*)
(define (s48-get-new-weaks-start-addr) *new-weaks-start-addr*)
(define (s48-set-new-small-start-addr! addr)
(set! *new-small-start-addr* addr))
(define (s48-set-new-large-start-addr! addr)
(set! *new-large-start-addr* addr))
(define (s48-set-new-weaks-start-addr! addr)
(set! *new-weaks-start-addr* addr))
;; ** Availability ***************************************************
(define (s48-available? cells)
(>= (s48-available) cells))
(define (bytes-available? bytes)
(>= (s48-available) (bytes->cells bytes)))
;; ** Initialization *************************************************
; the bibop-gc doesn't look at these areas at all yet... TODO?!
;; (initial values for the type-checker)
(define *pure-areas*)
(define *impure-areas*)
(define *pure-sizes*)
(define *impure-sizes*)
(define *pure-area-count* 0)
(define *impure-area-count* 0)
(define (s48-initialize-heap max-heap-size image-start-address image-size)
(address= image-start-address null-address) ; for the type checker
(= image-size 0) ; for the type checker
(set! *max-heap-size* max-heap-size)
(set! *min-heap-size* (* 4 image-size))
(s48-initialize-bibop-heap)
;; just some silly things for the type-checker...
(set! *pure-areas* (make-vector 0 (integer->address 0)))
(set! *impure-areas* *pure-areas*)
(set! *pure-sizes* (make-vector 0 0))
(set! *impure-sizes* *pure-sizes*))
;----------------
; Keeping track of all the areas.
(define (s48-register-static-areas pure-count pure-areas pure-sizes
impure-count impure-areas impure-sizes)
(set! *pure-area-count* pure-count)
(set! *pure-areas* pure-areas)
(set! *pure-sizes* pure-sizes)
(set! *impure-area-count* impure-count)
(set! *impure-areas* impure-areas)
(set! *impure-sizes* impure-sizes))
(define (walk-areas proc areas sizes count)
(let loop ((i 0))
(cond ((>= i count)
#t)
((proc (vector-ref areas i)
(address+ (vector-ref areas i)
(vector-ref sizes i)))
(loop (+ i 1)))
(else
#f))))
(define (walk-pure-areas proc)
(if (< 0 *pure-area-count*)
(walk-areas proc *pure-areas* *pure-sizes* *pure-area-count*)
#t))
(define (walk-impure-areas proc)
(if (< 0 *impure-area-count*)
(walk-areas proc *impure-areas* *impure-sizes* *impure-area-count*)
#t))
|
