Старые призраки

// LazyGhost — синглтон, создаваемый при первом обращении и уничтожаемый с задержкой, когда в нём пропадает необходимость.
//
// Например:
// — DLL, удерживаемая в памяти, пока существует хотя бы один работающий с ней объект,
//   и затем висящая ещё 1 минуту на случай, если снова кому-то понадобится.
//
// type
//     LuaScriptState = record
//         state: lua_State;
//         lib: LuaLibAnchor;
//
//         procedure Init;
//         begin
//             LuaLibGhost.Summon(lib);
//             ...
//         end;
//     end;
//
// — Вычисляемые лукап-таблицы, такие как в CRC-алгоритмах.
//
//     function CRC32(data: pointer; size: SizeUint): uint32;
//     var
//         table: CRC32TableAnchor;
//     begin
//         CRC32TableGhost.Summon(table);
//         ...
//     end;
//
// Была неоднозначная багофича с рекурсивными призраками.
// Например, плагины BASS требуют, и удерживают призрак, самой BASS.
// Поэтому если отпустить плагин, то сначала запускался таймер самоуничтожения плагина, по истечении которого плагин выгружался,
// в ходе выгрузки отпускал BASS, и только тогда запускался таймер самоуничтожения BASS.
// Если тот и другая имели таймер выгрузки 30 секунд, то BASS в результате выгружалась через 30+30 вместо ожидаемых 30.
//
// Это не сильно критично, но всё равно неприятно.
// Чтобы этого избежать, теперь запоминается lastTouch — время последнего Summon'а или НЕРЕКУРСИВНОГО Unsummon'а,
// и при рекурсивном Unsummon — UnsummonRecursive, таймер уменьшается на время, прошедшее с lastTouch.
//
// UnsummonRecursive нужно вызывать явно вместо обычного Unsummon, вызываемого автоматически. Например, призраки плагинов вызывают его в деструкторах.
// Если этого не сделать, потенциально будет получено старое поведение с полным сложением таймеров самоуничтожения.
//
// TODO:
// Возникают проблемы с финализацией глобальных переменных, приходится вручную следить за pending'ами. Пока полностью забил.
// Как минимум можно придумать что-то с флагом «УМРИ», с которым работа Finalize будет отложена до освобождения последней ссылки.
// В идеале можно попробовать извернуться и переписать всё на Reference'ы.
// Насчёт обоих вариантов не уверен, что они вообще возможны.
//
// TODO2:
// К тому же явно инициализируемые глобальные переменные не дают линкеру выбросить неиспользуемых призраков. Всё-таки желательно всё переделать.

{$include opts.inc}
unit Framework.LazyGhosts;

{$include non_copyable.inc} {$include logging.inc}

interface

uses
    Framework.Chrono, Framework.Threads, Framework.Exceptions, Framework.Intrinsics, Framework.Strings;

type
    pLazyGhost = ^LazyGhost;
    LazyGhost = record
    type
        InstanceBase = class
            class function NameFancySrc: Noun;
        protected
            constructor CreateGhost; virtual; abstract;
            class function Timeout: umsec; virtual;
        end;
        InstanceClass = class of InstanceBase;

        Anchor = record
            procedure SetMove(var anch: Anchor);
            procedure UnsummonRecursive;
        private
            g: pLazyGhost;
            class operator Initialize(var self: Anchor);
            class operator Finalize(var self: Anchor);
            {$define typ := Anchor} non_copyable
        end;

        procedure Init(ctl: InstanceClass);
        function OK: boolean;
        function Summon(out anch: Anchor): InstanceBase;

    const
        SmallTimeout = umsec(5 * 1000);
        QuiteATimeout = umsec(36 * 1000);

    private const
        CREATION_FAILED = pointer(1);
        LAST_FAKE_INSTANCE = CREATION_FAILED;
        NotInitialized = 'LazyGhost не инициализирован.';
        MinTimeout = umsec(100);
    var
        instance, destroyingInstance: InstanceBase;
        refcount: SizeInt;
        ctl: InstanceClass;
        delayedDestroy: ThreadTimer;
        err: TObject;
        lastTouch: Ticks;
        procedure Unsummon;
        procedure UnsummonRecursive;
        procedure HandleZeroRefCount(recursive: boolean);
        class procedure TimerCallback(param: pointer; var ci: ThreadTimer.CallbackInstance); static;
        class operator Initialize(var self: LazyGhost);
        class operator Finalize(var self: LazyGhost);
        {$define typ := LazyGhost} non_copyable

    public
        class procedure GlobalInitialize; static;

    private class var
        GlobalInitialized: boolean;
        GlobalLock: ThreadLock;
        GlobalHey: ThreadCV;
    end;

implementation

uses
    Framework.System;

    class function LazyGhost.InstanceBase.NameFancySrc: Noun;
    var
        s: StringView;
    begin
        s := ViewClassName(ClassType).CutSuffix('Ghost').CutSuffix('.');
        result := Noun.Parse(s.ToString);
    end;

    class function LazyGhost.InstanceBase.Timeout: umsec;
    begin
        result := {$ifdef Debug} SmallTimeout {$else} QuiteATimeout {$endif};
    end;

    procedure LazyGhost.Anchor.SetMove(var anch: Anchor);
    begin
        if Assigned(g) then g^.Unsummon;
        g := anch.g;
        anch.g := nil;
    end;

    procedure LazyGhost.Anchor.UnsummonRecursive;
    var
        t: pLazyGhost;
    begin
        t := Exchange(self.g, nil);
        if Assigned(t) then t^.UnsummonRecursive;
    end;

    class operator LazyGhost.Anchor.Initialize(var self: Anchor);
    begin
        self.g := nil;
    end;

    class operator LazyGhost.Anchor.Finalize(var self: Anchor);
    var
        t: pLazyGhost;
    begin
        t := Exchange(self.g, nil);
        if Assigned(t) then t^.Unsummon;
    end;
{$define typ := LazyGhost.Anchor} non_copyable_impl

    procedure LazyGhost.Init(ctl: InstanceClass);
    begin
        Assert(Assigned(ctl), 'не задан LazyGhost.InstanceClass');
        Assert(GlobalInitialized, 'LazyGhost.Initialize не выполнена');
        if Assigned(self.ctl) then
            ThrowOpenedOver('LazyGhost', FancyString.Parse(ctl.NameFancySrc.ToNom).ToString, FancyString.Parse(self.ctl.NameFancySrc.ToGen).ToString);
        self.ctl := ctl;
    end;

    function LazyGhost.OK: boolean;
    begin
        result := Assigned(ctl);
    end;

    function LazyGhost.Summon(out anch: Anchor): InstanceBase;
    const
        InstanceExpectedToBeNil = 'кто-то помимо первого призванного изменил instance = nil';
    var
        terr: TObject;
        r: SizeInt;
    begin
        Assert(Assigned(ctl), NotInitialized);
        if InterlockedIncrement(refcount) = 1 then
        begin
            // Первый саммон.
            // Либо инстанса вообще не существует, и нужно создать новый, либо взведён таймер уничтожения, и нужно попытаться вырвать старый инстанс из его лап.
            // В любом случае instance = nil, и, видя это, остальные потоки (которые пойдут по ветке refcount > 1) будут ждать, пока этот что-то придумает.
            //
            // Если создание инстанса провалилось, инстанс выставляется в CREATION_FAILED и (возможно) запоминается исключение в err, так что все ждущие
            // смогут его скопировать и перевыбросить. Последний ждущий в этом случае очищает инстанс назад в nil и уничтожает err
            // (вернее, утаскивает err себе и перевыбрасывает без копирования).
            //
            // Можно кэшировать ошибку на несколько секунд (или на тот же timeout — более безумный вариант), но это спорная практика.
            // Сделаю, если сильно понадобится.
            //
            // Всюду делается вид, что Enter и Wake не могут бросить исключение.

            GlobalLock.Enter;
            try
                lastTouch := Ticks.Get;

                // Нужна перепроверка на Assigned(instance) на случай, если перед этим InterlockedIncrement'ом начинал исполняться Unsummon,
                // но после него заметил, что refcount > 0, и отменился, оставив инстанс в живых.
                result := instance;
                if Assigned(result) then
                begin
                    Assert(pointer(result) > LAST_FAKE_INSTANCE, '{}: странный инстанс при refcount=1'.Format(instance.ToString));
                    anch.g := @self;
                    exit;
                end;

                // отобрать destroyingInstance у таймера уничтожения, если он взведён, так что если он начал срабатывать, то сработает вхолостую.
                // Если таймер не взведён, destroyingInstance = result = nil.
                pointer(result) := Exchange(pointer(destroyingInstance), nil);
            finally
                GlobalLock.Leave;
            end;

            try
                // Отпускание блокировки в любом случае не было избыточным:
                //
                // — (1) если таймера не существовало, в том числе если он успел сработать, уничтожил инстанс и уничтожился сам,
                //       то нужно отпустить блокировку, чтобы создать инстанс с нуля.
                //
                // — (2) если таймер начал срабатывать, то Close будет ждать завершения обработчика таймера, поэтому под блокировкой дедлокнется.
                //
                //       (Если таймер взведён, но ещё НЕ начал срабатывать, то Close отменит его без ожидания и блокировку отпускать было необязательно.
                //       Но отличить этот случай без гонки невозможно).

                if Assigned(result) then
                begin
                    delayedDestroy.Close; // реальная работа в случае (2)
                end else
                begin
                    result := ctl.CreateGhost; // реальная работа в случае (1)
                    Assert(pointer(result) > LAST_FAKE_INSTANCE);
                end;
            except
                GlobalLock.Enter;
                try
                    r := InterlockedDecrement(refcount);
                    Assert(not Assigned(instance), InstanceExpectedToBeNil);
                    if r > 0 then
                    begin
                        pointer(instance) := CREATION_FAILED;
                        err := Exception.Acquire;
                        GlobalHey.WakeAll;
                    end else
                        ; // Нет ждущих, просто оставляется instance = nil. Для кэширования ошибки вместо этого нужно было бы выставлять таймер, как в Unsummon.
                finally
                    GlobalLock.Leave;
                end;
                raise;
            end;

            GlobalLock.Enter;
            try
                Assert(not Assigned(instance), InstanceExpectedToBeNil);
                instance := result;
                GlobalHey.WakeAll;
            finally
                GlobalLock.Leave;
            end;

            anch.g := @self;
        end else
        begin
            lastTouch := Ticks.Get;

            result := instance;
            if pointer(result) > LAST_FAKE_INSTANCE then
            begin
                anch.g := @self;
                exit;
            end;

            GlobalLock.Enter;
            try
                repeat
                    result := instance;
                    if Assigned(result) then break;
                    GlobalHey.Wait(GlobalLock);
                until no;

                if pointer(result) > LAST_FAKE_INSTANCE then
                begin
                    anch.g := @self;
                    exit;
                end;

                Assert(pointer(result) = CREATION_FAILED, result.ToString + ' — инстанс после ожидания');
                if InterlockedDecrement(refcount) = 0 then
                begin
                    instance := nil;
                    pointer(terr) := Exchange(pointer(err), nil);
                end
                else if Assigned(err) then
                    terr := Exception.Clone(err)
                else
                    terr := nil;
                if not Assigned(terr) then terr := Error('Создание инстанса провалилось.');
                raise terr;
            finally
                GlobalLock.Leave;
            end;
        end;
    end;

    procedure LazyGhost.Unsummon;
    begin
        if InterlockedDecrement(refcount) = 0 then HandleZeroRefCount(no) else lastTouch := Ticks.Get;
    end;

    procedure LazyGhost.UnsummonRecursive;
    begin
        if InterlockedDecrement(refcount) = 0 then HandleZeroRefCount(yes);
    end;

    procedure LazyGhost.HandleZeroRefCount(recursive: boolean);
        procedure TraceInstantUnload(recursive: boolean);
        begin
            log.Trace('Немедленная выгрузка {M}{}.', IfThen(recursive, ' (рекурсивно)'), {M} FancyString.Parse(ctl.NameFancySrc.ToGen));
        end;
    var
        t: InstanceBase;
        timeout: umsec;
    begin
        // По-хорошему не должно происходить никогда, но с зависимыми призраками, такими как BASS и плагины, возможно при завершении приложения
        // из-за неопределённого порядка финализации.
        if not Assigned(ctl) then exit;

        t := nil;
        GlobalLock.Enter;
        try
            // Здесь нужна перепроверка на refcount = 0, потому что после InterlockedDecrement'а и перед захватом блокировки мог исполниться Summon.
            if (refcount = 0) and (pointer(instance) > LAST_FAKE_INSTANCE) then
            begin
                Assert(not Assigned(destroyingInstance), 'destroyingInstance и instance существуют одновременно');
                timeout := ctl.timeout;
                if recursive then timeout := umsecBaseType(timeout).SatSub((Ticks.Get - lastTouch).ToUmsecClamp);
                if timeout < MinTimeout then
                begin
                    if log.NeedTrace then TraceInstantUnload(recursive);
                    pointer(t) := Exchange(pointer(instance), nil);
                end else
                begin
                    pointer(destroyingInstance) := Exchange(pointer(instance), nil);
                    try
                        delayedDestroy.Start(@TimerCallback, @self, timeout, 0, ctl.NameFancySrc, [ThreadTimer.NonCritical]);
                    except
                        pointer(t) := Exchange(pointer(destroyingInstance), nil);
                        raise;
                    end;
                end;
            end;
        finally
            GlobalLock.Leave;
            if Assigned(t) then t.Destroy;
        end;
    end;

    class procedure LazyGhost.TimerCallback(param: pointer; var ci: ThreadTimer.CallbackInstance);
    var
        g: pLazyGhost absolute param;
        t: InstanceBase;
    begin
        GlobalLock.Enter;
        try
            t := g^.destroyingInstance;
            if Assigned(t) then
            begin
                g^.destroyingInstance := nil;
                GlobalLock.Leave;
                try
                    t.Destroy;
                finally
                    GlobalLock.Enter;
                end;
            end;
            ci.Close;
        finally
            GlobalLock.Leave;
        end;
    end;

    class operator LazyGhost.Initialize(var self: LazyGhost);
    begin
        self.instance := nil;
        self.destroyingInstance := nil;
        self.refcount := 0;
        self.ctl := nil;
        self.err := nil;
    end;

    class operator LazyGhost.Finalize(var self: LazyGhost);
    begin
        self.delayedDestroy.Close;
        if Assigned(self.destroyingInstance) then self.destroyingInstance.Free(self.destroyingInstance);
        if pointer(self.instance) > LAST_FAKE_INSTANCE then self.instance.Free(self.instance);
        self.ctl := nil;
    end;
{$define typ := LazyGhost} non_copyable_impl

    class procedure LazyGhost.GlobalInitialize;
    begin
        Assert(not GlobalInitialized, 'LazyGhost.Initialize уже выполнена.');
        GlobalLock.Init;
        GlobalHey.Init;
        GlobalInitialized := yes;
    end;

end.