\ heap by Lcc Wizard for win32forth v4.2 0671

: heap-create   ( -- heap-handle )
                0       \ SIZE_T dwMaximumSize   // maximum heap size
                65536   \ SIZE_T dwInitialSize,  // initial heap size
                \ DWORD flOptions,       // heap allocation attributes
                \ HEAP_GENERATE_EXCEPTIONS
                \ HEAP_NO_SERIALIZE
                HEAP_GENERATE_EXCEPTIONS \ HEAP_NO_SERIALIZE or
                call HeapCreate
                ;

: heap-destroy  ( heap-handle -- error? )
                call HeapDestroy 0=
                ;

: heap-alloc    ( size heap-handle -- addr )
                >r
                \ SIZE_T dwBytes  // number of bytes to allocate

                \ DWORD dwFlags,  // heap allocation control
                \ HEAP_GENERATE_EXCEPTIONS
                \ HEAP_NO_SERIALIZE
                \ HEAP_ZERO_MEMORY
                null \ HEAP_NO_SERIALIZE

                r> \ HANDLE hHeap,   // handle to private heap block
                call HeapAlloc
                dup 0= abort" Fail to heap-alloc"
                abs>rel ;


: heap-free     ( addr heap-handle -- error? )
                >r
                rel>abs \ LPVOID lpMem   // pointer to memory

                \ DWORD dwFlags, // heap free options
                null \ HEAP_NO_SERIALIZE

                r> \ HANDLE hHeap,  // handle to heap
                call HeapFree 0= ;

: heap-realloc  ( size adr heap-handle -- adr error? )
                >r
                \ SIZE_T dwBytes  // number of bytes to reallocate
                \ LPVOID lpMem,   // pointer to memory to reallocate
                rel>abs

                null \ HEAP_NO_SERIALIZE \ DWORD dwFlags,  // heap reallocation options
                r> \ HANDLE hHeap,   // handle to heap block
                call HeapReAlloc
                dup 0=
                swap abs>rel swap ;

: heap-resize   ( adr size heap-handle -- adr2 error? )
                >r swap r> heap-realloc ;

\ --------------

0 value heap2

: heap2-init    ( -- )
                heap-create to heap2
                ;

: heap2-free    ( -- )
                heap2 heap-destroy drop ;

: halloc        ( size -- adr ) heap2 heap-alloc ;
: hfree         ( adr -- error? ) heap2 heap-free ;
: hrealloc      ( size adr -- adr2 error? ) heap2 heap-realloc ;
: hresize       ( adr size -- adr2 error? ) heap2 heap-resize ;

heap2-init

INITIALIZATION-CHAIN CHAIN-ADD heap2-init
unload-chain chain-add heap2-free

in-system
: t             ( -- ) \ test
                cls
                ." Testing..." cr

                time-reset ." halloc 10000 times = "
               \ 102400000 malloc drop
                10000 0 do
                        512 halloc
                loop
                .elapsed cr


                time-reset ." hfree  10000 times = "
                10000 0 do
                        10000 i - pick hfree drop
                loop
                .elapsed cr

                10000 0 do drop loop


                cr

                time-reset  time-reset ." malloc 10000 times = "
               \ 102400000 malloc drop
                10000 0 do
                        512 malloc
                loop
                .elapsed cr
                time-reset

                time-reset ." free   10000 times = "
                \ It's very slow if free in order!"
                10000 0 do
                        10000 i - pick free drop
                loop
                .elapsed cr

                10000 0 do drop loop
                ;
in-application



\s

: t             ( -- )
                cls
                heap2-init

                /*
                1000000 halloc dup 1000000 'a' fill
                dup 10 dump
                hfree cr . key drop
                */
                time-reset
                1000000 0 do
                        10000 malloc free drop
                        10000 malloc free drop
                loop
                .elapsed cr

                 time-reset
                1000000 0 do
                        10000 halloc hfree drop
                        10000 halloc hfree drop
                loop
                .elapsed cr

                1000 halloc 10000 hresize if ." h-resize error" cr then drop

                heap2-free
                /*
                cls
                heap-create to heap2

                1000 heap2 heap-alloc dup 1000 'a' fill
                dup 1000 dump
                heap2 heap-free .

                heap2 heap-destroy .
                */

                ;


\s