\ *****************************************************************************
\ * Copyright (c) 2004, 2008 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
\ ****************************************************************************/

#include <claim.fs>
\ Memory "heap" (de-)allocation.

\ Keep a linked list of free blocks per power-of-two size.
\ Never coalesce entries when freed; split blocks when needed while allocating.

\ 3f CONSTANT (max-heads#)
heap-end heap-start - log2 1+ CONSTANT (max-heads#)

CREATE heads (max-heads#) cells allot
heads (max-heads#) cells erase


: size>head  ( size -- headptr )  log2 3 max cells heads + ;


\ Allocate a memory block
: alloc-mem  ( len -- a-addr )
   dup 0= IF EXIT THEN
   1 over log2 3 max                   ( len 1 log_len )
   dup (max-heads#) >= IF cr ." Out of internal memory." cr 3drop 0 EXIT THEN
   lshift >r                           ( len  R: 1<<log_len )
   size>head dup @ IF
      dup @ dup >r @ swap ! r> r> drop EXIT
   THEN                                ( headptr  R: 1<<log_len)
   r@ 2* recurse dup                   ( headptr a-addr2 a-addr2  R: 1<<log_len)
   dup 0= IF r> 2drop 2drop 0 EXIT THEN
   r> + >r 0 over ! swap ! r>
;


\ Free a memory block

: free-mem  ( a-addr len -- )
   dup 0= IF 2drop EXIT THEN size>head 2dup @ swap ! !
;


: #links  ( a -- n )
   @ 0 BEGIN over WHILE 1+ swap @ swap REPEAT nip
;


: .free  ( -- )
   0 (max-heads#) 0 DO
      heads i cells + #links dup IF
         cr dup . ." * " 1 i lshift dup . ." = " * dup .
      THEN
      +
   LOOP
   cr ." Total " .
;


\ Start with just one free block.
heap-start heap-end heap-start - free-mem


\ : free-mem  ( a-addr len -- ) 2drop ;

\ Uncomment the following line for debugging:
\ #include <alloc-mem-debug.fs>