Return to alloc-mem.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs

Annotation of qemu/roms/SLOF/slof/fs/alloc-mem.fs, revision 1.1.1.1

1.1       root        1: \ *****************************************************************************
                      2: \ * Copyright (c) 2004, 2008 IBM Corporation
                      3: \ * All rights reserved.
                      4: \ * This program and the accompanying materials
                      5: \ * are made available under the terms of the BSD License
                      6: \ * which accompanies this distribution, and is available at
                      7: \ * http://www.opensource.org/licenses/bsd-license.php
                      8: \ *
                      9: \ * Contributors:
                     10: \ *     IBM Corporation - initial implementation
                     11: \ ****************************************************************************/
                     12: 
                     13: #include <claim.fs>
                     14: \ Memory "heap" (de-)allocation.
                     15: 
                     16: \ Keep a linked list of free blocks per power-of-two size.
                     17: \ Never coalesce entries when freed; split blocks when needed while allocating.
                     18: 
                     19: \ 3f CONSTANT (max-heads#)
                     20: heap-end heap-start - log2 1+ CONSTANT (max-heads#)
                     21: 
                     22: CREATE heads (max-heads#) cells allot
                     23: heads (max-heads#) cells erase
                     24: 
                     25: 
                     26: : size>head  ( size -- headptr )  log2 3 max cells heads + ;
                     27: 
                     28: 
                     29: \ Allocate a memory block
                     30: : alloc-mem  ( len -- a-addr )
                     31:    dup 0= IF EXIT THEN
                     32:    1 over log2 3 max                   ( len 1 log_len )
                     33:    dup (max-heads#) >= IF cr ." Out of internal memory." cr 3drop 0 EXIT THEN
                     34:    lshift >r                           ( len  R: 1<<log_len )
                     35:    size>head dup @ IF
                     36:       dup @ dup >r @ swap ! r> r> drop EXIT
                     37:    THEN                                ( headptr  R: 1<<log_len)
                     38:    r@ 2* recurse dup                   ( headptr a-addr2 a-addr2  R: 1<<log_len)
                     39:    dup 0= IF r> 2drop 2drop 0 EXIT THEN
                     40:    r> + >r 0 over ! swap ! r>
                     41: ;
                     42: 
                     43: 
                     44: \ Free a memory block
                     45: 
                     46: : free-mem  ( a-addr len -- )
                     47:    dup 0= IF 2drop EXIT THEN size>head 2dup @ swap ! !
                     48: ;
                     49: 
                     50: 
                     51: : #links  ( a -- n )
                     52:    @ 0 BEGIN over WHILE 1+ swap @ swap REPEAT nip
                     53: ;
                     54: 
                     55: 
                     56: : .free  ( -- )
                     57:    0 (max-heads#) 0 DO
                     58:       heads i cells + #links dup IF
                     59:          cr dup . ." * " 1 i lshift dup . ." = " * dup .
                     60:       THEN
                     61:       +
                     62:    LOOP
                     63:    cr ." Total " .
                     64: ;
                     65: 
                     66: 
                     67: \ Start with just one free block.
                     68: heap-start heap-end heap-start - free-mem
                     69: 
                     70: 
                     71: \ : free-mem  ( a-addr len -- ) 2drop ;
                     72: 
                     73: \ Uncomment the following line for debugging:
                     74: \ #include <alloc-mem-debug.fs>
                     75: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.