mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 13:32:06 +02:00
1763 lines
59 KiB
PHP
1763 lines
59 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}
|
||
|
||
{ Memory manager }
|
||
{$if not defined(FPC_NO_DEFAULT_MEMORYMANAGER)}
|
||
const
|
||
MemoryManager: TMemoryManager = (
|
||
NeedLock: false; // Obsolete
|
||
GetMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysGetMem{$else}nil{$endif};
|
||
FreeMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysFreeMem{$else}nil{$endif};
|
||
FreeMemSize: {$ifndef FPC_NO_DEFAULT_HEAP}@SysFreeMemSize{$else}nil{$endif};
|
||
AllocMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysAllocMem{$else}nil{$endif};
|
||
ReAllocMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysReAllocMem{$else}nil{$endif};
|
||
MemSize: {$ifndef FPC_NO_DEFAULT_HEAP}@SysMemSize{$else}nil{$endif};
|
||
InitThread: nil;
|
||
DoneThread: nil;
|
||
RelocateHeap: nil;
|
||
GetHeapStatus: {$ifndef FPC_NO_DEFAULT_HEAP}@SysGetHeapStatus{$else}nil{$endif};
|
||
GetFPCHeapStatus: {$ifndef FPC_NO_DEFAULT_HEAP}@SysGetFPCHeapStatus{$else}nil{$endif};
|
||
);
|
||
{$elseif not defined(FPC_IN_HEAPMGR)}
|
||
const
|
||
MemoryManager: TMemoryManager = (
|
||
NeedLock: false; // Obsolete
|
||
GetMem: nil;
|
||
FreeMem: nil;
|
||
FreeMemSize: nil;
|
||
AllocMem: nil;
|
||
ReAllocMem: nil;
|
||
MemSize: nil;
|
||
InitThread: nil;
|
||
DoneThread: nil;
|
||
RelocateHeap: nil;
|
||
GetHeapStatus: nil;
|
||
GetFPCHeapStatus: nil;
|
||
);public name 'FPC_SYSTEM_MEMORYMANAGER';
|
||
{$endif FPC_IN_HEAPMGR}
|
||
|
||
|
||
{ Try to find the best matching block in general freelist }
|
||
{ define BESTMATCH}
|
||
|
||
{$ifndef FPC_NO_DEFAULT_MEMORYMANAGER}
|
||
|
||
{$endif HAS_MEMORYMANAGER}
|
||
|
||
{*****************************************************************************
|
||
Memory Manager
|
||
*****************************************************************************}
|
||
|
||
{$ifndef FPC_IN_HEAPMGR}
|
||
procedure GetMemoryManager(var MemMgr:TMemoryManager);
|
||
begin
|
||
MemMgr := MemoryManager;
|
||
end;
|
||
|
||
|
||
procedure SetMemoryManager(const MemMgr:TMemoryManager);
|
||
begin
|
||
MemoryManager := MemMgr;
|
||
end;
|
||
|
||
function IsMemoryManagerSet:Boolean;
|
||
begin
|
||
{$if defined(HAS_MEMORYMANAGER) or defined(FPC_NO_DEFAULT_MEMORYMANAGER)}
|
||
Result:=false;
|
||
{$else not FPC_NO_DEFAULT_MEMORYMANAGER}
|
||
IsMemoryManagerSet := (MemoryManager.GetMem<>@SysGetMem)
|
||
or (MemoryManager.FreeMem<>@SysFreeMem);
|
||
{$endif HAS_MEMORYMANAGER or FPC_NO_DEFAULT_MEMORYMANAGER}
|
||
end;
|
||
|
||
{$ifdef FPC_HAS_FEATURE_HEAP}
|
||
procedure GetMem(Out p:pointer;Size:ptruint);
|
||
begin
|
||
p := MemoryManager.GetMem(Size);
|
||
end;
|
||
|
||
procedure GetMemory(Out 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;
|
||
begin
|
||
FreeMem := MemoryManager.FreeMem(p);
|
||
end;
|
||
|
||
function FreeMemory(p:pointer):ptruint; cdecl;
|
||
begin
|
||
FreeMemory := FreeMem(p);
|
||
end;
|
||
|
||
function GetMem(size:ptruint):pointer;
|
||
begin
|
||
GetMem := MemoryManager.GetMem(Size);
|
||
end;
|
||
|
||
function GetMemory(size:ptruint):pointer; cdecl;
|
||
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(p:pointer;Size:ptruint):pointer; cdecl;
|
||
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;
|
||
{$endif FPC_HAS_FEATURE_HEAP}
|
||
{$endif FPC_IN_HEAPMGR}
|
||
|
||
{$if defined(FPC_HAS_FEATURE_HEAP) or defined(FPC_IN_HEAPMGR)}
|
||
{$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: < CommonHeader > [ ... user data ... ]
|
||
variable: [ VarHeader < CommonHeader > ] [ ... 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.
|
||
}
|
||
|
||
type
|
||
HeapInc = object
|
||
const
|
||
{ Alignment requirement for blocks. All fixed sizes (among other things) are assumed to be divisible. }
|
||
Alignment = 2 * sizeof(pointer);
|
||
|
||
{ Fixed chunk sizes are:
|
||
┌──── step = 16 ────┐┌─── step = 32 ────┐┌──── step = 48 ───┐┌ step 64 ┐
|
||
16, 32, 48, 64, 80, 96, 128, 160, 192, 224, 272, 320, 368, 416, 480, 544
|
||
#0 #1 #2 #3 #4 #5 #6 #7 #8 #9 #10 #11 #12 #13 #14 #15 }
|
||
MinFixedHeaderAndPayload = 16;
|
||
MaxFixedHeaderAndPayload = 544;
|
||
FixedSizesCount = 16;
|
||
FixedSizes: array[0 .. FixedSizesCount - 1] of uint16 = (16, 32, 48, 64, 80, 96, 128, 160, 192, 224, 272, 320, 368, 416, 480, 544);
|
||
SizeMinus1Div16ToIndex: array[0 .. (MaxFixedHeaderAndPayload - 1) div 16] of uint8 =
|
||
{ 16, 32, 48, 64, 80, 96, 112, 128, 144, 160, 176, 192, 208, 224, 240, 256, 272, 288, 304, 320, 336, 352, 368, 384, 400, 416, 432, 448, 464, 480, 496, 512, 528, 544 }
|
||
( 0, 1, 2, 3, 4, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 10, 11, 11, 11, 12, 12, 12, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15);
|
||
|
||
class function SizeMinus1ToIndex(sizeMinus1: SizeUint): SizeUint; static; inline; { sizeMinus1 + 1 ≤ MaxFixedHeaderAndPayload }
|
||
class function IndexToSize(sizeIndex: SizeUint): SizeUint; static; inline;
|
||
|
||
const
|
||
OSChunkFixedSizeQuant = 32 * 1024;
|
||
OSChunkVarSizeQuant = 64 * 1024;
|
||
MaxFixedChunkSize = 256 * 1024;
|
||
|
||
{ Variable freelist search strategy: -1 = exhaustive search for the best (smallest fitting) match, ≥0 = search this many after the first match. }
|
||
MatchEffort = {$ifdef BESTMATCH} -1 {$else} 10 {$endif};
|
||
|
||
{ Limit on shrinking variable chunks and keeping the tail when splitting the chunk in AllocVar / TryResizeVar. }
|
||
MinVarHeaderAndPayload = MaxFixedHeaderAndPayload * 3 div 4;
|
||
|
||
{ Adjustable part ends here~ }
|
||
|
||
const
|
||
SizeIndexBits = 1 + trunc(ln(FixedSizesCount - 1) / ln(2));
|
||
SizeIndexMask = 1 shl SizeIndexBits - 1;
|
||
FixedBitPos = {$if SizeIndexBits >= 3} SizeIndexBits {$else} 3 {$endif}; { Variable chunks use 3 low bits for used / first / last. }
|
||
FixedFlag = 1 shl FixedBitPos;
|
||
ChunkOffsetShift = FixedBitPos + 1;
|
||
|
||
{ Not really used; MaxFixedChunkSize limit on fixed OS chunks assumed to be strictly enforced and (much!) more restricting than MaxChunkOffset.
|
||
MaxFixedChunkSize = 256 Kb.
|
||
MaxChunkOffset ~ 2^(32 - 6) ~ 67 Mb.
|
||
Indices could be stored instead, but offsets avoid multiplications. }
|
||
MaxChunkOffset = High(uint32) shr ChunkOffsetShift;
|
||
|
||
UsedFlag = 1 shl 0;
|
||
FirstFlag = 1 shl 1;
|
||
LastFlag = 1 shl 2;
|
||
VarSizeQuant = 1 shl ChunkOffsetShift; {$if VarSizeQuant < Alignment} {$error Assumed to be >= Alignment.} {$endif}
|
||
VarSizeMask = SizeUint(-VarSizeQuant);
|
||
|
||
type
|
||
{ Common header of any memory chunk, residing immediately to the left of the ~payload~ (block).
|
||
|
||
Fixed chunk header, assuming SizeIndexBits = 4:
|
||
h[0:3] = size index (= h and SizeIndexMask)
|
||
h[4] = 1 (h and FixedFlag <> 0)
|
||
h[5:31] — offset in the OS chunk (= h shr ChunkOffsetShift)
|
||
|
||
Variable chunk header, assuming SizeIndexBits = 4:
|
||
h[0] = used flag (h and UsedFlag <> 0)
|
||
h[1] = first flag (h and FirstFlag <> 0)
|
||
h[2] = last flag (h and LastFlag <> 0)
|
||
h[3] = unused
|
||
h[4] = 0 (h and FixedFlag = 0)
|
||
h[5:31] = size, rounded up to 32 (VarSizeQuant), shr 5; in other words, size = h and VarSizeMask.
|
||
|
||
If sizeof(SizeUint) > 4: “h and VarSizeMask” is low part of size, high part is stored in VarChunk.sizeHi. }
|
||
|
||
pCommonHeader = ^CommonHeader;
|
||
CommonHeader = record
|
||
h: uint32;
|
||
end;
|
||
|
||
pThreadState = ^ThreadState;
|
||
|
||
{ Chunk that has been freed. Reuses the now-uninteresting payload, so payload must always fit its size.
|
||
Used for fixed freelists and cross-thread to-free queue. }
|
||
pFreeChunk = ^FreeChunk;
|
||
FreeChunk = record
|
||
next: pFreeChunk;
|
||
end;
|
||
|
||
pOSChunk = ^OSChunk;
|
||
OSChunk = object { Common header for all OS chunks. }
|
||
size: SizeUint; { Full size asked from SysOSAlloc. }
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
threadState: pThreadState; { Protected with gs.lock. Nil if orphaned. }
|
||
{$endif}
|
||
prev, next: pointer; { pOSChunk, but used for different subtypes. }
|
||
|
||
{ For what purpose this chunk was used the last time. -1 — var, N ≥ 0 — fixed size N. Allows for a small optimization when reusing fixed chunks. }
|
||
sizeIndex: SizeInt;
|
||
|
||
{ Remove from list src and push to list dest. }
|
||
procedure MoveTo(var src, dest: pOSChunk);
|
||
end;
|
||
|
||
pFreeOSChunk = ^FreeOSChunk;
|
||
FreeOSChunk = object(OSChunk)
|
||
end;
|
||
|
||
FreeOSChunkList = object
|
||
first, last: pFreeOSChunk;
|
||
{$ifdef HAS_SYSOSFREE}
|
||
n: SizeUint;
|
||
{$endif}
|
||
|
||
function Get(minSize, maxSize: SizeUint): pOSChunk;
|
||
{$ifdef HAS_SYSOSFREE}
|
||
function FreeOne: SizeUint;
|
||
procedure FreeAll;
|
||
{$endif}
|
||
end;
|
||
|
||
pFixedOSChunk = ^FixedOSChunk;
|
||
FixedOSChunk = object(OSChunk)
|
||
{ Data starts at FixedOSChunkDataOffset and spans for “maxSize” (virtual value, does not exist directly) bytes, of which:
|
||
— first formattedSize are either allocated (“used”; counted in usedSize) or in the freelist (firstFreeChunk; size = formattedSize - usedSize),
|
||
— the rest “maxSize” - formattedSize are yet unallocated space.
|
||
|
||
This design, together with tracking free chunks per FixedOSChunk rather than per fixed size, trivializes reusing the chunk.
|
||
Chopping all available space at once would get rid of the “unallocated space” entity, but is a lot of potentially wasted work:
|
||
https://gitlab.com/freepascal.org/fpc/source/-/issues/40447.
|
||
|
||
Values are multiples of the chunk size instead of counts (could be chunksUsed, chunksFormatted, chunksMax) to save on multiplications.
|
||
Moreover, instead of “maxSize” from the explanation above, fullThreshold is used, which is such a value that the chunk is full if usedSize >= fullThreshold.
|
||
maxSize = RoundUp(fullThreshold, chunk size).
|
||
Reason is, calculating fullThreshold does not require division. }
|
||
|
||
firstFreeChunk: pFreeChunk;
|
||
usedSize, formattedSize, fullThreshold: uint32;
|
||
end;
|
||
|
||
pVarOSChunk = ^VarOSChunk;
|
||
VarOSChunk = object(OSChunk)
|
||
end;
|
||
|
||
pVarHeader = ^VarHeader;
|
||
VarHeader = record
|
||
prevSize: SizeUint; { Always 0 for the first chunk. }
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
threadState: pThreadState;
|
||
{$endif}
|
||
{$if sizeof(SizeUint) > 4}
|
||
sizeHi: uint32;
|
||
{$endif}
|
||
{ Assumed to indeed match chunk’s CommonHeader, i.e. that there is no padding after this field.
|
||
Otherwise must be accessed as pCommonHeader(pointer(varHdr) + (VarHeaderSize - CommonHeaderSize))^ :D. }
|
||
ch: CommonHeader;
|
||
end;
|
||
|
||
{ Reuses the payload of variable chunks whose ch.h and UsedFlag = 0, so variable chunk payload must always fit its size. }
|
||
pFreeVarChunk = ^FreeVarChunk;
|
||
FreeVarChunk = record
|
||
prev, next: pFreeVarChunk;
|
||
size: SizeUint; { Cached size for easier access when working with free chunks, always equals to header.sizeHi shl 32 or header.ch.h and VarSizeMask. }
|
||
end;
|
||
|
||
ThreadState = object
|
||
fullOS: pFixedOSChunk; { Completely filled fixed OS chunks. }
|
||
freeOS: FreeOSChunkList; { Completely empty OS chunks. }
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
toFree: pFreeChunk; { Free requests from other threads, atomic. }
|
||
{$endif}
|
||
|
||
used, maxUsed, allocated, maxAllocated: SizeUint; { Statistics. }
|
||
|
||
varOS: pVarOSChunk;
|
||
varFree: pFreeVarChunk;
|
||
|
||
{ OS chunks with at least 1 free chunk (including unformatted space), but not completely empty.
|
||
OS chunks that become completely empty are moved to freeOS, completely full are moved to fullOS. }
|
||
fixedPartialOS: array[0 .. FixedSizesCount - 1] of pFixedOSChunk;
|
||
|
||
{ Only to calculate preferable new fixed OS chunk sizes...
|
||
(Updated infrequently, as opposed to possible “fixedUsed”. When a new fixed OS chunk is required, all existing chunks of its size are full.) }
|
||
allocatedByFullFixed: array[0 .. FixedSizesCount - 1] of SizeUint;
|
||
|
||
{$ifdef DEBUG_HEAP_INC}
|
||
procedure Dump(var f: text);
|
||
{$endif}
|
||
|
||
function AllocFixed(size: SizeUint): pointer;
|
||
function FreeFixed(p: pointer): SizeUint;
|
||
|
||
function GetOSChunk(minSize, maxSize: SizeUint; sizeIndex: SizeInt): pOSChunk;
|
||
function AllocateOSChunk(minSize: SizeUint; sizeIndex: SizeInt): pOSChunk;
|
||
|
||
function AllocVar(size: SizeUint): pointer;
|
||
function FreeVar(p: pointer): SizeUint;
|
||
function TryResizeVar(p: pointer; size: SizeUint): pointer;
|
||
{$ifdef HAS_SYSOSREALLOC}
|
||
function TrySysOSRealloc(p: pointer; oldSize, newSize: SizeUint): pointer;
|
||
{$endif}
|
||
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
procedure PushToFree(p: pFreeChunk);
|
||
procedure FlushToFree;
|
||
|
||
procedure Orphan; { Must be performed under gs.lock. }
|
||
class procedure Orphan(list: pFixedOSChunk); static;
|
||
procedure Adopt(osChunk: pFixedOSChunk); { Must be performed under gs.lock. }
|
||
procedure AdoptVarOwner(p: pointer); { Adopts the OS chunk that contains p. Must be performed under gs.lock. }
|
||
|
||
class function ChangeThreadStates(list: pOSChunk; ts: pThreadState): pOSChunk; static; { Returns the last item of the list. }
|
||
class procedure ChangeThreadState(vOs: pVarOSChunk; ts: pThreadState); static;
|
||
|
||
{$ifndef FPC_SECTION_THREADVARS}
|
||
procedure FixupSelfPtr;
|
||
{$endif ndef FPC_SECTION_THREADVARS}
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
end;
|
||
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
GlobalState = record
|
||
lock: TRTLCriticalSection;
|
||
lockUse: int32;
|
||
|
||
{ Data from dead threads (“orphaned”), protected by gs.lock. }
|
||
fixedOS: pFixedOSChunk;
|
||
freeOS: FreeOSChunkList;
|
||
varOS: pVarOSChunk;
|
||
end;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
class var
|
||
gs: GlobalState;
|
||
class threadvar
|
||
thisTs: ThreadState;
|
||
{$else FPC_HAS_FEATURE_THREADING}
|
||
class var
|
||
thisTs: ThreadState;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
|
||
const
|
||
CommonHeaderSize = sizeof(CommonHeader);
|
||
{$if MinFixedHeaderAndPayload < CommonHeaderSize + sizeof(FreeChunk)} {$error MinFixedHeaderAndPayload does not fit CommonHeader + FreeChunk.} {$endif}
|
||
FixedOSChunkDataOffset = (sizeof(FixedOSChunk) + CommonHeaderSize + Alignment - 1) and -Alignment - CommonHeaderSize;
|
||
VarHeaderSize = sizeof(VarHeader);
|
||
VarOSChunkDataOffset = (sizeof(VarOSChunk) + VarHeaderSize + Alignment - 1) and -Alignment - VarHeaderSize;
|
||
MaxVarPayload = High(SizeUint) - (VarOSChunkDataOffset + VarHeaderSize + OSChunkVarSizeQuant); { Absolute limit on chunk sizes. }
|
||
end;
|
||
|
||
class function HeapInc.SizeMinus1ToIndex(sizeMinus1: SizeUint): SizeUint;
|
||
begin
|
||
result := SizeMinus1Div16ToIndex[sizeMinus1 div 16];
|
||
end;
|
||
|
||
class function HeapInc.IndexToSize(sizeIndex: SizeUint): SizeUint;
|
||
begin
|
||
result := FixedSizes[sizeIndex];
|
||
end;
|
||
|
||
procedure HeapInc.OSChunk.MoveTo(var src, dest: pOSChunk);
|
||
var
|
||
osNext, osPrev: pOSChunk;
|
||
begin
|
||
osPrev := prev;
|
||
osNext := next;
|
||
if Assigned(osPrev) then
|
||
osPrev^.next := osNext
|
||
else
|
||
src := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osPrev;
|
||
prev := nil;
|
||
osNext := dest;
|
||
next := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := @self;
|
||
dest := @self;
|
||
end;
|
||
|
||
function HeapInc.FreeOSChunkList.Get(minSize, maxSize: SizeUint): pOSChunk;
|
||
var
|
||
prev, next: pFreeOSChunk;
|
||
begin
|
||
result := first;
|
||
while Assigned(result) and not ((result^.size >= minSize) and (result^.size <= maxSize)) do
|
||
result := result^.next;
|
||
if not Assigned(result) then
|
||
exit;
|
||
|
||
prev := result^.prev;
|
||
next := result^.next;
|
||
if Assigned(prev) then
|
||
prev^.next := next
|
||
else
|
||
first := next;
|
||
if Assigned(next) then
|
||
next^.prev := prev
|
||
else
|
||
last := prev;
|
||
{$ifdef HAS_SYSOSFREE} dec(n); {$endif}
|
||
end;
|
||
|
||
{$ifdef HAS_SYSOSFREE}
|
||
function HeapInc.FreeOSChunkList.FreeOne: SizeUint;
|
||
var
|
||
best, prev: pFreeOSChunk;
|
||
begin
|
||
{ Presently: the last one (which means LRU, as they are pushed to the beginning). }
|
||
best := last;
|
||
prev := best^.prev;
|
||
if Assigned(prev) then
|
||
prev^.next := nil
|
||
else
|
||
first := nil;
|
||
last := prev;
|
||
dec(n);
|
||
result := best^.size;
|
||
SysOSFree(best, best^.size);
|
||
end;
|
||
|
||
procedure HeapInc.FreeOSChunkList.FreeAll;
|
||
var
|
||
cur, next: pFreeOSChunk;
|
||
begin
|
||
cur := first;
|
||
first := nil;
|
||
last := nil;
|
||
n := 0;
|
||
while Assigned(cur) do
|
||
begin
|
||
next := cur^.next;
|
||
SysOSFree(cur, cur^.size);
|
||
cur := next;
|
||
end;
|
||
end;
|
||
{$endif HAS_SYSOSFREE}
|
||
|
||
{$ifdef DEBUG_HEAP_INC}
|
||
procedure HeapInc.ThreadState.Dump(var f: text);
|
||
var
|
||
i: SizeInt;
|
||
fix: pFixedOSChunk;
|
||
fr: pFreeOSChunk;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
tf: pFreeChunk;
|
||
{$endif}
|
||
vf: pFreeVarChunk;
|
||
vOs: pVarOSChunk;
|
||
p: pointer;
|
||
begin
|
||
writeln(f, 'used = ', used, ', allocated = ', allocated, ', maxUsed = ', maxUsed, ', maxAllocated = ', maxAllocated);
|
||
fix := fullOS;
|
||
if Assigned(fix) then
|
||
begin
|
||
writeln(f);
|
||
repeat
|
||
writeln(f, 'Full fixed: size = ', fix^.size, ', usedSize = ', fix^.usedSize, ', formattedSize = ', fix^.formattedSize, ', fullThreshold = ', fix^.fullThreshold);
|
||
fix := fix^.next;
|
||
until not Assigned(fix);
|
||
end;
|
||
for i := 0 to FixedSizesCount - 1 do
|
||
if Assigned(fixedPartialOS[i]) then
|
||
begin
|
||
write(f, 'Size #', i, ' (', IndexToSize(i), ')');
|
||
if allocatedByFullFixed[i] <> 0 then
|
||
write(f, ': allocatedByFullFixed = ', allocatedByFullFixed[i]);
|
||
writeln(f);
|
||
fix := fixedPartialOS[i];
|
||
while Assigned(fix) do
|
||
begin
|
||
writeln(f, 'size = ', fix^.size, ', usedSize = ', fix^.usedSize, ', formattedSize = ', fix^.formattedSize, ', fullThreshold = ', fix^.fullThreshold);
|
||
fix := fix^.next;
|
||
end;
|
||
end;
|
||
vOs := varOS;
|
||
while Assigned(vOs) do
|
||
begin
|
||
writeln(f, LineEnding, 'Var OS chunk, size ', vOs^.size);
|
||
p := pointer(vOs) + (VarOSChunkDataOffset + VarHeaderSize);
|
||
repeat
|
||
write(f, HexStr(p), ': ',
|
||
'prevSize = ', pVarHeader(p - VarHeaderSize)^.prevSize, ', size = ',
|
||
{$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(p - VarHeaderSize)^.sizeHi) shl 32 or {$endif} pVarHeader(p - VarHeaderSize)^.ch.h and VarSizeMask);
|
||
if pVarHeader(p - VarHeaderSize)^.ch.h and UsedFlag <> 0 then
|
||
write(f, ', used')
|
||
else
|
||
write(f, ', f r e e');
|
||
if pVarHeader(p - VarHeaderSize)^.ch.h and FirstFlag <> 0 then
|
||
write(f, ', first');
|
||
if pVarHeader(p - VarHeaderSize)^.ch.h and LastFlag <> 0 then
|
||
write(f, ', last');
|
||
writeln(f);
|
||
if pVarHeader(p - VarHeaderSize)^.ch.h and LastFlag <> 0 then
|
||
break;
|
||
p := p + ({$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(p - VarHeaderSize)^.sizeHi) shl 32 or {$endif} pVarHeader(p - VarHeaderSize)^.ch.h and uint32(VarSizeMask));
|
||
until false;
|
||
vOs := vOs^.next;
|
||
end;
|
||
fr := freeOS.first;
|
||
if Assigned(fr) then
|
||
begin
|
||
writeln(f);
|
||
repeat
|
||
writeln(f, 'Free OS: ', HexStr(fr), ', size = ', fr^.size);
|
||
fr := fr^.next;
|
||
until not Assigned(fr);
|
||
end;
|
||
vf := varFree;
|
||
if Assigned(vf) then
|
||
begin
|
||
write(f, LineEnding, 'Var free:');
|
||
repeat
|
||
write(f, ' ', vf^.size);
|
||
vf := vf^.next;
|
||
until not Assigned(vf);
|
||
writeln(f);
|
||
end;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
tf := toFree;
|
||
if Assigned(tf) then
|
||
begin
|
||
write(f, LineEnding, 'To-free:');
|
||
repeat
|
||
if pCommonHeader(pointer(tf) - CommonHeaderSize)^.h and FixedFlag <> 0 then
|
||
write(f, ' f ', CommonHeaderSize + SysMemSize(tf))
|
||
else
|
||
write(f, ' v ', VarHeaderSize + SysMemSize(tf));
|
||
tf := tf^.next;
|
||
until not Assigned(tf);
|
||
writeln(f);
|
||
end;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
end;
|
||
{$endif DEBUG_HEAP_INC}
|
||
|
||
function HeapInc.ThreadState.AllocFixed(size: SizeUint): pointer;
|
||
var
|
||
sizeIndex: SizeUint;
|
||
osChunk, osNext: pFixedOSChunk;
|
||
begin
|
||
sizeIndex := SizeMinus1ToIndex(size + (CommonHeaderSize - 1));
|
||
|
||
osChunk := fixedPartialOS[sizeIndex];
|
||
if not Assigned(osChunk) then
|
||
begin
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
if Assigned(toFree) then
|
||
begin
|
||
FlushToFree;
|
||
osChunk := fixedPartialOS[sizeIndex];
|
||
end;
|
||
if not Assigned(osChunk) then
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
begin
|
||
osChunk := pFixedOSChunk(GetOSChunk(FixedOSChunkDataOffset + MaxFixedHeaderAndPayload, MaxFixedChunkSize, sizeIndex));
|
||
if not Assigned(osChunk) then
|
||
exit(nil);
|
||
if SizeUint(osChunk^.sizeIndex) = sizeIndex then
|
||
{ Lucky! Just don’t reset the chunk and use its old freelist. }
|
||
else
|
||
begin
|
||
osChunk^.sizeIndex := sizeIndex;
|
||
osChunk^.firstFreeChunk := nil;
|
||
osChunk^.usedSize := 0;
|
||
osChunk^.formattedSize := 0;
|
||
osChunk^.fullThreshold := osChunk^.size - IndexToSize(sizeIndex) - (FixedOSChunkDataOffset - 1); { available OS chunk space - chunk size + 1. }
|
||
end;
|
||
|
||
{ Add osChunk to fixedPartialOS[sizeIndex]. }
|
||
osNext := fixedPartialOS[sizeIndex];
|
||
osChunk^.prev := nil;
|
||
osChunk^.next := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osChunk;
|
||
fixedPartialOS[sizeIndex] := osChunk;
|
||
end;
|
||
end;
|
||
|
||
size := IndexToSize(sizeIndex);
|
||
inc(used, size);
|
||
if used > maxUsed then
|
||
maxUsed := used;
|
||
|
||
{ osChunk from the fixedPartialOS list has either free chunk or free unformatted space for a new chunk. }
|
||
result := osChunk^.firstFreeChunk;
|
||
if Assigned(result) then
|
||
osChunk^.firstFreeChunk := pFreeChunk(result)^.next
|
||
else
|
||
begin
|
||
result := pointer(osChunk) + (FixedOSChunkDataOffset + CommonHeaderSize) + osChunk^.formattedSize;
|
||
pCommonHeader(result - CommonHeadersize)^.h := sizeIndex + osChunk^.formattedSize shl ChunkOffsetShift +
|
||
(FixedFlag + (FixedOSChunkDataOffset + CommonHeaderSize) shl ChunkOffsetShift); { ← const }
|
||
inc(osChunk^.formattedSize, size);
|
||
end;
|
||
inc(osChunk^.usedSize, size);
|
||
if osChunk^.usedSize >= osChunk^.fullThreshold then
|
||
begin
|
||
inc(allocatedByFullFixed[sizeIndex], osChunk^.size);
|
||
{ Remove osChunk from fixedPartialOS[sizeIndex], add to fullOS. }
|
||
osNext := osChunk^.next;
|
||
fixedPartialOS[sizeIndex] := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := nil;
|
||
osNext := fullOS;
|
||
osChunk^.next := osNext; { osChunk^.prev is already nil because osChunk was the first item of fixedPartialOS[sizeIndex]. }
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osChunk;
|
||
fullOS := osChunk;
|
||
end;
|
||
end;
|
||
|
||
function HeapInc.ThreadState.FreeFixed(p: pointer): SizeUint;
|
||
var
|
||
sizeIndex, usedSize: SizeUint;
|
||
osChunk, osPrev, osNext: pFixedOSChunk;
|
||
freeOsNext: pFreeOSChunk;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
chunkTs: pThreadState;
|
||
{$endif}
|
||
begin
|
||
osChunk := p - pCommonHeader(p - CommonHeaderSize)^.h shr ChunkOffsetShift;
|
||
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
{ This can be checked without blocking; osChunk^.threadState can only change from one value not equal to @self to another value not equal to @self. }
|
||
if osChunk^.threadState <> @self then
|
||
begin
|
||
EnterCriticalSection(gs.lock);
|
||
chunkTs := osChunk^.threadState;
|
||
if Assigned(chunkTs) then
|
||
begin
|
||
{ Despite atomic Push lock must be held as otherwise target thread might end and destroy chunkTs.
|
||
However, target thread won’t block to free p, so PushToFree instantly invalidates p. }
|
||
result := IndexToSize(pCommonHeader(p - CommonHeaderSize)^.h and SizeIndexMask) - CommonHeaderSize;
|
||
chunkTs^.PushToFree(p);
|
||
LeaveCriticalSection(gs.lock);
|
||
exit;
|
||
end;
|
||
Adopt(osChunk); { ...And continue! }
|
||
LeaveCriticalSection(gs.lock);
|
||
end;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
|
||
pFreeChunk(p)^.next := osChunk^.firstFreeChunk;
|
||
osChunk^.firstFreeChunk := p;
|
||
sizeIndex := pCommonHeader(p - CommonHeaderSize)^.h and SizeIndexMask;
|
||
result := IndexToSize(sizeIndex);
|
||
dec(used, result);
|
||
usedSize := osChunk^.usedSize;
|
||
if usedSize >= osChunk^.fullThreshold then
|
||
begin
|
||
dec(allocatedByFullFixed[sizeIndex], osChunk^.size);
|
||
|
||
{ Remove osChunk from fullOS, add to fixedPartialOS[sizeIndex]. }
|
||
osPrev := osChunk^.prev;
|
||
osNext := osChunk^.next;
|
||
if Assigned(osPrev) then
|
||
osPrev^.next := osNext
|
||
else
|
||
fullOS := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osPrev;
|
||
osChunk^.prev := nil;
|
||
osNext := fixedPartialOS[sizeIndex];
|
||
osChunk^.next := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osChunk;
|
||
fixedPartialOS[sizeIndex] := osChunk;
|
||
end;
|
||
dec(usedSize, result);
|
||
osChunk^.usedSize := usedSize;
|
||
if usedSize = 0 then
|
||
begin
|
||
{ Remove osChunk from fixedPartialOS[sizeIndex], add to freeOS. }
|
||
osPrev := osChunk^.prev;
|
||
osNext := osChunk^.next;
|
||
if Assigned(osPrev) then
|
||
osPrev^.next := osNext
|
||
else
|
||
fixedPartialOS[sizeIndex] := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osPrev;
|
||
|
||
freeOsNext := freeOS.first;
|
||
pFreeOSChunk(osChunk)^.prev := nil;
|
||
pFreeOSChunk(osChunk)^.next := freeOsNext;
|
||
if Assigned(freeOsNext) then
|
||
freeOsNext^.prev := osChunk
|
||
else
|
||
freeOS.last := pFreeOSChunk(osChunk);
|
||
freeOS.first := pFreeOSChunk(osChunk);
|
||
{$ifdef HAS_SYSOSFREE}
|
||
inc(freeOS.n);
|
||
if freeOS.n > MaxKeptOSChunks then
|
||
dec(allocated, freeOS.FreeOne);
|
||
{$endif}
|
||
end;
|
||
dec(result, CommonHeaderSize);
|
||
end;
|
||
|
||
function HeapInc.ThreadState.GetOSChunk(minSize, maxSize: SizeUint; sizeIndex: SizeInt): pOSChunk;
|
||
begin
|
||
result := freeOS.Get(minSize, maxSize);
|
||
if Assigned(result) then
|
||
exit;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
if Assigned(gs.freeOS.first) then { Racing precheck. }
|
||
begin
|
||
EnterCriticalSection(gs.lock);
|
||
result := gs.freeOS.Get(minSize, maxSize);
|
||
LeaveCriticalSection(gs.lock);
|
||
if Assigned(result) then
|
||
begin
|
||
result^.threadState := @self;
|
||
inc(allocated, result^.size);
|
||
if allocated > maxAllocated then
|
||
maxAllocated := allocated;
|
||
exit;
|
||
end;
|
||
end;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
result := AllocateOSChunk(minSize, sizeIndex);
|
||
end;
|
||
|
||
function HeapInc.ThreadState.AllocateOSChunk(minSize: SizeUint; sizeIndex: SizeInt): pOSChunk;
|
||
var
|
||
preferredSize: SizeUint;
|
||
begin
|
||
if sizeIndex < 0 then
|
||
begin
|
||
if minSize <= GrowHeapSize1 then { 256K by default. }
|
||
preferredSize := GrowHeapSize1
|
||
else if minSize <= GrowHeapSize2 then { 1M by default. }
|
||
preferredSize := GrowHeapSize2
|
||
else
|
||
preferredSize := (minSize + (OSChunkVarSizeQuant - 1)) and SizeUint(-OSChunkVarSizeQuant);
|
||
end else
|
||
begin
|
||
preferredSize := (allocatedByFullFixed[sizeIndex] div 8 + (OSChunkFixedSizeQuant - 1)) and SizeUint(-OSChunkFixedSizeQuant); { 12.5% of memory allocated by the size. }
|
||
if preferredSize < growheapsizesmall then
|
||
preferredSize := growheapsizesmall;
|
||
if preferredSize > MaxFixedChunkSize then
|
||
preferredSize := MaxFixedChunkSize;
|
||
end;
|
||
result := SysOSAlloc(preferredSize);
|
||
if not Assigned(result) and (preferredSize > minSize) then
|
||
begin
|
||
preferredSize := minSize;
|
||
result := SysOSAlloc(preferredSize);
|
||
end;
|
||
if not Assigned(result) then
|
||
if ReturnNilIfGrowHeapFails then
|
||
exit
|
||
else
|
||
HandleError(204);
|
||
inc(allocated, preferredSize);
|
||
if allocated > maxAllocated then
|
||
maxAllocated := allocated;
|
||
result^.size := preferredSize;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
result^.threadState := @self;
|
||
{$endif}
|
||
result^.sizeIndex := -2; { Neither −1 nor ≥0. }
|
||
end;
|
||
|
||
function HeapInc.ThreadState.AllocVar(size: SizeUint): pointer;
|
||
var
|
||
fv, fv2: pFreeVarChunk;
|
||
osChunk, osNext: pVarOSChunk;
|
||
varPrev, varNext: pFreeVarChunk;
|
||
vSize, minSize, maxSize: SizeUint;
|
||
{$if MatchEffort >= 0} fv2Size: SizeUint; {$endif}
|
||
{$if MatchEffort > 1} triesLeft: uint32; {$endif}
|
||
begin
|
||
if size > MaxVarPayload then
|
||
if ReturnNilIfGrowHeapFails then
|
||
exit(nil)
|
||
else
|
||
HandleError(204);
|
||
size := (size + (VarHeaderSize + VarSizeQuant - 1)) and SizeUint(-VarSizeQuant);
|
||
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
if Assigned(toFree) then
|
||
FlushToFree;
|
||
{$endif}
|
||
|
||
{ Seach varFree for a chunk that fits size, heuristically strive for smallest. }
|
||
fv := varFree;
|
||
while Assigned(fv) and (fv^.size < size) do
|
||
fv := fv^.next;
|
||
{$if MatchEffort <> 0}
|
||
if Assigned(fv) and (fv^.size > size) then { Don’t search further if the size is already exact. }
|
||
begin
|
||
{$if MatchEffort > 1} triesLeft := MatchEffort + 1; {$endif}
|
||
fv2 := fv;
|
||
repeat
|
||
{$if MatchEffort > 1}
|
||
dec(triesLeft);
|
||
if triesLeft = 0 then
|
||
break;
|
||
{$endif}
|
||
fv2 := fv2^.next;
|
||
if not Assigned(fv2) then
|
||
break;
|
||
fv2Size := fv2^.size;
|
||
if (fv2Size < size) or (fv2Size >= fv^.size) then
|
||
continue;
|
||
fv := fv2;
|
||
{$if MatchEffort > 1}
|
||
if fv2Size = size then { Check here instead of the loop condition to prevent ‘continue’ from jumping to the check. }
|
||
break;
|
||
{$endif}
|
||
until {$if MatchEffort = 1} true {$else} false {$endif};
|
||
end;
|
||
{$endif MatchEffort <> 0}
|
||
|
||
if Assigned(fv) then
|
||
begin
|
||
{ Remove fv from varFree. }
|
||
varPrev := fv^.prev;
|
||
varNext := fv^.next;
|
||
if Assigned(varPrev) then
|
||
varPrev^.next := varNext
|
||
else
|
||
varFree := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := varPrev;
|
||
end else
|
||
begin
|
||
minSize := VarOSChunkDataOffset + size;
|
||
if minSize <= GrowHeapSize1 then
|
||
maxSize := GrowHeapSize1
|
||
else if minSize <= GrowHeapSize2 then
|
||
maxSize := GrowHeapSize2
|
||
else
|
||
maxSize := High(SizeUint);
|
||
osChunk := pVarOSChunk(GetOSChunk(minSize, maxSize, -1));
|
||
if not Assigned(osChunk) then
|
||
exit(nil);
|
||
osChunk^.sizeIndex := -1;
|
||
|
||
{ Add osChunk to varOS. }
|
||
osNext := varOS;
|
||
osChunk^.prev := nil;
|
||
osChunk^.next := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osChunk;
|
||
varOS := osChunk;
|
||
|
||
{ Format new free var chunk spanning the entire osChunk (but don’t add to varFree, it is expected to be removed). }
|
||
fv := pointer(osChunk) + (VarOSChunkDataOffset + VarHeaderSize);
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.prevSize := 0;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.threadState := @self;
|
||
{$endif}
|
||
vSize := SizeUint(osChunk^.size - VarOSChunkDataOffset) and SizeUint(-VarSizeQuant);
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.sizeHi := vSize shr 32;
|
||
{$endif}
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.ch.h := uint32(vSize) or (FirstFlag or LastFlag);
|
||
fv^.size := vSize;
|
||
end;
|
||
|
||
{ Result will be allocated at the beginning of fv; maybe format the remainder and push it back to varFree. }
|
||
result := fv;
|
||
vSize := fv^.size - size;
|
||
if (vSize > MaxFixedHeaderAndPayload) or
|
||
{ If fv is last in the OS chunk, remainder ≤ MaxFixedHeaderAndPayload is guaranteedly wasted.
|
||
If fv is not last, there is a hope that occupied chunk to the right might get freed one day and merge with the remainder. }
|
||
(vSize >= MinVarHeaderAndPayload) and (pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag = 0) then
|
||
begin
|
||
inc(pointer(fv), size); { result = allocated block, fv = remainder. }
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.prevSize := size;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.threadState := @self;
|
||
{$endif}
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.sizeHi := vSize shr 32;
|
||
{$endif}
|
||
{ Remainder is still last in the OS chunk if the original chunk was last. }
|
||
pVarHeader(pointer(fv) - VarHeaderSize)^.ch.h := pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag or uint32(vSize);
|
||
fv^.size := vSize;
|
||
if pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag = 0 then
|
||
pVarHeader(pointer(fv) + vSize - VarHeaderSize)^.prevSize := vSize;
|
||
|
||
{ Add fv to varFree. }
|
||
varNext := varFree;
|
||
fv^.prev := nil;
|
||
fv^.next := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := fv;
|
||
varFree := fv;
|
||
|
||
{ Allocated chunk is still first in the OS chunk if the original chunk was first. }
|
||
pVarHeader(result - VarHeaderSize)^.ch.h := pVarHeader(result - VarHeaderSize)^.ch.h and FirstFlag or UsedFlag or uint32(size);
|
||
end else
|
||
begin
|
||
{ Use the entire chunk. }
|
||
size := fv^.size;
|
||
pVarHeader(result - VarHeaderSize)^.ch.h := pVarHeader(result - VarHeaderSize)^.ch.h and (FirstFlag or LastFlag) or UsedFlag or uint32(size);
|
||
end;
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(result - VarHeaderSize)^.sizeHi := size shr 32;
|
||
{$endif}
|
||
inc(used, size);
|
||
if used > maxUsed then
|
||
maxUsed := used;
|
||
end;
|
||
|
||
function HeapInc.ThreadState.FreeVar(p: pointer): SizeUint;
|
||
var
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
chunkTs: pThreadState;
|
||
{$endif}
|
||
varPrev, varNext: pFreeVarChunk;
|
||
p2: pointer;
|
||
fSizeFlags: SizeUint;
|
||
osChunk, osPrev, osNext: pVarOSChunk;
|
||
freeOsNext: pFreeOSChunk;
|
||
begin
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
chunkTs := pVarHeader(p - VarHeaderSize)^.threadState;
|
||
if chunkTs <> @self then
|
||
begin
|
||
EnterCriticalSection(gs.lock);
|
||
chunkTs := pVarHeader(p - VarHeaderSize)^.threadState;
|
||
if Assigned(chunkTs) then
|
||
begin
|
||
{ Despite atomic Push lock must be held as otherwise target thread might end and destroy chunkTs.
|
||
However, target thread won’t block to free p, so PushToFree instantly invalidates p. }
|
||
result := {$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(p - VarHeaderSize)^.sizeHi) shl 32 or {$endif} pVarHeader(p - VarHeaderSize)^.ch.h and uint32(VarSizeMask) - VarHeaderSize;
|
||
chunkTs^.PushToFree(p);
|
||
LeaveCriticalSection(gs.lock);
|
||
exit;
|
||
end;
|
||
AdoptVarOwner(p); { ...And continue! }
|
||
LeaveCriticalSection(gs.lock);
|
||
end;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
|
||
fSizeFlags := {$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(p - VarHeaderSize)^.sizeHi) shl 32 or {$endif} pVarHeader(p - VarHeaderSize)^.ch.h;
|
||
result := fSizeFlags and VarSizeMask;
|
||
dec(used, result);
|
||
|
||
{ If next/prev are free, remove them from varFree and merge with f — (f)uture (f)ree chunk that starts at p, has fSizeFlags,
|
||
and conveniently always inherits prevSize of its final location. }
|
||
if fSizeFlags and LastFlag = 0 then
|
||
begin
|
||
p2 := p + result;
|
||
if pVarHeader(p2 - VarHeaderSize)^.ch.h and UsedFlag = 0 then
|
||
begin
|
||
fSizeFlags := (fSizeFlags + pFreeVarChunk(p2)^.size) or pVarHeader(p2 - VarHeaderSize)^.ch.h and LastFlag;
|
||
|
||
{ Remove p2 from varFree. }
|
||
varPrev := pFreeVarChunk(p2)^.prev;
|
||
varNext := pFreeVarChunk(p2)^.next;
|
||
if Assigned(varPrev) then
|
||
varPrev^.next := varNext
|
||
else
|
||
varFree := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := varPrev;
|
||
end;
|
||
end;
|
||
|
||
if fSizeFlags and FirstFlag = 0 then
|
||
begin
|
||
p2 := p - pVarHeader(p - VarHeaderSize)^.prevSize;
|
||
if pVarHeader(p2 - VarHeaderSize)^.ch.h and UsedFlag = 0 then
|
||
begin
|
||
p := p2;
|
||
fSizeFlags := (fSizeFlags + pFreeVarChunk(p2)^.size) or pVarHeader(p2 - VarHeaderSize)^.ch.h and FirstFlag;
|
||
|
||
{ Remove p2 from varFree. }
|
||
varPrev := pFreeVarChunk(p2)^.prev;
|
||
varNext := pFreeVarChunk(p2)^.next;
|
||
if Assigned(varPrev) then
|
||
varPrev^.next := varNext
|
||
else
|
||
varFree := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := varPrev;
|
||
end;
|
||
end;
|
||
|
||
{ Turn p into a free chunk and add it back to varFree...
|
||
unless it spans the entire OS chunk, in which case instead move the chunk from varOS to freeOS. }
|
||
if fSizeFlags and (FirstFlag or LastFlag) <> FirstFlag or LastFlag then
|
||
begin
|
||
if fSizeFlags and LastFlag = 0 then
|
||
pVarHeader(p + fSizeFlags and VarSizeMask - VarHeaderSize)^.prevSize := fSizeFlags and VarSizeMask;
|
||
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(p - VarHeaderSize)^.sizeHi := fSizeFlags shr 32;
|
||
{$endif}
|
||
pVarHeader(p - VarHeaderSize)^.ch.h := uint32(fSizeFlags) xor UsedFlag;
|
||
pFreeVarChunk(p)^.size := fSizeFlags and VarSizeMask;
|
||
|
||
{ Add p to varFree. }
|
||
varNext := varFree;
|
||
pFreeVarChunk(p)^.prev := nil;
|
||
pFreeVarChunk(p)^.next := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := p;
|
||
varFree := p;
|
||
end else
|
||
begin
|
||
osChunk := p - (VarOSChunkDataOffset + VarHeaderSize);
|
||
|
||
{ Remove osChunk from varOS. }
|
||
osPrev := osChunk^.prev;
|
||
osNext := osChunk^.next;
|
||
if Assigned(osPrev) then
|
||
osPrev^.next := osNext
|
||
else
|
||
varOS := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := osPrev;
|
||
|
||
{ Instantly free if huge. }
|
||
{$ifdef HAS_SYSOSFREE}
|
||
if osChunk^.size > GrowHeapSize2 then
|
||
begin
|
||
dec(allocated, osChunk^.size);
|
||
SysOSFree(osChunk, osChunk^.size);
|
||
end else
|
||
{$endif}
|
||
begin
|
||
{ Add to freeOS. }
|
||
freeOsNext := freeOS.first;
|
||
osChunk^.prev := nil;
|
||
osChunk^.next := freeOsNext;
|
||
if Assigned(freeOsNext) then
|
||
freeOsNext^.prev := osChunk
|
||
else
|
||
freeOS.last := pFreeOSChunk(osChunk);
|
||
freeOS.first := pFreeOSChunk(osChunk);
|
||
{$ifdef HAS_SYSOSFREE}
|
||
inc(freeOS.n);
|
||
if freeOS.n > MaxKeptOSChunks then
|
||
dec(allocated, freeOS.FreeOne);
|
||
{$endif}
|
||
end;
|
||
end;
|
||
dec(result, VarHeaderSize);
|
||
end;
|
||
|
||
function HeapInc.ThreadState.TryResizeVar(p: pointer; size: SizeUint): pointer;
|
||
var
|
||
fp, p2: pointer;
|
||
oldpsize, fSizeFlags, growby: SizeUint;
|
||
varNext, varPrev: pFreeVarChunk;
|
||
begin
|
||
if (size < MinVarHeaderAndPayload - VarHeaderSize) or (size > MaxVarPayload)
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
or (pVarHeader(p - VarHeaderSize)^.threadState <> @self)
|
||
{$endif}
|
||
then
|
||
exit(nil);
|
||
size := (size + (VarHeaderSize + VarSizeQuant - 1)) and SizeUint(-VarSizeQuant);
|
||
result := p; { From now on use result instead of p (saves a register). }
|
||
|
||
oldpsize := {$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(result - VarHeaderSize)^.sizeHi) shl 32 or {$endif} pVarHeader(result - VarHeaderSize)^.ch.h and uint32(VarSizeMask);
|
||
p2 := result + oldpsize;
|
||
{ (f)uture (f)ree chunk starting at p + size and having fSizeFlags will be created at the end, must exit before that if not required. }
|
||
if size <= oldpsize then
|
||
begin
|
||
{ Shrink. Maybe. }
|
||
fSizeFlags := oldpsize - size;
|
||
|
||
if pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag <> 0 then
|
||
begin
|
||
{ Has nothing to the right: create free chunk if > MaxFixedHeaderAndPayload, otherwise report success but change nothing. }
|
||
if fSizeFlags <= MaxFixedHeaderAndPayload then
|
||
exit;
|
||
dec(used, fSizeFlags);
|
||
fSizeFlags := fSizeFlags or LastFlag;
|
||
end
|
||
else if pVarHeader(p2 - VarHeaderSize)^.ch.h and UsedFlag <> 0 then
|
||
begin
|
||
{ Has used chunk to the right: create free chunk if ≥ MinVarHeaderAndPayload, following the same logic as in AllocVar. }
|
||
if fSizeFlags < MinVarHeaderAndPayload then
|
||
exit;
|
||
dec(used, fSizeFlags);
|
||
end else
|
||
begin
|
||
dec(used, fSizeFlags);
|
||
{ Has empty chunk to the right: extend with freed space. }
|
||
fSizeFlags := (fSizeFlags + pFreeVarChunk(p2)^.size) or pVarHeader(p2 - VarHeaderSize)^.ch.h and LastFlag;
|
||
|
||
{ Remove p2 from varFree. }
|
||
varPrev := pFreeVarChunk(p2)^.prev;
|
||
varNext := pFreeVarChunk(p2)^.next;
|
||
if Assigned(varPrev) then
|
||
varPrev^.next := varNext
|
||
else
|
||
varFree := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := varPrev;
|
||
end;
|
||
|
||
{ Update p size. }
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(result - VarHeaderSize)^.sizeHi := size shr 32;
|
||
{$endif}
|
||
pVarHeader(result - VarHeaderSize)^.ch.h := uint32(size) or pVarHeader(result - VarHeaderSize)^.ch.h and (FirstFlag or UsedFlag);
|
||
end
|
||
{ Grow if there is free space. }
|
||
else if (pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag = 0) and (pVarHeader(p2 - VarHeaderSize)^.ch.h and UsedFlag = 0) and
|
||
(pFreeVarChunk(p2)^.size >= size - oldpsize) then
|
||
begin
|
||
fSizeFlags := pFreeVarChunk(p2)^.size - (size - oldpsize);
|
||
if pVarHeader(p2 - VarHeaderSize)^.ch.h and LastFlag = 0 then
|
||
begin
|
||
if fSizeFlags <= MaxFixedHeaderAndPayload then
|
||
fSizeFlags := 0;
|
||
end else
|
||
if fSizeFlags < MinVarHeaderAndPayload then
|
||
fSizeFlags := 0
|
||
else
|
||
fSizeFlags := fSizeFlags or LastFlag;
|
||
|
||
growby := pFreeVarChunk(p2)^.size - fSizeFlags and VarSizeMask;
|
||
size := oldpsize + growby;
|
||
inc(used, growby);
|
||
if used > maxUsed then
|
||
maxUsed := used;
|
||
|
||
{ Remove p2 from varFree. }
|
||
varPrev := pFreeVarChunk(p2)^.prev;
|
||
varNext := pFreeVarChunk(p2)^.next;
|
||
if Assigned(varPrev) then
|
||
varPrev^.next := varNext
|
||
else
|
||
varFree := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := varPrev;
|
||
|
||
{ Update p size. }
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(result - VarHeaderSize)^.sizeHi := size shr 32;
|
||
{$endif}
|
||
pVarHeader(result - VarHeaderSize)^.ch.h := uint32(size) or pVarHeader(result - VarHeaderSize)^.ch.h and (FirstFlag or UsedFlag);
|
||
{ No empty chunk? }
|
||
if fSizeFlags = 0 then
|
||
begin
|
||
if pVarHeader(p2 - VarHeaderSize)^.ch.h and LastFlag <> 0 then
|
||
pVarHeader(result - VarHeaderSize)^.ch.h := pVarHeader(result - VarHeaderSize)^.ch.h or LastFlag
|
||
else
|
||
pVarHeader(result + size - VarHeaderSize)^.prevSize := size;
|
||
exit;
|
||
end;
|
||
end
|
||
{$ifdef HAS_SYSOSREALLOC}
|
||
else if (oldpsize >= 64 * 1024) and { Don’t do SysOSRealloc if the source is under 64 Kb (arbitrary value). }
|
||
(pVarHeader(result - VarHeaderSize)^.ch.h and FirstFlag <> 0) and
|
||
((pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag <> 0) or (pVarHeader(p2 - VarHeaderSize)^.ch.h and (LastFlag or UsedFlag) = LastFlag)) then
|
||
exit(TrySysOSRealloc(result, oldpsize, size))
|
||
{$endif}
|
||
else
|
||
exit(nil);
|
||
|
||
{ Format new free var chunk. }
|
||
fp := result + size;
|
||
pVarHeader(fp - VarHeaderSize)^.prevSize := size;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
pVarHeader(fp - VarHeaderSize)^.threadState := @self;
|
||
{$endif}
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(fp - VarHeaderSize)^.sizeHi := fSizeFlags shr 32;
|
||
{$endif}
|
||
pVarHeader(fp - VarHeaderSize)^.ch.h := uint32(fSizeFlags);
|
||
pFreeVarChunk(fp)^.size := fSizeFlags and VarSizeMask;
|
||
if fSizeFlags and LastFlag = 0 then
|
||
pVarHeader(fp + fSizeFlags and VarSizeMask - VarHeaderSize)^.prevSize := fSizeFlags and VarSizeMask;
|
||
|
||
{ Add fp to varFree. }
|
||
varNext := varFree;
|
||
pFreeVarChunk(fp)^.prev := nil;
|
||
pFreeVarChunk(fp)^.next := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := fp;
|
||
varFree := fp;
|
||
end;
|
||
|
||
{$ifdef HAS_SYSOSREALLOC}
|
||
function HeapInc.ThreadState.TrySysOSRealloc(p: pointer; oldSize, newSize: SizeUint): pointer;
|
||
var
|
||
newOSSize: SizeUint;
|
||
hasFreeChunkToTheRight: boolean;
|
||
vf, varPrev, varNext: pFreeVarChunk;
|
||
begin
|
||
{ Either p is the only chunk or has last empty chunk to the right. }
|
||
hasFreeChunkToTheRight := pVarHeader(p - VarHeaderSize)^.ch.h and LastFlag = 0;
|
||
|
||
{ Don’t do SysOSRealloc if the source chunk is <12.5% (arbitrary value) of the empty chunk to the right. }
|
||
if hasFreeChunkToTheRight and (oldSize < pFreeVarChunk(p + oldSize)^.size div 8) then
|
||
exit(nil);
|
||
|
||
newOSSize := (newSize + (VarOSChunkDataOffset + OSChunkVarSizeQuant - 1)) and SizeUint(-OSChunkVarSizeQuant);
|
||
p := SysOSRealloc(p - (VarOSChunkDataOffset + VarHeaderSize), pVarOSChunk(p - (VarOSChunkDataOffset + VarHeaderSize))^.size, newOSSize);
|
||
if not Assigned(p) then
|
||
exit(nil);
|
||
|
||
inc(allocated, newOSSize - pVarOSChunk(p)^.size);
|
||
if allocated > maxAllocated then
|
||
maxAllocated := allocated;
|
||
pVarOSChunk(p)^.size := newOSSize;
|
||
{ For simplicity, new chunk spans the entire OS chunk. }
|
||
newOSSize := (newOSSize - VarOSChunkDataOffset) and SizeUint(-VarSizeQuant);
|
||
inc(used, newOSSize - oldSize);
|
||
if used > maxUsed then
|
||
maxUsed := used;
|
||
|
||
{ Update p size. }
|
||
{$if sizeof(SizeUint) > 4}
|
||
pVarHeader(p + VarOSChunkDataOffset)^.sizeHi := newOSSize shr 32;
|
||
{$endif}
|
||
pVarHeader(p + VarOSChunkDataOffset)^.ch.h := uint32(newOSSize) or (FirstFlag or LastFlag or UsedFlag);
|
||
|
||
{ Careful! Old pointers into p are invalidated and must be fixed.
|
||
There are up to 3 invalidated pointers: OS chunk in varOS, old p itself (p is reused for new OS chunk pointer), maybe empty chunk to the right in varFree. }
|
||
if Assigned(pVarOSChunk(p)^.next) then
|
||
pVarOSChunk(pVarOSChunk(p)^.next)^.prev := p;
|
||
if Assigned(pVarOSChunk(p)^.prev) then
|
||
pVarOSChunk(pVarOSChunk(p)^.prev)^.next := p
|
||
else
|
||
varOS := p;
|
||
|
||
result := p + (VarOSChunkDataOffset + VarHeaderSize);
|
||
if hasFreeChunkToTheRight then
|
||
begin
|
||
vf := result + oldSize;
|
||
|
||
{ Remove vf from varFree. }
|
||
varPrev := vf^.prev;
|
||
varNext := vf^.next;
|
||
if Assigned(varPrev) then
|
||
varPrev^.next := varNext
|
||
else
|
||
varFree := varNext;
|
||
if Assigned(varNext) then
|
||
varNext^.prev := varPrev;
|
||
end;
|
||
end;
|
||
{$endif HAS_SYSOSREALLOC}
|
||
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
procedure HeapInc.ThreadState.PushToFree(p: pFreeChunk);
|
||
var
|
||
next: pFreeChunk;
|
||
begin
|
||
repeat
|
||
next := toFree;
|
||
p^.next := next;
|
||
WriteBarrier; { Write p after p^.next. }
|
||
until InterlockedCompareExchange(toFree, p, next) = next;
|
||
end;
|
||
|
||
procedure HeapInc.ThreadState.FlushToFree;
|
||
var
|
||
tf, nx: pFreeChunk;
|
||
begin
|
||
tf := InterlockedExchange(toFree, nil);
|
||
while Assigned(tf) do
|
||
begin
|
||
ReadDependencyBarrier; { Read toFree^.next after toFree. }
|
||
nx := tf^.next;
|
||
if pCommonHeader(pointer(tf) - CommonHeaderSize)^.h and FixedFlag <> 0 then
|
||
FreeFixed(tf)
|
||
else
|
||
FreeVar(tf);
|
||
tf := nx;
|
||
end;
|
||
end;
|
||
|
||
procedure HeapInc.ThreadState.Orphan;
|
||
var
|
||
sizeIndex: SizeUint;
|
||
lastFree, nextFree: pFreeOSChunk;
|
||
vOs, nextVOs, lastVOs: pVarOSChunk;
|
||
begin
|
||
FlushToFree;
|
||
Orphan(fullOS);
|
||
for sizeIndex := 0 to High(fixedPartialOS) do
|
||
Orphan(fixedPartialOS[sizeIndex]);
|
||
{ Prepend freeOS to gs.freeOS. }
|
||
lastFree := freeOS.last;
|
||
if Assigned(lastFree) then
|
||
begin
|
||
nextFree := gs.freeOS.first;
|
||
lastFree^.next := nextFree;
|
||
if Assigned(nextFree) then
|
||
nextFree^.prev := lastFree
|
||
else
|
||
gs.freeOS.last := lastFree;
|
||
gs.freeOS.first := freeOS.first;
|
||
{$ifdef HAS_SYSOSFREE}
|
||
inc(gs.freeOS.n, freeOS.n);
|
||
while gs.freeOS.n > MaxKeptOSChunks do
|
||
gs.freeOS.FreeOne;
|
||
{$endif}
|
||
end;
|
||
{ Prepend varOS to gs.varOS. }
|
||
vOs := varOS;
|
||
if Assigned(vOs) then
|
||
begin
|
||
nextVOs := gs.varOS;
|
||
gs.varOS := vOs;
|
||
repeat
|
||
lastVOs := vOs;
|
||
ChangeThreadState(vOs, nil);
|
||
vOs := vOs^.next;
|
||
until not Assigned(vOs);
|
||
lastVOs^.next := nextVOs;
|
||
if Assigned(nextVOs) then
|
||
nextVOs^.prev := lastVOs;
|
||
end;
|
||
|
||
{ Zeroing is probably required, because Orphan is called from FinalizeHeap which is called from DoneThread which can be called twice, according to this comment from syswin.inc: }
|
||
// DoneThread; { Assume everything is idempotent there }
|
||
FillChar(self, sizeof(self), 0);
|
||
end;
|
||
|
||
class procedure HeapInc.ThreadState.Orphan(list: pFixedOSChunk);
|
||
var
|
||
last, osNext: pFixedOSChunk;
|
||
begin
|
||
if not Assigned(list) then
|
||
exit;
|
||
last := pFixedOSChunk(ChangeThreadStates(list, nil));
|
||
{ Prepend list to gs.fixedOS. }
|
||
osNext := gs.fixedOS;
|
||
last^.next := osNext;
|
||
if Assigned(osNext) then
|
||
osNext^.prev := last;
|
||
gs.fixedOS := list;
|
||
end;
|
||
|
||
procedure HeapInc.ThreadState.Adopt(osChunk: pFixedOSChunk);
|
||
var
|
||
sizeIndex: SizeUint;
|
||
dest: ^pFixedOSChunk;
|
||
begin
|
||
sizeIndex := pCommonHeader(pointer(osChunk) + FixedOSChunkDataOffset)^.h and SizeIndexMask;
|
||
inc(used, osChunk^.usedSize);
|
||
if used > maxUsed then
|
||
maxUsed := used;
|
||
inc(allocated, osChunk^.size);
|
||
if allocated > maxAllocated then
|
||
maxAllocated := allocated;
|
||
|
||
{ Remove osChunk from gs.fixedOS, add to fullOS or fixedPartialOS[sizeIndex] as appropriate. }
|
||
dest := @fixedPartialOS[sizeIndex];
|
||
if osChunk^.usedSize >= osChunk^.fullThreshold then
|
||
begin
|
||
inc(allocatedByFullFixed[sizeIndex], osChunk^.size);
|
||
dest := @fullOS;
|
||
end;
|
||
osChunk^.MoveTo(gs.fixedOS, dest^);
|
||
|
||
osChunk^.threadState := @self;
|
||
end;
|
||
|
||
procedure HeapInc.ThreadState.AdoptVarOwner(p: pointer);
|
||
var
|
||
prevSize, size: SizeUint;
|
||
h: uint32;
|
||
varFreeHead: pFreeVarChunk;
|
||
begin
|
||
repeat
|
||
prevSize := pVarHeader(p - VarHeaderSize)^.prevSize;
|
||
dec(p, prevSize);
|
||
until prevSize = 0;
|
||
|
||
{ Move OS chunk from gs.varOS to varOS. }
|
||
pOSChunk(p - (VarOSChunkDataOffset + VarHeaderSize))^.MoveTo(gs.varOS, varOS);
|
||
inc(allocated, pOSChunk(p - (VarOSChunkDataOffset + VarHeaderSize))^.size);
|
||
if allocated > maxAllocated then
|
||
maxAllocated := allocated;
|
||
|
||
{ Careful: even though VarHeaders have own threadState links, correct threadState in the OS chunk is required,
|
||
as the chunk might be orphaned, then adopted with this function, then become free, then be reused as fixed chunk.
|
||
GetOSChunk does not set threadState if it takes the chunk from local freeOS, assuming it is already set. }
|
||
pOSChunk(p - (VarOSChunkDataOffset + VarHeaderSize))^.threadState := @self;
|
||
|
||
varFreeHead := varFree;
|
||
repeat
|
||
pVarHeader(p - VarHeaderSize)^.threadState := @self;
|
||
h := pVarHeader(p - VarHeaderSize)^.ch.h;
|
||
size := {$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(p - VarHeaderSize)^.sizeHi) shl 32 or {$endif} h and uint32(VarSizeMask);
|
||
if h and UsedFlag = 0 then
|
||
begin
|
||
{ Add free chunk to varFree. }
|
||
pFreeVarChunk(p)^.prev := nil;
|
||
pFreeVarChunk(p)^.next := varFreeHead;
|
||
if Assigned(varFreeHead) then
|
||
varFreeHead^.prev := pFreeVarChunk(p);
|
||
varFreeHead := p;
|
||
end else
|
||
inc(used, size); { maxUsed is updated after the loop. }
|
||
inc(p, size);
|
||
until h and LastFlag <> 0;
|
||
varFree := varFreeHead;
|
||
if used > maxUsed then
|
||
maxUsed := used;
|
||
end;
|
||
|
||
class function HeapInc.ThreadState.ChangeThreadStates(list: pOSChunk; ts: pThreadState): pOSChunk; static; { Returns the last item of list. }
|
||
begin
|
||
if not Assigned(list) then
|
||
exit(nil);
|
||
repeat
|
||
list^.threadState := ts;
|
||
result := list;
|
||
list := list^.next;
|
||
until not Assigned(list);
|
||
end;
|
||
|
||
class procedure HeapInc.ThreadState.ChangeThreadState(vOs: pVarOSChunk; ts: pThreadState);
|
||
var
|
||
h: uint32;
|
||
p: pointer;
|
||
begin
|
||
vOs^.threadState := ts; { Not really required (for now), but done for symmetry; also see the comment on setting OSChunk.threadState in AdoptVarOwner. }
|
||
p := pointer(vOs) + (VarOSChunkDataOffset + VarHeaderSize);
|
||
repeat
|
||
pVarHeader(p - VarHeaderSize)^.threadState := ts;
|
||
h := pVarHeader(p - VarHeaderSize)^.ch.h;
|
||
inc(p, {$if sizeof(SizeUint) > 4} SizeUint(pVarHeader(p - VarHeaderSize)^.sizeHi) shl 32 or {$endif} h and uint32(VarSizeMask));
|
||
until h and LastFlag <> 0;
|
||
end;
|
||
|
||
{$ifndef FPC_SECTION_THREADVARS}
|
||
procedure HeapInc.ThreadState.FixupSelfPtr;
|
||
var
|
||
sizeIndex: SizeUint;
|
||
vOs: pVarOSChunk;
|
||
begin
|
||
ChangeThreadStates(fullOS, @self);
|
||
for sizeIndex := 0 to High(fixedPartialOS) do
|
||
ChangeThreadStates(fixedPartialOS[sizeIndex], @self);
|
||
ChangeThreadStates(freeOS.first, @self);
|
||
vOs := varOS;
|
||
while Assigned(vOs) do
|
||
begin
|
||
ChangeThreadState(vOs, @self);
|
||
vOs := vOs^.next;
|
||
end;
|
||
end;
|
||
{$endif ndef FPC_SECTION_THREADVARS}
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
|
||
function SysGetFPCHeapStatus:TFPCHeapStatus;
|
||
var
|
||
ts: HeapInc.pThreadState;
|
||
begin
|
||
ts := @HeapInc.thisTs;
|
||
result.MaxHeapSize := ts^.maxAllocated;
|
||
result.MaxHeapUsed := ts^.maxUsed;
|
||
result.CurrHeapSize := ts^.allocated;
|
||
result.CurrHeapUsed := ts^.used;
|
||
result.CurrHeapFree := result.CurrHeapSize - result.CurrHeapUsed;
|
||
end;
|
||
|
||
function SysGetHeapStatus :THeapStatus;
|
||
var
|
||
ts: HeapInc.pThreadState;
|
||
begin
|
||
FillChar((@result)^, sizeof(result), 0);
|
||
ts := @HeapInc.thisTs;
|
||
result.TotalAllocated :=ts^.used;
|
||
result.TotalFree :=ts^.allocated - ts^.used;
|
||
result.TotalAddrSpace :=ts^.allocated;
|
||
end;
|
||
|
||
function SysGetMem(size : ptruint):pointer;
|
||
var
|
||
ts: HeapInc.pThreadState;
|
||
begin
|
||
ts := @HeapInc.thisTs;
|
||
if size <= HeapInc.MaxFixedHeaderAndPayload - HeapInc.CommonHeaderSize then
|
||
result := ts^.AllocFixed(size)
|
||
else
|
||
result := ts^.AllocVar(size);
|
||
end;
|
||
|
||
function SysFreeMem(p: pointer): ptruint;
|
||
var
|
||
ts: HeapInc.pThreadState;
|
||
begin
|
||
result := 0;
|
||
if Assigned(p) then
|
||
begin
|
||
ts := @HeapInc.thisTs;
|
||
if HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h and HeapInc.FixedFlag <> 0 then
|
||
result := ts^.FreeFixed(p)
|
||
else
|
||
result := ts^.FreeVar(p);
|
||
end;
|
||
end;
|
||
|
||
function SysTryResizeMem(var p: pointer; size: ptruint): boolean;
|
||
var
|
||
ts: HeapInc.pThreadState;
|
||
h: uint32;
|
||
newp: pointer;
|
||
begin
|
||
h := HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h;
|
||
if h and HeapInc.FixedFlag <> 0 then
|
||
{ Don’t shrink fixed chunk. }
|
||
result := size <= SizeUint(HeapInc.IndexToSize(h and HeapInc.SizeIndexMask) - HeapInc.CommonHeaderSize)
|
||
else
|
||
begin
|
||
ts := @HeapInc.thisTs;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
if Assigned(ts^.toFree) then
|
||
ts^.FlushToFree;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
newp := ts^.TryResizeVar(p, size);
|
||
result := Assigned(newp);
|
||
if result then
|
||
p := newp;
|
||
end;
|
||
end;
|
||
|
||
function SysMemSize(p: pointer): ptruint;
|
||
var
|
||
h: uint32;
|
||
begin
|
||
if not Assigned(p) then
|
||
exit(0);
|
||
h := HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h;
|
||
if h and HeapInc.FixedFlag <> 0 then
|
||
result := HeapInc.IndexToSize(h and HeapInc.SizeIndexMask) - HeapInc.CommonHeaderSize
|
||
else
|
||
result := {$if sizeof(SizeUint) > 4} SizeUint(HeapInc.pVarHeader(p - HeapInc.VarHeaderSize)^.sizeHi) shl 32 or {$endif}
|
||
HeapInc.pVarHeader(p - HeapInc.VarHeaderSize)^.ch.h and uint32(HeapInc.VarSizeMask)
|
||
- HeapInc.VarHeaderSize;
|
||
end;
|
||
|
||
function SysReAllocMem(var p: pointer; size: ptruint):pointer;
|
||
var
|
||
oldsize, newsize, tocopy: SizeUint;
|
||
begin
|
||
if size = 0 then
|
||
begin
|
||
SysFreeMem(p);
|
||
result := nil;
|
||
p := nil;
|
||
end
|
||
else if not Assigned(p) then
|
||
begin
|
||
result := SysGetMem(size);
|
||
p := result;
|
||
end
|
||
else if SysTryResizeMem(p, size) then
|
||
result := p
|
||
else
|
||
begin
|
||
oldsize := SysMemSize(p);
|
||
newsize := size;
|
||
result := SysGetMem(newsize);
|
||
if not Assigned(result) then
|
||
begin
|
||
if size <= oldsize then
|
||
{ Don’t fail if shrinking. }
|
||
result := p;
|
||
exit; { If growing failed, return nil, but keep the old p. }
|
||
end;
|
||
tocopy := oldsize;
|
||
if tocopy > newsize then
|
||
tocopy := newsize;
|
||
Move(p^, result^, tocopy);
|
||
SysFreeMem(p);
|
||
p := result;
|
||
end;
|
||
end;
|
||
|
||
Function SysFreeMemSize(p: pointer; size: ptruint):ptruint;
|
||
begin
|
||
{ can't free partial blocks, ignore size }
|
||
result := SysFreeMem(p);
|
||
end;
|
||
|
||
function SysAllocMem(size: ptruint): pointer;
|
||
begin
|
||
result := SysGetMem(size);
|
||
if Assigned(result) then
|
||
FillChar(result^, SysMemSize(result), 0);
|
||
end;
|
||
|
||
{$endif FPC_NO_DEFAULT_HEAP}
|
||
|
||
{$ifndef HAS_MEMORYMANAGER}
|
||
|
||
{*****************************************************************************
|
||
InitHeap
|
||
*****************************************************************************}
|
||
|
||
{$ifndef FPC_NO_DEFAULT_HEAP}
|
||
{ This function will initialize the Heap manager and need to be called from
|
||
the initialization of the system unit }
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
procedure InitHeapThread;
|
||
begin
|
||
if HeapInc.gs.lockUse>0 then
|
||
InterlockedIncrement(HeapInc.gs.lockUse);
|
||
end;
|
||
{$endif}
|
||
|
||
procedure InitHeap; public name '_FPC_InitHeap';
|
||
begin
|
||
{ we cannot initialize the locks here yet, thread support is
|
||
not loaded yet }
|
||
end;
|
||
|
||
procedure RelocateHeap;
|
||
begin
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
if HeapInc.gs.lockUse > 0 then
|
||
exit;
|
||
HeapInc.gs.lockUse := 1;
|
||
InitCriticalSection(HeapInc.gs.lock);
|
||
{$ifndef FPC_SECTION_THREADVARS}
|
||
{ threadState pointers still point to main thread's thisTs, but they
|
||
have a reference to the global main thisTs, fix them to point
|
||
to the main thread specific variable.
|
||
even if section threadvars are used, this shouldn't cause problems as threadState pointers simply
|
||
do not change but we do not need it }
|
||
HeapInc.thisTs.FixupSelfPtr;
|
||
{$endif FPC_SECTION_THREADVARS}
|
||
if MemoryManager.RelocateHeap <> nil then
|
||
MemoryManager.RelocateHeap();
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
end;
|
||
|
||
procedure FinalizeHeap;
|
||
begin
|
||
{ Do not try to do anything if the heap manager already reported an error }
|
||
if (errorcode=203) or (errorcode=204) then
|
||
exit;
|
||
{$ifdef FPC_HAS_FEATURE_THREADING}
|
||
if HeapInc.gs.lockUse > 0 then
|
||
EnterCriticalSection(HeapInc.gs.lock);
|
||
HeapInc.thisTs.Orphan;
|
||
if HeapInc.gs.lockUse > 0 then
|
||
begin
|
||
LeaveCriticalSection(HeapInc.gs.lock);
|
||
if InterlockedDecrement(HeapInc.gs.lockUse) = 0 then
|
||
begin
|
||
DoneCriticalSection(HeapInc.gs.lock);
|
||
{$ifdef HAS_SYSOSFREE}
|
||
HeapInc.gs.freeOS.FreeAll;
|
||
{$endif}
|
||
end;
|
||
end;
|
||
{$else FPC_HAS_FEATURE_THREADING}
|
||
HeapInc.thisTs.freeOS.FreeAll;
|
||
{$endif FPC_HAS_FEATURE_THREADING}
|
||
end;
|
||
|
||
{$endif ndef HAS_MEMORYMANAGER}
|
||
|
||
{$endif ndef FPC_NO_DEFAULT_MEMORYMANAGER}
|
||
{$endif defined(FPC_HAS_FEATURE_HEAP) or defined(FPC_IN_HEAPMGR)}
|