MycLib/Src/Myc.Core.Atomic.pas

unit Myc.Core.Atomic;

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
        // Creates and initializes an aligned SList header.
        class function Create: PSList; static;
        // Initializes the SList header for use.
        procedure Init;
        // Frees the SList header.
        procedure Free;
        // Atomically pushes an entry onto the SList.
        function Push(ListEntry: PSListEntry): PSListEntry;
        // Atomically pops an entry from the SList.
        function Pop: PSListEntry;
        // Returns the current number of entries in the SList.
        function QueryDepth: Integer;
    end;

    TMycAtomicStack<T> = record
    private type
        PItem = ^TItem;
        TItem = packed record
            Next: TSListEntry;
            Data: T;
        end;

    var
        FSList: PSList;

    public
        // Initializes the atomic stack, creating the underlying SList.
        class operator Initialize(out Dest: TMycAtomicStack<T>);
        // Finalizes the atomic stack, freeing all items and the SList.
        class operator Finalize(var Dest: TMycAtomicStack<T>);

        // Pops an item from the stack; returns Default(T) if empty.
        function Pop: T; inline;
        // Tries to pop an item from the stack; returns true if successful.
        function TryPop(out Item: T): Boolean; inline;
        // Pushes an item onto the stack.
        procedure Push(const Data: T); inline;

        procedure Clear;

        // Allocates an aligned memory block for a stack item.
        function Alloc: PItem; inline;
        // Pushes a pre-allocated item pointer onto the SList.
        procedure PushPtr(Item: PItem); inline;
        // Pops a raw item pointer from the SList.
        function PopPtr: PItem; inline;
    end;

// Allocates memory with a specified alignment.
procedure GetMemAligned(var P; Size: NativeUInt);
// Frees memory allocated by GetMemAligned.
procedure FreeMemAligned(var P);

implementation

const
    AlignmentBoundary = 16;
    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));
    Pointer(P) := nil;
end;

{$endif}

{ TSList }

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

procedure TSList.Free;
var
    tempSelf: Pointer;
begin
    tempSelf := Pointer(@Self); // @Self is valid here as Free is an instance method of a record
    FreeMemAligned(tempSelf);
end;

procedure TSList.Init;
begin
    Assert((NativeUInt(@FList) and AlignmentMask) = 0, 'TSList.FList member 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 to be pushed is not aligned');
    Result := InterlockedPushEntrySList(@FList, ListEntry);
end;

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

{ TMycAtomicStack<T> }

class operator TMycAtomicStack<T>.Initialize(out Dest: TMycAtomicStack<T>);
begin
    // Use Dest to access fields of the record instance being initialized
    Dest.FSList := TSList.Create;
end;

class operator TMycAtomicStack<T>.Finalize(var Dest: TMycAtomicStack<T>);
begin
    Dest.Clear;
end;

function TMycAtomicStack<T>.Alloc: PItem;
begin
    // This is an instance method, FSList is accessed directly (implicitly Self.FSList)
    GetMemAligned(Pointer(Result), SizeOf(TItem));
    FillChar(Result^, SizeOf(TItem), 0);
    Result.Data := Default(T);
end;

procedure TMycAtomicStack<T>.Clear;
var
    item: PItem;
begin
    // Use Dest to access fields and call instance methods
    // on the record instance being finalized
    item := PopPtr; // Call instance method PopPtr via Dest
    while item <> nil do
    begin
        item.Data := Default(T);
        FreeMemAligned(item); // Global procedure
        item := PopPtr;  // Call instance method PopPtr via Dest
    end;
    if FSList <> nil then // Check if FSList was initialized
    begin
        FSList.Free; // Call instance method Free on FSList via Dest
    end;
end;

function TMycAtomicStack<T>.Pop: T;
begin
    // Instance method
    if not TryPop(Result) then
    begin
        Result := Default(T);
    end;
end;

function TMycAtomicStack<T>.PopPtr: PItem;
begin
    // Instance method, FSList is Self.FSList
    Result := PItem(FSList.Pop);
end;

procedure TMycAtomicStack<T>.Push(const Data: T);
var
    item: PItem;
begin
    // Instance method
    item := Alloc; // Calls Self.Alloc
    item.Data := Data;
    PushPtr(item); // Calls Self.PushPtr
end;

procedure TMycAtomicStack<T>.PushPtr(Item: PItem);
begin
    // Instance method, FSList is Self.FSList
    FSList.Push(PSListEntry(Item));
end;

function TMycAtomicStack<T>.TryPop(out Item: T): Boolean;
var
    currentPItem: PItem;
begin
    // Instance method
    currentPItem := PopPtr; // Calls Self.PopPtr
    Result := currentPItem <> nil;
    if Result then
    begin
        Item := currentPItem.Data;
        currentPItem.Data := Default(T);
        FreeMemAligned(currentPItem);
    end
    else
    begin
        Item := Default(T);
    end;
end;

end.