1 \ *****************************************************************************
2 \ * Copyright (c) 2004, 2011 IBM Corporation
3 \ * All rights reserved.
4 \ * This program and the accompanying materials
5 \ * are made available under the terms of the BSD License
6 \ * which accompanies this distribution, and is available at
7 \ * http://www.opensource.org/licenses/bsd-license.php
10 \ * IBM Corporation - initial implementation
11 \ ****************************************************************************/
13 \ \\\\\\\\\\\\\\ Constants
14 500 CONSTANT AVAILABLE-SIZE
15 4000 CONSTANT MIN-RAM-RESERVE \ prevent from using first pages
17 : MIN-RAM-SIZE \ Initially available memory size
21 20000000 \ assumed minimal memory size
24 MIN-RAM-SIZE CONSTANT MIN-RAM-SIZE
26 \ \\\\\\\\\\\\\\ Structures
28 \ The available element size depends strictly on the address/size
29 \ value formats and will be different for various device types
32 cell field available>address
33 cell field available>size
37 \ \\\\\\\\\\\\\\ Global Data
38 CREATE available AVAILABLE-SIZE /available * allot available AVAILABLE-SIZE /available * erase
39 VARIABLE mem-pre-released 0 mem-pre-released !
41 \ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
42 : available>size@ available>size @ ;
43 : available>address@ available>address @ ;
44 : available>size! available>size ! ;
45 : available>address! available>address ! ;
47 : available! ( addr size available-ptr -- )
48 dup -rot available>size! available>address!
51 : available@ ( available-ptr -- addr size )
52 dup available>address@ swap available>size@
56 \ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
58 \ Warning: They are not yet really independent from available formatting
62 \ Find position in the "available" where given range exists or can be inserted,
63 \ return pointer and logical found/notfound value
64 \ If error, return NULL pointer in addition to notfound code
66 : (?available-segment<) ( start1 end1 start2 end2 -- true/false ) drop < nip ;
68 : (?available-segment>) ( start1 end1 start2 end2 -- true/false ) -rot 2drop > ;
70 \ start1 to end1 is the area that should be claimed
71 \ start2 to end2 is the available segment
72 \ return true if it can not be claimed, false if it can be claimed
73 : (?available-segment-#) ( start1 end1 start2 end2 -- true/false )
74 2dup 5 roll -rot ( e1 s2 e2 s1 s2 e2 )
75 between >r between r> and not
78 : (find-available) ( addr addr+size-1 a-ptr a-size -- a-ptr' found )
79 ?dup 0= IF -rot 2drop false EXIT THEN \ Not Found
81 2dup 2/ dup >r /available * +
82 ( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' )
83 dup available>size@ 0= IF 2drop r> RECURSE EXIT THEN
85 ( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' )
87 ( addr addr+size-1 a-ptr a-size addr' size' R: a-size' a-ptr' )
89 ( a-ptr a-size addr addr+size-1 )
90 ( R: a-size' a-ptr' addr' addr'+size'-1 )
92 2dup 2r@ (?available-segment>) IF
94 /available + -rot r> - 1- nip RECURSE EXIT \ Look Right
96 2dup 2r@ (?available-segment<) IF
98 2drop r> RECURSE EXIT \ Look Left
100 2dup 2r@ (?available-segment-#) IF \ Conflict - segments overlap
101 2r> 2r> 3drop 3drop 2drop
104 2r> 3drop 3drop r> r> drop ( a-ptr' -- )
105 dup available>size@ 0<> ( a-ptr' found -- )
108 : (find-available) ( addr size -- seg-ptr found )
109 over + 1- available AVAILABLE-SIZE ['] (find-available) catch IF
115 : dump-available ( available-ptr -- )
117 dup available - /available / AVAILABLE-SIZE swap - 0 ?DO
118 dup available@ ?dup 0= IF
127 : .available available dump-available ;
134 \ (drop-available) just blindly compresses space of available map
136 : (drop-available) ( available-ptr -- )
137 dup available - /available / \ current element index
138 AVAILABLE-SIZE swap - \ # of remaining elements
140 ( first nelements ) 1- 0 ?DO
141 dup /available + dup available@
143 ( current next next>address next>size ) ?dup 0= IF
144 2drop LEAVE \ NULL element - goto last copy
146 3 roll available! ( next )
149 \ Last element : just zero it out
154 \ (stick-to-previous-available) merge the segment on stack
155 \ with the previous one, if possible, and modified segment parameters if merged
156 \ Return success code
158 : (stick-to-previous-available) ( addr size available-ptr -- naddr nsize nptr success )
160 false EXIT \ This was the first available segment
163 dup /available - dup available@
165 nip \ Drop available-ptr since we are going to previous one
166 rot drop \ Drop start addr, we take the previous one
168 dup available@ 3 roll + rot true
169 ( prev-addr prev-size+size prev-ptr true )
172 ( addr size available-ptr false )
177 \ (insert-available) just blindly makes space for another element on given
180 \ insert-available should also check adjacent elements and merge if new
181 \ region is contiguos w. others
183 : (insert-available) ( available-ptr -- available-ptr )
184 dup \ current element
185 dup available - /available / \ current element index
186 AVAILABLE-SIZE swap - \ # of remaining elements
188 dup 0<= 3 pick available>size@ 0= or IF
189 \ End of "available" or came to an empty element - Exit
195 ( first first/=current/ first>address first>size nelements ) 1- 0 ?DO
197 ( first current R: current>address current>size )
199 /available + dup available@
200 ( first current+1/=next/ next>address next>size )
201 ( R: current>address current>size )
203 2r> 4 pick available! dup 0= IF
204 \ NULL element - last copy
205 rot /available + available!
210 ( first next/=last/ last[0]>address last[0]>size ) ?dup 0<> IF
211 cr ." release error: available map overflow"
212 cr ." Dumping available property"
214 cr ." No space for one before last entry:" cr swap . .
215 cr ." Dying ..." cr 123 throw
221 : insert-available ( addr size available-ptr -- addr size available-ptr )
222 dup available>address@ 0<> IF
224 dup available>address@ rot dup -rot -
226 ( addr available-ptr size available>address@-size )
228 3 pick = IF \ if (available>address@ - size == addr)
229 \ Merge w. next segment - no insert needed
231 over available>size@ + swap
232 ( addr size+available>size@ available-ptr )
234 (stick-to-previous-available) IF
235 \ Merged w. prev & next one : discard extra seg
236 dup /available + (drop-available)
239 \ shift the rest of "available" to make space
241 swap (stick-to-previous-available)
242 not IF (insert-available) THEN
245 (stick-to-previous-available) drop
254 : drop-available ( addr size available-ptr -- addr )
256 ( req_addr req_size segment_addr segment_size R: available-ptr )
258 over 4 pick swap - ?dup 0<> IF
259 \ Segment starts before requested address : free the head space
260 dup 3 roll swap r> available! -
262 ( req_addr req_size segment_size-segment_addr+req_addr )
264 \ That's it - remainder of segment is what we claim
267 \ Both head and tail of segment remain unclaimed :
268 \ need an extra available element
269 swap 2 pick + swap release
272 nip ( req_addr req_size segment_size )
274 \ Exact match : drop the whole available segment
275 drop r> (drop-available)
277 \ We claimed the head, need to leave the tail available
278 -rot over + rot r> available!
284 : pwr2roundup ( value -- pwr2value )
289 dup 1 DO drop i dup +LOOP
293 : (claim-best-fit) ( len align -- len base )
295 ( len align-1 best-fit-residue/=-1/ best-fit-base/=-1/ )
297 available AVAILABLE-SIZE /available * + available DO
298 i \ Must be saved now, before we use Return stack
301 ( len i R: best-fit-base best-fit-residue align-1 )
303 available@ ?dup 0= IF drop r> r> r> LEAVE THEN \ EOL
306 2drop \ Can't Fit: Too Small
308 dup 2 pick r@ and - 0< IF
309 2drop \ Can't Fit When Aligned
311 ( len i>address i>size-len )
312 ( R: best-fit-base best-fit-residue align-1 )
314 \ Best Fit so far: drop the old one
317 ( len align-1 nu-base nu-residue R: )
318 \ Now align new base and push to R:
319 swap 2 pick + 2 pick invert and >r >r >r
328 -rot 2drop ( len best-fit-base/or -1 if none found/ )
331 : (adjust-release0) ( 0 size -- addr' size' )
332 \ segment 0 already pre-relased in early phase: adjust
333 2dup MIN-RAM-SIZE dup 3 roll + -rot -
335 2swap 2drop 0 mem-pre-released !
340 \ \\\\\\\\\\\\\\ Exported Interface:
342 \ IEEE 1275 implementation:
344 \ Claim the region with given start address and size (if align parameter is 0);
345 \ alternatively claim any region of given alignment
347 \ Throw an exception if failed
349 : claim ( [ addr ] len align -- base )
351 (claim-best-fit) dup -1 = IF
352 2drop cr ." claim error : aligned allocation failed" cr
353 ." available:" cr .available
359 2dup (find-available) not IF
361 \ cr ." claim error : requested " . ." bytes of memory at " .
362 \ ." not available" cr
363 \ ." available:" cr .available
367 ( req_addr req_size available-ptr ) drop-available
374 \ IEEE 1275 implementation:
376 \ Free the region with given start address and size
378 : .release ( addr len -- )
379 over 0= mem-pre-released @ and IF (adjust-release0) THEN
381 2dup (find-available) IF
383 cr ." release error: region " . ." , " . ." already released" cr
387 cr ." release error: Bad/conflicting region " . ." , " .
388 ." or available list full " cr
390 ( addr size available-ptr ) insert-available
392 \ NOTE: insert did not change the stack layout
393 \ but it may have changed any of the three values
394 \ in order to implement merge of free regions
395 \ We do not interpret these values any more
396 \ just blindly copy it in
398 ( addr size available-ptr ) available!
403 ' .release to release
406 \ pre-release minimal memory size
407 0 MIN-RAM-SIZE release 1 mem-pre-released !
409 \ claim first pages used for PPC exception vectors
410 0 MIN-RAM-RESERVE 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop
412 \ claim region used by firmware (assume 31 MiB size right now)
413 paflof-start ffff not and 1f00000 0 ' claim CATCH IF
414 ." claim failed!" cr 2drop