MycLib/Src/Myc.Heap.pas

unit Myc.Heap;

interface

{$align on}
uses
    {$ifndef NO_FASTMM}
    FastMM5,
    {$endif}
    Winapi.Windows;

type
    TSListEntry = Winapi.Windows.TSListEntry;
    PSListEntry = Winapi.Windows.PSListEntry;

    PSList = ^TSList;
    TSList = packed record
    private
        FList: TSListHeader;

    public
        class function Create: PSList; static;
        procedure Init;
        procedure Free;
        function Push( ListEntry: PSListEntry ): PSListEntry;
        function Pop: PSListEntry;
        function QueryDepth: Integer;
    end;

procedure GetMemAligned( var P; Size: NativeUInt );
procedure FreeMemAligned( var P );

procedure InitializeSListHead( ListHead: PSListHeader ); stdcall; external kernel32;
function InterlockedPushEntrySList( ListHead: PSListHeader; ListEntry: PSListEntry ): PSListEntry; stdcall; external kernel32;
function InterlockedPopEntrySList( ListHead: PSListHeader ): PSListEntry; stdcall; external kernel32;
function QueryDepthSList( ListHead: PSListHeader ): Word; stdcall; external kernel32;

implementation

const
    // Defines the alignment boundary (16 bytes for SList and common SIMD operations)
    AlignmentBoundary = 16;
    // Mask to achieve alignment, (AlignmentBoundary - 1)
    AlignmentMask = AlignmentBoundary - 1;

{$ifdef NO_FASTMM}

const
    MetaDataSize = SizeOf(Pointer);

procedure GetMemAligned(var P; Size: NativeUInt);
var
    rawAllocatedPtr: Pointer;
    alignedUserPtrVal: NativeUInt;
    rawAllocatedPtrVal: NativeUInt;
    totalSizeToAllocate: NativeUInt;
begin
    totalSizeToAllocate := Size + MetaDataSize + AlignmentMask;
    System.GetMem(rawAllocatedPtr, totalSizeToAllocate);
    if rawAllocatedPtr = nil then
    begin
        Pointer(P) := nil;
        Exit;
    end;
    rawAllocatedPtrVal := NativeUInt(rawAllocatedPtr);
    alignedUserPtrVal := (rawAllocatedPtrVal + MetaDataSize + AlignmentMask) and not AlignmentMask;
    Pointer(P) := Pointer(alignedUserPtrVal);
    PPointer(alignedUserPtrVal - MetaDataSize)^ := rawAllocatedPtr;
    Assert((NativeUInt(P) and AlignmentMask) = 0, 'GetMemAligned did not return an aligned pointer.');
end;

procedure FreeMemAligned( var P );
var
    alignedUserPtrVal: NativeUInt;
    rawAllocatedPtr: Pointer;
    ptrToRawAllocatedPtr: PPointer;
begin
    if Pointer(P) = nil then
        Exit;
    alignedUserPtrVal := NativeUInt(P);
    ptrToRawAllocatedPtr := PPointer(alignedUserPtrVal - MetaDataSize);
    rawAllocatedPtr := ptrToRawAllocatedPtr^;
    System.FreeMem(rawAllocatedPtr);
    Pointer(P) := nil;
end;

{$else}

procedure GetMemAligned(var P; Size: NativeUInt); inline;
begin
    FastMM_EnterMinimumAddressAlignment(maa16Bytes);
    try
        GetMem( Pointer(P), Size );
    finally
        FastMM_ExitMinimumAddressAlignment(maa16Bytes)
    end;
end;

procedure FreeMemAligned( var P ); inline;
begin
    FreeMem( Pointer(P) );
end;

{$endif}

{ TSList }

class function TSList.Create: PSList;
begin
    GetMemAligned( Result, sizeof( TSList ) );
    Result.Init;
end;

procedure TSList.Free;
var
    P: Pointer;
begin
    P := @Self;
    FreeMemAligned( P );
end;

procedure TSList.Init;
begin
    Assert( NativeUInt( @FList ) and AlignmentMask = 0, 'ListHeader not aligned' );
    InitializeSListHead( @FList );
end;

function TSList.Pop: PSListEntry;
begin
    Result := InterlockedPopEntrySList( @FList );
end;

function TSList.Push( ListEntry: PSListEntry ): PSListEntry;
begin
    Assert( NativeUInt( ListEntry ) and AlignmentMask = 0, 'ListEntry not aligned' );
    Result := InterlockedPushEntrySList( @FList, ListEntry );
end;

function TSList.QueryDepth: Integer;
begin
    Result := QueryDepthSList( @FList );
end;

end.