Re: Working with dynamic memory

Taking a closer look to dynamic memory function brought me to structure
functions.
So now I can use in my apps 0 /HEAP to allocate/release memory in process
heap,
If I want to use memory from another heap just use HEAPOBJECT HANDLE @ /HEAP
Also I try to preserve stack notation for standard words ALLOCATE, FREE,
RESIZE
as they now defined as deferred words.
I add word MEMSIZE which return the size of allocated memory.
Also just for consistency I add RESIZE and MEMSIZE for virtual memory
functions.
The package provide 7 public words: ALLOCATE, FREE, RESIZE, MEMSIZE, /GLOBAL,
/VIRTUAL, /HEAP.
The new created heaps have initial size in 1 Megabyte and extensible up to
memory limit.

With best regards,
Alexander

PACKAGE DYNAMIC-MEMORY

Function: HeapCreate ( a b c -- d )
Function: HeapDestroy ( a -- b )
Function: HeapAlloc ( a b c -- d )
Function: HeapFree ( a b c -- d )
Function: HeapReAlloc ( a b c d -- e )
Function: HeapSize ( a b c -- d )
Function: GetProcessHeap ( -- a )

PUBLIC

DEFER ALLOCATE DEFER FREE DEFER RESIZE DEFER MEMSIZE

CLASS HEAP
   VARIABLE HANDLE

   : CONSTRUCT ( - )
      0 #1048576 ( 1Megabyte) 0 ( growable) :: HeapCreate HANDLE ! ;

   : DESTRUCT ( - )
      HANDLE @ :: HeapDestroy DROP ;

   : ALLOCATE ( size - addr ior )
      HANDLE @ HEAP_ZERO_MEMORY ROT :: HeapAlloc DUP 0= -100 AND ;

   : FREE ( addr - ior )
      HANDLE @ 0 ROT :: HeapFree 0= -102 AND ;

   : RESIZE ( addr1 size - addr2 ior )
      HANDLE @ HEAP_ZERO_MEMORY 2SWAP :: HeapReAlloc DUP 0= -100 AND ;

   : MEMSIZE ( addr - size )
      HANDLE @ 0 ROT :: HeapSize ;

END-CLASS

PRIVATE

\ Heap in which memory will be allocated
HEAP BUILDS CurrentHeap

\ Allocation in local process memory
: H-ALLOCATE ( size - addr ior )
   CurrentHeap ALLOCATE ;

: H-FREE ( addr - ior )
   CurrentHeap FREE ;

: H-RESIZE ( addr1 size - addr2 ior )
   CurrentHeap RESIZE ;

: H-SIZEOF ( addr - size )
   CurrentHeap MEMSIZE ;

PUBLIC

: /HEAP ( handle - )
   ?DUP 0= IF GetProcessHeap THEN CurrentHeap HANDLE !
   ['] H-ALLOCATE IS ALLOCATE ['] H-FREE IS FREE
   ['] H-RESIZE IS RESIZE ['] H-SIZEOF IS MEMSIZE ;

PRIVATE

Function: GlobalAlloc ( a b -- c )
Function: GlobalFree ( a -- b )
Function: GlobalReAlloc ( a b c -- d )
Function: GlobalSize ( a -- b )

\ Allocation in global memory
: G-ALLOCATE ( size - addr ior )
   GPTR SWAP GlobalAlloc DUP 0= -100 AND ;

: G-FREE ( addr - ior )
   GlobalFree 0<> -102 AND ;

: G-RESIZE ( addr1 size - addr2 ior )
   GMEM_ZEROINIT GlobalReAlloc DUP 0= -100 AND ;

: G-SIZEOF ( addr - size )
   GlobalSize ;

PUBLIC

: /GLOBAL
   ['] G-ALLOCATE IS ALLOCATE ['] G-FREE IS FREE
   ['] G-RESIZE IS RESIZE ['] G-SIZEOF IS MEMSIZE ;

PRIVATE

Function: VirtualAlloc ( a b c d -- e )
Function: VirtualFree ( a b c -- d )
Function: VirtualQuery ( a b c -- d )

\ Allocation in the virtual address space of the calling process
CLASS MEMORY_BASIC_INFORMATION
   VARIABLE BaseAddress
   VARIABLE AllocationBase
   VARIABLE AllocationProtect
   VARIABLE RegionSize
   VARIABLE State
   VARIABLE Protect
   VARIABLE Type
END-CLASS

: V-ALLOCATE ( size - addr ior )
   0 SWAP MEM_COMMIT PAGE_READWRITE VirtualAlloc DUP 0= -100 AND ;

: V-FREE ( addr - ior )
   0 MEM_RELEASE VirtualFree 0= -102 AND ;

: V-SIZEOF ( addr - size )
   [OBJECTS MEMORY_BASIC_INFORMATION MAKES mbi OBJECTS]
   mbi ADDR MEMORY_BASIC_INFORMATION SIZEOF VirtualQuery
   DUP IF DROP mbi RegionSize @ THEN ;

: V-RESIZE ( addr1 size - addr2 ior )
   SWAP V-FREE THROW V-ALLOCATE ;

PUBLIC

: /VIRTUAL
   ['] V-ALLOCATE IS ALLOCATE ['] V-FREE IS FREE
   ['] V-RESIZE IS RESIZE ['] V-SIZEOF IS MEMSIZE ;

END-PACKAGE

----------------------------------------------------------------------
sftalk_at_forth.com The SwiftForth programming discussion email list
To unsubscribe, send subject "unsubscribe" to sftalk-request_at_forth.com
For list command help, send subject "help" to sftalk-request_at_forth.com
Message archives are located at http://www.forth.com/archive/sftalk
----------------------------------------------------------------------
This list is a forum for SwiftForth users. For product support and
bug reports, please send email to support_at_forth.com
----------------------------------------------------------------------
Received on Mon Apr 28 2008 - 06:03:46 PDT