\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\
\ User-interface words:
\
\ malloc ( size -- pObj ) allocate the specified number of addresses for an object
\
\ mfree ( pObj -- ) free the space used by an object
\
\ mresize ( pObj size -- pObj' ) resize the amount of space used by an object. its
\ original contents are moved to the new location. if
\ pObj is 0, a new object is created (malloc is called).
\ if size is 0, pObj is freed (mfree is called) and 0
\ is returned.
\
\ msize ( pObj -- size ) get the number of addresses allocated for this object
\ uncommon words that might have been defined more efficiently by the system:
bl word [UNDEFINED] find nip 0= [IF]
: [UNDEFINED] bl word find nip 0= ; immediate
[THEN]
[UNDEFINED] cell- [IF] : cell- -1 cells + ; [THEN]
[UNDEFINED] 3pick [IF] : 3pick 3 pick ; [THEN]
[UNDEFINED] 2pick [IF] : 2pick 2 pick ; [THEN]
[UNDEFINED] <= [IF] : <= > 0= ; [THEN]
[UNDEFINED] drop0 [IF] : drop0 drop 0 ; [THEN]
[UNDEFINED] swap- [IF] : swap- swap - ; [THEN]
\ All routines use these words to get and manipulate memory space. Adjust these
\ definitions if you want/need to alter their default behavior, such as getting
\ memory from somewhere else. These default implementations just use the original
\ equivalents as placeholders.
: _allot postpone allot ; immediate
: _here postpone here ; immediate
: _align postpone align ; immediate
: _, postpone , ; immediate
\ If you'd rather use this code for a fixed heap, you can remove the conditionals
\ from mfree and mresize that start "over _obj_end _here = if", adjust _bub_list
\ to point to a large bubble of free memory that you've created above _bub_list
\ itself, and then do something very "abort"-like at the end of malloc, instead
\ of trying to create space at "here".
\ A pBubble is a two-cell record defining an unused region of memory that was freed,
\ previously. Memory cells between pBubble and pBubble+F-1c (inclusive) could be
\ repurposed, if of sufficient size, for allocation. The element pointing to pBubble
\ would need to be updated to either merge used regions, or F can be decreased by
\ enough to allocate more space. If pNext is zero, the region from pBubble+F to
\ "here" is in use.
\
\ ("1c" means one 'cell', etc. all pointers are cell-aligned.)
\
\
\ @pBubble+0c: pNext - pointer to next bubble (or 0, if end of list)
\ @pBubble+1c: pBubble+F - pointer to end of this bubble
\ @pBubble+2c..F-1c: free memory
\ @pBubble+F...: used memory
\ A pObj is a pointer to the beginning of storage returned from mresize or malloc.
\ It is an aligned address, and the cell immediately before it stores the number of
\ addresses allocated:
\
\
\ @pObj-1c: N - number of addresses in this allocation
\ @pObj+0..N-1: user data
\
\
\ Regions are only allocated as an integral number of *cells*, but the requested number
\ of *address locations* (number of bytes, for many systems) is recorded in the cell
\ before the object, in order to assist the user by allowing querying of the exact size.
\ _bub_list is a 0-space bubble after which more bubbles can be added. This must be
\ at the lowest viable memory address for storage, since we use u< to compare addresses
\ while walking through the bubble list.
create _bub_list
here 0 , ,
: _size_to_cells aligned cell+ ; ( size -- a-size )
: _obj_get_size cell- @ ; ( pObj -- size )
: _obj_set_size cell- ! ; ( size pObj -- )
: _obj_start cell- ; ( pObj -- addr )
: _obj_end dup _obj_get_size aligned + ; ( pObj -- addr ) \ compute the address just after this object
: _obj_num_cells _obj_get_size _size_to_cells ; ( pObj -- a-size )
: _bub_next @ ; ( pBub -- pBub' )
: _bub_end cell+ @ ; ( pBub -- pEnd )
: _bub_set_end cell+ ! ; ( pEnd pBub -- )
: _bub_size cell+ dup @ swap cell+ - ; ( pBub -- size ) \ conservative estimate for bubble size (size when keeping bubble pointers)
: _bub_resize cell+ +! ; ( a-adj pBub -- ) \ change the size of free space at the end of this bubble by the specified (aligned) amount
: _bub_move _bub_next 2@ 2pick 2! ; ( dst prevBub -- dst ) \ move the bubble after prevBub to dst
\ find the address of the bubble right before 'pObj':
: _bub_prev ( pObj -- pBub )
_bub_list
begin
dup @ dup
while
( pObj pBub pNext )
dup 3pick u< if
nip
else
drop nip exit
then
repeat
drop
nip
;
\ find a bubble large enough for an object of 'size' addresses, or return 0:
\ UNIMPLEMENTED: could return the entirety of a bubble, if the caller can "pop" the
\ bubble and the object will fit exactly.
: _bub_find ( size -- pBub | 0 )
_size_to_cells
_bub_list @
begin
dup
while
2dup _bub_size <= if
nip exit
then
@
repeat
nip
;
: _adj_this over _obj_start over _bub_end = ; ( pObj pBub -- pObj pBub flag ) \ if pObj starts right at the end of this bubble
: _adj_next over _obj_end over _bub_next = ; ( pObj pBub -- pObj pBub flag ) \ if pObj ends right at the start of the next bubble
\ get the size of the allocated object
: msize ( pObj -- size )
dup if _obj_get_size then
;
\ allocate an object of the given number of bytes
: malloc ( size -- pObj )
\ return null pointer for 0-size objects :
dup 0= if exit then
dup _bub_find dup if
( size pBub )
\ shrink the bubble:
over _size_to_cells negate over _bub_resize
\ and use the new space for the object:
_bub_end tuck ! cell+ exit
then
drop
\ just allocate from 'here' (aligned)
( size -- pObj )
dup _size_to_cells unused > abort" out of memory"
_align dup _,
_here swap aligned _allot
;
\ free a previously-allocated object
: mfree ( pObj -- )
\ no-op if null pointer:
dup 0= if drop exit then
\ find the previous bubble:
dup _bub_prev
( pObj pBub )
\ if pObj ends right at 'here':
over _obj_end _here = if
\ rewind 'here' to de-allot:
over _obj_num_cells negate _allot
_adj_this if
\ remove this bubble if pObj was adjacent:
nip 0 over _bub_prev !
\ and rewind 'here' further:
_here - _allot
else
2drop
then
exit
then
( pObj pBub )
_adj_this if
_adj_next if
\ adjacent to both bubbles, merge them:
dup _bub_move
2drop
exit
then
\ expand this bubble by the number of cells used for pObj:
swap _obj_num_cells swap _bub_resize
exit
then
( pObj pBub )
_adj_next if
\ expand the next bubble by moving it to pObj:
swap _obj_start over _bub_move swap !
exit
then
\ create a new bubble at pObj
( pObj pBub )
swap dup _obj_end over ! _obj_start
\ and insert it into the chain:
( pBub pNew )
swap 2dup _bub_next swap ! !
;
\ try to resize the object in place, if there is enough room
\ either return success and the original object, or failure and the original stack
: _grow_in_place ( size pObj pBub -- pObj -1 | size pObj pBub 0 )
\ end of new object if resized in-place:
over 3pick aligned +
( size pObj pBub objNewEnd )
\ end of next bubble (minus bubble info):
over _bub_next _bub_end -2 cells +
over < if
drop0
exit
then
\ can resize in-place just by moving next bubble:
( size pObj pBub objNewEnd )
over _bub_move
swap !
tuck _obj_start ! -1
;
\ try to shrink the object in place, if enough room frees up for a new bubble
\ either return success and the original object, or failure and the original stack
: _shrink_in_place ( size pObj pBub -- pObj -1 | size pObj pBub 0 )
>r
over _size_to_cells
over _obj_num_cells - -2 cells > if
r> 0 exit
then
dup _obj_end >r \ save orig obj end before shrinking
tuck _obj_set_size \ tuck the object and set a new size
r> over _obj_end tuck _bub_set_end \ new bubble ends at orig obj end
r@ _bub_next over ! \ new bubble points to pBub's next
r> ! \ pBub now points to new bubble
-1 \ return success!
;
\ resize a previously-allocated object
: mresize ( pObj size -- pObj' )
\ null-ptr in means just call malloc:
over 0= if nip malloc exit then
\ zero-byte request means free object:
dup 0= if swap mfree exit then
\ option 1: current aligned size is same as aligned request. update size field and exit:
\ (e.g., when an object grows by one byte, and that is not enough to need more cells)
over _obj_get_size aligned over aligned = if
over _obj_set_size exit
then
\ option 2: object is right before 'here'. simply call _allot to adjust its size:
over _obj_end _here = if
over _obj_get_size aligned over aligned swap- _allot
over _obj_set_size exit
then
\ otherwise, find the nearest bubble:
swap dup _bub_prev
( size pObj pBub )
\ option 3: object is just before a bubble that has enough room for it to grow:
_adj_next if
_grow_in_place if
exit
then
else
\ option 4: object is shrinking by more than 2 cells and is not adjacent
\ to the next bubble. shrink in-place and make a new bubble in the freed space.
_shrink_in_place if
exit
then
then
drop
\ default: no free space found in adjacent bubbles. call malloc, move object, and mfree original:
swap malloc
( pOld pNew )
tuck over swap
( pNew pOld pOld pNew )
over _obj_get_size over _obj_get_size min
( pNew pOld pOld pNew minsize )
move
mfree
;
