116 lines
3.6 KiB
Forth
116 lines
3.6 KiB
Forth
\ *****************************************************************************
|
|
\ * Copyright (c) 2011 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
|
|
\ ****************************************************************************/
|
|
\ * Dynamic memory allocation/de-allocation debug functions
|
|
\ *****************************************************************************
|
|
|
|
|
|
\ Uncomment the following code for debugging bad write accesses beyond
|
|
\ the end of the allocated block:
|
|
\ Store magic value past the end of the block during alloc-mem and
|
|
\ check for this magic value when free-mem has been called.
|
|
#if 1
|
|
: alloc-mem ( len -- addr )
|
|
dup /n + alloc-mem ( len addr )
|
|
2dup + 3141592653589793 swap ! nip
|
|
;
|
|
|
|
: free-mem ( addr len -- )
|
|
2dup + @ 3141592653589793 <> IF
|
|
cr ." Detected memory corrupt during free-mem of "
|
|
swap . . cr EXIT
|
|
THEN
|
|
/n + free-mem
|
|
;
|
|
#endif
|
|
|
|
|
|
\ Never ever assume that allocated memory is pre-initialized with 0 ...
|
|
: alloc-mem ( len -- addr )
|
|
dup alloc-mem swap 2dup ff fill drop
|
|
;
|
|
|
|
\ Make sure that memory block do not contain "valid" data after free-mem:
|
|
: free-mem ( addr len -- )
|
|
2dup ff fill free-mem
|
|
;
|
|
|
|
|
|
\ The following definitions are used for debugging the parameters of free-mem:
|
|
\ Store block address and size of allocated blocks
|
|
\ in an array, then check for right values on free-mem.
|
|
|
|
1000 CONSTANT max-malloced-blocks
|
|
CREATE malloced-blocks max-malloced-blocks 2 * cells allot
|
|
malloced-blocks max-malloced-blocks 2 * cells erase
|
|
|
|
|
|
: alloc-mem ( len -- addr )
|
|
dup alloc-mem dup 0= IF
|
|
cr ." alloc-mem returned 0 for size " swap . cr EXIT
|
|
THEN ( len addr )
|
|
malloced-blocks max-malloced-blocks 0 DO ( len addr m-blocks-ptr )
|
|
dup @ 0= IF ( len addr m-blocks-ptr )
|
|
\ Found a free entry: store addr and len
|
|
over >r dup >r !
|
|
r> cell+ !
|
|
r> UNLOOP EXIT
|
|
THEN
|
|
cell+ cell+ ( len addr next-m-blocks-ptr )
|
|
LOOP
|
|
." Please increase max-malloced-blocks." cr ( len addr next-m-blocks-ptr )
|
|
drop nip
|
|
;
|
|
|
|
|
|
: free-mem ( addr len -- )
|
|
malloced-blocks max-malloced-blocks 0 DO ( addr len m-blocks-ptr )
|
|
dup @ ?dup IF
|
|
( addr len m-blocks-ptr s-addr )
|
|
3 pick = IF
|
|
( addr len m-blocks-ptr )
|
|
dup cell+ @ ( addr len m-blocks-ptr s-len )
|
|
2 pick = IF ( addr len m-blocks-ptr )
|
|
\ All right, addr and len matched,
|
|
\ clear entry and call original free-mem.
|
|
dup cell+ 0 swap !
|
|
0 swap !
|
|
free-mem
|
|
ELSE
|
|
>r swap cr
|
|
." free-mem called for block " . ." with wrong size=" . cr
|
|
." ( correct size should be: " r> cell+ @ . ." )" cr
|
|
THEN
|
|
UNLOOP EXIT
|
|
THEN ( addr len m-blocks-ptr )
|
|
THEN
|
|
cell+ cell+ ( addr len next-m-blocks-ptr )
|
|
LOOP
|
|
drop swap cr
|
|
." free-mem called for block " .
|
|
." ( size=" .
|
|
." ) which has never been allocated before!" cr
|
|
;
|
|
|
|
|
|
\ Enable these for verbose debug messages:
|
|
#if 0
|
|
: alloc-mem
|
|
cr ." alloc-mem with len=" dup .
|
|
alloc-mem
|
|
." returned addr=" dup . cr
|
|
;
|
|
|
|
: free-mem
|
|
cr ." free mem addr=" over . ." len=" dup . cr
|
|
free-mem
|
|
;
|
|
#endif
|