Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: malloc.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | id: @(#)malloc.fth 2.10 03/09/09 | |
43 | purpose: | |
44 | copyright: Copyright 1990-2001, 2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | ||
46 | \ Forth dynamic storage managment. | |
47 | \ | |
48 | \ By Don Hopkins, University of Maryland | |
49 | \ Modified by Mitch Bradley, Bradley Forthware | |
50 | \ Public Domain | |
51 | \ | |
52 | \ First fit storage allocation of blocks of varying size. | |
53 | \ Blocks are prefixed with a usage flag and a length count. | |
54 | \ Free blocks are collapsed downwards during free-memory and while | |
55 | \ searching during allocate-memory. Based on the algorithm described | |
56 | \ in Knuth's _An_Introduction_To_Data_Structures_With_Applications_, | |
57 | \ sections 5-6.2 and 5-6.3, pp. 501-511. | |
58 | \ | |
59 | \ init-allocator ( -- ) | |
60 | \ Initializes the allocator, with no memory. Should be executed once, | |
61 | \ before any other allocation operations are attempted. | |
62 | \ | |
63 | \ add-memory ( adr len -- ) | |
64 | \ Adds a region of memory to the allocation pool. That memory will | |
65 | \ be available for subsequent use by allocate-memory. This may | |
66 | \ be executed any number of times. | |
67 | \ | |
68 | \ allocate-memory ( size -- adr false | error true ) | |
69 | \ Tries to allocate a chunk of memory at least size bytes long. | |
70 | \ Returns error code and true on failure, or the address of the | |
71 | \ first byte of usable data and false on success. | |
72 | \ | |
73 | \ free-memory ( adr -- ) | |
74 | \ Frees a chunk of memory allocated by malloc. adr should be an | |
75 | \ address returned by allocate-memory. Error if adr is not a | |
76 | \ valid address. | |
77 | \ | |
78 | \ memory-available ( -- size ) | |
79 | \ Returns the size in bytes of the largest contiguous chunk of memory | |
80 | \ that can be allocated by allocate-memory . | |
81 | ||
82 | headers | |
83 | vocabulary allocator | |
84 | also allocator also definitions | |
85 | headerless | |
86 | 8 constant #dalign \ Machine-dependent worst-case alignment boundary | |
87 | ||
88 | 2 base ! | |
89 | 1110000000000111 constant *dbuf-free* | |
90 | 1111010101011111 constant *dbuf-used* | |
91 | decimal | |
92 | ||
93 | \ : field \ name ( offset size -- offset' ) | |
94 | \ create over , + does> @ + | |
95 | \ ; | |
96 | ||
97 | struct | |
98 | /n field >dbuf-flag | |
99 | /n field >dbuf-size | |
100 | aligned | |
101 | 0 field >dbuf-data | |
102 | /n field >dbuf-suc | |
103 | /n field >dbuf-pred | |
104 | constant dbuf-min | |
105 | ||
106 | \ In a multitasking system, the memory allocator head node should | |
107 | \ be located in a global area, instead in the per-task user area. | |
108 | ||
109 | dbuf-min ualloc user dbuf-head | |
110 | ||
111 | : dbuf-data> ( adr -- 'dbuf ) 0 >dbuf-data - ; | |
112 | ||
113 | : dbuf-flag! ( flag 'dbuf -- ) >dbuf-flag ! ; | |
114 | : dbuf-flag@ ( 'dbuf -- flag ) >dbuf-flag @ ; | |
115 | : dbuf-size! ( size 'dbuf -- ) >dbuf-size ! ; | |
116 | : dbuf-size@ ( 'dbuf -- size ) >dbuf-size @ ; | |
117 | : dbuf-suc! ( suc 'dbuf -- ) >dbuf-suc ! ; | |
118 | : dbuf-suc@ ( 'dbuf -- 'dbuf ) >dbuf-suc @ ; | |
119 | : dbuf-pred! ( pred 'dbuf -- ) >dbuf-pred ! ; | |
120 | : dbuf-pred@ ( 'dbuf -- 'dbuf ) >dbuf-pred @ ; | |
121 | ||
122 | : next-dbuf ( 'dbuf -- 'next-dbuf ) dup dbuf-size@ + ; | |
123 | ||
124 | \ Insert new-node into doubly-linked list after old-node | |
125 | : insert-after ( new-node old-node -- ) | |
126 | >r r@ dbuf-suc@ over dbuf-suc! \ old's suc is now new's suc | |
127 | dup r@ dbuf-suc! \ new is now old's suc | |
128 | r> over dbuf-pred! \ old is now new's pred | |
129 | dup dbuf-suc@ dbuf-pred! \ new is now new's suc's pred | |
130 | ; | |
131 | ||
132 | : link-with-free ( 'dbuf -- ) | |
133 | ||
134 | \ Following code will look for possibility of this node getting | |
135 | \ merged with any of the other nodes. If it cannot be merged than | |
136 | \ create a new node and mark it as "free". The algorithm is to | |
137 | \ start with the "head" node and look for "next-dbuf" of the first | |
138 | \ node if it's free node and see if it matches with the start address | |
139 | \ of the current node. If it does, then just add this node's "size" to | |
140 | \ the node. If this can not be merged or the dbuf is not free then | |
141 | \ continue search with the next dbuf until we go through all the nodes. | |
142 | ||
143 | dbuf-head dbuf-suc@ ( 'dbuf head-suc ) | |
144 | begin ( 'dbuf dbuf-suc ) | |
145 | dup dbuf-head = if ( 'dbuf dbuf-suc ) | |
146 | drop ( 'dbuf ) | |
147 | *dbuf-free* over dbuf-flag! \ Set node status to "free" | |
148 | dbuf-head insert-after \ Insert in list after head node | |
149 | exit | |
150 | else ( 'dbuf dbuf-suc ) | |
151 | dup dbuf-flag@ *dbuf-free* = if ( 'dbuf dbuf-suc ) | |
152 | over >r ( 'dbuf dbuf-suc ) ( r: 'dbuf ) | |
153 | dup next-dbuf ( 'dbuf dbuf-suc next-dbuf ) ( r: 'dbuf ) | |
154 | rot ( dbuf-suc next-dbuf 'dbuf ) ( r: 'dbuf ) | |
155 | = if ( dbuf-suc ) ( r: 'debuf ) | |
156 | r> dbuf-size@ ( dbuf-suc dbuf-size ) | |
157 | over dbuf-size@ + ( dbuf-suc dbuf-new-size ) | |
158 | swap dbuf-size! ( ) \ Found node to link, just add the size | |
159 | true ( true ) | |
160 | else ( dbuf-suc ) ( r: 'dbuf ) | |
161 | dbuf-suc@ r> ( dbuf-suc 'dbuf ) | |
162 | swap false ( 'dbuf dbuf-suc false ) | |
163 | then | |
164 | else ( 'dbuf dbuf-suc ) | |
165 | dbuf-suc@ ( 'dbuf dbuf-suc ) | |
166 | false ( 'dbuf dbuf-suc false ) | |
167 | then | |
168 | then | |
169 | until | |
170 | ; | |
171 | ||
172 | \ Remove node from doubly-linked list | |
173 | ||
174 | : remove-node ( node -- ) | |
175 | dup dbuf-pred@ over dbuf-suc@ dbuf-pred! | |
176 | dup dbuf-suc@ swap dbuf-pred@ dbuf-suc! | |
177 | ; | |
178 | ||
179 | \ Collapse the next node into the current node | |
180 | ||
181 | : merge-with-next ( 'dbuf -- ) | |
182 | dup next-dbuf dup remove-node ( 'dbuf >next-dbuf ) \ Off of free list | |
183 | ||
184 | over dbuf-size@ swap dbuf-size@ + rot dbuf-size! \ Increase size | |
185 | ; | |
186 | ||
187 | \ 'dbuf is a free node. Merge all free nodes immediately following | |
188 | \ into the node. | |
189 | ||
190 | : merge-down ( 'dbuf -- 'dbuf ) | |
191 | begin | |
192 | dup next-dbuf dbuf-flag@ *dbuf-free* = | |
193 | while | |
194 | dup merge-with-next | |
195 | repeat | |
196 | ; | |
197 | ||
198 | : .node ( 'dbuf -- ) | |
199 | base @ swap hex | |
200 | dup 8 u.r 3 spaces | |
201 | dup dbuf-flag@ 5 u.r | |
202 | dup dbuf-size@ 9 u.r | |
203 | dup dbuf-suc@ 9 u.r | |
204 | dbuf-pred@ 9 u.r | |
205 | cr | |
206 | base ! | |
207 | ; | |
208 | ||
209 | headers | |
210 | : .list ( -- ) | |
211 | dbuf-head | |
212 | begin dbuf-suc@ dup dbuf-head <> while dup .node repeat | |
213 | drop | |
214 | ; | |
215 | headerless | |
216 | forth definitions | |
217 | ||
218 | : msize ( adr -- count ) dbuf-data> dbuf-size@ dbuf-data> ; | |
219 | ||
220 | : free-memory ( adr -- ) | |
221 | dbuf-data> ( 'dbuf ) | |
222 | dup dbuf-flag@ *dbuf-used* - if | |
223 | \ This is here because the the allocator has completely given up | |
224 | \ and rather than corrupt state we just deliberately puke. | |
225 | \ the old 'abort' was insufficient because it was being caught and the | |
226 | \ error code mis-interpreted; so instead we force a hard fault that we | |
227 | \ can back trace. | |
228 | ??cr ." FATAL: free-memory: bad address." cr -1 @ | |
229 | then | |
230 | merge-down link-with-free | |
231 | ; | |
232 | ||
233 | : add-memory ( adr len -- ) | |
234 | \ Align the starting address to a "worst-case" boundary. This helps | |
235 | \ guarantee that allocated data areas will be on a "worst-case" | |
236 | \ alignment boundary. | |
237 | ||
238 | swap dup #dalign round-up ( len adr adr' ) | |
239 | dup rot - ( len adr' diff ) | |
240 | rot swap - ( adr' len' ) | |
241 | #dalign round-down ( adr' len'' ) | |
242 | ||
243 | \ Set size and flags fields for first piece | |
244 | ||
245 | \ Subtract off the size of one node header, because we carve out | |
246 | \ a node header from the end of the piece to use as a "stopper". | |
247 | \ That "stopper" is marked "used", and prevents merge-down from | |
248 | \ trying to merge past the end of the piece. | |
249 | ||
250 | dbuf-data> ( 'dbuf-first #dbuf-first ) | |
251 | ||
252 | \ Ensure that the piece is big enough to be useable. | |
253 | \ A piece of size dbuf-min (after having subtracted off the "stopper" | |
254 | \ header) is barely useable, because the space used by the free list | |
255 | \ links can be used as the data space. | |
256 | ||
257 | dup dbuf-min < abort" add-memory: piece too small" | |
258 | ||
259 | \ Set the size and flag for the new free piece | |
260 | ||
261 | *dbuf-free* 2 pick dbuf-flag! ( 'dbuf-first #dbuf-first ) | |
262 | 2dup swap dbuf-size! ( 'dbuf-first #dbuf-first ) | |
263 | ||
264 | \ Create the "stopper" header | |
265 | ||
266 | \ XXX The stopper piece should be linked into a piece list, | |
267 | \ and the flags should be set to a different value. The size | |
268 | \ field should indicate the total size for this piece. | |
269 | \ The piece list should be consulted when adding memory, and | |
270 | \ if there is a piece immediately following the new piece, they | |
271 | \ should be merged. | |
272 | ||
273 | over + ( 'dbuf-first 'dbuf-limit ) | |
274 | *dbuf-used* swap dbuf-flag! ( 'dbuf-first ) | |
275 | ||
276 | link-with-free | |
277 | ; | |
278 | ||
279 | : (allocate-memory) ( size -- adr false | error-code true ) | |
280 | \ Keep pieces aligned on "worst-case" hardware boundaries | |
281 | #dalign round-up ( size' ) | |
282 | ||
283 | >dbuf-data dbuf-min max ( size ) | |
284 | ||
285 | \ Search for a sufficiently-large free piece | |
286 | dbuf-head ( size 'dbuf ) | |
287 | begin ( size 'dbuf ) | |
288 | dbuf-suc@ ( size 'dbuf ) | |
289 | dup dbuf-head = if \ Bail out if we've already been around | |
290 | 2drop 1 true exit ( error-code true ) | |
291 | then ( size 'dbuf-suc ) | |
292 | merge-down ( size 'dbuf ) | |
293 | dup dbuf-size@ ( size 'dbuf dbuf-size ) | |
294 | 2 pick >= ( size 'dbuf big-enough? ) | |
295 | until ( size 'dbuf ) | |
296 | ||
297 | dup dbuf-size@ 2 pick - ( size 'dbuf left-over ) | |
298 | dup dbuf-min <= if \ Too small to fragment? | |
299 | ||
300 | \ The piece is too small to split, so we just remove the whole | |
301 | \ thing from the free list. | |
302 | ||
303 | drop nip ( 'dbuf ) | |
304 | dup remove-node ( 'dbuf ) | |
305 | else ( size 'dbuf left-over ) | |
306 | ||
307 | \ The piece is big enough to split up, so we make the free piece | |
308 | \ smaller and take the stuff after it as the allocated piece. | |
309 | ||
310 | 2dup swap dbuf-size! ( size 'dbuf left-over) \ Set frag size | |
311 | + ( size 'dbuf' ) | |
312 | tuck dbuf-size! ( 'dbuf' ) | |
313 | then | |
314 | *dbuf-used* over dbuf-flag! \ Mark as used | |
315 | >dbuf-data false ( adr false ) | |
316 | ; | |
317 | ||
318 | : memory-available ( -- size ) | |
319 | 0 >dbuf-data ( current-largest-size ) | |
320 | ||
321 | dbuf-head ( size 'dbuf ) | |
322 | begin ( size 'dbuf ) | |
323 | dbuf-suc@ dup dbuf-head <> ( size 'dbuf more? ) | |
324 | while \ Go once around the free list | |
325 | merge-down ( size 'dbuf ) | |
326 | dup dbuf-size@ ( size 'dbuf dbuf-size ) | |
327 | rot max swap ( size' 'dbuf ) | |
328 | repeat | |
329 | drop dbuf-data> ( largest-data-size ) | |
330 | ; | |
331 | ||
332 | \ Head node has 0 size, is not free, and is initially linked to itself | |
333 | ||
334 | : init-allocator ( -- ) | |
335 | *dbuf-used* dbuf-head dbuf-flag! | |
336 | 0 dbuf-head dbuf-size! \ Must be 0 so the allocator won't find it. | |
337 | dbuf-head dup dbuf-suc! \ Link to self | |
338 | dbuf-head dup dbuf-pred! | |
339 | ; | |
340 | ||
341 | previous previous definitions | |
342 | ||
343 | \ Tries to allocate, and if that fails, requests more memory from the system | |
344 | ||
345 | also allocator also | |
346 | ||
347 | defer more-memory ( request-size -- adr actual-size false | error-code true ) | |
348 | ||
349 | : allocate-memory ( size -- adr false | error-code true ) | |
350 | dup (allocate-memory) if ( size error-code ) | |
351 | \ No more memory in the heap; try to get some more from the system | |
352 | drop ( size ) | |
353 | \ use same alignment requirements and add space | |
354 | \ for header and stopper header as in (allocate-memory) | |
355 | dup #dalign round-up ( size size' ) | |
356 | >dbuf-data >dbuf-data ( size size' ) | |
357 | more-memory if ( size error-code ) | |
358 | nip true ( error-code true ) | |
359 | else ( size adr actual ) | |
360 | add-memory ( size ) | |
361 | (allocate-memory) ( adr false | error-code true ) | |
362 | then ( adr false | error-code true ) | |
363 | else ( size adr ) | |
364 | nip false ( adr false ) | |
365 | then ( adr false | error-code true ) | |
366 | ; | |
367 | previous previous | |
368 | ||
369 | : heap-alloc-mem ( bytes -- adr ) | |
370 | allocate-memory abort" Out of memory" | |
371 | ; | |
372 | ||
373 | : heap-free-mem ( adr size -- ) drop free-memory ; | |
374 | ||
375 | init-allocator | |
376 | ||
377 | headers | |
378 | h# 10.0000 constant 1meg |