I hooked it from the network:
unit LocalObject; interface uses SysUtils, Windows; const // AOS -> allocate object strategy // allocate objects on stack AOS_STACK = 0; // allocate on a global buffer AOS_GLOBAL = 1; // allcoate on a specified buffer AOS_LOCAL = 2; //allocate through IMemoryAllocator AOS_ALLOCATOR = 3; // allocate as normal Delphi does (on the heap). AOS_HEAP = 4; GlobalBufferLen = 1024 * 16; type IMemoryAllocator = interface function GetMem(Size: Integer): Pointer; function FreeMem(P: Pointer): Integer; end; { Control how and where to allocate the objects. AStrategy: the strategy values. Can be any constant prefixed with AOS_ ABuffer and ABufferSize: Only used by AOS_LOCAL and AOS_ALLOCATOR. For AOS_LOCAL, ABuffer is the memory address of the buffer, ABufferSize is the buffer size. For AOS_ALLOCATOR, ABuffer is a pointer of interface IMemoryAllocator, ABufferSize is unused. } procedure SetObjectAllocateStrategy(AStrategy: Integer; ABuffer: Pointer = nil; ABufferSize: Integer = 0); { Enter the local object memory allocation. You must call it once for each procedure. ASize: the size of total memory. It the maximum size that can be allocated. } procedure EnterLocalObject(ASize: Integer); overload; { Enter the local object memory allocation AClass: the class type ACount: the maximum object count } procedure EnterLocalObject(AClass: TClass; ACount: Integer = 1); overload; { Leave the local object memory allocation } procedure LeaveLocalObject; { Reset current local object memory allocation Then all memory will be reclaimed and can be reused again } procedure ResetLocalObject; { Initialize locat object memory allocation. This function should be called only once or called by EnterLocalObject implicitly. } procedure InitLocalObject; { Finalize locat object memory allocation. This function should be called only once or called by LeaveLocalObject implicitly. } procedure DeInitLocalObject; implementation const HookHeaderLen = 5; type THookHeader = array[0 .. HookHeaderLen - 1] of Byte; TAllocateStrategy = packed record Strategy: Integer; Buffer: Pointer; BufferSize: Integer; end; TLocalMemoryInfo = packed record TopMost: Pointer; Top: Pointer; Size: Cardinal; Strategy: Integer; Buffer: Pointer; end; PLocalMemoryInfo = ^TLocalMemoryInfo; const LocalMemoryInfoSize = SizeOf(TLocalMemoryInfo); var MemInfoStack: array of TLocalMemoryInfo; MemInfoStackSize: Integer; MemInfoStackTop: Integer; CriticalSection: TRTLCriticalSection; HookHeaders: array[ 0 .. 1 ] of THookHeader; CanLocalObject: Boolean; LocalObjectInitCount: Integer; AllocateStrategy: TAllocateStrategy; GlobalBuffer: array[ 0 .. GlobalBufferLen - 1 ] of Byte; procedure GrowMemInfoStack; begin Inc(MemInfoStackSize, 10); SetLength(MemInfoStack, MemInfoStackSize); end; // eax - ASize procedure EnterLocalObject(ASize: Integer); asm push eax call InitLocalObject lea ecx, CriticalSection push ecx call EnterCriticalSection mov ecx, MemInfoStackTop cmp ecx, MemInfoStackSize jb @@nogrow call GrowMemInfoStack mov ecx, MemInfoStackTop @@nogrow: pop eax inc MemInfoStackTop imul ecx, LocalMemoryInfoSize lea edx, MemInfoStack[0] mov edx, [edx] add edx, ecx mov edx.TLocalMemoryInfo.Size, eax mov ecx, AllocateStrategy.Buffer mov edx.TLocalMemoryInfo.Buffer, ecx mov ecx, AllocateStrategy.Strategy mov edx.TLocalMemoryInfo.Strategy, ecx // mov ecx, AllocateStrategy.Strategy cmp ecx, AOS_STACK jz @@Stack cmp ecx, AOS_GLOBAL jz @@Global cmp ecx, AOS_LOCAL jz @@Local cmp ecx, AOS_HEAP jz @@Heap cmp ecx, AOS_ALLOCATOR jz @@Allocator @@Stack: pop ecx //store the return address mov edx.TLocalMemoryInfo.Top, esp add eax, 3 and eax, not 3 @@loop: cmp eax, 4096 jb @@1 sub esp, 4092 push edx sub eax, 4096 jmp @@loop @@1: sub esp, eax mov edx.TLocalMemoryInfo.TopMost, esp push ecx jmp @@end @@Global: lea eax, GlobalBuffer[0] mov edx.TLocalMemoryInfo.TopMost, eax add eax, GlobalBufferLen mov edx.TLocalMemoryInfo.Top, eax jmp @@end @@Local: mov eax, AllocateStrategy.Buffer mov edx.TLocalMemoryInfo.TopMost, eax add eax, AllocateStrategy.BufferSize mov edx.TLocalMemoryInfo.Top, eax jmp @@end @@Heap: mov edx.TLocalMemoryInfo.Top, 0 jmp @@end @@Allocator: // jmp @@end @@end: end; procedure EnterLocalObject(AClass: TClass; ACount: Integer); overload; asm push edx call TObject.InstanceSize pop edx mul eax, edx jmp EnterLocalObject end; procedure LeaveLocalObject; asm mov ecx, MemInfoStackTop dec ecx jl @@end imul ecx, LocalMemoryInfoSize lea edx, MemInfoStack[0] mov edx, [edx] add edx, ecx mov ecx, edx.TLocalMemoryInfo.Strategy cmp ecx, AOS_ALLOCATOR jnz @@NotAllocator push ecx push edx push MemInfoStackTop mov MemInfoStackTop, 0 mov ecx, edx.TLocalMemoryInfo.Buffer push ecx mov ecx, [ecx] call dword ptr [ecx] + VMTOFFSET IMemoryAllocator._Release pop MemInfoStackTop pop edx pop ecx @@NotAllocator: cmp ecx, AOS_STACK jnz @@done // store stack that should not be modified. // ecx is the return address // eax may be used by try..finally code structure. pop ecx pop eax add esp, edx.TLocalMemoryInfo.Size // mov edx.TLocalMemoryInfo.Top, 0 push eax push ecx @@done: lea eax, CriticalSection push eax call LeaveCriticalSection call DeInitLocalObject @@end: end; procedure ResetLocalObject; begin if (MemInfoStackTop <> 0) then MemInfoStack[MemInfoStackTop - 1].Top := Pointer(Cardinal(MemInfoStack[MemInfoStackTop - 1].TopMost) + MemInfoStack[MemInfoStackTop - 1].Size); end; procedure SetObjectAllocateStrategy(AStrategy: Integer; ABuffer: Pointer; ABufferSize: Integer); begin EnterCriticalSection(CriticalSection); try AllocateStrategy.Strategy := AStrategy; if AStrategy = AOS_LOCAL then begin AllocateStrategy.Buffer := ABuffer; AllocateStrategy.BufferSize := ABufferSize; Assert(ABuffer <> nil, 'The buffer can not be nil.'); end else begin if AStrategy = AOS_ALLOCATOR then begin AllocateStrategy.Buffer := ABuffer; IMemoryAllocator(AllocateStrategy.Buffer)._AddRef; end else begin AllocateStrategy.Buffer := nil; end; end finally LeaveCriticalSection(CriticalSection); end; end; function GetLocalMem(ASize: Integer): Pointer; var lMemInfo: PLocalMemoryInfo; begin if (MemInfoStackTop = 0) or (MemInfoStack[MemInfoStackTop - 1].Strategy = AOS_HEAP) then begin GetMem(Result, ASize); end else begin lMemInfo := @MemInfoStack[MemInfoStackTop - 1]; if lMemInfo^.Strategy = AOS_ALLOCATOR then Result := IMemoryAllocator(lMemInfo^.Buffer).GetMem(ASize) else begin ASize := (ASize + 3) and not 3; if Cardinal(lMemInfo^.Top) + Cardinal(ASize) < Cardinal(lMemInfo^.TopMost) then raise Exception.Create('Out of stack memory'); lMemInfo^.Top := Pointer(Cardinal(lMemInfo^.Top) - Cardinal(ASize)); Result := lMemInfo^.Top; end; end; end; procedure FreeLocalMem(AMem: Pointer); var lMemInfo: PLocalMemoryInfo; begin if (MemInfoStackTop = 0) or (MemInfoStack[MemInfoStackTop - 1].Strategy = AOS_HEAP) then begin FreeMem(AMem); end else begin lMemInfo := @MemInfoStack[MemInfoStackTop - 1]; if lMemInfo^.Strategy = AOS_ALLOCATOR then IMemoryAllocator(lMemInfo^.Buffer).FreeMem(AMem); end; end; function NewNewInstance(ASelf: TClass): TObject; var P: Pointer; begin P := GetLocalMem(ASelf.InstanceSize); Result := TObject(P); Result := ASelf.InitInstance(Result); end; procedure NewFreeInstance(ASelf: TObject); begin ASelf.CleanupInstance; FreeLocalMem(Pointer(ASelf)); end; procedure SimpleHook(ATarget, AHook: Pointer); function GetRelativeAddr(ACode: PByte; AInstOffset: Integer; AAddr: Cardinal): Integer; begin Inc(ACode, AInstOffset); Result := Integer(AAddr) - (Integer(ACode) + 4); end; begin PByte(ATarget)^ := $e9; PInteger(Cardinal(ATarget) + 1)^ := GetRelativeAddr(ATarget, 1, Cardinal(AHook)); end; procedure SimpleUnhook(ATarget: Pointer; AHeader: THookHeader); begin Move(AHeader[0], ATarget^, HookHeaderLen); end; procedure SimplePrepareHook(ATarget: Pointer; var AHeader: THookHeader); var lOldProtect: Cardinal; begin VirtualProtect(ATarget, HookHeaderLen, PAGE_READWRITE, lOldProtect); if IsBadWritePtr(ATarget, HookHeaderLen) then begin CanLocalObject := False; raise Exception.Create('Can not write target function required by local object.'); end; Move(ATarget^, AHeader[0], HookHeaderLen); end; procedure InitLocalObject; begin if not CanLocalObject then Exit; EnterCriticalSection(CriticalSection); try Inc(LocalObjectInitCount); if LocalObjectInitCount = 1 then begin SimpleHook(@TObject.NewInstance, @NewNewInstance); SimpleHook(@TObject.FreeInstance, @NewFreeInstance); end; finally LeaveCriticalSection(CriticalSection); end; end; procedure DeInitLocalObject; begin if not CanLocalObject then Exit; EnterCriticalSection(CriticalSection); try Dec(LocalObjectInitCount); if LocalObjectInitCount <= 0 then begin LocalObjectInitCount := 0; SimpleUnhook(@TObject.NewInstance, HookHeaders[0]); SimpleUnhook(@TObject.FreeInstance, HookHeaders[1]); end; finally LeaveCriticalSection(CriticalSection); end; end; procedure Init; begin LocalObjectInitCount := 0; MemInfoStackSize := 0; MemInfoStackTop := 0; GrowMemInfoStack; InitializeCriticalSection(CriticalSection); CanLocalObject := True; SetObjectAllocateStrategy(AOS_STACK, nil, 0); SimplePrepareHook(@TObject.NewInstance, HookHeaders[0]); SimplePrepareHook(@TObject.FreeInstance, HookHeaders[1]); end; initialization Init; end.
In this example, TestObject will be created on the stack:
procedure TestIt; var lObj: TTestObject; I: Integer; begin EnterLocalObject(TTestObject, 100); try for I := 1 to 100 do lObj := TTestObject.Create; try lObj.ShowMsg; finally lObj.Free; end; finally LeaveLocalObject; end; end;
link: http://www.kbasm.com/delphi-stack-local-object.html