--- /dev/null
+\ 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
+
+ ;
Code Review / kvmfornfv.git / blobdiff