\ *****************************************************************************
\ * 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