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
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
\ tag: forth memory allocation
\
\ Copyright (C) 2002-2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ 7.3.3.2 memory allocation
\ these need to be initialized by the forth kernel by now.
variable start-mem 0 start-mem ! \ start of memory
variable end-mem 0 end-mem ! \ end of memory
variable free-list 0 free-list ! \ free list head
\ initialize necessary variables and write a valid
\ free-list entry containing all of the memory.
\ start-mem: pointer to start of memory.
\ end-mem: pointer to end of memory.
\ free-list: head of linked free list
: init-mem ( start-addr size )
over dup
start-mem ! \ write start-mem
free-list ! \ write first freelist entry
2dup /n - swap ! \ write 'len' entry
over cell+ 0 swap ! \ write 'next' entry
+ end-mem ! \ write end-mem
;
\ --------------------------------------------------------------------
\ return pointer to smallest free block that contains
\ at least nb bytes and the block previous the the
\ actual block. On failure the pointer to the smallest
\ free block is 0.
: smallest-free-block ( nb -- prev ptr | 0 0 )
0 free-list @
fffffff 0 0 >r >r >r
begin
dup
while
( nb prev pp R: best_nb best_pp )
dup @ 3 pick r@ within if
( nb prev pp )
r> r> r> 3drop \ drop old smallest
2dup >r >r dup @ >r \ new smallest
then
nip dup \ prev = pp
cell + @ \ pp = pp->next
repeat
3drop r> drop r> r>
;
\ --------------------------------------------------------------------
\ allocate size bytes of memory
\ return pointer to memory (or throws an exception on failure).
: alloc-mem ( size -- addr )
\ make it legal (and fast) to allocate 0 bytes
dup 0= if exit then
aligned \ keep memory aligned.
dup smallest-free-block \ look up smallest free block.
dup 0= if
\ 2drop
-15 throw \ out of memory
then
( al-size prev addr )
\ If the smallest fitting block found is bigger than
\ the size of the requested block plus 2*cellsize we
\ can split the block in 2 parts. otherwise return a
\ slightly bigger block than requested.
dup @ ( d->len ) 3 pick cell+ cell+ > if
\ splitting the block in 2 pieces.
\ new block = old block + len field + size of requested mem
dup 3 pick cell+ + ( al-size prev addr nd )
\ new block len = old block len - req. mem size - 1 cell
over @ ( al-size prev addr nd addr->len )
4 pick ( ... al-size )
cell+ - ( al-size prev addr nd nd nd->len )
over ! ( al-size prev addr nd )
over cell+ @ ( al-size prev addr nd addr->next )
\ write addr->next to nd->next
over cell+ ! ( al-size prev addr nd )
over 4 pick swap !
else
\ don't split the block, it's too small.
dup cell+ @
then
( al-size prev addr nd )
\ If the free block we got is the first one rewrite free-list
\ pointer instead of the previous entry's next field.
rot dup 0= if drop free-list else cell+ then
( al-size addr nd prev->next|fl )
!
nip cell+ \ remove al-size and skip len field of returned pointer
;
\ --------------------------------------------------------------------
\ free block given by addr. The length of the
\ given block is stored at addr - cellsize.
\
\ merge with blocks to the left and right
\ immediately, if they are free.
: free-mem ( addr len -- )
\ we define that it is legal to free 0-byte areas
0= if drop exit then
( addr )
\ check if the address to free is somewhere within
\ our available memory. This fails badly on discontigmem
\ architectures. If we need more RAM than fits on one
\ contiguous memory area we are too bloated anyways. ;)
dup start-mem @ end-mem @ within 0= if
\ ." free-mem: no such memory: 0x" u. cr
exit
then
/n - \ get real block address
0 free-list @ ( addr prev l )
begin \ now scan the free list
dup 0<> if \ only check len, if block ptr != 0
dup dup @ cell+ + 3 pick <
else
false
then
while
nip dup \ prev=l
cell+ @ \ l=l->next
repeat
( addr prev l )
dup 0<> if \ do we have free memory to merge with?
dup dup @ cell+ + 3 pick = if \ hole hit. adding bytes.
\ freeaddr = end of current block -> merge
( addr prev l )
rot @ cell+ ( prev l f->len+cellsize )
over @ + \ add l->len
over ! ( prev l )
swap over cell+ @ \ f = l; l = l->next;
\ The free list is sorted by addresses. When merging at the
\ start of our block we might also want to merge at the end
\ of it. Therefore we fall through to the next border check
\ instead of returning.
true \ fallthrough value
else
false \ no fallthrough
then
>r \ store fallthrough on ret stack
( addr prev l )
dup 3 pick dup @ cell+ + = if \ hole hit. real merging.
\ current block starts where block to free ends.
\ end of free block addr = current block -> merge and exit
( addr prev l )
2 pick dup @ ( f f->len )
2 pick @ cell+ + ( f newlen )
swap ! ( addr prev l )
3dup drop
0= if
free-list
else
2 pick cell+
then ( value prev->next|free-list )
! ( addr prev l )
cell+ @ rot ( prev l->next addr )
cell+ ! drop
r> drop exit \ clean up return stack
then
r> if 3drop exit then \ fallthrough? -> exit
then
\ loose block - hang it before current.
( addr prev l )
\ hang block to free in front of the current entry.
dup 3 pick cell+ ! \ f->next = l;
free-list @ = if \ is block to free new list head?
over free-list !
then
( addr prev )
dup 0<> if \ if (prev) prev->next=f
cell+ !
else
2drop \ no fixup needed. clean up.
then
;
|
