Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1777 lines (1614 sloc) 54.7 KB
/// fast scaling memory manager for Delphi
// - this unit is a part of the freeware Synopse framework,
// licensed under a MPL/GPL/LGPL tri-license; version 0.4
unit SynScaleMM;
{
Original code is ScaleMM - Fast scaling memory manager for Delphi
by André Mussche - Released under Mozilla Public License 1.1
http://code.google.com/p/scalemm
Simple, small and compact MM, built on top of the main Memory Manager
(FastMM4 is a good candidate, standard since Delphi 2007), architectured
in order to scale on multi core CPU's (which is what FastMM4 is lacking).
Usage:
- Delphi 6 up to Delphi 2005 with FastMM4:
Place FastMM4 as the very first unit under the "uses" clause of your
project's .dpr file THEN add SynScaleMM to the "uses" clause
- Delphi 6 up to Delphi 2005 with no FastMM4 or Delphi 2006 up to Delphi XE:
Place SynScaleMM as the very first unit under the "uses" clause of your
project's .dpr file.
SynScaleMM - fast scaling memory manager for Delphi
-----------------------------------------------------
Modifications/fork to SynScaleMM by A.Bouchez - https://synopse.info:
- Synchronized with r19 revision, from Dec 6, 2010;
- Compiles from Delphi 6 up to Delphi XE;
- Some pascal code converted to faster asm;
- Some code refactoring, a lot of comments added;
- Added medium block handling from 2048 bytes up to 16384;
- Released under MPL 1.1/GPL 2.0/LGPL 2.1 tri-license.
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is ScaleMM - Fast scaling memory manager for Delphi.
The Initial Developer of the Original Code is André Mussche.
Portions created by the Initial Developer are Copyright (C) 2018
the Initial Developer. All Rights Reserved.
Contributor(s):
- Arnaud Bouchez https://synopse.info
Portions created by each contributor are Copyright (C) 2018
each contributor. All Rights Reserved.
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
Version 0.4
- Reallocation made a lot faster, in case of a growing size by some bytes
}
interface
{.$DEFINE DEBUG_SCALEMM} // slower but better debugging (no inline functions etc)
/// internal GetSmallMemManager function is 2% faster with an injected offset
{$define SCALE_INJECT_OFFSET}
// inlined TLS access
// - injected offset + GetSmallMemManager call can be slower than offset loading
{$define INLINEGOWN}
{$ifdef INLINEGOWN}
{$ifndef HASINLINE} // inlined Getmem/Freemem will call GetSmallMemManager
{$undef SCALE_INJECT_OFFSET}
{$endif}
{$endif}
// enable Backing Off Locks with Spin-Wait Loops
// - see http://software.intel.com/en-us/articles/implementing-scalable-atomic-locks-for-multi-core-intel-em64t-and-ia32-architectures
{$define SPINWAITBACKOFF}
// other posible defines:
{.$define ALLOCBY64} // allocated by 64 memory items (if undefined, by 32)
{.$define PURE_PASCAL} // no assembly, pure delphi code
{.$define Align16Bytes} // 16 byte aligned header, so some more overhead
{$define USEMEDIUM} // handling of 2048..16384 bytes blocks
{.$define USEBITMAP} // freed blocks per bit storage (experimental)
{.$define BACKOFFSLEEP1} // could avoid race condition in some (rare) cases
{$ifdef DEBUG_SCALEMM}
{$OPTIMIZATION OFF}
{$STACKFRAMES ON}
{$ASSERTIONS ON}
{$DEBUGINFO ON}
{$OVERFLOWCHECKS ON}
{$RANGECHECKS ON}
{$else} // default "release" mode, much faster!
{$OPTIMIZATION ON} // 235% faster!
{$STACKFRAMES OFF} // 12% faster
{$ASSERTIONS OFF}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$if CompilerVersion >= 17}
{$define HASINLINE} // Delphi 2005 or newer
{$ifend}
{$D-}
{$L-}
{$endif}
{$ifdef USEBITMAP} // bitmap size must match NativeUInt bit count
{$ifdef CPUX64}
{$define ALLOCBY64}
{$else}
{$undef ALLOCBY64}
{$endif}
{$endif}
const
/// alloc memory blocks with 64 or 32 memory items each time
// - 64 = 1 shl 6, 32 = 1 shl 5, therefore any multiplication compiles into
// nice and fast shl opcode
// - on a heavily multi-threaded application, with USEMEDIUM defined below,
// a lower value (i.e. 32) could be used instead (maybe dedicated value for
// medium blocks would be even better)
// - if USEBITMAP is defined, this size will match the NativeUInt bit count
C_ARRAYSIZE = {$ifdef ALLOCBY64}64{$else}32{$endif};
/// keep 10 free blocks in cache
C_GLOBAL_BLOCK_CACHE = 10;
{$if CompilerVersion < 19}
type // from Delphi 6 up to Delphi 2007
NativeUInt = Cardinal;
NativeInt = Integer;
{$ifend}
{$if CompilerVersion >= 17}
{$define USEMEMMANAGEREX}
{$ifend}
const
{$ifdef USEMEDIUM}
/// Maximum index of 2048 bytes granularity Medium blocks
// - 63488 could have been the upper limit because 65536=63488+2048 won't fit in
// a FItemSize: word, but it will allocate 63488*C_ARRAYSIZE=4 MB per thread!
// - so we allocate here up to 16384 bytes, i.e. 1 MB, which sounds
// reasonable
// - a global VirtualAlloc() bigger block, splitted into several medium blocks,
// via a double-linked list (see FastMM4 algorithm) could be implemented instead
MAX_MEDIUMMEMBLOCK = 7;
/// Maximum index of 256 bytes granularity Small blocks
MAX_SMALLMEMBLOCK = 6;
{$else}
/// Maximum index of 256 bytes granularity Small blocks
// - Small blocks will include 2048 if Medium Blocks not handled
MAX_SMALLMEMBLOCK = 7;
{$endif}
type
PMemBlock = ^TMemBlock;
PMemBlockList = ^TMemBlockList;
PThreadMemManager = ^TThreadMemManager;
PMemHeader = ^TMemHeader;
{$A-} { all object/record must be packed }
/// Header appended to the beginning of every allocated memory block
TMemHeader = object
/// the memory block handler which owns this memory block
Owner: PMemBlock;
{$ifdef USEBITMAP}
/// the index in the array[0..C_ARRAYSIZE-1] of Owner memory items
FIndexInMemBlockArray: NativeUInt;
{$else}
/// linked to next single memory item (other thread freem mem)
NextMem: PMemHeader;
{$endif}
{$ifdef Align16Bytes}
todo
{$endif}
end;
/// memory block handler
// - internal storage of the memory blocks will follow this structure, and
// will contain array[0..C_ARRAYSIZE-1] of memory items,
// i.e. (FItemSize + SizeOf(TMemHeader)) * C_ARRAYSIZE bytes
TMemBlock = object
/// the memory block list which owns this memory block handler
Owner: PMemBlockList;
/// link to the next list with free memory
FNextMemBlock: PMemBlock;
/// link to the previous list with free memory
// - double linked to be able for fast removal of one block
FPreviousMemBlock: PMemBlock;
/// link to the next list with freed memory, in case this list has no more freed mem
FNextFreedMemBlock: PMemBlock;
/// link to the previous list with freed memory
FPreviousFreedMemBlock: PMemBlock;
{$ifdef USEBITMAP}
/// individual bit is set for any block which is to be freed from other thread
FToBeFreedFromOtherThread: NativeUInt;
/// link to the next TMemBlock containing blocks to be freed from other thread
NextMem: PMemBlock;
/// individual bit is set for any available block in [0..C_ARRAYSIZE-1]
FAvailable: NativeUInt;
{$else}
/// how much free mem is used, max is C_ARRAYSIZE
FUsageCount: NativeUInt;
/// current index in FFreedArray
FFreedIndex: NativeUInt;
/// points to all freed PMemHeader
FFreedArray: array[0..C_ARRAYSIZE-1] of Pointer;
{$endif}
function GetUsedMemoryItem: PMemHeader; {$ifdef HASINLINE}inline;{$endif}
procedure FreeMem(aMemoryItem: PMemHeader); {$ifdef HASINLINE}inline;{$endif}
procedure FreeBlockMemoryToGlobal;
end;
/// memory block list
// - current size if 16 bytes (this is a packed object)
TMemBlockList = object
/// the per-thread memory manager which created this block
Owner: PThreadMemManager;
/// list containing freed memory (which this block owns)
// - used to implement a fast caching of memory blocks
FFirstFreedMemBlock: PMemBlock;
/// list containing all memory this block owns
FFirstMemBlock: PMemBlock;
/// size of memory items (32, 64 etc bytes)
FItemSize : word;
/// number of blocks inside FFirstFreedMemBlock
FFreeMemCount: byte;
/// recursive check when we alloc memory for this blocksize (new memory list)
FRecursive: boolean;
{$ifdef CPUX64}
// for faster "array[0..7] of TMemBlockList" calc
// (for 32 bits, the TMemBlockList instance size if 16 bytes)
FFiller: array[1..sizeof(NativeInt)-sizeof(word)-sizeof(byte)-sizeof(boolean)] of byte;
{$endif}
procedure AddNewMemoryBlock;
function GetMemFromNewBlock : Pointer;
end;
POtherThreadFreedMemory = {$ifdef USEBITMAP}PMemBlock{$else}PMemHeader{$endif};
/// handles per-thread memory managment
TThreadMemManager = object
private
/// link to the list of mem freed in other thread
FOtherThreadFreedMemory: POtherThreadFreedMemory;
/// array with memory per block size of 32 bytes (mini blocks)
// - i.e. 32, 64, 96, 128, 160, 192, 224 bytes
FMiniMemoryBlocks: array[0..6] of TMemBlockList;
/// array with memory per block size of 256 bytes (small blocks)
// - i.e. 256,512,768,1024,1280,1536,1792[,2048] bytes
FSmallMemoryBlocks: array[0..MAX_SMALLMEMBLOCK] of TMemBlockList;
{$ifdef USEMEDIUM}
/// array with memory per block size of 2048 bytes (medium blocks)
// - i.e. 2048,4096,6144,8192,10240,12288,14336,16384 bytes
FMediumMemoryBlocks: array[0..MAX_MEDIUMMEMBLOCK] of TMemBlockList;
{$endif}
// link to list of items to reuse after thread terminated
FNextThreadManager: PThreadMemManager;
procedure ProcessFreedMemFromOtherThreads;
procedure AddFreedMemFromOtherThread(aMemory: PMemHeader);
public
FThreadId: LongWord;
/// is this thread memory available to new thread?
FThreadTerminated: Boolean;
procedure Init;
procedure Reset;
function GetMem(aSize: NativeUInt): Pointer; {$ifdef HASINLINE}inline;{$endif}
function FreeMem(aMemory: Pointer): NativeInt; {$ifdef HASINLINE}inline;{$endif}
end;
/// Global memory manager
// - a single instance is created for the whole process
// - caches some memory (blocks + threadmem) for fast reuse
// - also keeps allocated memory in case an old thread allocated some memory
// for another thread
TGlobalMemManager = object
private
/// all thread memory managers
FFirstThreadMemory: PThreadMemManager;
/// freed/used thread memory managers
// - used to cache the per-thread managers in case of multiple threads creation
FFirstFreedThreadMemory: PThreadMemManager;
/// main thread manager (owner of all global mem)
FMainThreadMemory: PThreadMemManager;
/// Freed/used memory: array with memory per 32 bytes block size
// - i.e. 32, 64, 96, 128, 160, 192, 224 bytes
FFreedMiniMemoryBlocks : array[0..6] of TMemBlockList;
/// Freed/used memory: array with memory per 256 bytes block size
// - i.e. 256,512,768,1024,1280,1536,1792[,2048] bytes
FFreedSmallMemoryBlocks : array[0..MAX_SMALLMEMBLOCK] of TMemBlockList;
{$ifdef USEMEDIUM}
/// Freed/used memory: array with memory per block size of 2048 bytes
// - i.e. 2048,4096,6144,8192,10240,12288,14336,16384 bytes
FFreedMediumMemoryBlocks: array[0..MAX_MEDIUMMEMBLOCK] of TMemBlockList;
{$endif}
procedure Init;
procedure FreeBlocksFromThreadMemory(aThreadMem: PThreadMemManager);
public
procedure AddNewThreadManagerToList(aThreadMem: PThreadMemManager);
procedure FreeThreadManager(aThreadMem: PThreadMemManager);
function GetNewThreadManager: PThreadMemManager;
procedure FreeAllMemory;
procedure FreeBlockMemory(aBlockMem: PMemBlock);
function GetBlockMemory(aItemSize: NativeUInt): PMemBlock;
end;
{$A+}
function Scale_GetMem(aSize: Integer): Pointer;
function Scale_AllocMem(aSize: Cardinal): Pointer;
function Scale_FreeMem(aMemory: Pointer): Integer;
function Scale_ReallocMem(aMemory: Pointer; aSize: Integer): Pointer;
var
GlobalManager: TGlobalMemManager;
/// Points to the Memory Manager on which ScaleMM is based
// - ScaleMM works on top of a main MM, which is FastMM4 since Delphi 2007
// - ScaleMM will handle blocks up to 2048 bytes (or 16384 is medium blocks
// are enabled)
// - but larger blocks are delegated to OldMM
// - you can explicitely use OldMM on purpose (but it doesn't seem to be a good idea)
// - note that also "root" block memory is allocated by OldMM if ScaleMM needs
// memory itself (to populate its internal buffers): there is not direct call
// to the VirtualAlloc() API, for instance
var
{$ifdef USEMEMMANAGEREX}
OldMM: TMemoryManagerEx;
{$else}
OldMM: TMemoryManager;
{$endif}
implementation
// Windows.pas unit dependency should be not used -> code inlined here
type
DWORD = LongWord;
BOOL = LongBool;
const
PAGE_EXECUTE_READWRITE = $40;
kernel32 = 'kernel32.dll';
function TlsAlloc: DWORD; stdcall; external kernel32 name 'TlsAlloc';
function TlsGetValue(dwTlsIndex: DWORD): Pointer; stdcall; external kernel32 name 'TlsGetValue';
function TlsSetValue(dwTlsIndex: DWORD; lpTlsValue: Pointer): BOOL; stdcall; external kernel32 name 'TlsSetValue';
function TlsFree(dwTlsIndex: DWORD): BOOL; stdcall; external kernel32 name 'TlsFree';
procedure Sleep(dwMilliseconds: DWORD); stdcall; external kernel32 name 'Sleep';
{$ifdef SPINWAITBACKOFF}
function SwitchToThread: BOOL; stdcall; external kernel32 name 'SwitchToThread';
{$else}
{$undef BACKOFFSLEEP1} // this additional Sleep(1) is for spin wait backoff
{$endif}
function FlushInstructionCache(hProcess: THandle; const lpBaseAddress: Pointer; dwSize: DWORD): BOOL; stdcall; external kernel32 name 'FlushInstructionCache';
function GetCurrentProcess: THandle; stdcall; external kernel32 name 'GetCurrentProcess';
function GetCurrentThreadId: DWORD; stdcall; external kernel32 name 'GetCurrentThreadId';
function Scale_VirtualProtect(lpAddress: Pointer; dwSize, flNewProtect: DWORD;
var OldProtect: DWORD): BOOL; stdcall; overload; external kernel32 name 'VirtualProtect';
procedure ExitThread(dwExitCode: DWORD); stdcall; external kernel32 name 'ExitThread';
function SetPermission(Code: Pointer; Size, Permission: Cardinal): Cardinal;
begin
Assert(Assigned(Code) and (Size > 0));
{ Flush the instruction cache so changes to the code page are effective immediately }
if Permission <> 0 then
if FlushInstructionCache(GetCurrentProcess, Code, Size) then
Scale_VirtualProtect(Code, Size, Permission, Longword(Result));
end;
function CreateSmallMemManager: PThreadMemManager; forward;
{$ifdef PURE_PASCAL}
threadvar
GCurrentThreadManager: PThreadMemManager;
function GetSmallMemManager: PThreadMemManager; {$ifdef HASINLINE}inline;{$endif}
begin
Result := GCurrentThreadManager;
if Result = nil then
Result := CreateSmallMemManager;
end;
{$else}
var
GOwnTlsIndex,
GOwnTlsOffset: NativeUInt;
function GetSmallMemManager: PThreadMemManager;
asm
{$ifdef SCALE_INJECT_OFFSET}
mov eax,123456789 // dummy value: calc once and inject at runtime
{$else}
mov eax,GOwnTlsOffset // 2% slower, so we default use injected offset
{$endif}
mov ecx,fs:[$00000018]
mov eax,[ecx+eax] // fixed offset, calculated only once
or eax,eax
jz CreateSmallMemManager
end;
procedure _FixedOffset;
{$ifdef SCALE_INJECT_OFFSET}
var p: PAnsiChar;
{$endif}
begin
GOwnTlsOffset := GOwnTlsIndex * 4 + $0e10;
{$ifdef SCALE_INJECT_OFFSET}
p := @GetSmallMemManager;
SetPermission(p, 5, PAGE_EXECUTE_READWRITE);
PCardinal(p+1)^ := GOwnTlsOffset; // write fixed offset
{$endif}
end;
{$endif PURE_PASCAL}
function CreateSmallMemManager: PThreadMemManager;
begin
Result := GlobalManager.GetNewThreadManager;
if Result = nil then
begin
Result := OldMM.GetMem( SizeOf(TThreadMemManager) );
Result.Init;
end
else
begin
Result.FThreadId := GetCurrentThreadId;
Result.FThreadTerminated := False;
end;
{$ifdef PURE_PASCAL}
GCurrentThreadManager := Result;
{$else}
TlsSetValue(GOwnTLSIndex, Result);
{$endif}
end;
// compare oldvalue with destination: if equal then newvalue is set
function CAS0(const oldValue: pointer; newValue: pointer; var destination): boolean;
// - if failed, try to Switch to next OS thread, or Sleep 0 ms if it no next thread
asm // eax=oldValue, edx=newValue, ecx=Destination
lock cmpxchg dword ptr [Destination],newValue
// will compile as "lock cmpxchg dword ptr [ecx],edx" under Win32 e.g.
setz al
{$ifdef SPINWAITBACKOFF}
jz @ok
call SwitchToThread
test oldValue,oldValue // oldValue=eax under Win32 e.g.
jnz @ok
push 0
call Sleep
xor oldValue,oldValue // return false
{$else}
jz @ok
pause // let the CPU know this thread is in a Spin Wait loop
{$endif}
@ok:
end;
{$ifdef BACKOFFSLEEP1}
function CAS1(const oldValue: pointer; newValue: pointer; var destination): boolean;
// - if failed, try to Switch to next OS thread, or Sleep 1 ms if it no next thread
// (this 1 ms sleep is necessary to avoid race condition - see
// https://synopse.info/forum/viewtopic.php?pid=914#p914 )
asm // eax=oldValue, edx=newValue, ecx=Destination
lock cmpxchg dword ptr [Destination],newValue
// will compile as "lock cmpxchg dword ptr [ecx],edx" under Win32 e.g.
setz al
jz @ok
call SwitchToThread
test oldValue,oldValue
jnz @ok
push 1
call Sleep
xor oldValue,oldValue
@ok:
end;
{$endif}
procedure InterlockedIncrement(var Value: Byte);
asm
lock inc byte [Value] // will compile as "lock inc byte [eax]" under Win32 e.g.
end;
procedure InterlockedDecrement(var Value: Byte);
asm
lock dec byte [Value] // will compile as "lock dec byte [eax]" under Win32 e.g.
end;
/// gets the first set bit and resets it, returning the bit index
function FindFirstSetBit(Value: NativeUInt): NativeUInt;
asm
bsf Value,Value // will compile as "bsf eax,eax" under Win32 e.g.
end;
/// sets a specified bit
function SetBit(var Value: NativeUInt; BitIndex: NativeUInt): NativeUInt;
asm
bts [Value],BitIndex // will compile as "bts [eax],edx" under Win32 e.g.
end;
{$ifdef DEBUG_SCALEMM}
procedure Assert(aCondition: boolean);
begin
if not aCondition then
begin
asm
int 3;
end;
Sleep(0); // no exception, just dummy for breakpoint
end;
end;
{$endif}
function GetOldMem(aSize: NativeUInt): Pointer; {$ifdef HASINLINE}inline;{$endif}
begin
Result := OldMM.GetMem(aSize + SizeOf(TMemHeader));
if Result<>nil then begin
PMemHeader(Result)^.Owner := nil; // not our memlist, so mark as such
Result := Pointer(NativeUInt(Result) + SizeOf(TMemHeader) );
end;
end;
{ TThreadMemManager }
procedure TThreadMemManager.Init;
var i, j: NativeUInt;
begin
fillchar(self,sizeof(self),0);
FThreadId := GetCurrentThreadId;
j := 32;
for i := Low(FMiniMemoryBlocks) to High(FMiniMemoryBlocks) do
begin // 32, 64, 96, 128, 160, 192, 224 bytes
FMiniMemoryBlocks[i].Owner := @Self;
FMiniMemoryBlocks[i].FItemSize := j;
inc(j,32);
end;
assert(j=256);
for i := Low(FSmallMemoryBlocks) to High(FSmallMemoryBlocks) do
begin // 256,512,768,1024,1280,1536,1792 bytes
FSmallMemoryBlocks[i].Owner := @Self;
FSmallMemoryBlocks[i].FItemSize := j;
inc(j,256);
end;
{$ifdef USEMEDIUM}
assert(j=2048);
for i := Low(FMediumMemoryBlocks) to High(FMediumMemoryBlocks) do
begin // 2048, 4096...16384 bytes
FMediumMemoryBlocks[i].Owner := @Self;
FMediumMemoryBlocks[i].FItemSize := j;
inc(j,2048);
end;
assert(j=(MAX_MEDIUMMEMBLOCK+2)*2048);
{$else}
assert(j=2304);
{$endif}
end;
procedure TThreadMemManager.ProcessFreedMemFromOtherThreads;
var
pcurrentmem, ptempmem: POtherThreadFreedMemory;
begin
// reset first item (to get all mem in linked list)
repeat
pcurrentmem := FOtherThreadFreedMemory;
if CAS0(pcurrentmem, nil, FOtherThreadFreedMemory) then
break;
{$ifdef BACKOFFSLEEP1}
pcurrentmem := FOtherThreadFreedMemory;
if CAS1(pcurrentmem, nil, FOtherThreadFreedMemory) then
break;
{$endif}
until false;
// free all mem in linked list
while pcurrentmem <> nil do
begin
ptempmem := pcurrentmem;
pcurrentmem := pcurrentmem.NextMem;
{$ifdef USEBITMAP}
with ptempmem^ do
while FToBeFreedFromOtherThread<>0 do
FreeMem(Pointer( NativeUInt(ptempmem) + sizeof(ptempmem^) +
FindFirstSetBit(FToBeFreedFromOtherThread) * (Owner^.FItemSize + SizeOf(TMemHeader)) ));
{$else}
ptempmem.Owner.FreeMem(ptempmem);
{$endif}
end;
end;
procedure TThreadMemManager.Reset;
var
i: NativeUInt;
procedure __ResetBlocklist(aBlocklist: PMemBlockList);
begin
aBlocklist.FFirstFreedMemBlock := nil;
aBlocklist.FFirstMemBlock := nil;
aBlocklist.FRecursive := False;
end;
begin
FThreadId := 0;
FThreadTerminated := True;
FOtherThreadFreedMemory := nil;
FNextThreadManager := nil;
for i := Low(FMiniMemoryBlocks) to High(FMiniMemoryBlocks) do
__ResetBlocklist(@FMiniMemoryBlocks[i]);
for i := Low(FSmallMemoryBlocks) to High(FSmallMemoryBlocks) do
__ResetBlocklist(@FSmallMemoryBlocks[i]);
{$ifdef USEMEDIUM}
for i := Low(FMediumMemoryBlocks) to High(FMediumMemoryBlocks) do
__ResetBlocklist(@FMediumMemoryBlocks[i]);
{$endif}
end;
procedure TThreadMemManager.AddFreedMemFromOtherThread(aMemory: PMemHeader);
var
poldmem, currentmem: POtherThreadFreedMemory;
begin
{$ifdef USEBITMAP}
currentmem := aMemory^.Owner;
SetBit(currentmem^.FToBeFreedFromOtherThread,aMemory^.FIndexInMemBlockArray);
{$else}
currentmem := aMemory;
{$endif}
repeat
poldmem := FOtherThreadFreedMemory;
currentmem.NextMem := poldmem; // link to current next BEFORE the swap!
// set new item as first (to created linked list)
if CAS0(poldmem, currentmem, FOtherThreadFreedMemory) then
break;
{$ifdef BACKOFFSLEEP1}
poldmem := FOtherThreadFreedMemory;
currentmem.NextMem := poldmem;
if CAS1(poldmem, currentmem, FOtherThreadFreedMemory) then
break;
{$endif}
until false;
end;
function TThreadMemManager.FreeMem(aMemory: Pointer): NativeInt;
var
pm: PMemBlock;
p: Pointer;
begin
p := Pointer(NativeUInt(aMemory) - SizeOf(TMemHeader));
pm := PMemHeader(p).Owner;
if FOtherThreadFreedMemory <> nil then
ProcessFreedMemFromOtherThreads;
if pm <> nil then
with pm^ do
begin
// block obtained via Scale_GetMem()
Assert(Owner <> nil);
Assert(Owner.Owner <> nil);
if Owner.Owner = @Self then
// mem of own thread
FreeMem(PMemHeader(p)) else
// put mem in lockfree queue of owner thread
Owner.Owner.AddFreedMemFromOtherThread(PMemHeader(p));
Result := 0;
end
else
Result := OldMM.FreeMem(p);
end;
function TThreadMemManager.GetMem(aSize: NativeUInt): Pointer;
var
bm: PMemBlockList;
begin
if aSize <= (length(FMiniMemoryBlocks)*32) then
if aSize > 0 then
// blocks of 32: 32, 64, 96, 128, 160, 192, 224
bm := @FMiniMemoryBlocks[(aSize-1) shr 5] else
begin
Result := nil;
Exit;
end
else if aSize <= (length(FSmallMemoryBlocks)*256) then
// blocks of 256: 256,512,768,1024,1280,1536,1792 bytes
bm := @FSmallMemoryBlocks[(aSize-1) shr 8]
{$ifdef USEMEDIUM}
else if aSize <= (length(FMediumMemoryBlocks)*2048) then
// blocks of 2048: 2048, 4096... bytes
bm := @FMediumMemoryBlocks[(aSize-1) shr 11]
{$endif}
else
begin
// larger blocks are allocated via the old Memory Manager
Result := GetOldMem(aSize);
Exit;
end;
if FOtherThreadFreedMemory <> nil then
ProcessFreedMemFromOtherThreads;
with bm^ do
begin
{$ifndef USEBITMAP}
if FFirstFreedMemBlock <> nil then
// first get from freed mem (fastest because most chance?)
Result := FFirstFreedMemBlock.GetUsedMemoryItem else
{$endif}
// from normal list
Result := GetMemFromNewBlock;
end;
Assert(NativeUInt(Result) > $10000);
Result := Pointer(NativeUInt(Result) + SizeOf(TMemHeader));
end;
{ TMemBlock }
procedure TMemBlock.FreeBlockMemoryToGlobal;
begin
if Owner.FFirstMemBlock = @Self then
Exit; //keep one block
// remove ourselves from linked list
if FPreviousMemBlock <> nil then
FPreviousMemBlock.FNextMemBlock := Self.FNextMemBlock;
if FPreviousFreedMemBlock <> nil then
FPreviousFreedMemBlock.FNextFreedMemBlock := Self.FNextFreedMemBlock;
if FNextMemBlock <> nil then
FNextMemBlock.FPreviousMemBlock := Self.FPreviousMemBlock;
if FNextFreedMemBlock <> nil then
FNextFreedMemBlock.FPreviousFreedMemBlock := Self.FPreviousFreedMemBlock;
if Owner.FFirstFreedMemBlock = @Self then
Owner.FFirstFreedMemBlock := nil;
if Owner.FFirstMemBlock = @Self then
Owner.FFirstMemBlock := nil;
GlobalManager.FreeBlockMemory(@Self);
end;
procedure TMemBlock.FreeMem(aMemoryItem: PMemHeader);
begin
// first free item of block?
// then we add this block to (linked) list with available mem
{$ifdef USEBITMAP}
if FAvailable=NativeUInt(-1) then
{$else}
if FFreedIndex = 0 then
{$endif}
with Owner^ do //faster
begin
{Self.}FNextFreedMemBlock := {Owner}FFirstFreedMemBlock; //link to first list
{Self.}FPreviousFreedMemBlock := nil;
if {Self}FNextFreedMemBlock <> nil then
{Self}FNextFreedMemBlock.FPreviousFreedMemBlock := @Self; //back link
{Owner}FFirstFreedMemBlock := @Self; //replace first list
end;
{$ifdef USEBITMAP}
SetBit(FAvailable,aMemoryItem^.FIndexInMemBlockArray);
if FAvailable=NativeUInt(-1) then
{$else}
// free mem block
FFreedArray[FFreedIndex] := aMemoryItem;
inc(FFreedIndex);
if FFreedIndex = C_ARRAYSIZE then
{$endif}
// all memory available
with Owner^ do
if (FFreeMemCount >= C_GLOBAL_BLOCK_CACHE) and
({Owner.}FFirstMemBlock <> @Self) then // keep one block
Self.FreeBlockMemoryToGlobal else
inc(FFreeMemCount);
end;
function TMemBlock.GetUsedMemoryItem: PMemHeader;
begin
Assert(Self.Owner <> nil);
{$ifdef USEBITMAP}
Assert(FAvailable<>0);
Result := Pointer( NativeUInt(@Self)+ sizeof(Self) +
FindFirstSetBit(FAvailable) * (Owner.FItemSize + SizeOf(TMemHeader)) );
if FAvailable=0 then
{$else}
Assert(FFreedIndex > 0);
dec(FFreedIndex);
Result := FFreedArray[FFreedIndex];
if FFreedIndex = 0 then
{$endif}
begin // no free items left:
// set next free memlist
Owner.FFirstFreedMemBlock := FNextFreedMemBlock;
// first one has no previous
if FNextFreedMemBlock <> nil then
FNextFreedMemBlock.FPreviousFreedMemBlock := nil;
// remove from free list
FPreviousFreedMemBlock := nil;
FNextFreedMemBlock := nil;
end
else
{$ifdef USEBITMAP}
if FAvailable=NativeUInt(-1) then
{$else}
if FFreedIndex = C_ARRAYSIZE-1 then
{$endif}
// all memory is now available
dec(Owner.FFreeMemCount);
end;
{ TMemBlockList }
procedure TMemBlockList.AddNewMemoryBlock;
var
pm: PMemBlock;
begin
FRecursive := True;
// get block from cache
pm := GlobalManager.GetBlockMemory(FItemSize);
if pm = nil then
begin
// create own one
pm :=
{$ifdef USEMEDIUM}
Owner.GetMem {$else}
GetOldMem // (32+8)*64=2560 > 2048 -> use OldMM
{$endif}
( SizeOf(pm^) + (FItemSize + SizeOf(TMemHeader)) * C_ARRAYSIZE );
with pm^ do begin // put zero only to needed properties
{$ifdef USEBITMAP}
fillchar(FNextFreedMemBlock,SizeOf(FNextFreedMemBlock)+
SizeOf(FPreviousFreedMemBlock)+
SizeOf(FToBeFreedFromOtherThread)+SizeOf(NextMem),0);
FAvailable := NativeUInt(-1); // set all bits = mark all available
{$else}
fillchar(FNextFreedMemBlock,SizeOf(FNextFreedMemBlock)+
SizeOf(FPreviousFreedMemBlock)+SizeOf(FUsageCount)+SizeOf(FFreedIndex),0);
{$endif}
end;
end;
// init
with pm^ do
begin
{pm.}Owner := @Self;
// set new memlist as first, add link to current item
{pm.}FNextMemBlock := {self.}FFirstMemBlock;
// back link to new first item
if {self.}FFirstMemBlock <> nil then
{self.}FFirstMemBlock.FPreviousMemBlock := pm;
{self.}FFirstMemBlock := pm;
{pm.}FPreviousMemBlock := nil;
{$ifdef USEBITMAP}
if FAvailable<>NativeUInt(-1) then
{$else}
if {pm.}FFreedIndex > 0 then
{$endif}
begin
// if block has already some freed memory (previous used block from cache)
// then add to used list
{pm.}FNextFreedMemBlock := {Self}FFirstFreedMemBlock; // link to first list
{pm.}FPreviousFreedMemBlock := nil;
if {pm.}FNextFreedMemBlock <> nil then
{pm.}FNextFreedMemBlock.FPreviousFreedMemBlock := pm; // back link
{Self.}FFirstFreedMemBlock := pm; // replace first list
{$ifndef USEBITMAP}
if {pm.}FFreedIndex = C_ARRAYSIZE then
inc({pm.}Owner.FFreeMemCount);
{$endif}
end;
end;
FRecursive := False;
end;
function TMemBlockList.GetMemFromNewBlock: Pointer;
var
pm: PMemBlock;
begin
// store: first time init?
if FFirstMemBlock = nil then
begin
if FRecursive then
begin
Result := GetOldMem(Self.FItemSize);
Exit;
end;
AddNewMemoryBlock;
end;
pm := FFirstMemBlock;
with pm^ do
{$ifdef USEBITMAP}
if FAvailable=0 then
{$else}
if FUsageCount >= C_ARRAYSIZE then
{$endif}
begin
// memlist full? make new memlist
if FRecursive then
begin
Result := GetOldMem(Self.FItemSize);
Exit;
end;
AddNewMemoryBlock;
pm := FFirstMemBlock;
end;
// get mem from list
with pm^ do
// space left?
{$ifndef USEBITMAP}
if FUsageCount < C_ARRAYSIZE then
begin
// calc next item
Result := Pointer( NativeUInt(pm) + sizeof(pm^) +
FUsageCount * (FItemSize + SizeOf(TMemHeader)) );
inc(FUsageCount);
// startheader = link to memlist
TMemHeader(Result^).Owner := pm;
end
else
{$endif}
Result := GetUsedMemoryItem;
Assert(NativeUInt(Result) > $10000);
end;
{ TGlobalManager }
procedure TGlobalMemManager.AddNewThreadManagerToList(aThreadMem: PThreadMemManager);
var
pprevthreadmem: PThreadMemManager;
begin
repeat
pprevthreadmem := FFirstThreadMemory;
// try to set "result" in global var
if CAS0(pprevthreadmem, aThreadMem, FFirstThreadMemory) then
break;
{$ifdef BACKOFFSLEEP1}
pprevthreadmem := FFirstThreadMemory;
if CAS1(pprevthreadmem, aThreadMem, FFirstThreadMemory) then
break;
{$endif}
until false;
// make linked list: new one is first item (global var), next item is previous item
aThreadMem.FNextThreadManager := pprevthreadmem;
end;
procedure TGlobalMemManager.FreeAllMemory;
procedure __ProcessBlockMem(aOldBlock: PMemBlockList);
var
allmem, oldmem: PMemBlock;
begin
if aOldBlock = nil then
Exit;
allmem := aOldBlock.FFirstFreedMemBlock;
while allmem <> nil do
begin
// not in use
{$ifdef USEBITMAP}
{$else}
if allmem.FUsageCount = allmem.FFreedIndex then
begin
oldmem := allmem;
allmem := allmem.FNextFreedMemBlock;
FMainThreadMemory.FreeMem(oldmem);
end
else
allmem := allmem.FNextFreedMemBlock;
{$endif}
end;
end;
var
oldthreadmem, tempthreadmem: PThreadMemManager;
i: NativeUInt;
begin
// free internal blocks
for i := Low(Self.FFreedMiniMemoryBlocks) to High(Self.FFreedMiniMemoryBlocks) do
__ProcessBlockMem(@Self.FFreedMiniMemoryBlocks[i]);
for i := Low(Self.FFreedSmallMemoryBlocks) to High(Self.FFreedSmallMemoryBlocks) do
__ProcessBlockMem(@Self.FFreedSmallMemoryBlocks[i]);
{$ifdef USEMEDIUM}
for i := Low(Self.FFreedMediumMemoryBlocks) to High(Self.FFreedMediumMemoryBlocks) do
__ProcessBlockMem(@Self.FFreedMediumMemoryBlocks[i]);
{$endif}
// free current thread
tempthreadmem := GetSmallMemManager;
for i := Low(tempthreadmem.FMiniMemoryBlocks) to High(tempthreadmem.FMiniMemoryBlocks) do
__ProcessBlockMem(@tempthreadmem.FMiniMemoryBlocks[i]);
for i := Low(tempthreadmem.FSmallMemoryBlocks) to High(tempthreadmem.FSmallMemoryBlocks) do
__ProcessBlockMem(@tempthreadmem.FSmallMemoryBlocks[i]);
{$ifdef USEMEDIUM}
for i := Low(tempthreadmem.FMediumMemoryBlocks) to High(tempthreadmem.FMediumMemoryBlocks) do
__ProcessBlockMem(@tempthreadmem.FMediumMemoryBlocks[i]);
{$endif}
// free cached threads
oldthreadmem := Self.FFirstFreedThreadMemory;
while oldthreadmem <> nil do
begin
tempthreadmem := oldthreadmem;
oldthreadmem := oldthreadmem.FNextThreadManager;
OldMM.FreeMem(tempthreadmem);
end;
end;
procedure TGlobalMemManager.FreeBlockMemory(aBlockMem: PMemBlock);
var bl: PMemBlockList;
prevmem: PMemBlock;
begin
{$ifndef USEBITMAP}
Assert( aBlockMem.FFreedIndex = aBlockMem.FUsageCount );
{$endif}
with aBlockMem.Owner^ do
if FItemSize <= (length(Self.FFreedMiniMemoryBlocks)*32) then
// blocks of 32: 32, 64, 96, 128, 160, 192, 224
bl := @Self.FFreedMiniMemoryBlocks[(FItemSize-1) shr 5]
else if FItemSize <= (length(Self.FFreedSmallMemoryBlocks)*256) then
// blocks of 256: 256,512,768,1024,1280,1536,1792[,2048] bytes
bl := @Self.FFreedSmallMemoryBlocks[(FItemSize-1) shr 8]
{$ifdef USEMEDIUM}
else if FItemSize <= (length(Self.FFreedMediumMemoryBlocks)*2048) then
// blocks of 2048: 2048,4096,6144,8192,10240,12288,14336,16384 bytes
bl := @Self.FFreedMediumMemoryBlocks[(FItemSize-1) shr 11]
{$endif}
else begin
// large block
FMainThreadMemory.FreeMem(aBlockMem);
Exit;
end;
// too much cached?
if bl.FFreeMemCount > C_GLOBAL_BLOCK_CACHE then
begin
// dispose
FMainThreadMemory.FreeMem(aBlockMem);
Exit;
end;
// add freemem block to front (replace first item, link previous to first items)
repeat
prevmem := bl.FFirstFreedMemBlock;
aBlockMem.FNextFreedMemBlock := prevmem;
if CAS0(prevmem, aBlockMem, bl.FFirstFreedMemBlock) then
break;
{$ifdef BACKOFFSLEEP1}
prevmem := bl.FFirstFreedMemBlock;
aBlockMem.FNextFreedMemBlock := prevmem;
if CAS1(prevmem, aBlockMem, bl.FFirstFreedMemBlock) then
break;
{$endif}
until False;
// inc items cached
InterlockedIncrement(bl.FFreeMemCount);
// prepare block content
aBlockMem.Owner := bl;
aBlockMem.FNextMemBlock := nil;
aBlockMem.FPreviousMemBlock := nil;
aBlockMem.FPreviousFreedMemBlock := nil;
end;
procedure TGlobalMemManager.FreeBlocksFromThreadMemory(aThreadMem: PThreadMemManager);
var
i: NativeUInt;
procedure __ProcessBlockMem(aOldBlock, aGlobalBlock: PMemBlockList);
var
allmem, prevmem, tempmem,
lastunusedmem, lastinusemem,
unusedmem, inusemem: PMemBlock;
begin
allmem := aOldBlock.FFirstMemBlock;
unusedmem := nil;
lastunusedmem := nil;
inusemem := nil;
lastinusemem := nil;
// scan all memoryblocks and filter unused blocks
while allmem <> nil do
begin
if allmem.Owner = nil then
Break; // loop?
// fully free, no mem in use?
{$ifdef USEBITMAP}
{$else}
if allmem.FFreedIndex = allmem.FUsageCount then
begin
if aGlobalBlock.FFreeMemCount > C_GLOBAL_BLOCK_CACHE then
begin
// next one
tempmem := allmem;
allmem := allmem.FNextMemBlock;
// dispose
aThreadMem.FreeMem(tempmem);
Continue;
end;
// first item of list?
if unusedmem = nil then
unusedmem := allmem
else
// else add to list (link to previous)
lastunusedmem.FNextMemBlock := allmem;
lastunusedmem := allmem;
// update number of items cached
inc(aGlobalBlock.FFreeMemCount);
end
else
// some items in use (in other thread? or mem leak?)
begin
// first item of list?
if inusemem = nil then
inusemem := allmem
else
// else add to list (link to previous)
lastinusemem.FNextMemBlock := allmem;
lastinusemem := allmem;
// update number of items cached
inc(aGlobalBlock.FFreeMemCount);
end;
{$endif}
allmem.Owner := aGlobalBlock;
allmem.FNextFreedMemBlock := nil;
allmem.FPreviousMemBlock := nil;
allmem.FPreviousFreedMemBlock := nil;
// next one
allmem := allmem.FNextMemBlock;
end;
if inusemem <> nil then
begin
assert(lastinusemem <> nil);
// add freemem list to front (replace first item, link previous to last item)
repeat
prevmem := aGlobalBlock.FFirstFreedMemBlock;
lastinusemem.FNextFreedMemBlock := prevmem;
if CAS0(prevmem, inusemem, aGlobalBlock.FFirstFreedMemBlock) then
break;
{$ifdef BACKOFFSLEEP1}
prevmem := aGlobalBlock.FFirstFreedMemBlock;
lastinusemem.FNextFreedMemBlock := prevmem;
if CAS1(prevmem, inusemem, aGlobalBlock.FFirstFreedMemBlock) then
break;
{$endif}
until false;
end;
if unusedmem <> nil then
begin
assert(lastunusedmem <> nil);
//add unusedmem list to front (replace first item, link previous to last item)
repeat
prevmem := aGlobalBlock.FFirstMemBlock;
lastunusedmem.FNextMemBlock := prevmem;
if CAS0(prevmem, unusedmem, aGlobalBlock.FFirstMemBlock) then
break;
{$ifdef BACKOFFSLEEP1}
prevmem := aGlobalBlock.FFirstMemBlock;
lastunusedmem.FNextMemBlock := prevmem;
if CAS1(prevmem, unusedmem, aGlobalBlock.FFirstMemBlock) then
break;
{$endif}
until false;
end;
end;
begin
assert(GetSmallMemManager=aThreadMem);
for i := Low(aThreadMem.FMiniMemoryBlocks) to High(aThreadMem.FMiniMemoryBlocks) do
__ProcessBlockMem( @aThreadMem.FMiniMemoryBlocks[i], @Self.FFreedMiniMemoryBlocks[i]);
for i := Low(aThreadMem.FSmallMemoryBlocks) to High(aThreadMem.FSmallMemoryBlocks) do
__ProcessBlockMem( @aThreadMem.FSmallMemoryBlocks[i], @Self.FFreedSmallMemoryBlocks[i]);
{$ifdef USEMEDIUM}
for i := Low(aThreadMem.FMediumMemoryBlocks) to High(aThreadMem.FMediumMemoryBlocks) do
__ProcessBlockMem( @aThreadMem.FMediumMemoryBlocks[i], @Self.FFreedMediumMemoryBlocks[i]);
{$endif}
end;
procedure TGlobalMemManager.FreeThreadManager(aThreadMem: PThreadMemManager);
var
pprevthreadmem: PThreadMemManager;
begin
// clear mem (partial: add to reuse list, free = free)
FreeBlocksFromThreadMemory(aThreadMem);
aThreadMem.Reset;
{ TODO : keep max nr of threads }
// add to available list
repeat
pprevthreadmem := FFirstFreedThreadMemory;
// make linked list: new one is first item (global var), next item is previous item
aThreadMem.FNextThreadManager := pprevthreadmem;
// try to set "result" in global var
if CAS0(pprevthreadmem, aThreadMem, FFirstFreedThreadMemory) then
break;
{$ifdef BACKOFFSLEEP1}
pprevthreadmem := FFirstFreedThreadMemory;
aThreadMem.FNextThreadManager := pprevthreadmem;
if CAS1(pprevthreadmem, aThreadMem, FFirstFreedThreadMemory) then
break;
{$endif}
until false;
end;
function TGlobalMemManager.GetBlockMemory(aItemSize: NativeUInt): PMemBlock;
var bl: PMemBlockList;
prevmem, nextmem: PMemBlock;
begin
Result := nil;
dec(aItemSize);
if aItemSize < (length(Self.FFreedMiniMemoryBlocks)*32) then
// blocks of 32: 32, 64, 96, 128, 160, 192, 224
bl := @Self.FFreedMiniMemoryBlocks[aItemSize shr 5]
else if aItemSize < (length(Self.FFreedSmallMemoryBlocks)*256) then
// blocks of 256: 256,512,768,1024,1280,1536,1792[,2048] bytes
bl := @Self.FFreedSmallMemoryBlocks[aItemSize shr 8]
{$ifdef USEMEDIUM}
else if aItemSize < (length(Self.FFreedMediumMemoryBlocks)*2048) then
// blocks of 2048: 2048,4096,6144,8192,10240,12288,14336,16384 bytes
bl := @Self.FFreedMediumMemoryBlocks[aItemSize shr 11]
{$endif}
else begin
// not allocated by this unit (should not happen)
assert(false);
Exit;
end;
// get freed mem from list from front (replace first item)
repeat
if bl.FFirstFreedMemBlock <> nil then
begin
prevmem := bl.FFirstFreedMemBlock;
if prevmem = nil then
Continue;
nextmem := prevmem.FNextFreedMemBlock;
if CAS0(prevmem, nextmem, bl.FFirstFreedMemBlock) then
begin
Result := prevmem;
Break;
end;
{$ifdef BACKOFFSLEEP1}
prevmem := bl.FFirstFreedMemBlock;
if prevmem = nil then
Continue;
nextmem := prevmem.FNextFreedMemBlock;
if CAS1(prevmem, nextmem, bl.FFirstFreedMemBlock) then
begin
Result := prevmem;
Break;
end;
{$endif}
end
// get free mem from list from front (replace first item)
else if bl.FFirstMemBlock <> nil then
begin
prevmem := bl.FFirstMemBlock;
if prevmem = nil then
Continue;
nextmem := prevmem.FNextMemBlock;
if CAS0(prevmem, nextmem, bl.FFirstMemBlock) then
begin
Result := prevmem;
Break;
end;
{$ifdef BACKOFFSLEEP1}
prevmem := bl.FFirstMemBlock;
if prevmem = nil then
Continue;
nextmem := prevmem.FNextMemBlock;
if CAS1(prevmem, nextmem, bl.FFirstMemBlock) then
begin
Result := prevmem;
Break;
end;
{$endif}
end
else
Break;
until false;
if Result <> nil then
begin
InterlockedDecrement(bl.FFreeMemCount);
Result.Owner := bl;
Result.FNextFreedMemBlock := nil;
Result.FNextMemBlock := nil;
Result.FPreviousMemBlock := nil;
Result.FPreviousFreedMemBlock := nil;
end;
end;
function TGlobalMemManager.GetNewThreadManager: PThreadMemManager;
var
pprevthreadmem, newthreadmem: PThreadMemManager;
begin
Result := nil;
// get one cached instance from freed list
while FFirstFreedThreadMemory <> nil do
begin
pprevthreadmem := FFirstFreedThreadMemory;
if pprevthreadmem <> nil then
newthreadmem := pprevthreadmem.FNextThreadManager else
newthreadmem := nil;
// try to set "result" in global var
if CAS0(pprevthreadmem, newthreadmem, FFirstFreedThreadMemory) then
begin
Result := pprevthreadmem;
Result.FNextThreadManager := nil;
break;
end;
{$ifdef BACKOFFSLEEP1}
pprevthreadmem := FFirstFreedThreadMemory;
if pprevthreadmem <> nil then
newthreadmem := pprevthreadmem.FNextThreadManager else
newthreadmem := nil;
if CAS1(pprevthreadmem, newthreadmem, FFirstFreedThreadMemory) then
begin
Result := pprevthreadmem;
Result.FNextThreadManager := nil;
break;
end;
{$endif}
end;
end;
procedure TGlobalMemManager.Init;
var i, j: NativeUInt;
begin
fillchar(self,SizeOf(self),0);
j := 32;
for i := Low(FFreedMiniMemoryBlocks) to High(FFreedMiniMemoryBlocks) do
begin
FFreedMiniMemoryBlocks[i].Owner := @Self;
FFreedMiniMemoryBlocks[i].FItemSize := j;
inc(j,32);
end;
Assert(j=256);
for i := Low(FFreedSmallMemoryBlocks) to High(FFreedSmallMemoryBlocks) do
begin
FFreedSmallMemoryBlocks[i].Owner := @Self;
FFreedSmallMemoryBlocks[i].FItemSize := j;
inc(j,256);
end;
{$ifdef USEMEDIUM}
Assert(j=2048);
for i := Low(FFreedMediumMemoryBlocks) to High(FFreedMediumMemoryBlocks) do
begin
FFreedMediumMemoryBlocks[i].Owner := @Self;
FFreedMediumMemoryBlocks[i].FItemSize := j;
inc(j,2048);
end;
assert(j=18432);
{$else}
assert(j=2304);
{$endif}
FMainThreadMemory := GetSmallMemManager;
end;
{$ifndef PURE_PASCAL}
{$if CompilerVersion < 19}
procedure Move(const Source; var Dest; Count: Integer);
asm // eax=source edx=dest ecx=count
// original code by John O'Harrow - included since Delphi 2007
cmp ecx, 32
ja @@LargeMove {Count > 32 or Count < 0}
sub ecx, 8
jg @@SmallMove
jmp dword ptr [@@JumpTable+32+ecx*4] {0..8 Byte Move}
@@SmallMove: {9..32 Byte Move}
fild qword ptr [eax+ecx] {Load Last 8}
fild qword ptr [eax] {Load First 8}
cmp ecx, 8
jle @@Small16
fild qword ptr [eax+8] {Load Second 8}
cmp ecx, 16
jle @@Small24
fild qword ptr [eax+16] {Load Third 8}
fistp qword ptr [edx+16] {Save Third 8}
@@Small24:
fistp qword ptr [edx+8] {Save Second 8}
@@Small16:
fistp qword ptr [edx] {Save First 8}
fistp qword ptr [edx+ecx] {Save Last 8}
@@Exit:
ret
lea eax,eax+0 // for alignment of @@JumpTable
@@JumpTable: {4-Byte Aligned}
dd @@Exit, @@M01, @@M02, @@M03, @@M04, @@M05, @@M06, @@M07, @@M08
@@LargeForwardMove: {4-Byte Aligned}
push edx
fild qword ptr [eax] {First 8}
lea eax, [eax+ecx-8]
lea ecx, [ecx+edx-8]
fild qword ptr [eax] {Last 8}
push ecx
neg ecx
and edx, -8 {8-Byte Align Writes}
lea ecx, [ecx+edx+8]
pop edx
@FwdLoop:
fild qword ptr [eax+ecx]
fistp qword ptr [edx+ecx]
add ecx, 8
jl @FwdLoop
fistp qword ptr [edx] {Last 8}
pop edx
fistp qword ptr [edx] {First 8}
ret
@@LargeMove:
jng @@LargeDone {Count < 0}
cmp eax, edx
ja @@LargeForwardMove
sub edx, ecx
cmp eax, edx
lea edx, [edx+ecx]
jna @@LargeForwardMove
sub ecx, 8 {Backward Move}
push ecx
fild qword ptr [eax+ecx] {Last 8}
fild qword ptr [eax] {First 8}
add ecx, edx
and ecx, -8 {8-Byte Align Writes}
sub ecx, edx
@BwdLoop:
fild qword ptr [eax+ecx]
fistp qword ptr [edx+ecx]
sub ecx, 8
jg @BwdLoop
pop ecx
fistp qword ptr [edx] {First 8}
fistp qword ptr [edx+ecx] {Last 8}
@@LargeDone:
ret
@@M01:
movzx ecx, [eax]
mov [edx], cl
ret
@@M02:
movzx ecx, word ptr [eax]
mov [edx], cx
ret
@@M03:
mov cx, [eax]
mov al, [eax+2]
mov [edx], cx
mov [edx+2], al
ret
@@M04:
mov ecx, [eax]
mov [edx], ecx
ret
@@M05:
mov ecx, [eax]
mov al, [eax+4]
mov [edx], ecx
mov [edx+4], al
ret
@@M06:
mov ecx, [eax]
mov ax, [eax+4]
mov [edx], ecx
mov [edx+4], ax
ret
@@M07:
mov ecx, [eax]
mov eax, [eax+3]
mov [edx], ecx
mov [edx+3], eax
ret
@@M08:
fild qword ptr [eax]
fistp qword ptr [edx]
end;
{$ifend}
{$endif PURE_PASCAL}
function Scale_ReallocMem(aMemory: Pointer; aSize: Integer): Pointer;
var
pm: PMemBlock;
p: Pointer;
begin
// ReAlloc can be misued as GetMem or FreeMem (documented in delphi help) so check what the user wants
Assert(NativeUInt(aMemory) > $10000);
// Normal realloc of exisiting data?
if (aMemory <> nil) and (aSize > 0) then
begin
p := Pointer(NativeUInt(aMemory) - SizeOf(TMemHeader));
pm := PMemHeader(p).Owner;
if pm <> nil then
with pm^ do
begin
if (NativeUInt(aSize) <= Owner.FItemSize) then
begin
// new size smaller than current size
if NativeUInt(aSize) > (Owner.FItemSize shr 2) then
Result := aMemory // no resize needed up to 1/4 the current item size
else
// too much downscaling: use move
with GetSmallMemManager^ do
begin
Result := GetMem(aSize); // new mem
if aMemory <> Result then
begin
Move(aMemory^, Result^, aSize); // copy (use smaller new size)
FreeMem(aMemory); // free old mem
end;
end;
end
else
with GetSmallMemManager^ do
begin
// new size bigger than current size: avoid moves with small granularity
if aSize <= (length(FMiniMemoryBlocks)*32) then
aSize := (length(FMiniMemoryBlocks)*32) else
if aSize <= (length(FSmallMemoryBlocks)*256) then
aSize := (length(FSmallMemoryBlocks)*256)
{$ifdef USEMEDIUM}
else if aSize <= (length(FMediumMemoryBlocks)*2048) then
aSize := (length(FMediumMemoryBlocks)*2048)
{$endif};
Result := GetMem(aSize); // new mem
if aMemory <> Result then
begin
Move(aMemory^, Result^, Owner.FItemSize); // copy (use smaller old size)
FreeMem(aMemory); // free old mem
end;
end;
end
// was allocated via OldMM -> rely on OldMM for reallocation
else
begin
Result := OldMM.ReallocMem(p, aSize + SizeOf(TMemHeader));
if Result<>nil then
begin
PMemHeader(Result)^.Owner := nil; // mark not from our memlist
Result := Pointer(NativeUInt(Result) + SizeOf(TMemHeader) );
end;
end;
end
else
begin
if (aMemory = nil) and (aSize > 0) then
// GetMem disguised as ReAlloc
Result := Scale_GetMem(aSize)
else
begin
// FreeMem disguised as ReAlloc
Result := nil;
Scale_FreeMem(aMemory);
end;
end;
end;
function Scale_GetMem(aSize: Integer): Pointer;
{$ifdef HASINLINE}
begin
Result := GetSmallMemManager.GetMem(aSize);
Assert(NativeUInt(Result) > $10000);
end;
{$else}
{$ifdef PURE_PASCAL}
begin
Result := GetSmallMemManager.GetMem(aSize);
Assert(NativeUInt(Result) > $10000);
end;
{$else}
asm
{$ifdef INLINEGOWN}
mov edx,eax
mov eax,GOwnTlsOffset
mov ecx,fs:[$00000018]
mov eax,[ecx+eax] // fixed offset, calculated only once
or eax,eax
jnz TThreadMemManager.GetMem
push edx
call CreateSmallMemManager
pop edx
jmp TThreadMemManager.GetMem
{$else}
push eax
call GetSmallMemManager
pop edx
jmp TThreadMemManager.GetMem
{$endif}
end;
{$endif}
{$endif}
function Scale_AllocMem(aSize: Cardinal): Pointer;
begin
Result := GetSmallMemManager.GetMem(aSize);
Assert(NativeUInt(Result) > $10000);
fillchar(Result^, aSize, 0); // AllocMem() = GetMem()+ZeroMemory()
end;
function Scale_FreeMem(aMemory: Pointer): Integer;
{$ifdef HASINLINE}
begin
Assert(NativeUInt(aMemory) > $10000);
Result := GetSmallMemManager.FreeMem(aMemory);
end;
{$else}
{$ifdef PURE_PASCAL}
begin
Assert(NativeUInt(aMemory) > $10000);
Result := GetSmallMemManager.FreeMem(aMemory);
end;
{$else}
asm
{$ifdef INLINEGOWN}
mov edx,eax
mov eax,GOwnTlsOffset
mov ecx,fs:[$00000018]
mov eax,[ecx+eax] // fixed offset, calculated only once
or eax,eax
jnz TThreadMemManager.FreeMem
push edx
call CreateSmallMemManager
pop edx
jmp TThreadMemManager.FreeMem
{$else}
push eax
call GetSmallMemManager
pop edx
jmp TThreadMemManager.FreeMem
{$endif}
end;
{$endif}
{$endif}
{$ifdef USEMEMMANAGEREX}
function Scale_RegisterMemoryLeak(P: Pointer): Boolean;
begin
{ TODO : implement memory leak checking }
Result := OldMM.RegisterExpectedMemoryLeak(p);
end;
function Scale_UnregisterMemoryLeak(P: Pointer): Boolean;
begin
Result := OldMM.UnregisterExpectedMemoryLeak(p);
end;
{$endif}
type
TEndThread = procedure(ExitCode: Integer);
var
OldEndThread: TEndThread;
procedure NewEndThread(ExitCode: Integer); //register; // ensure that calling convension matches EndThread
begin
// free all thread mem
GlobalManager.FreeThreadManager( GetSmallMemManager );
// OldEndThread(ExitCode); todo: make trampoline with original begin etc
// code of original EndThread;
ExitThread(ExitCode);
end;
type
PJump = ^TJump;
TJump = packed record
OpCode: Byte;
Distance: Integer;
end;
var
NewCode: TJump = (OpCode : $E9;
Distance: 0);
// redirect calls to System.EndThread to NewEndThread
procedure PatchThread;
var
pEndThreadAddr: PJump;
iOldProtect: DWord;
begin
pEndThreadAddr := Pointer(@EndThread);
Scale_VirtualProtect(pEndThreadAddr, 5, PAGE_EXECUTE_READWRITE, iOldProtect);
// calc jump to new function
NewCode.Distance := Cardinal(@NewEndThread) - (Cardinal(@EndThread) + 5);
// store old
OldEndThread := TEndThread(pEndThreadAddr);
// overwrite with jump to new function
pEndThreadAddr^ := NewCode;
// flush CPU
FlushInstructionCache(GetCurrentProcess, pEndThreadAddr, 5);
end;
const
{$ifdef USEMEMMANAGEREX}
ScaleMM_Ex: TMemoryManagerEx = (
GetMem: Scale_GetMem;
FreeMem: Scale_FreeMem;
ReallocMem: Scale_ReallocMem;
AllocMem: Scale_AllocMem;
RegisterExpectedMemoryLeak: Scale_RegisterMemoryLeak;
UnregisterExpectedMemoryLeak: Scale_UnregisterMemoryLeak );
{$else}
ScaleMM_Ex: TMemoryManager = (
GetMem: Scale_GetMem;
FreeMem: Scale_FreeMem;
ReallocMem: Scale_ReallocMem );
{$endif}
procedure ScaleMMInstall;
begin
{$ifndef PURE_PASCAL}
// get TLS slot
GOwnTlsIndex := TlsAlloc;
// write fixed offset to TLS slot (instead calc via GOwnTlsIndex)
_FixedOffset;
{$endif}
// Hook memory Manager
GetMemoryManager(OldMM);
if @OldMM <> @ScaleMM_Ex then
SetMemoryManager(ScaleMM_Ex);
// init main thread manager
GlobalManager.Init;
// we need to patch System.EndThread to properly mark memory to be freed
PatchThread;
end;
initialization
ScaleMMInstall;
finalization
{ TODO : check for memory leaks }
GlobalManager.FreeAllMemory;
end.