217 lines
5.8 KiB
Forth
217 lines
5.8 KiB
Forth
\ 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
|
|
|
|
;
|