unit Myc.Core.Notifier;

interface

uses
    System.SysUtils,
    System.SyncObjs;

type
    // A thread-safe, low-level list for managing multicast event sinks of type IInterface.
    // It uses a doubly linked list and a spinlock for synchronization.
    // `Advise` registers a sink and returns a tag for constant-time removal via `Unadvise`.
    TMycNotifyList<T: IInterface> = record
        type
            // Opaque tag used to identify a registered receiver for unsubscription.
            TTag = Pointer;

            // Pointer to an internal list item.
            PItem = ^TItem;
            // Internal structure for storing a receiver and list linkage.
            TItem = record
            private
                FNext: PItem;
                FPrev: PItem;
                function GetNext: PItem; inline;
            public

                Receiver: T; // The registered interface instance (the event sink).
                property Next: PItem read GetNext;
                property Prev: PItem read FPrev;
            end;

            // Notify function. If this results false, it will be removed from the notify list
            TNotifyProc = reference to function(const Obj: T): Boolean;

    strict private
        // Head of the linked list. The pointer value itself is repurposed for a spinlock.
        // Bit 0 of the address stores the lock state (0 = locked, 1 = unlocked).
        [volatile]
        FList: PItem;
        class var
            FReverseOnNotify: Boolean;
        class constructor CreateClass;

        // Allocates memory for a new TItem.
        class function AllocItem: PItem; static; inline;
        // Frees memory previously allocated for a TItem.
        class procedure FreeItem(Item: PItem); static; inline;

    private
        function GetFirst: PItem;

    public
        // Initializes the list in an unlocked state.
        class operator Initialize(out Dest: TMycNotifyList<T>);
        // Safely clears all registered receivers and cleans up resources.
        procedure Finalize;
        // Registers a receiver interface and returns an opaque tag for later unsubscription.
        function Advise(const Receiver: T): TTag;
        // Unregisters a single receiver using its subscription tag.
        procedure Unadvise(Tag: TTag);
        // Unregisters all currently advised receivers.
        procedure UnadviseAll;
        // Acquires an exclusive lock for thread-safe operations on the list.
        procedure Lock; inline;
        // Releases the previously acquired exclusive lock.
        procedure Release; inline;
        // Checks if the list is currently locked by any thread.
        function IsLocked: Boolean; inline;
        // Invokes a predicate for each registered receiver.
        // If the predicate returns false, the receiver is detached from further notifications
        // by setting its interface reference to nil. The list item itself is not freed here.
        procedure Notify(const Func: TNotifyProc);
        property First: PItem read GetFirst;

        // If this is true, the list is reversed after each Notify, hoping for a better distrubution of events.
        class property ReverseOnNotify: Boolean read FReverseOnNotify write FReverseOnNotify;
    end;

implementation

class constructor TMycNotifyList<T>.CreateClass;
begin
    FReverseOnNotify := true;
end;

class operator TMycNotifyList<T>.Initialize(out Dest: TMycNotifyList<T>);
begin
    NativeUInt(Dest.FList) := 1;
end;

procedure TMycNotifyList<T>.Finalize;
begin
    Lock;
    UnadviseAll;
end;

function TMycNotifyList<T>.Advise(const Receiver: T): TTag;
var
    Item: PItem;
begin
    Assert(IsLocked);

    if not Assigned(Receiver) then
        exit(nil);

    Item := AllocItem;
    Item.Receiver := Receiver;
    Item.FPrev := nil;
    Item.FNext := FList;
    if Item.FNext <> nil then
        Item.FNext.FPrev := Item;

    FList := Item;

    exit(Item);
end;

procedure TMycNotifyList<T>.Lock;
begin
    while not TInterlocked.BitTestAndClear(NativeUint(FList), 0) do
        YieldProcessor;

    Assert(IsLocked, 'Locking failed');
end;

class function TMycNotifyList<T>.AllocItem: PItem;
begin
    Result := AllocMem(sizeof(TItem));
end;

class procedure TMycNotifyList<T>.FreeItem(Item: PItem);
begin
    FreeMem(Item, sizeof(TItem));
end;

function TMycNotifyList<T>.GetFirst: PItem;
begin
    Assert(IsLocked);
    Result := FList;
end;

function TMycNotifyList<T>.IsLocked: Boolean;
begin
    Result := NativeUInt(FList) and 1 = 0;
end;

procedure TMycNotifyList<T>.Notify(const Func: TNotifyProc);
var
    Item: PItem;
begin
    Assert(IsLocked);

    // Invariant: Append all detached items at end of the list. We can't simply free them, because the subscription is owned by the client.

    if FReverseOnNotify then
    begin
        // Method: stack assigned items and rebuild the list from the stack (reversing the order)

        var stack: PItem := nil;
        var released: PItem := nil;

        while (FList <> nil) and Assigned(FList.Receiver) do
        begin
            Item := FList;
            FList := Item.FNext;

            if Func(Item.Receiver) then
            begin
                // item stays valid
                Item.FNext := stack;
                stack := Item;
            end
            else
            begin
                // release the receiver
                Item.Receiver := nil;

                Item.FNext := released;
                released := Item;
            end;
        end;

        // The list now only contains old released items. Push the newly released ones.
        while released <> nil do
        begin
            Item := released;
            released := Item.FNext;

            Item.FPrev := nil;
            Item.FNext := FList;
            FList := Item;
            if Item.FNext <> nil then
                Item.FNext.FPrev := Item;
        end;

        // Now push the valid items, so that they are at the beginning of the list.
        while stack <> nil do
        begin
            Item := stack;
            stack := Item.FNext;

            Item.FPrev := nil;
            Item.FNext := FList;
            FList := Item;
            if Item.FNext <> nil then
                Item.FNext.FPrev := Item;
        end;
    end
    else
    begin
        // Method: filter released items and add then to the end of the list

        var released: PItem := nil;
        var lastValid: PItem := nil;

        Item := FList;
        while (Item <> nil) and Assigned(Item.Receiver) do
        begin
            if not Func(Item.Receiver) then
            begin
                // item is now invalid
                if Item = FList then
                    FList := Item.FNext;

                if Item.FPrev <> nil then
                    Item.FPrev.FNext := Item.FNext;
                if Item.FNext <> nil then
                    Item.FNext.FPrev := Item.FPrev;

                // release the receiver
                Item.Receiver := nil;

                // and save the list item in a tmp list for later use
                var nxt := Item.FNext;
                Item.FNext := released;
                released := Item;
                Item := nxt;
            end
            else
            begin
                // save a pointer to the last valid item
                lastValid := Item;
                Item := lastValid.FNext;
            end;
        end;

        // insert all new released items after the last valid item
        while released <> nil do
        begin
            Item := released;
            released := Item.FNext;

            if lastValid = nil then
            begin
                Item.FPrev := nil;
                Item.FNext := FList;
                FList := Item;
            end
            else
            begin
                Item.FPrev := lastValid;
                Item.FNext := lastValid.Next;
                if Item.FPrev <> nil then
                    Item.FPrev.FNext := Item;
            end;
            if Item.FNext <> nil then
                Item.FNext.FPrev := Item;
        end;
    end;
end;

procedure TMycNotifyList<T>.Release;
begin
    Assert(IsLocked);
    TInterlocked.BitTestAndSet(NativeUint(FList), 0);
end;

procedure TMycNotifyList<T>.Unadvise(Tag: TTag);
var
    Item: PItem;
begin
    Assert(IsLocked);

    if (Tag = nil) or (FList = nil) then
        exit;

{$ifdef DEBUG}
    Item := FList;
    while Item <> nil do
    begin
        if Item = Tag then
            break;
        Item := Item.Next;
    end;
    Assert(Item <> nil, 'Receiver not advised');
{$endif}

    if FList = nil then
        exit;

    Item := PItem(Tag);
    Item.Receiver := nil;

    if Item = FList then
        FList := Item.FNext;

    if Item.FPrev <> nil then
        Item.FPrev.FNext := Item.FNext;
    if Item.FNext <> nil then
        Item.FNext.FPrev := Item.FPrev;

    FreeItem(Item);
end;

procedure TMycNotifyList<T>.UnadviseAll;
begin
    Assert(IsLocked);
    while FList <> nil do
        Unadvise(TTag(FList));
end;

function TMycNotifyList<T>.TItem.GetNext: PItem;
begin
    if not Assigned(Receiver) then
        exit(nil);
    Result := FNext;
end;

end.