forked from vygr/OSX-Forth
-
Notifications
You must be signed in to change notification settings - Fork 0
/
memory.f
190 lines (172 loc) · 2.72 KB
/
memory.f
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
\ dynamic memory allocation
list freelist
\ ( s mn lh -- 0 | mn )
: mem-search-cb
drop swap over
node-get-obj >
if
drop 0
then
;
\ ( mn -- )
: mem-insert
dup node-get-obj ['] mem-search-cb [ freelist ] literal list-enumerate-forwards
?dup
if
node-add-before
else
[ freelist ] literal list-add-at-tail
then
;
\ ( s mn -- mn )
: mem-slice
2dup node-get-obj swap -
dup [ node-structure ] literal <
if
drop nip
else
2dup over node-set-obj mem-insert
+ swap over node-set-obj
then
;
\ ( mn mn lh -- 0 | mn )
: mem-splice-left-cb
drop
over dup node-get-obj +
over =
if
dup node-remove
node-get-obj over node-get-obj +
over node-set-obj
else
2drop 0
then
;
\ ( mn mn lh -- 0 | mn )
: mem-splice-right-cb
drop swap
over dup node-get-obj +
over =
if
over node-remove
node-get-obj over node-get-obj +
over node-set-obj
else
2drop 0
then
;
\ ( mn -- )
: mem-free
dup ['] mem-splice-left-cb [ freelist ] literal list-enumerate-forwards
?dup
if
nip
then
dup ['] mem-splice-right-cb [ freelist ] literal list-enumerate-forwards
?dup
if
nip
then
mem-insert
;
\ ( s -- 0 | mn )
: mem-alloc
[ node-structure ] literal max aligned
dup ['] mem-search-cb [ freelist ] literal list-enumerate-forwards
dup
if
dup node-remove mem-slice
else
nip
then
;
\ ( bytes -- )
: mem-allot
align aligned here over allot dup -rot node-set-obj mem-free
;
node-structure begin-structure
field _nodes
field _total
field _max
end-structure mem-info-structure
\ ( mi mn lh -- 0 )
: mem-info-cb
drop swap >r
node-get-obj dup
r@ >field _total +!
r@ @field _max max r@ !field _max
1 r> >field _nodes +!
0
;
\ ( -- )
: mem-info
[ mem-info-structure ] literal mem-alloc ?dup
if
dup [ node-structure ] literal + [ mem-info-structure node-structure - ] literal erase
dup ['] mem-info-cb [ freelist ] literal list-enumerate-forwards drop
dup ." Total " @field _total .
dup ." Max block size " @field _max .
dup ." Num nodes " @field _nodes .
mem-free
else
." No free memory !"
then
cr
;
\ c style malloc, calloc, realloc and free
\ ( s -- 0 | addr )
: malloc
4+ mem-alloc
dup
if
dup dup node-get-obj swap ! 4+
then
;
\ ( s -- 0 | addr )
: calloc
malloc dup
if
dup dup 4- @ 4- erase
then
;
\ ( 0 | addr -- )
: free
?dup
if
4- dup @ over node-set-obj mem-free
then
;
\ ( 0 | addr, 0 | s -- 0 | addr )
: realloc
dup
if
over
if
dup malloc
dup
if
dup >r 2 pick >r
swap r@ 4- @ 4- min
cmove
r> free r>
else
nip nip
then
else
nip malloc
then
else
swap free
then
;
hide _nodes
hide _total
hide _max
hide mem-info-cb
hide mem-info-structure
hide mem-search-cb
hide mem-splice-left-cb
hide mem-splice-right-cb
hide mem-insert
hide mem-slice
hide freelist