是否有在堆栈上分配内存的Delphi内存管理函数？

C world具有或，它在堆栈而不是堆上分配内存

---

Delphi有这样的功能吗？

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

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

---

从网上搜到这个：

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.

参考：

---

如果您真的想在Delphi中复制

alloca

功能，我建议您查看VCL中网格单元中的

StackAlloc

函数。这是一个在单元的实现部分声明的过程，因此您必须复制VCL源代码以利用它。

这迫使您在编译时决定大小。与alloca.TOndrej不同，您的技巧在某些情况下非常有用。所以，我投赞成票。谢谢。当发布其他人的代码时，请包括一个属性。另外，由于使用了锁，该代码的性能肯定会很差。@David：当然没问题。我没有测试这段代码，我确信这不是一个好主意。只是表明它是possible@David_Heffernan谢谢但是，在Delphi XE3中，在64位环境中编译时，

StackAlloc（）

调用

GetMem（）

。无论如何，也许我可以将x86 BASM代码移植到XE3 x64 BASM或NASM。所以，你的答案仍然值得接受。再次感谢。所有的赌注都在x64上。但是你的问题没有提到x64，所以我忽略了！事实上，我故意没有提到x64，这样我就可以阅读类似于您的内容：-）。额外的努力对我来说没问题。我的评论只是给其他用户的一个提示。描述这个堆栈分配技术的文章：。@LURD，它描述了其他一些东西。

StackAlloc

功能是

alloca

的真正模拟。链接到的内容用于将类实例放在堆栈上。以这种方式分配的内存的主要用途是确保在调用函数返回时将其释放。如果这是你的目标，那就使用try-finally块和普通内存分配。你为什么要这样做呢？

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;