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     ! 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.