mmalloc.pas

一套及时通讯的原码

unit MMAlloc;

{$I COMPILER.INC}

interface

uses
    {$IFDEF WIN32}
    Windows,
    SyncObjs,
    {$ELSE}
    WinTypes,
    WinProcs,
    {$ENDIF}
    SysUtils,
    Classes,
    MMObj,
    MMUtils;

type
    TMMAllocator = class(TObject)
    private
       FBuffers: TList;
       {$IFDEF WIN32}
       FSection: TCriticalSection;
       {$ENDIF}
    public
       constructor Create;
       destructor  Destroy; override;

       procedure Discard;
       procedure DiscardFreeBuffers;

       function  AllocBufferEx(dwFlags, dwSize: DWORD): Pointer;
       function  AllocBuffer(dwFlags, dwSize: DWORD): Pointer;
       procedure FreeBuffer(var lpBuffer: Pointer);
       procedure DiscardBuffer(var lpBuffer: Pointer);
    end;

implementation

type
    PMMBuffer    = ^TMMBuffer;
    TMMBuffer    = record
       lpPointer : Pointer;
       dwLength  : DWORD;
       dwRefCount: integer;
    end;

{== TMMAllocator ==============================================================}
constructor TMMAllocator.Create;
begin
   inherited Create;

   FBuffers := TList.Create;
   {$IFDEF WIN32}
   FSection := TCriticalSection.Create;
   {$ENDIF}
end;

{-- TMMAllocator --------------------------------------------------------------}
destructor TMMAllocator.Destroy;
begin
   Discard;

   FBuffers.Free;

   {$IFDEF WIN32}
   FSection.Free;
   {$ENDIF}

   inherited Destroy;
end;

{-- TMMAllocator --------------------------------------------------------------}
procedure TMMAllocator.Discard;
var
   i: integer;
begin
   {$IFDEF WIN32}
   FSection.Enter;
   {$ENDIF}
   try
      for i := FBuffers.Count-1 downto 0 do
      begin
         GlobalFreePtr(PMMBuffer(FBuffers[i])^.lpPointer);
         Dispose(FBuffers[i]);
         FBuffers.Delete(i);
      end;
   finally
      {$IFDEF WIN32}
       FSection.Leave;
       {$ENDIF}
   end;
end;

{-- TMMAllocator --------------------------------------------------------------}
procedure TMMAllocator.DiscardFreeBuffers;
var
   i: integer;
begin
   {$IFDEF WIN32}
   FSection.Enter;
   {$ENDIF}
   try
      for i := FBuffers.Count-1 downto 0 do
      begin
         with PMMBuffer(FBuffers[i])^ do
         begin
            if (dwRefCount = 0) then
            begin
               GlobalFreePtr(PMMBuffer(FBuffers[i])^.lpPointer);
               Dispose(FBuffers[i]);
               FBuffers.Delete(i);
            end;
         end;
      end;
   finally
      {$IFDEF WIN32}
       FSection.Leave;
       {$ENDIF}
   end;
end;

{-- TMMAllocator --------------------------------------------------------------}
function TMMAllocator.AllocBufferEx(dwFlags: DWORD; dwSize: DWORD): Pointer;
var
   i: integer;
   P: PMMBuffer;
begin
   Result := nil;
   {$IFDEF WIN32}
   FSection.Enter;
   {$ENDIF}
   try
      for i := 0 to FBuffers.Count-1 do
      begin
         with PMMBuffer(FBuffers[i])^ do
         begin
            if (dwRefCount = 0) and (dwLength = dwSize) then
            begin
               Result := lpPointer;
               inc(dwRefCount);
               break;
            end;
         end;
      end;
      if (Result = nil) then
      begin
         { free all unused buffers }
         DiscardFreeBuffers;

         New(P);
         with P^ do
         begin
            lpPointer  := GlobalAllocPtr(dwFlags,dwSize);
            dwLength   := dwSize;
            dwRefCount := 1;
         end;
         FBuffers.Add(P);
         Result := P^.lpPointer;
      end;
   finally
      {$IFDEF WIN32}
      FSection.Leave;
      {$ENDIF}
   end;
end;

{-- TMMAllocator --------------------------------------------------------------}
function TMMAllocator.AllocBuffer(dwFlags,dwSize: DWORD): Pointer;
var
   i: integer;
   P: PMMBuffer;
begin
   Result := nil;
   {$IFDEF WIN32}
   FSection.Enter;
   {$ENDIF}
   try
      for i := 0 to FBuffers.Count-1 do
      begin
         with PMMBuffer(FBuffers[i])^ do
         begin
            if (dwRefCount = 0) and (dwLength = dwSize) then
            begin
               Result := lpPointer;
               inc(dwRefCount);
               break;
            end;
         end;
      end;
      if (Result = nil) then
      for i := 0 to FBuffers.Count-1 do
      begin
         with PMMBuffer(FBuffers[i])^ do
         begin
            if (dwRefCount = 0) and (dwLength >= dwSize) then
            begin
               Result := lpPointer;
               inc(dwRefCount);
               break;
            end;
         end;
      end;
      if (Result = nil) then
      begin
         New(P);
         with P^ do
         begin
            lpPointer  := GlobalAllocPtr(dwFlags,dwSize);
            dwLength   := dwSize;
            dwRefCount := 1;
         end;
         FBuffers.Add(P);
         Result := P^.lpPointer;
      end;
   finally
      {$IFDEF WIN32}
      FSection.Leave;
      {$ENDIF}
   end;
end;

{-- TMMAllocator --------------------------------------------------------------}
procedure TMMAllocator.FreeBuffer(var lpBuffer: Pointer);
var
   i: integer;
begin
   if (lpBuffer <> nil) then
   begin
      {$IFDEF WIN32}
      FSection.Enter;
      {$ENDIF}
      try
         for i := 0 to FBuffers.Count-1 do
         with PMMBuffer(FBuffers[i])^ do
         begin
            if (lpBuffer = lpPointer) then
            begin
               dec(dwRefCount);
               lpBuffer := nil;
               break;
            end;
         end;
      finally
         {$IFDEF WIN32}
         FSection.Leave;
         {$ENDIF}
      end;
   end;
end;

{-- TMMAllocator --------------------------------------------------------------}
procedure TMMAllocator.DiscardBuffer(var lpBuffer: Pointer);
var
   i: integer;
begin
   if (lpBuffer <> nil) then
   begin
      {$IFDEF WIN32}
      FSection.Enter;
      {$ENDIF}
      try
         for i := 0 to FBuffers.Count-1 do
         with PMMBuffer(FBuffers[i])^ do
         begin
            if (lpBuffer = lpPointer) then
            begin
               GlobalFreePtr(PMMBuffer(FBuffers[i])^.lpPointer);
               Dispose(FBuffers[i]);
               FBuffers.Delete(i);
               lpBuffer := nil;
               break;
            end;
         end;
      finally
         {$IFDEF WIN32}
         FSection.Leave;
         {$ENDIF}
      end;
   end;
end;

end.