memory.fs

open source bios with linux platform, very good and can be reused.

\ tag: forth memory allocation
\ 
\ Copyright (C) 2002-2003 Stefan Reinauer
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 

\ 7.3.3.2 memory allocation

\ these need to be initialized by the forth kernel by now.
variable start-mem 0 start-mem !	\ start of memory
variable end-mem   0 end-mem   !	\ end of memory
variable free-list 0 free-list !	\ free list head

\ initialize necessary variables and write a valid 
\ free-list entry containing all of the memory.
\   start-mem: pointer to start of memory.
\   end-mem:   pointer to end of memory.
\   free-list: head of linked free list

: init-mem ( start-addr size )
  over dup
  start-mem !		\ write start-mem 
  free-list !		\ write first freelist entry
  2dup /n - swap !	\ write 'len'  entry
  over cell+ 0 swap !	\ write 'next' entry
  + end-mem  !		\ write end-mem 
  ;
 
\ --------------------------------------------------------------------

\ return pointer to smallest free block that contains 
\ at least nb bytes and the block previous the the 
\ actual block. On failure the pointer to the smallest
\ free block is 0.

: smallest-free-block ( nb -- prev ptr | 0 0 )
  0 free-list @
  fffffff 0 0 >r >r >r
  begin
    dup
  while
    ( nb prev pp R: best_nb best_pp )
    dup @ 3 pick r@ within if
      ( nb prev pp )
      r> r> r> 3drop            \ drop old smallest
      2dup >r >r dup @ >r       \ new smallest
    then
    nip dup                     \ prev = pp
    cell + @                    \ pp = pp->next
  repeat
  3drop r> drop r> r>
;


\ --------------------------------------------------------------------

\ allocate size bytes of memory
\ return pointer to memory (or throws an exception on failure).

: alloc-mem ( size -- addr )

  \ make it legal (and fast) to allocate 0 bytes
  dup 0= if exit then

  aligned			\ keep memory aligned.
  dup smallest-free-block	\ look up smallest free block.
  
  dup 0= if 
    \ 2drop
    -15 throw \ out of memory
  then
  
  ( al-size prev addr )
  
  \ If the smallest fitting block found is bigger than
  \ the size of the requested block plus 2*cellsize we
  \ can split the block in 2 parts. otherwise return a
  \ slightly bigger block than requested.

  dup @ ( d->len ) 3 pick cell+ cell+ > if
  
    \ splitting the block in 2 pieces.
    \ new block = old block + len field + size of requested mem
    dup 3 pick cell+ +	(  al-size prev addr nd )

    \ new block len = old block len - req. mem size - 1 cell
    over @		( al-size prev addr nd addr->len )
    4 pick		( ... al-size )
    cell+ -		( al-size prev addr nd nd nd->len )
    over !		( al-size prev addr nd )

    over cell+ @	( al-size prev addr nd addr->next )
    			\ write addr->next to nd->next
    over cell+ !	( al-size prev addr nd )
    over 4 pick swap !
  else
    \ don't split the block, it's too small.
    dup cell+ @
  then

  ( al-size prev addr nd )

  \ If the free block we got is the first one rewrite free-list
  \ pointer instead of the previous entry's next field.
  rot dup 0= if drop free-list else cell+ then
  ( al-size addr nd prev->next|fl )
  !
  nip cell+	\ remove al-size and skip len field of returned pointer

  ;


\ --------------------------------------------------------------------
  
\ free block given by addr. The length of the
\ given block is stored at addr - cellsize.
\ 
\ merge with blocks to the left and right 
\ immediately, if they are free.

: free-mem ( addr len -- )

  \ we define that it is legal to free 0-byte areas
  0= if drop exit then
  ( addr )
	
  \ check if the address to free is somewhere within
  \ our available memory. This fails badly on discontigmem
  \ architectures. If we need more RAM than fits on one 
  \ contiguous memory area we are too bloated anyways. ;)
  
  dup start-mem @ end-mem @ within 0= if
 \   ." free-mem: no such memory: 0x" u. cr
    exit
  then

  /n -				\ get real block address
  0 free-list @			( addr prev l )
  
  begin				\ now scan the free list
    dup 0<> if			\ only check len, if block ptr != 0
      dup dup @ cell+ + 3 pick < 
    else
      false
    then
  while 
    nip dup			\ prev=l
    cell+ @			\ l=l->next
  repeat

  ( addr prev l )

  dup 0<> if				\ do we have free memory to merge with?
  
    dup dup @ cell+ + 3 pick  = if	\ hole hit. adding bytes.
      \ freeaddr = end of current block -> merge
      ( addr prev l )
      rot @ cell+		( prev l f->len+cellsize )
      over @ +			\ add l->len
      over !			( prev l )
      swap over cell+ @		\ f = l; l = l->next;

      \ The free list is sorted by addresses. When merging at the
      \ start of our block we might also want to merge at the end
      \ of it. Therefore we fall through to the next border check
      \ instead of returning.
      true				\ fallthrough value
    else
      false				\ no fallthrough
    then
    >r					\ store fallthrough on ret stack
    
    ( addr prev l )

    dup 3 pick dup @ cell+ + = if	\ hole hit. real merging.
      \ current block starts where block to free ends.
      \ end of free block addr = current block -> merge and exit
      					( addr prev l )
      2 pick dup @			( f f->len ) 
      2 pick @ cell+ +			( f newlen )
      swap !				( addr prev l )
      3dup drop
      0= if
	free-list
      else
	2 pick cell+ 
      then				( value prev->next|free-list )
      !					( addr prev l )
      cell+ @ rot			( prev l->next addr )
      cell+ ! drop
      r> drop exit			\ clean up return stack
    then

    r> if 3drop exit then		\ fallthrough? -> exit
  then
  
  \ loose block - hang it before current.

  ( addr prev l )

  \ hang block to free in front of the current entry.
  dup 3 pick cell+ !			\ f->next = l;
  free-list @ = if			\ is block to free new list head?
    over free-list !
  then
  
  ( addr prev )
  dup 0<> if				\ if (prev) prev->next=f
    cell+ !
  else 
    2drop				\ no fixup needed. clean up.
  then
    
  ;