mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-26 01:01:34 +02:00
eb83213f10
been allocated. E.g. allocate 100 blocks of 80 bytes and free them
all, then the same with blocks of 96, 112, 128, 144, 160 and 176
bytes, after which again 80 bytes -> previously, regardless of
the value of MaxKeptOSChunks, the empty block for 80 bytes was
reformatted for those of 96 bytes, then for 112 bytes etc. Now,
if MaxKeptOSChunks is set to 7, none will ever be reformatted
because enough chunks will be allocated from the OS.
git-svn-id: trunk@9696 -
1489 lines
43 KiB
PHP
1489 lines
43 KiB
PHP
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by the Free Pascal development team.
|
|
|
|
functions for heap management in the data segment
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{****************************************************************************}
|
|
|
|
{ Do not use standard memory manager }
|
|
{ define HAS_MEMORYMANAGER}
|
|
|
|
{ Try to find the best matching block in general freelist }
|
|
{ define BESTMATCH}
|
|
|
|
{ DEBUG: Dump info when the heap needs to grow }
|
|
{ define DUMPGROW}
|
|
|
|
{ Memory profiling: at moment in time of max heap size usage,
|
|
keep statistics of number of each size allocated
|
|
(with 16 byte granularity) }
|
|
{ define DUMP_MEM_USAGE}
|
|
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
{$define SHOW_MEM_USAGE}
|
|
{$endif}
|
|
|
|
const
|
|
{$ifdef CPU64}
|
|
blocksize = 32; { at least size of freerecord }
|
|
blockshift = 5; { shr value for blocksize=2^blockshift}
|
|
maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
|
|
{$else}
|
|
blocksize = 16; { at least size of freerecord }
|
|
blockshift = 4; { shr value for blocksize=2^blockshift}
|
|
maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
|
|
{$endif}
|
|
maxblockindex = maxblocksize div blocksize; { highest index in array of lists of memchunks }
|
|
|
|
{ common flags }
|
|
fixedsizeflag = 1; { flag if the block is of fixed size }
|
|
{ memchunk var flags }
|
|
usedflag = 2; { flag if the block is used or not }
|
|
lastblockflag = 4; { flag if the block is the last in os chunk }
|
|
firstblockflag = 8; { flag if the block is the first in os chunk }
|
|
{ os chunk flags }
|
|
ocrecycleflag = 1;
|
|
{ above flags stored in size field }
|
|
sizemask = not(blocksize-1);
|
|
fixedoffsetshift = 16;
|
|
fixedsizemask = sizemask and ((1 shl fixedoffsetshift) - 1);
|
|
|
|
{****************************************************************************}
|
|
|
|
{$ifdef DUMPGROW}
|
|
{$define DUMPBLOCKS}
|
|
{$endif}
|
|
|
|
{ Memory manager }
|
|
const
|
|
MemoryManager: TMemoryManager = (
|
|
NeedLock: false; // Obsolete
|
|
GetMem: @SysGetMem;
|
|
FreeMem: @SysFreeMem;
|
|
FreeMemSize: @SysFreeMemSize;
|
|
AllocMem: @SysAllocMem;
|
|
ReAllocMem: @SysReAllocMem;
|
|
MemSize: @SysMemSize;
|
|
InitThread: nil;
|
|
DoneThread: nil;
|
|
RelocateHeap: nil;
|
|
GetHeapStatus: @SysGetHeapStatus;
|
|
GetFPCHeapStatus: @SysGetFPCHeapStatus;
|
|
);
|
|
|
|
{$ifndef HAS_MEMORYMANAGER}
|
|
|
|
{
|
|
We use 'fixed' size chunks for small allocations,
|
|
and os chunks with variable sized blocks for big
|
|
allocations.
|
|
|
|
* a block is an area allocated by user
|
|
* a chunk is a block plus our bookkeeping
|
|
* an os chunk is a collection of chunks
|
|
|
|
Memory layout:
|
|
fixed: < chunk size > [ ... user data ... ]
|
|
variable: < prev chunk size > < chunk size > [ ... user data ... ]
|
|
|
|
When all chunks in an os chunk are free, we keep a few around
|
|
but otherwise it will be freed to the OS.
|
|
|
|
Fixed os chunks can be converted to variable os chunks and back
|
|
(if not too big). To prevent repeated conversion overhead in case
|
|
of user freeing/allocing same or a small set of sizes, we only do
|
|
the conversion to the new fixed os chunk size format after we
|
|
reuse the os chunk for another fixed size, or variable. Note that
|
|
while the fixed size os chunk is on the freelists.oslist, it is also
|
|
still present in a freelists.fixedlists, therefore we can easily remove
|
|
the os chunk from the freelists.oslist if this size is needed again; we
|
|
don't need to search freelists.oslist in alloc_oschunk, since it won't
|
|
be present anymore if alloc_oschunk is reached. Note that removing
|
|
from the freelists.oslist is not really done, only the recycleflag is
|
|
set, allowing to reset the flag easily. alloc_oschunk will clean up
|
|
the list while passing over it, that was a slow function anyway.
|
|
}
|
|
|
|
type
|
|
pfreelists = ^tfreelists;
|
|
|
|
poschunk = ^toschunk;
|
|
toschunk = record
|
|
size : 0..high(ptrint); {Cannot be ptruint because used field is signed.}
|
|
next_free : poschunk;
|
|
prev_any : poschunk;
|
|
next_any : poschunk;
|
|
used : ptrint; { 0: free, >0: fixed, -1: var }
|
|
freelists : pfreelists;
|
|
{ padding inserted automatically by alloc_oschunk }
|
|
end;
|
|
|
|
ppmemchunk_fixed = ^pmemchunk_fixed;
|
|
pmemchunk_fixed = ^tmemchunk_fixed;
|
|
tmemchunk_fixed = record
|
|
{ aligning is done automatically in alloc_oschunk }
|
|
size : ptruint;
|
|
next_fixed,
|
|
prev_fixed : pmemchunk_fixed;
|
|
end;
|
|
|
|
ppmemchunk_var = ^pmemchunk_var;
|
|
pmemchunk_var = ^tmemchunk_var;
|
|
tmemchunk_var = record
|
|
prevsize : ptruint;
|
|
freelists : pfreelists;
|
|
size : ptruint;
|
|
next_var,
|
|
prev_var : pmemchunk_var;
|
|
end;
|
|
|
|
{ ``header'', ie. size of structure valid when chunk is in use }
|
|
{ should correspond to tmemchunk_var_hdr structure starting with the
|
|
last field. Reason is that the overlap is starting from the end of the
|
|
record. }
|
|
tmemchunk_fixed_hdr = record
|
|
{ aligning is done automatically in alloc_oschunk }
|
|
size : ptruint;
|
|
end;
|
|
tmemchunk_var_hdr = record
|
|
prevsize : ptruint;
|
|
freelists : pfreelists;
|
|
size : ptruint;
|
|
end;
|
|
|
|
pfpcheapstatus = ^tfpcheapstatus;
|
|
|
|
tfixedfreelists = array[1..maxblockindex] of pmemchunk_fixed;
|
|
|
|
tfreelists = record
|
|
oslist : poschunk; { os chunks free, available for use }
|
|
oscount : dword; { number of os chunks on oslist }
|
|
oslist_all : poschunk; { all os chunks allocated }
|
|
fixedlists : tfixedfreelists;
|
|
varlist : pmemchunk_var;
|
|
{ chunks waiting to be freed from other thread }
|
|
waitfixed : pmemchunk_fixed;
|
|
waitvar : pmemchunk_var;
|
|
{ heap statistics }
|
|
internal_status : TFPCHeapStatus;
|
|
end;
|
|
|
|
const
|
|
fixedfirstoffset = ((sizeof(toschunk) + sizeof(tmemchunk_fixed_hdr) + $f)
|
|
and not $f) - sizeof(tmemchunk_fixed_hdr);
|
|
varfirstoffset = ((sizeof(toschunk) + sizeof(tmemchunk_var_hdr) + $f)
|
|
and not $f) - sizeof(tmemchunk_var_hdr);
|
|
{$ifdef BESTMATCH}
|
|
matcheffort = high(longint);
|
|
{$else}
|
|
matcheffort = 10;
|
|
{$endif}
|
|
|
|
var
|
|
main_relo_freelists : pfreelists;
|
|
orphaned_freelists : tfreelists;
|
|
heap_lock : trtlcriticalsection;
|
|
threadvar
|
|
freelists : tfreelists;
|
|
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
const
|
|
sizeusageshift = 4;
|
|
sizeusageindex = 2049;
|
|
sizeusagesize = sizeusageindex shl sizeusageshift;
|
|
type
|
|
tsizeusagelist = array[0..sizeusageindex] of longint;
|
|
threadvar
|
|
sizeusage, maxsizeusage: tsizeusagelist;
|
|
{$endif}
|
|
|
|
{$endif HAS_MEMORYMANAGER}
|
|
|
|
{*****************************************************************************
|
|
Memory Manager
|
|
*****************************************************************************}
|
|
|
|
procedure GetMemoryManager(var MemMgr:TMemoryManager);
|
|
begin
|
|
MemMgr := MemoryManager;
|
|
end;
|
|
|
|
|
|
procedure SetMemoryManager(const MemMgr:TMemoryManager);
|
|
begin
|
|
MemoryManager := MemMgr;
|
|
end;
|
|
|
|
function IsMemoryManagerSet:Boolean;
|
|
begin
|
|
IsMemoryManagerSet := (MemoryManager.GetMem<>@SysGetMem)
|
|
or (MemoryManager.FreeMem<>@SysFreeMem);
|
|
end;
|
|
|
|
procedure GetMem(Var p:pointer;Size:ptruint);
|
|
begin
|
|
p := MemoryManager.GetMem(Size);
|
|
end;
|
|
|
|
procedure GetMemory(Var p:pointer;Size:ptruint);
|
|
begin
|
|
GetMem(p,size);
|
|
end;
|
|
|
|
procedure FreeMem(p:pointer;Size:ptruint);
|
|
begin
|
|
MemoryManager.FreeMemSize(p,Size);
|
|
end;
|
|
|
|
procedure FreeMemory(p:pointer;Size:ptruint);
|
|
begin
|
|
FreeMem(p,size);
|
|
end;
|
|
|
|
|
|
function GetHeapStatus:THeapStatus;
|
|
begin
|
|
Result:=MemoryManager.GetHeapStatus();
|
|
end;
|
|
|
|
|
|
function GetFPCHeapStatus:TFPCHeapStatus;
|
|
begin
|
|
Result:=MemoryManager.GetFPCHeapStatus();
|
|
end;
|
|
|
|
|
|
function MemSize(p:pointer):ptruint;
|
|
begin
|
|
MemSize := MemoryManager.MemSize(p);
|
|
end;
|
|
|
|
|
|
{ Delphi style }
|
|
function FreeMem(p:pointer):ptruint;[Public,Alias:'FPC_FREEMEM_X'];
|
|
begin
|
|
FreeMem := MemoryManager.FreeMem(p);
|
|
end;
|
|
|
|
function FreeMemory(p:pointer):ptruint;
|
|
begin
|
|
FreeMemory := FreeMem(p);
|
|
end;
|
|
|
|
function GetMem(size:ptruint):pointer;
|
|
begin
|
|
GetMem := MemoryManager.GetMem(Size);
|
|
end;
|
|
|
|
function GetMemory(size:ptruint):pointer;
|
|
begin
|
|
GetMemory := GetMem(size);
|
|
end;
|
|
|
|
function AllocMem(Size:ptruint):pointer;
|
|
begin
|
|
AllocMem := MemoryManager.AllocMem(size);
|
|
end;
|
|
|
|
|
|
function ReAllocMem(var p:pointer;Size:ptruint):pointer;
|
|
begin
|
|
ReAllocMem := MemoryManager.ReAllocMem(p,size);
|
|
end;
|
|
|
|
function ReAllocMemory(var p:pointer;Size:ptruint):pointer;
|
|
begin
|
|
ReAllocMemory := ReAllocMem(p,size);
|
|
end;
|
|
|
|
|
|
{ Needed for calls from Assembler }
|
|
function fpc_getmem(size:ptruint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
|
|
begin
|
|
fpc_GetMem := MemoryManager.GetMem(size);
|
|
end;
|
|
|
|
procedure fpc_freemem(p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
|
|
begin
|
|
MemoryManager.FreeMem(p);
|
|
end;
|
|
|
|
{$ifndef HAS_MEMORYMANAGER}
|
|
{*****************************************************************************
|
|
GetHeapStatus
|
|
*****************************************************************************}
|
|
|
|
function SysGetFPCHeapStatus:TFPCHeapStatus;
|
|
var
|
|
status: pfpcheapstatus;
|
|
begin
|
|
status := @freelists.internal_status;
|
|
status^.CurrHeapFree := status^.CurrHeapSize - status^.CurrHeapUsed;
|
|
result := status^;
|
|
end;
|
|
|
|
function SysGetHeapStatus :THeapStatus;
|
|
var
|
|
status: pfpcheapstatus;
|
|
begin
|
|
status := @freelists.internal_status;
|
|
status^.CurrHeapFree := status^.CurrHeapSize - status^.CurrHeapUsed;
|
|
result.TotalAllocated :=status^.CurrHeapUsed;
|
|
result.TotalFree :=status^.CurrHeapFree;
|
|
result.TotalAddrSpace :=status^.CurrHeapSize;
|
|
result.TotalUncommitted :=0;
|
|
result.TotalCommitted :=0;
|
|
result.FreeSmall :=0;
|
|
result.FreeBig :=0;
|
|
result.Unused :=0;
|
|
result.Overhead :=0;
|
|
result.HeapErrorCode :=0;
|
|
end;
|
|
|
|
|
|
{$ifdef DUMPBLOCKS} // TODO
|
|
procedure DumpBlocks(loc_freelists: pfreelists);
|
|
var
|
|
s,i,j : ptruint;
|
|
hpfixed : pmemchunk_fixed;
|
|
hpvar : pmemchunk_var;
|
|
begin
|
|
{ fixed freelist }
|
|
for i := 1 to maxblockindex do
|
|
begin
|
|
hpfixed := loc_freelists^.fixedlists[i];
|
|
j := 0;
|
|
while assigned(hpfixed) do
|
|
begin
|
|
inc(j);
|
|
hpfixed := hpfixed^.next_fixed;
|
|
end;
|
|
writeln('Block ',i*blocksize,': ',j);
|
|
end;
|
|
{ var freelist }
|
|
hpvar := loc_freelists^.varlist;
|
|
j := 0;
|
|
s := 0;
|
|
while assigned(hpvar) do
|
|
begin
|
|
inc(j);
|
|
if hpvar^.size>s then
|
|
s := hpvar^.size;
|
|
hpvar := hpvar^.next_var;
|
|
end;
|
|
writeln('Variable: ',j,' maxsize: ',s);
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
{*****************************************************************************
|
|
Forwards
|
|
*****************************************************************************}
|
|
|
|
procedure finish_waitfixedlist(loc_freelists: pfreelists); forward;
|
|
procedure finish_waitvarlist(loc_freelists: pfreelists); forward;
|
|
function try_finish_waitfixedlist(loc_freelists: pfreelists): boolean; forward;
|
|
procedure try_finish_waitvarlist(loc_freelists: pfreelists); forward;
|
|
|
|
{*****************************************************************************
|
|
List adding/removal
|
|
*****************************************************************************}
|
|
|
|
procedure append_to_list_var(pmc: pmemchunk_var); inline;
|
|
var
|
|
varlist: ppmemchunk_var;
|
|
begin
|
|
varlist := @pmc^.freelists^.varlist;
|
|
pmc^.prev_var := nil;
|
|
pmc^.next_var := varlist^;
|
|
if varlist^<>nil then
|
|
varlist^^.prev_var := pmc;
|
|
varlist^ := pmc;
|
|
end;
|
|
|
|
{$ifdef HEAP_DEBUG}
|
|
|
|
function find_fixed_mc(loc_freelists: pfreelists; chunkindex: ptruint;
|
|
pmc: pmemchunk_fixed): boolean;
|
|
var
|
|
pmc_temp: pmemchunk_fixed;
|
|
begin
|
|
pmc_temp := loc_freelists^.fixedlists[chunkindex];
|
|
while pmc_temp <> nil do
|
|
begin
|
|
if pmc_temp = pmc then exit(true);
|
|
pmc_temp := pmc_temp^.next_fixed;
|
|
end;
|
|
result := false;
|
|
end;
|
|
|
|
{$endif}
|
|
|
|
procedure remove_from_list_fixed(pmc: pmemchunk_fixed; fixedlist: ppmemchunk_fixed); inline;
|
|
begin
|
|
if assigned(pmc^.next_fixed) then
|
|
pmc^.next_fixed^.prev_fixed := pmc^.prev_fixed;
|
|
if assigned(pmc^.prev_fixed) then
|
|
pmc^.prev_fixed^.next_fixed := pmc^.next_fixed
|
|
else
|
|
fixedlist^ := pmc^.next_fixed;
|
|
end;
|
|
|
|
procedure remove_from_list_var(pmc: pmemchunk_var); inline;
|
|
begin
|
|
if assigned(pmc^.next_var) then
|
|
pmc^.next_var^.prev_var := pmc^.prev_var;
|
|
if assigned(pmc^.prev_var) then
|
|
pmc^.prev_var^.next_var := pmc^.next_var
|
|
else
|
|
pmc^.freelists^.varlist := pmc^.next_var;
|
|
end;
|
|
|
|
procedure remove_freed_fixed_chunks(poc: poschunk);
|
|
{ remove all fixed chunks from the fixed free list, as this os chunk
|
|
is going to be used for other purpose }
|
|
var
|
|
pmc, pmc_end: pmemchunk_fixed;
|
|
fixedlist: ppmemchunk_fixed;
|
|
chunksize: ptruint;
|
|
begin
|
|
{ exit if this is a var size os chunk, function only applicable to fixed size }
|
|
if poc^.used < 0 then
|
|
exit;
|
|
pmc := pmemchunk_fixed(pointer(poc)+fixedfirstoffset);
|
|
chunksize := pmc^.size and fixedsizemask;
|
|
pmc_end := pmemchunk_fixed(pointer(poc)+(poc^.size and sizemask)-chunksize);
|
|
fixedlist := @poc^.freelists^.fixedlists[chunksize shr blockshift];
|
|
repeat
|
|
remove_from_list_fixed(pmc, fixedlist);
|
|
pmc := pointer(pmc)+chunksize;
|
|
until pmc > pmc_end;
|
|
end;
|
|
|
|
procedure free_oschunk(loc_freelists: pfreelists; poc: poschunk);
|
|
var
|
|
pocsize: ptruint;
|
|
begin
|
|
remove_freed_fixed_chunks(poc);
|
|
if assigned(poc^.prev_any) then
|
|
poc^.prev_any^.next_any := poc^.next_any
|
|
else
|
|
loc_freelists^.oslist_all := poc^.next_any;
|
|
if assigned(poc^.next_any) then
|
|
poc^.next_any^.prev_any := poc^.prev_any;
|
|
pocsize := poc^.size and sizemask;
|
|
dec(loc_freelists^.internal_status.currheapsize, pocsize);
|
|
SysOSFree(poc, pocsize);
|
|
end;
|
|
|
|
procedure append_to_oslist(poc: poschunk);
|
|
var
|
|
loc_freelists: pfreelists;
|
|
begin
|
|
loc_freelists := poc^.freelists;
|
|
{ check if already on list }
|
|
if (poc^.size and ocrecycleflag) <> 0 then
|
|
begin
|
|
inc(loc_freelists^.oscount);
|
|
poc^.size := poc^.size and not ocrecycleflag;
|
|
exit;
|
|
end;
|
|
{ decide whether to free block or add to list }
|
|
{$ifdef HAS_SYSOSFREE}
|
|
if (loc_freelists^.oscount >= MaxKeptOSChunks) or
|
|
((poc^.size and sizemask) > growheapsize2) then
|
|
begin
|
|
free_oschunk(loc_freelists, poc);
|
|
end
|
|
else
|
|
begin
|
|
{$endif}
|
|
poc^.next_free := loc_freelists^.oslist;
|
|
loc_freelists^.oslist := poc;
|
|
inc(loc_freelists^.oscount);
|
|
{$ifdef HAS_SYSOSFREE}
|
|
end;
|
|
{$endif}
|
|
end;
|
|
|
|
procedure append_to_oslist_var(pmc: pmemchunk_var);
|
|
var
|
|
poc: poschunk;
|
|
begin
|
|
// block eligable for freeing
|
|
poc := pointer(pmc)-varfirstoffset;
|
|
remove_from_list_var(pmc);
|
|
append_to_oslist(poc);
|
|
end;
|
|
|
|
procedure modify_oschunk_freelists(poc: poschunk; new_freelists: pfreelists);
|
|
var
|
|
pmcv: pmemchunk_var;
|
|
begin
|
|
poc^.freelists := new_freelists;
|
|
{ only if oschunk contains var memchunks, we need additional assignments }
|
|
if poc^.used <> -1 then exit;
|
|
pmcv := pmemchunk_var(pointer(poc)+varfirstoffset);
|
|
repeat
|
|
pmcv^.freelists := new_freelists;
|
|
if (pmcv^.size and lastblockflag) <> 0 then
|
|
break;
|
|
pmcv := pmemchunk_var(pointer(pmcv)+(pmcv^.size and sizemask));
|
|
until false;
|
|
end;
|
|
|
|
function modify_freelists(loc_freelists, new_freelists: pfreelists): poschunk;
|
|
var
|
|
poc: poschunk;
|
|
begin
|
|
poc := loc_freelists^.oslist_all;
|
|
if assigned(poc) then
|
|
begin
|
|
repeat
|
|
{ fixed and var freelist for orphaned freelists do not need maintenance }
|
|
{ we assume the heap is not severely fragmented at thread exit }
|
|
modify_oschunk_freelists(poc, new_freelists);
|
|
if not assigned(poc^.next_any) then
|
|
exit(poc);
|
|
poc := poc^.next_any;
|
|
until false;
|
|
end;
|
|
modify_freelists := nil;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
Split block
|
|
*****************************************************************************}
|
|
|
|
function split_block(pcurr: pmemchunk_var; size: ptruint): ptruint;
|
|
var
|
|
pcurr_tmp : pmemchunk_var;
|
|
size_flags, oldsize, sizeleft: ptruint;
|
|
begin
|
|
size_flags := pcurr^.size;
|
|
oldsize := size_flags and sizemask;
|
|
sizeleft := oldsize-size;
|
|
if sizeleft>=sizeof(tmemchunk_var) then
|
|
begin
|
|
pcurr_tmp := pmemchunk_var(pointer(pcurr)+size);
|
|
{ update prevsize of block to the right }
|
|
if (size_flags and lastblockflag) = 0 then
|
|
pmemchunk_var(pointer(pcurr)+oldsize)^.prevsize := sizeleft;
|
|
{ inherit the lastblockflag }
|
|
pcurr_tmp^.size := sizeleft or (size_flags and lastblockflag);
|
|
pcurr_tmp^.prevsize := size;
|
|
pcurr_tmp^.freelists := pcurr^.freelists;
|
|
{ the block we return is not the last one anymore (there's now a block after it) }
|
|
{ decrease size of block to new size }
|
|
pcurr^.size := size or (size_flags and (not sizemask and not lastblockflag));
|
|
{ insert the block in the freelist }
|
|
append_to_list_var(pcurr_tmp);
|
|
result := size;
|
|
end
|
|
else
|
|
result := oldsize;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Try concat freerecords
|
|
*****************************************************************************}
|
|
|
|
procedure concat_two_blocks(mc_left, mc_right: pmemchunk_var);
|
|
var
|
|
mc_tmp : pmemchunk_var;
|
|
size_right : ptruint;
|
|
begin
|
|
// mc_right can't be a fixed size block
|
|
if mc_right^.size and fixedsizeflag<>0 then
|
|
HandleError(204);
|
|
// left block free, concat with right-block
|
|
size_right := mc_right^.size and sizemask;
|
|
inc(mc_left^.size, size_right);
|
|
// if right-block was last block, copy flag
|
|
if (mc_right^.size and lastblockflag) <> 0 then
|
|
begin
|
|
mc_left^.size := mc_left^.size or lastblockflag;
|
|
end
|
|
else
|
|
begin
|
|
// there is a block to the right of the right-block, adjust it's prevsize
|
|
mc_tmp := pmemchunk_var(pointer(mc_right)+size_right);
|
|
mc_tmp^.prevsize := mc_left^.size and sizemask;
|
|
end;
|
|
// remove right-block from doubly linked list
|
|
remove_from_list_var(mc_right);
|
|
end;
|
|
|
|
function try_concat_free_chunk_forward(mc: pmemchunk_var): boolean;
|
|
var
|
|
mc_tmp : pmemchunk_var;
|
|
begin
|
|
{ try concat forward }
|
|
result := false;
|
|
if (mc^.size and lastblockflag) = 0 then
|
|
begin
|
|
mc_tmp := pmemchunk_var(pointer(mc)+(mc^.size and sizemask));
|
|
if (mc_tmp^.size and usedflag) = 0 then
|
|
begin
|
|
// next block free: concat
|
|
concat_two_blocks(mc, mc_tmp);
|
|
result := true;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function try_concat_free_chunk(mc: pmemchunk_var): pmemchunk_var;
|
|
var
|
|
mc_tmp : pmemchunk_var;
|
|
begin
|
|
try_concat_free_chunk_forward(mc);
|
|
|
|
{ try concat backward }
|
|
if (mc^.size and firstblockflag) = 0 then
|
|
begin
|
|
mc_tmp := pmemchunk_var(pointer(mc)-mc^.prevsize);
|
|
if (mc_tmp^.size and usedflag) = 0 then
|
|
begin
|
|
// prior block free: concat
|
|
concat_two_blocks(mc_tmp, mc);
|
|
mc := mc_tmp;
|
|
end;
|
|
end;
|
|
|
|
result := mc;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Grow Heap
|
|
*****************************************************************************}
|
|
|
|
function find_free_oschunk(loc_freelists: pfreelists;
|
|
minsize, maxsize: ptruint; var size: ptruint): poschunk;
|
|
var
|
|
prev_poc, poc: poschunk;
|
|
pocsize: ptruint;
|
|
begin
|
|
poc := loc_freelists^.oslist;
|
|
prev_poc := nil;
|
|
while poc <> nil do
|
|
begin
|
|
if (poc^.size and ocrecycleflag) <> 0 then
|
|
begin
|
|
{ oops! we recycled this chunk; remove it from list }
|
|
poc^.size := poc^.size and not ocrecycleflag;
|
|
poc := poc^.next_free;
|
|
if prev_poc = nil then
|
|
loc_freelists^.oslist := poc
|
|
else
|
|
prev_poc^.next_free := poc;
|
|
continue;
|
|
end;
|
|
pocsize := poc^.size and sizemask;
|
|
if (pocsize >= minsize) and
|
|
(pocsize <= maxsize) then
|
|
begin
|
|
size := pocsize;
|
|
if prev_poc = nil then
|
|
loc_freelists^.oslist := poc^.next_free
|
|
else
|
|
prev_poc^.next_free := poc^.next_free;
|
|
dec(loc_freelists^.oscount);
|
|
remove_freed_fixed_chunks(poc);
|
|
break;
|
|
end;
|
|
prev_poc := poc;
|
|
poc := poc^.next_free;
|
|
end;
|
|
result := poc;
|
|
end;
|
|
|
|
function alloc_oschunk(loc_freelists: pfreelists; chunkindex, size: ptruint): pointer;
|
|
var
|
|
pmc,
|
|
pmc_next : pmemchunk_fixed;
|
|
pmcv : pmemchunk_var;
|
|
poc : poschunk;
|
|
minsize,
|
|
maxsize,
|
|
i : ptruint;
|
|
chunksize : ptruint;
|
|
status : pfpcheapstatus;
|
|
begin
|
|
{ increase size by size needed for os block header }
|
|
minsize := size + varfirstoffset;
|
|
{ for fixed size chunks we keep offset from os chunk to mem chunk in
|
|
upper bits, so maximum os chunk size is 64K on 32bit for fixed size }
|
|
if chunkindex<>0 then
|
|
maxsize := 1 shl (32-fixedoffsetshift)
|
|
else
|
|
maxsize := high(ptruint);
|
|
poc:=nil;
|
|
if (loc_freelists^.oscount>=MaxKeptOSChunks) then
|
|
begin
|
|
{ blocks available in freelist? }
|
|
poc := find_free_oschunk(loc_freelists, minsize, maxsize, size);
|
|
if not assigned(poc) and (assigned(orphaned_freelists.waitfixed)
|
|
or assigned(orphaned_freelists.waitvar) or (orphaned_freelists.oscount > 0)) then
|
|
begin
|
|
entercriticalsection(heap_lock);
|
|
finish_waitfixedlist(@orphaned_freelists);
|
|
finish_waitvarlist(@orphaned_freelists);
|
|
if orphaned_freelists.oscount > 0 then
|
|
begin
|
|
{ blocks available in orphaned freelist ? }
|
|
poc := find_free_oschunk(@orphaned_freelists, minsize, maxsize, size);
|
|
if assigned(poc) then
|
|
begin
|
|
{ adopt this os chunk }
|
|
poc^.freelists := loc_freelists;
|
|
if assigned(poc^.prev_any) then
|
|
poc^.prev_any^.next_any := poc^.next_any
|
|
else
|
|
orphaned_freelists.oslist_all := poc^.next_any;
|
|
if assigned(poc^.next_any) then
|
|
poc^.next_any^.prev_any := poc^.prev_any;
|
|
poc^.next_any := loc_freelists^.oslist_all;
|
|
if assigned(loc_freelists^.oslist_all) then
|
|
loc_freelists^.oslist_all^.prev_any := poc;
|
|
poc^.prev_any := nil;
|
|
loc_freelists^.oslist_all := poc;
|
|
end;
|
|
end;
|
|
leavecriticalsection(heap_lock);
|
|
end;
|
|
end;
|
|
if poc = nil then
|
|
begin
|
|
{$ifdef DUMPGROW}
|
|
writeln('growheap(',size,') allocating ',(size+sizeof(toschunk)+$ffff) and not $ffff);
|
|
DumpBlocks(loc_freelists);
|
|
{$endif}
|
|
{ allocate by 64K size }
|
|
size := (size+varfirstoffset+$ffff) and not $ffff;
|
|
{ allocate smaller blocks for fixed-size chunks }
|
|
if chunkindex<>0 then
|
|
begin
|
|
poc := SysOSAlloc(GrowHeapSizeSmall);
|
|
if poc<>nil then
|
|
size := GrowHeapSizeSmall;
|
|
end
|
|
{ first try 256K (default) }
|
|
else if size<=GrowHeapSize1 then
|
|
begin
|
|
poc := SysOSAlloc(GrowHeapSize1);
|
|
if poc<>nil then
|
|
size := GrowHeapSize1;
|
|
end
|
|
{ second try 1024K (default) }
|
|
else if size<=GrowHeapSize2 then
|
|
begin
|
|
poc := SysOSAlloc(GrowHeapSize2);
|
|
if poc<>nil then
|
|
size := GrowHeapSize2;
|
|
end
|
|
{ else allocate the needed bytes }
|
|
else
|
|
poc := SysOSAlloc(size);
|
|
{ try again }
|
|
if poc=nil then
|
|
begin
|
|
poc := SysOSAlloc(size);
|
|
if poc=nil then
|
|
begin
|
|
if ReturnNilIfGrowHeapFails then
|
|
begin
|
|
result := nil;
|
|
exit
|
|
end
|
|
else
|
|
HandleError(203);
|
|
end;
|
|
end;
|
|
poc^.freelists := loc_freelists;
|
|
poc^.prev_any := nil;
|
|
poc^.next_any := loc_freelists^.oslist_all;
|
|
if assigned(loc_freelists^.oslist_all) then
|
|
loc_freelists^.oslist_all^.prev_any := poc;
|
|
loc_freelists^.oslist_all := poc;
|
|
{ set the total new heap size }
|
|
status := @loc_freelists^.internal_status;
|
|
inc(status^.currheapsize, size);
|
|
if status^.currheapsize > status^.maxheapsize then
|
|
status^.maxheapsize := status^.currheapsize;
|
|
end;
|
|
{ initialize os-block }
|
|
poc^.size := size;
|
|
if chunkindex<>0 then
|
|
begin
|
|
poc^.used := 0;
|
|
{ chop os chunk in fixedsize parts,
|
|
maximum of $ffff elements are allowed, otherwise
|
|
there will be an overflow }
|
|
chunksize := chunkindex shl blockshift;
|
|
if ptruint(size-chunksize)>maxsize then
|
|
HandleError(204);
|
|
{ we need to align the user pointers to 8 byte at least for
|
|
mmx/sse and doubles on sparc, align to 16 bytes }
|
|
i := fixedfirstoffset;
|
|
result := pointer(poc) + i;
|
|
pmc := pmemchunk_fixed(result);
|
|
pmc^.prev_fixed := nil;
|
|
repeat
|
|
pmc^.size := fixedsizeflag or chunksize or (i shl fixedoffsetshift);
|
|
inc(i, chunksize);
|
|
if i > ptruint(size - chunksize) then break;
|
|
pmc_next := pmemchunk_fixed(pointer(pmc)+chunksize);
|
|
pmc^.next_fixed := pmc_next;
|
|
pmc_next^.prev_fixed := pmc;
|
|
pmc := pmc_next;
|
|
until false;
|
|
pmc_next := loc_freelists^.fixedlists[chunkindex];
|
|
pmc^.next_fixed := pmc_next;
|
|
if pmc_next<>nil then
|
|
pmc_next^.prev_fixed := pmc;
|
|
loc_freelists^.fixedlists[chunkindex] := pmemchunk_fixed(result);
|
|
end
|
|
else
|
|
begin
|
|
poc^.used := -1;
|
|
{ we need to align the user pointers to 8 byte at least for
|
|
mmx/sse and doubles on sparc, align to 16 bytes }
|
|
result := pointer(poc)+varfirstoffset;
|
|
pmcv := pmemchunk_var(result);
|
|
pmcv^.size := (ptruint(size-varfirstoffset) and sizemask) or (firstblockflag or lastblockflag);
|
|
pmcv^.prevsize := 0;
|
|
pmcv^.freelists := loc_freelists;
|
|
append_to_list_var(pmcv);
|
|
end;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
SysGetMem
|
|
*****************************************************************************}
|
|
|
|
function SysGetMem_Fixed(chunksize: ptruint): pointer;
|
|
var
|
|
pmc, pmc_next: pmemchunk_fixed;
|
|
poc: poschunk;
|
|
chunkindex: ptruint;
|
|
loc_freelists: pfreelists;
|
|
begin
|
|
{ try to find a block in one of the freelists per size }
|
|
chunkindex := chunksize shr blockshift;
|
|
loc_freelists := @freelists;
|
|
pmc := loc_freelists^.fixedlists[chunkindex];
|
|
{ no free blocks ? }
|
|
if assigned(pmc) then
|
|
begin
|
|
{ remove oschunk from free list in case we recycle it }
|
|
poc := poschunk(pointer(pmc) - (pmc^.size shr fixedoffsetshift));
|
|
if poc^.used = 0 then
|
|
begin
|
|
poc^.size := poc^.size or ocrecycleflag;
|
|
dec(loc_freelists^.oscount);
|
|
end;
|
|
end
|
|
else if try_finish_waitfixedlist(loc_freelists) then
|
|
{ freed some to-be freed chunks, retry allocation }
|
|
exit(SysGetMem_Fixed(chunksize))
|
|
else
|
|
begin
|
|
pmc := alloc_oschunk(loc_freelists, chunkindex, chunksize);
|
|
if not assigned(pmc) then
|
|
exit(nil);
|
|
poc := poschunk(pointer(pmc)-fixedfirstoffset);
|
|
end;
|
|
{ get a pointer to the block we should return }
|
|
result := pointer(pmc)+sizeof(tmemchunk_fixed_hdr);
|
|
{ update freelist }
|
|
pmc_next := pmc^.next_fixed;
|
|
loc_freelists^.fixedlists[chunkindex] := pmc_next;
|
|
if assigned(pmc_next) then
|
|
pmc_next^.prev_fixed := nil;
|
|
inc(poc^.used);
|
|
{ statistics }
|
|
with loc_freelists^.internal_status do
|
|
begin
|
|
inc(currheapused, chunksize);
|
|
if currheapused > maxheapused then
|
|
begin
|
|
maxheapused := currheapused;
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
maxsizeusage := sizeusage;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function SysGetMem_Var(size: ptruint): pointer;
|
|
var
|
|
pcurr : pmemchunk_var;
|
|
pbest : pmemchunk_var;
|
|
loc_freelists : pfreelists;
|
|
iter : cardinal;
|
|
begin
|
|
result:=nil;
|
|
{ free pending items }
|
|
loc_freelists := @freelists;
|
|
try_finish_waitvarlist(loc_freelists);
|
|
pbest := nil;
|
|
pcurr := loc_freelists^.varlist;
|
|
iter := high(iter);
|
|
while assigned(pcurr) and (iter>0) do
|
|
begin
|
|
if (pcurr^.size>size) then
|
|
begin
|
|
if not assigned(pbest) or (pcurr^.size<pbest^.size) then
|
|
begin
|
|
pbest := pcurr;
|
|
if pcurr^.size = size then
|
|
break;
|
|
iter := matcheffort;
|
|
end;
|
|
end;
|
|
pcurr := pcurr^.next_var;
|
|
dec(iter);
|
|
end;
|
|
pcurr := pbest;
|
|
|
|
if not assigned(pcurr) then
|
|
begin
|
|
// all os-chunks full, allocate a new one
|
|
pcurr := alloc_oschunk(loc_freelists, 0, size);
|
|
if not assigned(pcurr) then
|
|
exit;
|
|
end;
|
|
|
|
{ get pointer of the block we should return }
|
|
result := pointer(pcurr)+sizeof(tmemchunk_var_hdr);
|
|
{ remove the current block from the freelist }
|
|
remove_from_list_var(pcurr);
|
|
{ create the left over freelist block, if at least 16 bytes are free }
|
|
size := split_block(pcurr, size);
|
|
{ flag block as used }
|
|
pcurr^.size := pcurr^.size or usedflag;
|
|
{ statistics }
|
|
with loc_freelists^.internal_status do
|
|
begin
|
|
inc(currheapused, size);
|
|
if currheapused > maxheapused then
|
|
begin
|
|
maxheapused := currheapused;
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
maxsizeusage := sizeusage;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function SysGetMem(size : ptruint):pointer;
|
|
begin
|
|
{ Something to allocate ? }
|
|
if size=0 then
|
|
{ we always need to allocate something, using heapend is not possible,
|
|
because heappend can be changed by growheap (PFV) }
|
|
size := 1;
|
|
{ calc to multiple of 16 after adding the needed bytes for memchunk header }
|
|
if size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr)) then
|
|
begin
|
|
size := (size+(sizeof(tmemchunk_fixed_hdr)+(blocksize-1))) and fixedsizemask;
|
|
result := sysgetmem_fixed(size);
|
|
end
|
|
else
|
|
begin
|
|
size := (size+(sizeof(tmemchunk_var_hdr)+(blocksize-1))) and sizemask;
|
|
result := sysgetmem_var(size);
|
|
end;
|
|
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
size := sysmemsize(result);
|
|
if size > sizeusagesize then
|
|
inc(sizeusage[sizeusageindex])
|
|
else
|
|
inc(sizeusage[size shr sizeusageshift]);
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
SysFreeMem
|
|
*****************************************************************************}
|
|
|
|
procedure waitfree_fixed(pmc: pmemchunk_fixed; poc: poschunk);
|
|
begin
|
|
entercriticalsection(heap_lock);
|
|
pmc^.next_fixed := poc^.freelists^.waitfixed;
|
|
poc^.freelists^.waitfixed := pmc;
|
|
leavecriticalsection(heap_lock);
|
|
end;
|
|
|
|
procedure waitfree_var(pmcv: pmemchunk_var);
|
|
begin
|
|
entercriticalsection(heap_lock);
|
|
pmcv^.next_var := pmcv^.freelists^.waitvar;
|
|
pmcv^.freelists^.waitvar := pmcv;
|
|
leavecriticalsection(heap_lock);
|
|
end;
|
|
|
|
function SysFreeMem_Fixed(loc_freelists: pfreelists; pmc: pmemchunk_fixed): ptruint;
|
|
var
|
|
chunkindex,
|
|
chunksize: ptruint;
|
|
poc: poschunk;
|
|
pmc_next: pmemchunk_fixed;
|
|
begin
|
|
poc := poschunk(pointer(pmc)-(pmc^.size shr fixedoffsetshift));
|
|
chunksize := pmc^.size and fixedsizemask;
|
|
if loc_freelists <> poc^.freelists then
|
|
begin
|
|
{ deallocated in wrong thread! add to to-be-freed list of correct thread }
|
|
waitfree_fixed(pmc, poc);
|
|
exit(chunksize);
|
|
end;
|
|
|
|
dec(loc_freelists^.internal_status.currheapused, chunksize);
|
|
{ insert the block in its freelist }
|
|
chunkindex := chunksize shr blockshift;
|
|
pmc_next := loc_freelists^.fixedlists[chunkindex];
|
|
pmc^.prev_fixed := nil;
|
|
pmc^.next_fixed := pmc_next;
|
|
if assigned(pmc_next) then
|
|
pmc_next^.prev_fixed := pmc;
|
|
loc_freelists^.fixedlists[chunkindex] := pmc;
|
|
{ decrease used blocks count }
|
|
dec(poc^.used);
|
|
if poc^.used <= 0 then
|
|
begin
|
|
{ decrease used blocks count }
|
|
if poc^.used<0 then
|
|
HandleError(204);
|
|
{ osblock can be freed? }
|
|
append_to_oslist(poc);
|
|
end;
|
|
result := chunksize;
|
|
end;
|
|
|
|
function SysFreeMem_Var(loc_freelists: pfreelists; pmcv: pmemchunk_var): ptruint;
|
|
var
|
|
chunksize: ptruint;
|
|
begin
|
|
chunksize := pmcv^.size and sizemask;
|
|
if loc_freelists <> pmcv^.freelists then
|
|
begin
|
|
{ deallocated in wrong thread! add to to-be-freed list of correct thread }
|
|
waitfree_var(pmcv);
|
|
exit(chunksize);
|
|
end;
|
|
|
|
dec(loc_freelists^.internal_status.currheapused, chunksize);
|
|
{ insert the block in it's freelist }
|
|
pmcv^.size := pmcv^.size and (not usedflag);
|
|
append_to_list_var(pmcv);
|
|
pmcv := try_concat_free_chunk(pmcv);
|
|
if (pmcv^.size and (firstblockflag or lastblockflag)) = (firstblockflag or lastblockflag) then
|
|
append_to_oslist_var(pmcv);
|
|
result := chunksize;
|
|
end;
|
|
|
|
|
|
function SysFreeMem(p: pointer): ptruint;
|
|
var
|
|
pmc: pmemchunk_fixed;
|
|
loc_freelists: pfreelists;
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
size: sizeint;
|
|
{$endif}
|
|
begin
|
|
if p=nil then
|
|
begin
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
size := sysmemsize(p);
|
|
if size > sizeusagesize then
|
|
dec(sizeusage[sizeusageindex])
|
|
else
|
|
dec(sizeusage[size shr sizeusageshift]);
|
|
{$endif}
|
|
loc_freelists := @freelists;
|
|
pmc := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr));
|
|
{ check if this is a fixed- or var-sized chunk }
|
|
if (pmc^.size and fixedsizeflag) = 0 then
|
|
result := sysfreemem_var(loc_freelists, pmemchunk_var(p-sizeof(tmemchunk_var_hdr)))
|
|
else
|
|
result := sysfreemem_fixed(loc_freelists, pmc);
|
|
end;
|
|
|
|
procedure finish_waitfixedlist(loc_freelists: pfreelists);
|
|
{ free to-be-freed chunks, return whether we freed anything }
|
|
var
|
|
pmc: pmemchunk_fixed;
|
|
begin
|
|
while loc_freelists^.waitfixed <> nil do
|
|
begin
|
|
{ keep next_fixed, might be destroyed }
|
|
pmc := loc_freelists^.waitfixed;
|
|
loc_freelists^.waitfixed := pmc^.next_fixed;
|
|
SysFreeMem_Fixed(loc_freelists, pmc);
|
|
end;
|
|
end;
|
|
|
|
function try_finish_waitfixedlist(loc_freelists: pfreelists): boolean;
|
|
begin
|
|
if loc_freelists^.waitfixed = nil then
|
|
exit(false);
|
|
entercriticalsection(heap_lock);
|
|
finish_waitfixedlist(loc_freelists);
|
|
leavecriticalsection(heap_lock);
|
|
result := true;
|
|
end;
|
|
|
|
procedure finish_waitvarlist(loc_freelists: pfreelists);
|
|
{ free to-be-freed chunks, return whether we freed anything }
|
|
var
|
|
pmcv: pmemchunk_var;
|
|
begin
|
|
while loc_freelists^.waitvar <> nil do
|
|
begin
|
|
{ keep next_var, might be destroyed }
|
|
pmcv := loc_freelists^.waitvar;
|
|
loc_freelists^.waitvar := pmcv^.next_var;
|
|
SysFreeMem_Var(loc_freelists, pmcv);
|
|
end;
|
|
end;
|
|
|
|
procedure try_finish_waitvarlist(loc_freelists: pfreelists);
|
|
begin
|
|
if loc_freelists^.waitvar = nil then
|
|
exit;
|
|
entercriticalsection(heap_lock);
|
|
finish_waitvarlist(loc_freelists);
|
|
leavecriticalsection(heap_lock);
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
SysFreeMemSize
|
|
*****************************************************************************}
|
|
|
|
Function SysFreeMemSize(p: pointer; size: ptruint):ptruint;
|
|
begin
|
|
if size=0 then
|
|
exit(0);
|
|
{ can't free partial blocks, ignore size }
|
|
result := SysFreeMem(p);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
SysMemSize
|
|
*****************************************************************************}
|
|
|
|
function SysMemSize(p: pointer): ptruint;
|
|
begin
|
|
result := pmemchunk_fixed(pointer(p)-sizeof(tmemchunk_fixed_hdr))^.size;
|
|
if (result and fixedsizeflag) = 0 then
|
|
begin
|
|
result := result and sizemask;
|
|
dec(result, sizeof(tmemchunk_var_hdr));
|
|
end
|
|
else
|
|
begin
|
|
result := result and fixedsizemask;
|
|
dec(result, sizeof(tmemchunk_fixed_hdr));
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
SysAllocMem
|
|
*****************************************************************************}
|
|
|
|
function SysAllocMem(size: ptruint): pointer;
|
|
begin
|
|
result := MemoryManager.GetMem(size);
|
|
if result<>nil then
|
|
FillChar(result^,MemoryManager.MemSize(result),0);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
SysResizeMem
|
|
*****************************************************************************}
|
|
|
|
function SysTryResizeMem(var p: pointer; size: ptruint): boolean;
|
|
var
|
|
chunksize,
|
|
oldsize,
|
|
currsize : ptruint;
|
|
pcurr : pmemchunk_var;
|
|
begin
|
|
SysTryResizeMem := false;
|
|
|
|
{ fix p to point to the heaprecord }
|
|
chunksize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size;
|
|
|
|
{ handle fixed memchuncks separate. Only allow resizes when the
|
|
new size fits in the same block }
|
|
if (chunksize and fixedsizeflag) <> 0 then
|
|
begin
|
|
currsize := chunksize and fixedsizemask;
|
|
|
|
{ 1. Resizing to smaller sizes will never allocate a new block. We just keep the current block. This
|
|
is needed for the expectations that resizing to a small block will not move the contents of
|
|
a memory block
|
|
2. For resizing to greater size first check if the size fits in the fixed block range to prevent
|
|
"truncating" the size by the fixedsizemask }
|
|
if ((size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr))) and
|
|
((size+(sizeof(tmemchunk_fixed_hdr)+(blocksize-1))) and sizemask <= currsize)) then
|
|
begin
|
|
systryresizemem:=true;
|
|
exit;
|
|
end;
|
|
|
|
{ we need to allocate a new fixed or var memchunck }
|
|
exit;
|
|
end;
|
|
|
|
{ var memchunk }
|
|
|
|
{ do not fragment the heap with small shrinked blocks }
|
|
{ also solves problem with var sized chunks smaller than sizeof(tmemchunk_var) }
|
|
if size < maxblocksize div 2 then
|
|
exit(false);
|
|
|
|
currsize := chunksize and sizemask;
|
|
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
|
|
|
|
{ is the allocated block still correct? }
|
|
if (currsize>=size) and (size>ptruint(currsize-blocksize)) then
|
|
begin
|
|
SysTryResizeMem := true;
|
|
exit;
|
|
end;
|
|
|
|
{ get pointer to block }
|
|
pcurr := pmemchunk_var(pointer(p)-sizeof(tmemchunk_var_hdr));
|
|
oldsize := currsize;
|
|
|
|
{ do we need to allocate more memory ? }
|
|
if try_concat_free_chunk_forward(pcurr) then
|
|
currsize := pcurr^.size and sizemask;
|
|
if size>currsize then
|
|
begin
|
|
{ the size is bigger than the previous size, we need to allocate more mem
|
|
but we could not concatenate with next block or not big enough }
|
|
exit;
|
|
end
|
|
else
|
|
{ is the size smaller then we can adjust the block to that size and insert
|
|
the other part into the freelist }
|
|
if currsize>size then
|
|
currsize := split_block(pcurr, size);
|
|
|
|
with pcurr^.freelists^.internal_status do
|
|
begin
|
|
inc(currheapused, currsize-oldsize);
|
|
if currheapused > maxheapused then
|
|
maxheapused := currheapused;
|
|
end;
|
|
SysTryResizeMem := true;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
SysResizeMem
|
|
*****************************************************************************}
|
|
|
|
function SysReAllocMem(var p: pointer; size: ptruint):pointer;
|
|
var
|
|
newsize,
|
|
oldsize,
|
|
minsize : ptruint;
|
|
p2 : pointer;
|
|
begin
|
|
{ Free block? }
|
|
if size=0 then
|
|
begin
|
|
if p<>nil then
|
|
begin
|
|
MemoryManager.FreeMem(p);
|
|
p := nil;
|
|
end;
|
|
end
|
|
else
|
|
{ Allocate a new block? }
|
|
if p=nil then
|
|
begin
|
|
p := MemoryManager.GetMem(size);
|
|
end
|
|
else
|
|
begin
|
|
{ Resize block }
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
oldsize:=SysMemSize(p);
|
|
{$endif}
|
|
if not SysTryResizeMem(p,size) then
|
|
begin
|
|
oldsize:=MemoryManager.MemSize(p);
|
|
{ Grow with bigger steps to prevent the need for
|
|
multiple getmem/freemem calls for fixed blocks. It might cost a bit
|
|
of extra memory, but in most cases a reallocmem is done multiple times. }
|
|
if oldsize<maxblocksize then
|
|
begin
|
|
newsize:=oldsize*2+blocksize;
|
|
if size>newsize then
|
|
newsize:=size;
|
|
end
|
|
else
|
|
newsize:=size;
|
|
{ calc size of data to move }
|
|
minsize:=oldsize;
|
|
if newsize < minsize then
|
|
minsize := newsize;
|
|
p2 := MemoryManager.GetMem(newsize);
|
|
if p2<>nil then
|
|
Move(p^,p2^,minsize);
|
|
MemoryManager.FreeMem(p);
|
|
p := p2;
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
end else begin
|
|
size := sysmemsize(p);
|
|
if size <> oldsize then
|
|
begin
|
|
if oldsize > sizeusagesize then
|
|
dec(sizeusage[sizeusageindex])
|
|
else if oldsize >= 0 then
|
|
dec(sizeusage[oldsize shr sizeusageshift]);
|
|
if size > sizeusagesize then
|
|
inc(sizeusage[sizeusageindex])
|
|
else if size >= 0 then
|
|
inc(sizeusage[size shr sizeusageshift]);
|
|
end;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
SysReAllocMem := p;
|
|
end;
|
|
|
|
{$endif HAS_MEMORYMANAGER}
|
|
|
|
{$ifndef HAS_MEMORYMANAGER}
|
|
|
|
{*****************************************************************************
|
|
InitHeap
|
|
*****************************************************************************}
|
|
|
|
{ This function will initialize the Heap manager and need to be called from
|
|
the initialization of the system unit }
|
|
procedure InitHeapThread;
|
|
var
|
|
loc_freelists: pfreelists;
|
|
begin
|
|
loc_freelists := @freelists;
|
|
fillchar(loc_freelists^,sizeof(tfreelists),0);
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
fillchar(sizeusage,sizeof(sizeusage),0);
|
|
fillchar(maxsizeusage,sizeof(sizeusage),0);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure InitHeap;
|
|
var
|
|
loc_freelists: pfreelists;
|
|
begin
|
|
{ we cannot initialize the locks here yet, thread support is
|
|
not loaded yet }
|
|
loc_freelists := @freelists;
|
|
fillchar(loc_freelists^,sizeof(tfreelists),0);
|
|
fillchar(orphaned_freelists,sizeof(orphaned_freelists),0);
|
|
end;
|
|
|
|
procedure RelocateHeap;
|
|
var
|
|
loc_freelists: pfreelists;
|
|
begin
|
|
{ this function should be called in main thread context }
|
|
loc_freelists := @freelists;
|
|
main_relo_freelists := loc_freelists;
|
|
initcriticalsection(heap_lock);
|
|
modify_freelists(loc_freelists, main_relo_freelists);
|
|
if MemoryManager.RelocateHeap <> nil then
|
|
MemoryManager.RelocateHeap();
|
|
end;
|
|
|
|
procedure FinalizeHeap;
|
|
var
|
|
poc, poc_next: poschunk;
|
|
loc_freelists: pfreelists;
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
i : longint;
|
|
{$endif}
|
|
begin
|
|
loc_freelists := @freelists;
|
|
if main_relo_freelists <> nil then
|
|
begin
|
|
entercriticalsection(heap_lock);
|
|
finish_waitfixedlist(loc_freelists);
|
|
finish_waitvarlist(loc_freelists);
|
|
{$ifdef HAS_SYSOSFREE}
|
|
end;
|
|
poc := loc_freelists^.oslist;
|
|
while assigned(poc) do
|
|
begin
|
|
poc_next := poc^.next_free;
|
|
{ check if this os chunk was 'recycled' i.e. taken in use again }
|
|
if (poc^.size and ocrecycleflag) = 0 then
|
|
free_oschunk(loc_freelists, poc)
|
|
else
|
|
poc^.size := poc^.size and not ocrecycleflag;
|
|
poc := poc_next;
|
|
end;
|
|
loc_freelists^.oslist := nil;
|
|
loc_freelists^.oscount := 0;
|
|
if main_relo_freelists <> nil then
|
|
begin
|
|
{$endif HAS_SYSOSFREE}
|
|
if main_relo_freelists <> loc_freelists then
|
|
begin
|
|
poc := modify_freelists(loc_freelists, @orphaned_freelists);
|
|
if assigned(poc) then
|
|
begin
|
|
poc^.next_any := orphaned_freelists.oslist_all;
|
|
if assigned(orphaned_freelists.oslist_all) then
|
|
orphaned_freelists.oslist_all^.prev_any := poc;
|
|
orphaned_freelists.oslist_all := loc_freelists^.oslist_all;
|
|
end;
|
|
end;
|
|
leavecriticalsection(heap_lock);
|
|
if main_relo_freelists = loc_freelists then
|
|
donecriticalsection(heap_lock);
|
|
end;
|
|
{$ifdef SHOW_MEM_USAGE}
|
|
writeln('Max heap used/size: ', loc_freelists^.internal_status.maxheapused, '/',
|
|
loc_freelists^.internal_status.maxheapsize);
|
|
flush(output);
|
|
{$endif}
|
|
{$ifdef DUMP_MEM_USAGE}
|
|
for i := 0 to sizeusageindex-1 do
|
|
if maxsizeusage[i] <> 0 then
|
|
writeln('size ', i shl sizeusageshift, ' usage ', maxsizeusage[i]);
|
|
writeln('size >', sizeusagesize, ' usage ', maxsizeusage[sizeusageindex]);
|
|
flush(output);
|
|
{$endif}
|
|
end;
|
|
|
|
{$endif HAS_MEMORYMANAGER}
|