75 lines
2 KiB
Forth
75 lines
2 KiB
Forth
\ *****************************************************************************
|
|
\ * 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>
|
|
|