415 lines
11 KiB
Forth
415 lines
11 KiB
Forth
\ *****************************************************************************
|
|
\ * Copyright (c) 2004, 2011 IBM Corporation
|
|
\ * All rights reserved.
|
|
\ * This program and the accompanying materials
|
|
\ * are made available under the terms of the BSD License
|
|
\ * which accompanies this distribution, and is available at
|
|
\ * http://www.opensource.org/licenses/bsd-license.php
|
|
\ *
|
|
\ * Contributors:
|
|
\ * IBM Corporation - initial implementation
|
|
\ ****************************************************************************/
|
|
|
|
\ \\\\\\\\\\\\\\ Constants
|
|
500 CONSTANT AVAILABLE-SIZE
|
|
4000 CONSTANT MIN-RAM-RESERVE \ prevent from using first pages
|
|
|
|
: MIN-RAM-SIZE \ Initially available memory size
|
|
epapr-ima-size IF
|
|
epapr-ima-size
|
|
ELSE
|
|
20000000 \ assumed minimal memory size
|
|
THEN
|
|
;
|
|
MIN-RAM-SIZE CONSTANT MIN-RAM-SIZE
|
|
|
|
\ \\\\\\\\\\\\\\ Structures
|
|
\ +
|
|
\ The available element size depends strictly on the address/size
|
|
\ value formats and will be different for various device types
|
|
\ +
|
|
STRUCT
|
|
cell field available>address
|
|
cell field available>size
|
|
CONSTANT /available
|
|
|
|
|
|
\ \\\\\\\\\\\\\\ Global Data
|
|
CREATE available AVAILABLE-SIZE /available * allot available AVAILABLE-SIZE /available * erase
|
|
VARIABLE mem-pre-released 0 mem-pre-released !
|
|
|
|
\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
|
|
: available>size@ available>size @ ;
|
|
: available>address@ available>address @ ;
|
|
: available>size! available>size ! ;
|
|
: available>address! available>address ! ;
|
|
|
|
: available! ( addr size available-ptr -- )
|
|
dup -rot available>size! available>address!
|
|
;
|
|
|
|
: available@ ( available-ptr -- addr size )
|
|
dup available>address@ swap available>size@
|
|
;
|
|
|
|
|
|
\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
|
|
\ +
|
|
\ Warning: They are not yet really independent from available formatting
|
|
\ +
|
|
|
|
\ +
|
|
\ Find position in the "available" where given range exists or can be inserted,
|
|
\ return pointer and logical found/notfound value
|
|
\ If error, return NULL pointer in addition to notfound code
|
|
\ +
|
|
: (?available-segment<) ( start1 end1 start2 end2 -- true/false ) drop < nip ;
|
|
|
|
: (?available-segment>) ( start1 end1 start2 end2 -- true/false ) -rot 2drop > ;
|
|
|
|
\ start1 to end1 is the area that should be claimed
|
|
\ start2 to end2 is the available segment
|
|
\ return true if it can not be claimed, false if it can be claimed
|
|
: (?available-segment-#) ( start1 end1 start2 end2 -- true/false )
|
|
2dup 5 roll -rot ( e1 s2 e2 s1 s2 e2 )
|
|
between >r between r> and not
|
|
;
|
|
|
|
: (find-available) ( addr addr+size-1 a-ptr a-size -- a-ptr' found )
|
|
?dup 0= IF -rot 2drop false EXIT THEN \ Not Found
|
|
|
|
2dup 2/ dup >r /available * +
|
|
( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' )
|
|
dup available>size@ 0= IF 2drop r> RECURSE EXIT THEN
|
|
|
|
( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' )
|
|
dup >r available@
|
|
( addr addr+size-1 a-ptr a-size addr' size' R: a-size' a-ptr' )
|
|
over + 1- 2>r 2swap
|
|
( a-ptr a-size addr addr+size-1 )
|
|
( R: a-size' a-ptr' addr' addr'+size'-1 )
|
|
|
|
2dup 2r@ (?available-segment>) IF
|
|
2swap 2r> 2drop r>
|
|
/available + -rot r> - 1- nip RECURSE EXIT \ Look Right
|
|
THEN
|
|
2dup 2r@ (?available-segment<) IF
|
|
2swap 2r> 2drop r>
|
|
2drop r> RECURSE EXIT \ Look Left
|
|
THEN
|
|
2dup 2r@ (?available-segment-#) IF \ Conflict - segments overlap
|
|
2r> 2r> 3drop 3drop 2drop
|
|
1212 throw
|
|
THEN
|
|
2r> 3drop 3drop r> r> drop ( a-ptr' -- )
|
|
dup available>size@ 0<> ( a-ptr' found -- )
|
|
;
|
|
|
|
: (find-available) ( addr size -- seg-ptr found )
|
|
over + 1- available AVAILABLE-SIZE ['] (find-available) catch IF
|
|
2drop 2drop 0 false
|
|
THEN
|
|
;
|
|
|
|
|
|
: dump-available ( available-ptr -- )
|
|
cr
|
|
dup available - /available / AVAILABLE-SIZE swap - 0 ?DO
|
|
dup available@ ?dup 0= IF
|
|
2drop UNLOOP EXIT
|
|
THEN
|
|
swap . . cr
|
|
/available +
|
|
LOOP
|
|
dup
|
|
;
|
|
|
|
: .available available dump-available ;
|
|
|
|
\ +
|
|
\ release utils:
|
|
\ +
|
|
|
|
\ +
|
|
\ (drop-available) just blindly compresses space of available map
|
|
\ +
|
|
: (drop-available) ( available-ptr -- )
|
|
dup available - /available / \ current element index
|
|
AVAILABLE-SIZE swap - \ # of remaining elements
|
|
|
|
( first nelements ) 1- 0 ?DO
|
|
dup /available + dup available@
|
|
|
|
( current next next>address next>size ) ?dup 0= IF
|
|
2drop LEAVE \ NULL element - goto last copy
|
|
THEN
|
|
3 roll available! ( next )
|
|
LOOP
|
|
|
|
\ Last element : just zero it out
|
|
0 0 rot available!
|
|
;
|
|
|
|
\ +
|
|
\ (stick-to-previous-available) merge the segment on stack
|
|
\ with the previous one, if possible, and modified segment parameters if merged
|
|
\ Return success code
|
|
\ +
|
|
: (stick-to-previous-available) ( addr size available-ptr -- naddr nsize nptr success )
|
|
dup available = IF
|
|
false EXIT \ This was the first available segment
|
|
THEN
|
|
|
|
dup /available - dup available@
|
|
+ 4 pick = IF
|
|
nip \ Drop available-ptr since we are going to previous one
|
|
rot drop \ Drop start addr, we take the previous one
|
|
|
|
dup available@ 3 roll + rot true
|
|
( prev-addr prev-size+size prev-ptr true )
|
|
ELSE
|
|
drop false
|
|
( addr size available-ptr false )
|
|
THEN
|
|
;
|
|
|
|
\ +
|
|
\ (insert-available) just blindly makes space for another element on given
|
|
\ position
|
|
\ +
|
|
\ insert-available should also check adjacent elements and merge if new
|
|
\ region is contiguos w. others
|
|
\ +
|
|
: (insert-available) ( available-ptr -- available-ptr )
|
|
dup \ current element
|
|
dup available - /available / \ current element index
|
|
AVAILABLE-SIZE swap - \ # of remaining elements
|
|
|
|
dup 0<= 3 pick available>size@ 0= or IF
|
|
\ End of "available" or came to an empty element - Exit
|
|
drop drop EXIT
|
|
THEN
|
|
|
|
over available@ rot
|
|
|
|
( first first/=current/ first>address first>size nelements ) 1- 0 ?DO
|
|
2>r
|
|
( first current R: current>address current>size )
|
|
|
|
/available + dup available@
|
|
( first current+1/=next/ next>address next>size )
|
|
( R: current>address current>size )
|
|
|
|
2r> 4 pick available! dup 0= IF
|
|
\ NULL element - last copy
|
|
rot /available + available!
|
|
UNLOOP EXIT
|
|
THEN
|
|
LOOP
|
|
|
|
( first next/=last/ last[0]>address last[0]>size ) ?dup 0<> IF
|
|
cr ." release error: available map overflow"
|
|
cr ." Dumping available property"
|
|
.available
|
|
cr ." No space for one before last entry:" cr swap . .
|
|
cr ." Dying ..." cr 123 throw
|
|
THEN
|
|
|
|
2drop
|
|
;
|
|
|
|
: insert-available ( addr size available-ptr -- addr size available-ptr )
|
|
dup available>address@ 0<> IF
|
|
\ Not empty :
|
|
dup available>address@ rot dup -rot -
|
|
|
|
( addr available-ptr size available>address@-size )
|
|
|
|
3 pick = IF \ if (available>address@ - size == addr)
|
|
\ Merge w. next segment - no insert needed
|
|
|
|
over available>size@ + swap
|
|
( addr size+available>size@ available-ptr )
|
|
|
|
(stick-to-previous-available) IF
|
|
\ Merged w. prev & next one : discard extra seg
|
|
dup /available + (drop-available)
|
|
THEN
|
|
ELSE
|
|
\ shift the rest of "available" to make space
|
|
|
|
swap (stick-to-previous-available)
|
|
not IF (insert-available) THEN
|
|
THEN
|
|
ELSE
|
|
(stick-to-previous-available) drop
|
|
THEN
|
|
;
|
|
|
|
defer release
|
|
|
|
\ +
|
|
\ claim utils:
|
|
\ +
|
|
: drop-available ( addr size available-ptr -- addr )
|
|
dup >r available@
|
|
( req_addr req_size segment_addr segment_size R: available-ptr )
|
|
|
|
over 4 pick swap - ?dup 0<> IF
|
|
\ Segment starts before requested address : free the head space
|
|
dup 3 roll swap r> available! -
|
|
|
|
( req_addr req_size segment_size-segment_addr+req_addr )
|
|
over - ?dup 0= IF
|
|
\ That's it - remainder of segment is what we claim
|
|
drop
|
|
ELSE
|
|
\ Both head and tail of segment remain unclaimed :
|
|
\ need an extra available element
|
|
swap 2 pick + swap release
|
|
THEN
|
|
ELSE
|
|
nip ( req_addr req_size segment_size )
|
|
over - ?dup 0= IF
|
|
\ Exact match : drop the whole available segment
|
|
drop r> (drop-available)
|
|
ELSE
|
|
\ We claimed the head, need to leave the tail available
|
|
-rot over + rot r> available!
|
|
THEN
|
|
THEN
|
|
( base R: -- )
|
|
;
|
|
|
|
: pwr2roundup ( value -- pwr2value )
|
|
dup CASE
|
|
0 OF EXIT ENDOF
|
|
1 OF EXIT ENDOF
|
|
ENDCASE
|
|
dup 1 DO drop i dup +LOOP
|
|
dup +
|
|
;
|
|
|
|
: (claim-best-fit) ( len align -- len base )
|
|
pwr2roundup 1- -1 -1
|
|
( len align-1 best-fit-residue/=-1/ best-fit-base/=-1/ )
|
|
|
|
available AVAILABLE-SIZE /available * + available DO
|
|
i \ Must be saved now, before we use Return stack
|
|
-rot >r >r swap >r
|
|
|
|
( len i R: best-fit-base best-fit-residue align-1 )
|
|
|
|
available@ ?dup 0= IF drop r> r> r> LEAVE THEN \ EOL
|
|
|
|
2 pick - dup 0< IF
|
|
2drop \ Can't Fit: Too Small
|
|
ELSE
|
|
dup 2 pick r@ and - 0< IF
|
|
2drop \ Can't Fit When Aligned
|
|
ELSE
|
|
( len i>address i>size-len )
|
|
( R: best-fit-base best-fit-residue align-1 )
|
|
r> -rot dup r@ U< IF
|
|
\ Best Fit so far: drop the old one
|
|
2r> 2drop
|
|
|
|
( len align-1 nu-base nu-residue R: )
|
|
\ Now align new base and push to R:
|
|
swap 2 pick + 2 pick invert and >r >r >r
|
|
ELSE
|
|
2drop >r
|
|
THEN
|
|
THEN
|
|
THEN
|
|
r> r> r>
|
|
/available +LOOP
|
|
|
|
-rot 2drop ( len best-fit-base/or -1 if none found/ )
|
|
;
|
|
|
|
: (adjust-release0) ( 0 size -- addr' size' )
|
|
\ segment 0 already pre-relased in early phase: adjust
|
|
2dup MIN-RAM-SIZE dup 3 roll + -rot -
|
|
dup 0< IF 2drop ELSE
|
|
2swap 2drop 0 mem-pre-released !
|
|
THEN
|
|
;
|
|
|
|
|
|
\ \\\\\\\\\\\\\\ Exported Interface:
|
|
\ +
|
|
\ IEEE 1275 implementation:
|
|
\ claim
|
|
\ Claim the region with given start address and size (if align parameter is 0);
|
|
\ alternatively claim any region of given alignment
|
|
\ +
|
|
\ Throw an exception if failed
|
|
\ +
|
|
: claim ( [ addr ] len align -- base )
|
|
?dup 0<> IF
|
|
(claim-best-fit) dup -1 = IF
|
|
2drop cr ." claim error : aligned allocation failed" cr
|
|
." available:" cr .available
|
|
321 throw EXIT
|
|
THEN
|
|
swap
|
|
THEN
|
|
|
|
2dup (find-available) not IF
|
|
drop
|
|
\ cr ." claim error : requested " . ." bytes of memory at " .
|
|
\ ." not available" cr
|
|
\ ." available:" cr .available
|
|
2drop
|
|
321 throw EXIT
|
|
THEN
|
|
( req_addr req_size available-ptr ) drop-available
|
|
|
|
( req_addr )
|
|
;
|
|
|
|
|
|
\ +
|
|
\ IEEE 1275 implementation:
|
|
\ release
|
|
\ Free the region with given start address and size
|
|
\ +
|
|
: .release ( addr len -- )
|
|
over 0= mem-pre-released @ and IF (adjust-release0) THEN
|
|
|
|
2dup (find-available) IF
|
|
drop swap
|
|
cr ." release error: region " . ." , " . ." already released" cr
|
|
ELSE
|
|
?dup 0= IF
|
|
swap
|
|
cr ." release error: Bad/conflicting region " . ." , " .
|
|
." or available list full " cr
|
|
ELSE
|
|
( addr size available-ptr ) insert-available
|
|
|
|
\ NOTE: insert did not change the stack layout
|
|
\ but it may have changed any of the three values
|
|
\ in order to implement merge of free regions
|
|
\ We do not interpret these values any more
|
|
\ just blindly copy it in
|
|
|
|
( addr size available-ptr ) available!
|
|
THEN
|
|
THEN
|
|
;
|
|
|
|
' .release to release
|
|
|
|
|
|
\ pre-release minimal memory size
|
|
0 MIN-RAM-SIZE release 1 mem-pre-released !
|
|
|
|
\ claim first pages used for PPC exception vectors
|
|
0 MIN-RAM-RESERVE 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop
|
|
|
|
\ claim region used by firmware (assume 31 MiB size right now)
|
|
paflof-start ffff not and 1f00000 0 ' claim CATCH IF
|
|
." claim failed!" cr 2drop
|
|
THEN drop
|