delphi - 有没有在栈上分配内存的Delphi内存管理功能？

Question

C 世界有alloca()或_alloca()在堆栈而不是堆上分配内存。

Delphi有这样的功能吗？

Answer 1

如果您真的想复制allocaDelphi 中的功能，我建议您查看StackAllocVCL 中 Grids 单元中的功能。这是在单元的实现部分中声明的过程，因此您必须复制 VCL 源才能使用它。

Answer 2

您可以声明一个局部变量，例如一个字节数组：

var
  Buf: array[0..BufSize - 1] of Byte;

Answer 3

这是从网上截取的：

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's 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.

用法，在此示例中，将在堆栈上创建 TestObject：

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;

参考： http ://www.kbasm.com/delphi-stack-local-object.html