1777 lines
53 KiB
ObjectPascal
1777 lines
53 KiB
ObjectPascal
/// 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) 2022
|
|
the Initial Developer. All Rights Reserved.
|
|
|
|
Contributor(s):
|
|
- Arnaud Bouchez https://synopse.info
|
|
Portions created by each contributor are Copyright (C) 2022
|
|
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. |