\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: malloc.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)malloc.fth 2.10 03/09/09
copyright: Copyright 1990-2001, 2003 Sun Microsystems, Inc. All Rights Reserved
\ Forth dynamic storage managment.
\ By Don Hopkins, University of Maryland
\ Modified by Mitch Bradley, Bradley Forthware
\ First fit storage allocation of blocks of varying size.
\ Blocks are prefixed with a usage flag and a length count.
\ Free blocks are collapsed downwards during free-memory and while
\ searching during allocate-memory. Based on the algorithm described
\ in Knuth's _An_Introduction_To_Data_Structures_With_Applications_,
\ sections 5-6.2 and 5-6.3, pp. 501-511.
\ Initializes the allocator, with no memory. Should be executed once,
\ before any other allocation operations are attempted.
\ add-memory ( adr len -- )
\ Adds a region of memory to the allocation pool. That memory will
\ be available for subsequent use by allocate-memory. This may
\ be executed any number of times.
\ allocate-memory ( size -- adr false | error true )
\ Tries to allocate a chunk of memory at least size bytes long.
\ Returns error code and true on failure, or the address of the
\ first byte of usable data and false on success.
\ Frees a chunk of memory allocated by malloc. adr should be an
\ address returned by allocate-memory. Error if adr is not a
\ memory-available ( -- size )
\ Returns the size in bytes of the largest contiguous chunk of memory
\ that can be allocated by allocate-memory .
also allocator also definitions
8 constant #dalign \ Machine-dependent worst-case alignment boundary
1110000000000111 constant *dbuf-free*
1111010101011111 constant *dbuf-used*
\ : field \ name ( offset size -- offset' )
\ create over , + does> @ +
\ In a multitasking system, the memory allocator head node should
\ be located in a global area, instead in the per-task user area.
dbuf-min ualloc user dbuf-head
: dbuf-data> ( adr -- 'dbuf ) 0 >dbuf-data - ;
: dbuf-flag! ( flag 'dbuf -- ) >dbuf-flag ! ;
: dbuf-flag@ ( 'dbuf -- flag ) >dbuf-flag @ ;
: dbuf-size! ( size 'dbuf -- ) >dbuf-size ! ;
: dbuf-size@ ( 'dbuf -- size ) >dbuf-size @ ;
: dbuf-suc! ( suc 'dbuf -- ) >dbuf-suc ! ;
: dbuf-suc@ ( 'dbuf -- 'dbuf ) >dbuf-suc @ ;
: dbuf-pred! ( pred 'dbuf -- ) >dbuf-pred ! ;
: dbuf-pred@ ( 'dbuf -- 'dbuf ) >dbuf-pred @ ;
: next-dbuf ( 'dbuf -- 'next-dbuf ) dup dbuf-size@ + ;
\ Insert new-node into doubly-linked list after old-node
: insert-after ( new-node old-node -- )
>r r@ dbuf-suc@ over dbuf-suc! \ old's suc is now new's suc
dup r@ dbuf-suc! \ new is now old's suc
r> over dbuf-pred! \ old is now new's pred
dup dbuf-suc@ dbuf-pred! \ new is now new's suc's pred
: link-with-free ( 'dbuf -- )
\ Following code will look for possibility of this node getting
\ merged with any of the other nodes. If it cannot be merged than
\ create a new node and mark it as "free". The algorithm is to
\ start with the "head" node and look for "next-dbuf" of the first
\ node if it's free node and see if it matches with the start address
\ of the current node. If it does, then just add this node's "size" to
\ the node. If this can not be merged or the dbuf is not free then
\ continue search with the next dbuf until we go through all the nodes.
dbuf-head dbuf-suc@ ( 'dbuf head-suc )
dup dbuf-head = if ( 'dbuf dbuf-suc )
*dbuf-free* over dbuf-flag! \ Set node status to "free"
dbuf-head insert-after \ Insert in list after head node
dup dbuf-flag@ *dbuf-free* = if ( 'dbuf dbuf-suc )
over >r ( 'dbuf dbuf-suc ) ( r: 'dbuf )
dup next-dbuf ( 'dbuf dbuf-suc next-dbuf ) ( r: 'dbuf )
rot ( dbuf-suc next-dbuf 'dbuf ) ( r: 'dbuf )
= if ( dbuf-suc ) ( r: 'debuf )
r> dbuf-size@ ( dbuf-suc dbuf-size )
over dbuf-size@ + ( dbuf-suc dbuf-new-size )
swap dbuf-size! ( ) \ Found node to link, just add the size
else ( dbuf-suc ) ( r: 'dbuf )
dbuf-suc@ r> ( dbuf-suc 'dbuf )
swap false ( 'dbuf dbuf-suc false )
dbuf-suc@ ( 'dbuf dbuf-suc )
false ( 'dbuf dbuf-suc false )
\ Remove node from doubly-linked list
: remove-node ( node -- )
dup dbuf-pred@ over dbuf-suc@ dbuf-pred!
dup dbuf-suc@ swap dbuf-pred@ dbuf-suc!
\ Collapse the next node into the current node
: merge-with-next ( 'dbuf -- )
dup next-dbuf dup remove-node ( 'dbuf >next-dbuf ) \ Off of free list
over dbuf-size@ swap dbuf-size@ + rot dbuf-size! \ Increase size
\ 'dbuf is a free node. Merge all free nodes immediately following
: merge-down ( 'dbuf -- 'dbuf )
dup next-dbuf dbuf-flag@ *dbuf-free* =
begin dbuf-suc@ dup dbuf-head <> while dup .node repeat
: msize ( adr -- count ) dbuf-data> dbuf-size@ dbuf-data> ;
dup dbuf-flag@ *dbuf-used* - if
\ This is here because the the allocator has completely given up
\ and rather than corrupt state we just deliberately puke.
\ the old 'abort' was insufficient because it was being caught and the
\ error code mis-interpreted; so instead we force a hard fault that we
??cr ." FATAL: free-memory: bad address." cr -1 @
merge-down link-with-free
: add-memory ( adr len -- )
\ Align the starting address to a "worst-case" boundary. This helps
\ guarantee that allocated data areas will be on a "worst-case"
swap dup #dalign round-up ( len adr adr' )
dup rot - ( len adr' diff )
#dalign round-down ( adr' len'' )
\ Set size and flags fields for first piece
\ Subtract off the size of one node header, because we carve out
\ a node header from the end of the piece to use as a "stopper".
\ That "stopper" is marked "used", and prevents merge-down from
\ trying to merge past the end of the piece.
dbuf-data> ( 'dbuf-first #dbuf-first )
\ Ensure that the piece is big enough to be useable.
\ A piece of size dbuf-min (after having subtracted off the "stopper"
\ header) is barely useable, because the space used by the free list
\ links can be used as the data space.
dup dbuf-min < abort" add-memory: piece too small"
\ Set the size and flag for the new free piece
*dbuf-free* 2 pick dbuf-flag! ( 'dbuf-first #dbuf-first )
2dup swap dbuf-size! ( 'dbuf-first #dbuf-first )
\ Create the "stopper" header
\ XXX The stopper piece should be linked into a piece list,
\ and the flags should be set to a different value. The size
\ field should indicate the total size for this piece.
\ The piece list should be consulted when adding memory, and
\ if there is a piece immediately following the new piece, they
over + ( 'dbuf-first 'dbuf-limit )
*dbuf-used* swap dbuf-flag! ( 'dbuf-first )
: (allocate-memory) ( size -- adr false | error-code true )
\ Keep pieces aligned on "worst-case" hardware boundaries
#dalign round-up ( size' )
>dbuf-data dbuf-min max ( size )
\ Search for a sufficiently-large free piece
dup dbuf-head = if \ Bail out if we've already been around
2drop 1 true exit ( error-code true )
merge-down ( size 'dbuf )
dup dbuf-size@ ( size 'dbuf dbuf-size )
2 pick >= ( size 'dbuf big-enough? )
dup dbuf-size@ 2 pick - ( size 'dbuf left-over )
dup dbuf-min <= if \ Too small to fragment?
\ The piece is too small to split, so we just remove the whole
\ thing from the free list.
dup remove-node ( 'dbuf )
else ( size 'dbuf left-over )
\ The piece is big enough to split up, so we make the free piece
\ smaller and take the stuff after it as the allocated piece.
2dup swap dbuf-size! ( size 'dbuf left-over) \ Set frag size
tuck dbuf-size! ( 'dbuf' )
*dbuf-used* over dbuf-flag! \ Mark as used
>dbuf-data false ( adr false )
: memory-available ( -- size )
0 >dbuf-data ( current-largest-size )
dbuf-suc@ dup dbuf-head <> ( size 'dbuf more? )
while \ Go once around the free list
merge-down ( size 'dbuf )
dup dbuf-size@ ( size 'dbuf dbuf-size )
rot max swap ( size' 'dbuf )
drop dbuf-data> ( largest-data-size )
\ Head node has 0 size, is not free, and is initially linked to itself
*dbuf-used* dbuf-head dbuf-flag!
0 dbuf-head dbuf-size! \ Must be 0 so the allocator won't find it.
dbuf-head dup dbuf-suc! \ Link to self
previous previous definitions
\ Tries to allocate, and if that fails, requests more memory from the system
defer more-memory ( request-size -- adr actual-size false | error-code true )
: allocate-memory ( size -- adr false | error-code true )
dup (allocate-memory) if ( size error-code )
\ No more memory in the heap; try to get some more from the system
\ use same alignment requirements and add space
\ for header and stopper header as in (allocate-memory)
dup #dalign round-up ( size size' )
>dbuf-data >dbuf-data ( size size' )
more-memory if ( size error-code )
nip true ( error-code true )
(allocate-memory) ( adr false | error-code true )
then ( adr false | error-code true )
then ( adr false | error-code true )
: heap-alloc-mem ( bytes -- adr )
allocate-memory abort" Out of memory"
: heap-free-mem ( adr size -- ) drop free-memory ;
projects / OpenSPARC-T2-SAM / blob