\ Allocator for GlasForth.
\
\ Based on a public domain memory allocator by Don Hopkins and Mitch
\ Bradley posted to comp.lang.forth by Mitch Bradley.  It is available
\ from ftp.taygeta.com.
\
\ Interface:
\
\ ALLOC-BAD-FREE-IOR	( -- ior)	Ior returned when FREE fails.
\ ALLOC-NOMEM-IOR	( -- ior)	Ior returned when ALLOCATE fails.
\
\ POOL	( -- a-addr)
\	A variable that contains a pointer to the current pool
\	from where allocations and deallocations are done from.
\
\ POOL-SIZE	( -- u)
\	The size in bytes of a pool header.  To create a new pool you should
\	obtain this much memory and pass its address to INIT-POOL.
\
\ INIT-POOL	( pool-addr --)
\	Initialise the pool at pool-addr to contain no memory.
\
\ DEF-POOL	( -- pool-addr)
\	The default pool for allocations.  Initially there is no memory
\	in the pool.
\
\ ADD-MEMORY	( addr size --)
\	Add size bytes of memory at addr for allocation to the current
\	pool.  ABORT" 's if the memory piece was too small.
\
\ ALLOCATE	( size -- addr ior)
\	Allocates memory of size bytes from the current pool.
\
\ FREE		( addr -- ior)
\	Frees memory at addr to whatever pool it was allocated from.
\
\ RESIZE	( addr new-size -- addr' ior)
\	Resizes the memory block at addr to be new-size bytes long.
\	If the block needs to be moved, then a new block is allocated
\	from the current pool and the block at addr is freed to whatever
\	pool it was allocated from.  On success, ior is zero and addr'
\	is the new memory block. On failure, ior tells why 
\
\ AVAIL		( -- size)
\	Returns the total number of available bytes in the current pool.
\
\ MAX-AVAIL	( -- size)
\	Returns the largest piece block for allocation from the current
\	pool.

DECIMAL
ONLY FORTH DEFINITIONS

NEW-IOR CONSTANT ALLOC-BAD-FREE-IOR
NEW-IOR CONSTANT ALLOC-NOMEM-IOR

VARIABLE POOL

VOCABULARY ALLOC
ALSO ALLOC DEFINITIONS

4 CONSTANT #align		\ bytes alignment boundary

: round-up  ( u u2 -- u')   1- DUP >R + R> INVERT AND ;
\ round up u to a boundary of u2 .  u2 should be a power of two.

: nd-size  ; IMMEDIATE
: nd-data  S" CELL+" EVALUATE  ; IMMEDIATE
: nd-succ  S" CELL+" EVALUATE  ; IMMEDIATE
: nd-pred  S" CELL+ CELL+ " EVALUATE  ; IMMEDIATE

ALSO FORTH DEFINITIONS
0 nd-pred CELL+ CONSTANT POOL-SIZE	\ the minimum size of a node.
PREVIOUS DEFINITIONS

HEX 80000000 CONSTANT mask
 mask INVERT CONSTANT ~mask
DECIMAL

: >node  ( adr -- node)	S" CELL- " EVALUATE ; IMMEDIATE
: free?	 ( node -- 0|x<>0)	nd-size @ mask AND  ;
: nd-size@  ( node -- size)	nd-size @ ~mask AND  ;
: nd-size!  ( size node --)	TUCK free? OR SWAP nd-size !  ;
: +free	 ( node --)		DUP nd-size @ mask OR SWAP nd-size !  ;
: -free	 ( node --)		DUP nd-size@ SWAP nd-size !  ;

: next-node ( node -- node')	DUP nd-size@ +  ;

: remove-node  ( node --)
\ remove node from free list.
	DUP nd-pred @  OVER nd-succ @  nd-pred !
	DUP nd-succ @  SWAP nd-pred @  nd-succ !  ;

: insert-after  ( new-node old-node --)
	DUP >R  nd-succ @  OVER  nd-succ !	\ new.succ <- old.succ
	DUP R@  nd-succ !			\ old.succ <- new
	R> OVER nd-pred !			\ new.pred <- old
	DUP nd-succ @ nd-pred !  ;		\ (new.succ).pred <- new

: link-with-free  ( node --)
	DUP +free
	POOL @ insert-after  ;

: merge-with-next  ( node --)
\ merge node with next node.
	DUP next-node DUP remove-node	( node next)
	nd-size@ OVER nd-size@ + SWAP nd-size!  ;

: merge-down  ( node --)
\ merge node with following free nodes.
	BEGIN   DUP next-node free? WHILE
		DUP merge-with-next   REPEAT  DROP  ;

: data-size   ( addr -- size)
\ Return the size of the data of an allocated node.
	>node nd-size@ >node  ;

ONLY FORTH DEFINITIONS ALSO ALLOC

: MEM-POOL  ( "name" --)
\ Create a new memory pool word "name" that when executed will cause
\ subsequent allocations and memory additions to be done from/to that pool.
\ Initially the pool has no memory.
	CREATE	HERE 0 ,	\ no memory, mark used.
		DUP , ,		\ link succ and pred to self.
DOES>	POOL ! ;

: ADD-MEMORY  ( addr len --)
\ Add memory to the current pool.
	SWAP DUP #align round-up		\ align addr and len
	DUP ROT -
	ROT SWAP -
	#align 1- INVERT AND			( addr' len' )

	>node					\ remove sentinel node size

	DUP POOL-SIZE < ABORT" ADD-MEMORY: piece too small."

	\ Create a nonfree sentinel node to prevent merge-down from
	\ merging with `nodes' that don't belong to this piece.
	\ The constant DEFACED is used as the size of the node
	\ as i) it is visually distinctive in a hex dump, and ii) 
	\ if the allocator accidentally tries to access node-addr+DEFACED
	\ it will hopefully crash colourfully.  This is safe as only
	\ free nodes, or nodes that are deallocated are ever inspected
	\ for their size.
	2DUP + [ HEX ] DEFACED [ DECIMAL ] SWAP ! ( first-node first-node-size)

	\ Make a single free node to hold all but the stopper and
	\ link it to the current free pool.
	OVER nd-size!  link-with-free	;

: MAX-AVAIL  ( -- n)
\ Return the largest available free area for allocation.
\ As a side effect merges all adjacent free nodes.
	0 POOL @
	BEGIN	nd-succ @
		DUP POOL @ <>
	WHILE	DUP merge-down
		DUP >R nd-size@ MAX R> 
	REPEAT	DROP >node 0 MAX  ;

: AVAIL  ( -- n)
\ Return the total number of bytes left in the free pool.
	MAX-AVAIL DROP
	0 POOL @
	BEGIN	nd-succ @
		DUP POOL @ <>
	WHILE	DUP >R nd-size@ + R> 
	REPEAT	DROP >node 0 MAX  ;

: FREE  ( addr -- ior)
	>node
	DUP free? IF
		ALLOC-BAD-FREE-IOR
	ELSE
		DUP merge-down DUP link-with-free +free 0
	THEN  ;

: ALLOCATE  ( size -- addr ior)
	nd-data POOL-SIZE MAX
	#align round-up >R		( R: size )

	\ Find a node big enough.
	POOL @
	BEGIN	nd-succ @		( node R: size)
		DUP POOL @ =  IF
			R> 2DROP 0 ALLOC-NOMEM-IOR EXIT
		THEN
		DUP merge-down
		DUP nd-size@ R@ < 0=
	UNTIL

	DUP nd-size@ R@ - 		( node left-over R: size )
	DUP POOL-SIZE < IF		( node left-over R: size )
		R> 2DROP DUP remove-node
	ELSE	\ node big enough to split.
		2DUP SWAP nd-size!	 \ set left-over size
		+  DUP R> SWAP nd-size ! \ set size of allocated node
	THEN 				( node )
	DUP -free
	nd-data 0  ;

: RESIZE  ( addr new-size -- addr' ior)
	OVER >node free? IF  DROP ALLOC-BAD-FREE-IOR  ELSE
	ALLOCATE ( addr addr' ior1) ?DUP IF
		\ Allocate failed with ior1.
		NIP				( addr ior1)
	ELSE
		\ Move contents of addr to addr' and free addr.
		2DUP OVER data-size OVER data-size MIN MOVE ( addr addr')
		SWAP FREE DROP 0
	THEN THEN ;

: INIT-POOL  ( pool-addr --)
\ Initialise pool at pool-addr to have no memory.
	>R
	 0 R@ !
	R@ R@ nd-succ !
	R@ R> nd-pred ! ;

\ Make a default pool DEF-POOL.
POOL-SIZE  BUFFER:  DEF-POOL
DEF-POOL INIT-POOL
DEF-POOL POOL !

ONLY FORTH DEFINITIONS
DECIMAL