Инкапсуляция работы с памятью. Часть 0

Хочу вернуться к описанию контейнеров в "стиле STL".

Немножко я рассказал тут - http://18delphi.blogspot.com/2013/03/generic-generic.html

И тут:
http://18delphi.blogspot.com/2013/03/blog-post_4606.html
http://18delphi.blogspot.com/2013/04/iunknown.html

Но там я использовал динамические массивы.

А в РЕАЛЬНОМ своём "микро-STL" я использую прямую работу с памятью - GetMem/FreeMem.

Посему - хочу начать с того - как я работаю с памятью напрямую. Точнее то - как я инкапсулировал работу с памятью во всякие фасадные функции/объекты.

Первый пример - получение размера куска памяти. Немножко я рассказал уже тут - http://18delphi.blogspot.com/2013/04/getmem.html

Но теперь я хочу показать - как это нарисовано на UML. И как это инкапсулировано в отдельный модуль.

Итак.

Сначала - модель:

И код:
l3MemorySizeUtilsPrim.pas:

unit l3MemorySizeUtilsPrim;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// Библиотека "L3$Basic Concepts"
// Модуль: "w:/common/components/rtl/L3/l3MemorySizeUtilsPrim.pas"
// Родные Delphi интерфейсы (.pas)
// Generated from UML model, root element: UtilityPack::Class Shared Delphi Требования к низкоуровневым библиотекам::L3$Basic Concepts::MemoryUtils::l3MemorySizeUtilsPrim
//
//
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// ! Полностью генерируется с модели. Править руками - нельзя. !

interface

type
 Tl3MemorySizeFunc = function (aPtr: Pointer): Integer;
 {$If not defined(XE)}
function L3MemorySizeDelphi7(aPtr: Pointer): Integer;
   {* функция для получения размера куска памяти }
 {$IfEnd} //not XE
 {$If defined(XE)}
function L3MemorySizeXE(aPtr: Pointer): Integer;
   {* функция для получения размера куска памяти }
 {$IfEnd} //XE

implementation

uses
  l3MemorySizeUtils
  ;

// unit methods

{$If not defined(XE)}
function L3MemorySizeDelphi7(aPtr: Pointer): Integer;
//#UC START# *51DAD8DC00B2_51DADE55035E_var*
const
  cThisUsedFlag = 2;
  cPrevFreeFlag = 1;
  cFillerFlag   = Integer($80000000);
  cFlags        = cThisUsedFlag or cPrevFreeFlag or cFillerFlag;

type
  PUsed = ^TUsed;
  TUsed = packed record
    sizeFlags: Integer;
  end;//TUsed

//#UC END# *51DAD8DC00B2_51DADE55035E_var*
begin
//#UC START# *51DAD8DC00B2_51DADE55035E_impl*
 if (aPtr = nil) then
  Result := 0
 else
  Result := PUsed(PMem(aPtr)-SizeOf(TUsed)).sizeFlags and not cFlags - sizeof(TUsed);
//  Result := (PLong(Long(aP) - 4)^ AND not cFlags) - 4;
//#UC END# *51DAD8DC00B2_51DADE55035E_impl*
end;//L3MemorySizeDelphi7
{$IfEnd} //not XE

{$If defined(XE)}
function L3MemorySizeXE(aPtr: Pointer): Integer;
//#UC START# *51DADA9600F9_51DADE55035E_var*

const
  {----------------------------Block type flags---------------------------}
  {The lower 3 bits in the dword header of small blocks (4 bits in medium and
   large blocks) are used as flags to indicate the state of the block}
  {Set if the block is not in use}
  IsFreeBlockFlag = 1;
  {Set if this is a medium block}
  IsMediumBlockFlag = 2;
  {Set if it is a medium block being used as a small block pool. Only valid if
   IsMediumBlockFlag is set.}
  IsSmallBlockPoolInUseFlag = 4;
  {Set if it is a large block. Only valid if IsMediumBlockFlag is not set.}
  IsLargeBlockFlag = 4;
  {Is the medium block preceding this block available?}
  PreviousMediumBlockIsFreeFlag = 8;
  {Is this large block segmented? I.e. is it actually built up from more than
   one chunk allocated through VirtualAlloc? (Only used by large blocks.)}
  LargeBlockIsSegmented = 8;
  {The flags masks for small blocks}
  DropSmallFlagsMask = -8;
  ExtractSmallFlagsMask = 7;
  {The flags masks for medium and large blocks}
  DropMediumAndLargeFlagsMask = -16;
  ExtractMediumAndLargeFlagsMask = 15;
{------------------------------Private types------------------------------}
type
 
  {Move procedure type}
  TMoveProc = procedure(const ASource; var ADest; ACount: NativeInt);
 
  {-----------------------Small block structures--------------------------}
 
  {Pointer to the header of a small block pool}
  PSmallBlockPoolHeader = ^TSmallBlockPoolHeader;
 
  {Small block type (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).}
  PSmallBlockType = ^TSmallBlockType;
  TSmallBlockType = record
    {True = Block type is locked}
    BlockTypeLocked: Boolean;
    {Bitmap indicating which of the first 8 medium block groups contain blocks
     of a suitable size for a block pool.}
    AllowedGroupsForBlockPoolBitmap: Byte;
    {The block size for this block type}
    BlockSize: Word;
    {The minimum and optimal size of a small block pool for this block type}
    MinimumBlockPoolSize: Word;
    OptimalBlockPoolSize: Word;
    {The first partially free pool for the given small block. This field must
     be at the same offset as TSmallBlockPoolHeader.NextPartiallyFreePool.}
    NextPartiallyFreePool: PSmallBlockPoolHeader;
    {The last partially free pool for the small block type. This field must
     be at the same offset as TSmallBlockPoolHeader.PreviousPartiallyFreePool.}
    PreviousPartiallyFreePool: PSmallBlockPoolHeader;
    {The offset of the last block that was served sequentially. The field must
     be at the same offset as TSmallBlockPoolHeader.FirstFreeBlock.}
    NextSequentialFeedBlockAddress: Pointer;
    {The last block that can be served sequentially.}
    MaxSequentialFeedBlockAddress: Pointer;
    {The pool that is current being used to serve blocks in sequential order}
    CurrentSequentialFeedPool: PSmallBlockPoolHeader;
{$ifdef UseCustomFixedSizeMoveRoutines}
    {The fixed size move procedure used to move data for this block size when
     it is upsized. When a block is downsized (which usually does not occur
     that often) the variable size move routine is used.}
    UpsizeMoveProcedure: TMoveProc;
{$else}
    Reserved1: Pointer;
{$endif}
{$if SizeOf(Pointer) = 8}
    {Pad to 64 bytes for 64-bit}
    Reserved2: Pointer;
{$ifend}
  end;
 
  {Small block pool (Size = 32 bytes for 32-bit, 48 bytes for 64-bit).}
  TSmallBlockPoolHeader = record
    {BlockType}
    BlockType: PSmallBlockType;
{$if SizeOf(Pointer) <> 8}
    {Align the next fields to the same fields in TSmallBlockType and pad this
     structure to 32 bytes for 32-bit}
    Reserved1: Cardinal;
{$ifend}
    {The next and previous pool that has free blocks of this size. Do not
     change the position of these two fields: They must be at the same offsets
     as the fields in TSmallBlockType of the same name.}
    NextPartiallyFreePool: PSmallBlockPoolHeader;
    PreviousPartiallyFreePool: PSmallBlockPoolHeader;
    {Pointer to the first free block inside this pool. This field must be at
     the same offset as TSmallBlockType.NextSequentialFeedBlockAddress.}
    FirstFreeBlock: Pointer;
    {The number of blocks allocated in this pool.}
    BlocksInUse: Cardinal;
    {Small block pool signature. Used by the leak checking mechanism to
     determine whether a medium block is a small block pool or a regular medium
     block.}
    SmallBlockPoolSignature: Cardinal;
    {The pool pointer and flags of the first block}
    FirstBlockPoolPointerAndFlags: NativeUInt;
  end;
 
  {Small block layout:
   At offset -SizeOf(Pointer) = Flags + address of the small block pool.
   At offset BlockSize - SizeOf(Pointer) = Flags + address of the small block
   pool for the next small block.
  }
 
  {------------------------Medium block structures------------------------}
 
  {The medium block pool from which medium blocks are drawn. Size = 16 bytes
   for 32-bit and 32 bytes for 64-bit.}
  PMediumBlockPoolHeader = ^TMediumBlockPoolHeader;
  TMediumBlockPoolHeader = record
    {Points to the previous and next medium block pools. This circular linked
     list is used to track memory leaks on program shutdown.}
    PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader;
    NextMediumBlockPoolHeader: PMediumBlockPoolHeader;
    {Padding}
    Reserved1: NativeUInt;
    {The block size and flags of the first medium block in the block pool}
    FirstMediumBlockSizeAndFlags: NativeUInt;
  end;
 
  {Medium block layout:
   Offset: -2 * SizeOf(Pointer) = Previous Block Size (only if the previous block is free)
   Offset: -SizeOf(Pointer) = This block size and flags
   Offset: 0 = User data / Previous Free Block (if this block is free)
   Offset: SizeOf(Pointer) = Next Free Block (if this block is free)
   Offset: BlockSize - 2*SizeOf(Pointer) = Size of this block (if this block is free)
   Offset: BlockSize - SizeOf(Pointer) = Size of the next block and flags
 
  {A medium block that is unused}
  PMediumFreeBlock = ^TMediumFreeBlock;
  TMediumFreeBlock = record
    PreviousFreeBlock: PMediumFreeBlock;
    NextFreeBlock: PMediumFreeBlock;
  end;
 
  {-------------------------Large block structures------------------------}
 
  {Large block header record (Size = 16 for 32-bit, 32 for 64-bit)}
  PLargeBlockHeader = ^TLargeBlockHeader;
  TLargeBlockHeader = record
    {Points to the previous and next large blocks. This circular linked
     list is used to track memory leaks on program shutdown.}
    PreviousLargeBlockHeader: PLargeBlockHeader;
    NextLargeBlockHeader: PLargeBlockHeader;
    {The user allocated size of the Large block}
    UserAllocatedSize: NativeUInt;
    {The size of this block plus the flags}
    BlockSizeAndFlags: NativeUInt;
  end; 

{---------------------------Private constants-----------------------------}
const
  {The size of the block header in front of small and medium blocks}
  BlockHeaderSize = SizeOf(Pointer);
  {The size of a small block pool header}
  SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader);
  {The size of a medium block pool header}
  MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader);
  {The size of the header in front of Large blocks}
  LargeBlockHeaderSize = SizeOf(TLargeBlockHeader);
  (*
  {This memory manager}
  ThisMemoryManager: TMemoryManagerEx = (
    GetMem: SysGetMem;
    FreeMem: SysFreeMem;
    ReallocMem: SysReallocMem;
    AllocMem: SysAllocMem;
    RegisterExpectedMemoryLeak: SysRegisterExpectedMemoryLeak;
    UnregisterExpectedMemoryLeak: SysUnregisterExpectedMemoryLeak);
   *)
   
var
 lBlockHeader: Cardinal;
 LPSmallBlockType: PSmallBlockType;
 LOldAvailableSize: Cardinal;
//#UC END# *51DADA9600F9_51DADE55035E_var*
begin
//#UC START# *51DADA9600F9_51DADE55035E_impl*
 if (aPtr = nil) then
   Result := 0
 else
 begin
 {Get the block header: Is it actually a small block?}
   LBlockHeader := PNativeUInt(PByte(aPtr) - BlockHeaderSize)^;
   {Is it a small block that is in use?}
   if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
   begin
     {----------------------------Small block------------------------------}
     {The block header is a pointer to the block pool: Get the block type}
     LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType;
     {Get the available size inside blocks of this type.}
     Result := LPSmallBlockType.BlockSize - BlockHeaderSize;
   end
   else
   begin
     {Is this a medium block or a large block?}
     if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then
     begin
      Result:= (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;
     end
     else
     begin
       {Is this a valid large block?}
       if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then
       begin
         {-----------------------Large block------------------------------}
         {Get the block header}
         //LBlockHeader := PNativeUInt(PByte(aP) - BlockHeaderSize)^;
         {Subtract the overhead to determine the useable size in the large block.}
         Result := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize);
       end
       else
       begin
         {-----------------------Invalid block------------------------------}
         {Bad pointer: probably an attempt to reallocate a free memory block.}
         Result := 0;
         assert(false);
       end;
     end;
   end;
 end;
//#UC END# *51DADA9600F9_51DADE55035E_impl*
end;//L3MemorySizeXE
{$IfEnd} //XE

end.

------
l3MemorySizeUtils.pas:

unit l3MemorySizeUtils;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// Библиотека "L3$Basic Concepts"
// Модуль: "w:/common/components/rtl/L3/l3MemorySizeUtils.pas"
// Родные Delphi интерфейсы (.pas)
// Generated from UML model, root element: UtilityPack::Class Shared Delphi Требования к низкоуровневым библиотекам::L3$Basic Concepts::MemoryUtils::l3MemorySizeUtils
//
//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// ! Полностью генерируется с модели. Править руками - нельзя. !

interface

uses
  l3MemorySizeUtilsPrim
  ;

type
 PMem = System.PANSIChar;

{$If not defined(XE)}
var l3MemorySize : Tl3MemorySizeFunc = L3MemorySizeDelphi7;
 {* функция для получения размера куска памяти}
{$IfEnd} //not XE

{$If defined(XE)}
var l3MemorySize : Tl3MemorySizeFunc = L3MemorySizeXE;
 {* функция для получения размера куска памяти}
{$IfEnd} //XE

implementation

end.

И тест:

Модель:

Код:

unit MemorySizeTest;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// Библиотека "SandBoxTest"
// Модуль: "w:/common/components/rtl/SandBox/MemorySizeTest.pas"
// Родные Delphi интерфейсы (.pas)
// Generated from UML model, root element: TestCase::Class Shared Delphi Sand Box::SandBoxTest::Memory::MemorySizeTest
//
//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// ! Полностью генерируется с модели. Править руками - нельзя. !

interface

{$If defined(nsTest)}
uses
  BaseTest
  ;
{$IfEnd} //nsTest

{$If defined(nsTest)}
type
 TMemorySizeTest = class(TBaseTest)
 protected
 // overridden protected methods
   function GetFolder: AnsiString; override;
     {* Папка в которую входит тест }
   function GetModelElementGUID: AnsiString; override;
     {* Идентификатор элемента модели, который описывает тест }
 published
 // published methods
   procedure DoIt;
 end;//TMemorySizeTest
{$IfEnd} //nsTest

implementation

{$If defined(nsTest)}
uses
  l3MemorySizeUtils,
  SysUtils,
  TestFrameWork
  ;
{$IfEnd} //nsTest

{$If defined(nsTest)}

// start class TMemorySizeTest

procedure TMemorySizeTest.DoIt;
//#UC START# *51DAE7030012_51DAE6E20300_var*
var
 l_Index : Integer;
 l_Size  : Integer;
 l_RealSize : Integer;
 l_P     : Pointer;
//#UC END# *51DAE7030012_51DAE6E20300_var*
begin
//#UC START# *51DAE7030012_51DAE6E20300_impl*
 for l_Index := 1 to 4 * 1024 do
 begin
  l_Size := l_Index * 2;
  System.GetMem(l_P, l_Size);
  try
   l_RealSize := l3MemorySize(l_P);
   Check(l_RealSize >= l_Size, Format('Выделяли %d. Выделилось %d.', [l_Size, l_RealSize]));
  finally
   System.FreeMem(l_P);
  end;//try..finally
 end;//form l_Index
//#UC END# *51DAE7030012_51DAE6E20300_impl*
end;//TMemorySizeTest.DoIt

function TMemorySizeTest.GetFolder: AnsiString;
 {-}
begin
 Result := 'Memory';
end;//TMemorySizeTest.GetFolder

function TMemorySizeTest.GetModelElementGUID: AnsiString;
 {-}
begin
 Result := '51DAE6E20300';
end;//TMemorySizeTest.GetModelElementGUID

{$IfEnd} //nsTest

initialization
 TestFramework.RegisterTest(TMemorySizeTest.Suite);

end.

Дальше - я надеюсь - расскажу про инкапсуляцию GetMem/FreeMem/ReallocMem в "объект" Tl3Ptr.

Все исходники тут - https://sourceforge.net/p/rumtmarc/code-0/15/tree/trunk/Blogger/STL.1/