1 files changed, 71 insertions, 15 deletions
diff --git a/slof/fs/alloc-mem.fs b/slof/fs/alloc-mem.fs
index 7dc7bd4..89c6a61 100644
--- a/slof/fs/alloc-mem.fs
+++ b/slof/fs/alloc-mem.fs
@@ -1,19 +1,75 @@
-\ =============================================================================
-\  * Copyright (c) 2004, 2005 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
-\ =============================================================================
-
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2007 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.
 
-\ For now, just allocate from the data space, and never take space back.
+\ 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>
 
-: alloc-mem ( len -- a-addr ) align here swap allot ;
-: free-mem  ( a-addr len -- ) 2drop ;