////////////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////////////// /// /// Mycelium Framework /// ------------------ /// /// (c)2007-2019 Michael Schimmel /// Ehrenhainstraße 40 /// 42329 Wuppertal / Germany /// info@mycelium.net /// /// All rights reserved. /// ////////////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////////////// unit Myc.Signals; interface uses System.SysUtils, System.SyncObjs, Myc.Atomic; {.$define DEBUG_SIGNALS} type IMyc2Sink = interface function Notify: Boolean; end; IMyc2Flag = interface( IMyc2Sink ) function Reset: Boolean; end; {$message hint 'Replace TSignalTag by IMycDeletable? '} TSignalTag = NativeInt; IMyc2Signal = interface function Advise( const Sink: IMyc2Sink ): TSignalTag; procedure Unadvise( Tag: TSignalTag ); end; IMyc2Notifier = interface( IMyc2Sink ) {$region 'property access'} function GetSignal: IMyc2Signal; {$endregion} property Signal: IMyc2Signal read GetSignal; end; IMyc2State = interface( IMyc2Signal ) {$region 'property access'} function GetIsSet: Boolean; {$endregion} property IsSet: Boolean read GetIsSet; end; IMyc2Condition = interface( IMyc2Sink ) {$region 'property access'} function GetState: IMyc2State; {$endregion} property State: IMyc2State read GetState; end; IMyc2Event = interface( IMyc2Condition ) function Reset: Boolean; end; TMycSinkList = record type PItem = ^TItem; TItem = record Next, Prev: PItem; Sink: IMyc2Sink; end; strict private FFirst: NativeUInt; FList: PItem; {$ifdef DEBUG_SIGNALS} FCount: Integer; {$endif} class var [volatile] FItems: TMycAtomicStack; [volatile] FPendingCnt: Int64; [volatile] FUsedCnt: Int64; class constructor CreateClass; class destructor DestroyClass; class function AllocItem: PItem; static; inline; class procedure FreeItem( Item: PItem ); static; inline; public procedure Create; procedure Destroy; function Advise( const Sink: IMyc2Sink ): TSignalTag; procedure Unadvise( Tag: TSignalTag ); procedure UnadviseAll; procedure Finalize; procedure Lock; inline; procedure Release; inline; function IsLocked: Boolean; inline; function IsFinalized: Boolean; inline; procedure Notify; end; TMyc2Signal = class( TInterfacedObject, IMyc2Signal, IMyc2State, IMyc2Sink ) private FList: TMycSinkList; class var FNull: IMyc2Condition; protected class constructor CreateClass; class destructor DestroyClass; function GetIsSet: Boolean; virtual; function DoNotify: Boolean; virtual; public constructor Create; destructor Destroy; override; function Advise( const Sink: IMyc2Sink ): TSignalTag; procedure Unadvise( Tag: TSignalTag ); function Notify: Boolean; class function CreateAdvised( Count: Integer; const Getter: TFunc ): IMyc2Signal; overload; class function IsStatic( const Signal: IMyc2Signal ): Boolean; overload; inline; class function IsStatic( const Sink: IMyc2Sink ): Boolean; overload; inline; class function MakeValid( const Signal: IMyc2Signal ): IMyc2Signal; overload; static; inline; class function MakeValid( const Signals: array of IMyc2Signal ): TArray; overload; static; class function CreateCounter( Count: Integer ): IMyc2Condition; static; inline; class function CreateEvent( Init: Boolean ): IMyc2Event; static; inline; class function CreateGroup( Count: Integer; const Getter: TFunc ): IMyc2Signal; overload; class function CreateNotifier: IMyc2Notifier; static; inline; class function CreateUnion( const Sigs: array of IMyc2Signal ): IMyc2Signal; static; class function CreateConcat( const States: array of IMyc2State ): IMyc2State; static; property IsSet: Boolean read GetIsSet; class property Null: IMyc2Condition read FNull; end; TMyc2Notifier = class( TMyc2Signal, IMyc2Notifier ) protected function GetSignal: IMyc2Signal; end; TMyc2Condition = class( TMyc2Signal, IMyc2Condition ) protected function GetState: IMyc2State; end; TMyc2Event = class( TMyc2Condition, IMyc2Event ) private [volatile] FValue: Integer; protected function DoNotify: Boolean; override; function GetIsSet: Boolean; override; public constructor Create( AInit: Boolean ); function Reset: Boolean; virtual; property IsSet: Boolean read GetIsSet; end; TMyc2CountSignal = class sealed( TMyc2Condition ) private [volatile] FCount: Integer; protected function GetIsSet: Boolean; override; function DoNotify: Boolean; override; public constructor Create( ACount: Integer ); end; TMyc2SinkProc = class sealed( TInterfacedObject, IMyc2Sink ) private FOnce: Boolean; FProc: TProc; function Notify: Boolean; public constructor Create( AOnce: Boolean; const AProc: TProc ); class function CreateSink( Once: Boolean; const Proc: TProc ): IMyc2Sink; static; end; TMyc2NullState = class sealed( TInterfacedObject, IMyc2Signal, IMyc2State ) protected function Advise( const Sink: IMyc2Sink ): TSignalTag; function GetIsSet: Boolean; procedure Unadvise( Tag: TSignalTag ); procedure UnadviseAll; end; TMyc2NullSink = class sealed( TInterfacedObject, IMyc2Sink, IMyc2Condition ) private FState: IMyc2State; function GetState: IMyc2State; protected function Notify: Boolean; public constructor Create; destructor Destroy; override; end; TMyc2Flag = class( TInterfacedObject, IMyc2Sink, IMyc2Flag ) private FFlag: Integer; function Notify: Boolean; function Reset: Boolean; public constructor Create( AFlag: Boolean ); end; TMycObserver = class type TNull = class( TInterfacedObject, IMycObserver ) private FSink: T; function GetItem: T; public constructor Create( const ASink: T ); end; TOne = class( TNull ) private FSignal: IMyc2Signal; FTag: TSignalTag; public constructor Create( const ASignal: IMyc2Signal; const ASink: T ); destructor Destroy; override; end; TArr = class( TNull ) private FSignals: TArray; FTags: TArray; public constructor Create( const ASignals: TArray; const ASink: T ); destructor Destroy; override; end; public class function CreateObserver( const Signals: array of IMyc2Signal; const Item: T ): IMycObserver; static; end; TMycSignalUnion = class( TInterfacedObject, IMyc2Signal ) private FNotifier: IMyc2Notifier; FSignals: TArray; FTags: TArray; function Advise( const Sink: IMyc2Sink ): TSignalTag; procedure Unadvise( Tag: TSignalTag ); public constructor Create( const ASignals: array of IMyc2Signal ); destructor Destroy; override; end; implementation { TMyc2Signal } constructor TMyc2Signal.Create; begin inherited Create; FList.Create; end; destructor TMyc2Signal.Destroy; begin FList.Destroy; inherited Destroy; end; class function TMyc2Signal.CreateAdvised( Count: Integer; const Getter: TFunc ): IMyc2Signal; var i, j: Integer; Sig: IMyc2Signal; Res: IMyc2Condition; begin for i := 0 to Count - 1 do begin Sig := Getter( i ); if not IsStatic( Sig ) then begin Res := TMyc2Condition.Create; Sig.Advise( Res ); for j := i + 1 to Count - 1 do begin Sig := Getter( j ); if not IsStatic( Sig ) then Sig.Advise( Res ); end; exit( Res.State ); end; end; exit( Null.State ); end; class constructor TMyc2Signal.CreateClass; begin FNull := TMyc2NullSink.Create; end; class destructor TMyc2Signal.DestroyClass; begin FNull := nil; end; class function TMyc2Signal.IsStatic( const Signal: IMyc2Signal ): Boolean; begin Result := ( Signal = nil ) or ( Signal = FNull.State ); end; class function TMyc2Signal.MakeValid( const Signal: IMyc2Signal ): IMyc2Signal; begin Result := Signal; if Result = nil then Result := Null.State; end; function TMyc2Signal.Advise( const Sink: IMyc2Sink ): TSignalTag; begin if IsStatic( Sink ) then exit( 0 ); FList.Lock; try Result := FList.Advise( Sink ); if IsSet then Sink.Notify; finally FList.Release; end; end; class function TMyc2Signal.CreateConcat( const States: array of IMyc2State ): IMyc2State; function CreatePair( const A, B: IMyc2State ): IMyc2State; var Counter: IMyc2Condition; begin if A=B then begin Result := A; end else if IsStatic( A ) then begin if IsStatic( B ) then Result := Signals.Null.State else Result := B; end else if IsStatic( B ) then begin Result := A; end else begin Counter := CreateCounter( 2 ); A.Advise( Counter ); B.Advise( Counter ); Result := Counter.State; end; end; function CreateSet( const States: array of IMyc2State ): IMyc2State; var Counter: IMyc2Condition; i, n: Integer; begin n := 0; for i := 0 to High( States ) do if not IsStatic( States[i] ) then inc( n ); Counter := CreateCounter( n ); for i := 0 to High( States ) do if not IsStatic( States[i] ) then States[i].Advise( Counter ); Result := Counter.State; end; begin {TODO -oMS: Potentielles Speicherloch. Im Gegensatz zur Union werden hier die States nicht explizit un-advised. Andererseits kann man eigentlich davon ausgehen, das States im Gegensatz zu einfachen Notifications irgendwann gesetzt und dann aufgeräumt werden. Im Auge behalten! } case Length( States ) of 0: Result := Signals.Null.State; 1: Result := States[0]; 2: Result := CreatePair( States[0], States[1] ); else Result := CreateSet( States ); end; end; class function TMyc2Signal.CreateCounter( Count: Integer ): IMyc2Condition; begin Assert( Count >=0 ); if Count > 0 then Result := TMyc2CountSignal.Create( Count ) else Result := Null; end; class function TMyc2Signal.CreateEvent( Init: Boolean ): IMyc2Event; begin Result := TMyc2Event.Create( Init ) end; class function TMyc2Signal.CreateGroup( Count: Integer; const Getter: TFunc ): IMyc2Signal; var i, n: Integer; Sigs: TArray; Res: IMyc2Condition; begin if Count = 0 then exit( Null.State ); SetLength( Sigs, Count ); n := 0; for i := 0 to Count - 1 do begin Sigs[n] := Getter( i ); if not IsStatic( Sigs[n] ) then inc( n ); end; if n = 0 then exit( Null.State ); Res := CreateCounter( n ); for i := 0 to n - 1 do Sigs[i].Advise( Res ); exit( Res.State ); end; class function TMyc2Signal.CreateNotifier: IMyc2Notifier; begin Result := TMyc2Notifier.Create; end; class function TMyc2Signal.MakeValid( const Signals: array of IMyc2Signal ): TArray; var i, n: Integer; begin n := 0; for i := 0 to High( Signals ) do if not IsStatic( Signals[i] ) then inc( n ); SetLength( Result, n ); n := 0; for i := 0 to High( Signals ) do if not IsStatic( Signals[i] ) then begin Result[n] := Signals[i]; inc( n ); end; end; class function TMyc2Signal.CreateUnion( const Sigs: array of IMyc2Signal ): IMyc2Signal; begin case Length( Sigs ) of 0: Result := Signals.Null.State; 1: Result := Sigs[0]; else Result := TMycSignalUnion.Create( Sigs ); end; end; function TMyc2Signal.DoNotify: Boolean; begin FList.Notify; exit( true ); end; function TMyc2Signal.GetIsSet: Boolean; begin Result := true; end; class function TMyc2Signal.IsStatic( const Sink: IMyc2Sink ): Boolean; begin Result := ( Sink = nil ) or ( Sink = FNull ); end; function TMyc2Signal.Notify: Boolean; begin FList.Lock; try Result := DoNotify; if not Result then FList.Finalize; finally FList.Release; end; end; procedure TMyc2Signal.Unadvise( Tag: TSignalTag ); begin if Tag=0 then exit; FList.Lock; try FList.Unadvise( Tag ); finally FList.Release; end; end; { TMyc2Event } constructor TMyc2Event.Create( AInit: Boolean ); begin inherited Create; if AInit then inc( FValue ); end; function TMyc2Event.GetIsSet: Boolean; begin Result := FValue <> 0; end; function TMyc2Event.DoNotify: Boolean; begin if TInterlocked.Exchange( FValue, 1 ) = 0 then inherited; exit( true ); end; function TMyc2Event.Reset: Boolean; begin Result := TInterlocked.Exchange( FValue, 0 ) = 1; end; { TMyc2CountownSignal } constructor TMyc2CountSignal.Create( ACount: Integer ); begin inherited Create; FCount := ACount; end; function TMyc2CountSignal.GetIsSet: Boolean; begin Result := FCount <= 0; end; function TMyc2CountSignal.DoNotify: Boolean; var n: Integer; begin n := TInterlocked.Decrement( FCount ); if n < -MaxInt div 2 then TInterlocked.Increment( FCount ); if n = 0 then inherited; Result := n > 0; end; { TMyc2SinkProc } constructor TMyc2SinkProc.Create( AOnce: Boolean; const AProc: TProc ); begin inherited Create; FProc := AProc; FOnce := AOnce; end; class function TMyc2SinkProc.CreateSink( Once: Boolean; const Proc: TProc ): IMyc2Sink; begin if Assigned( Proc ) then Result := TMyc2SinkProc.Create( Once, Proc ) else Result := TMyc2Signal.Null; end; function TMyc2SinkProc.Notify: Boolean; begin if Assigned( FProc ) then begin FProc( ); if FOnce then FProc := nil; end; Result := Assigned( FProc ); end; { TMyc2NullState } function TMyc2NullState.Advise( const Sink: IMyc2Sink ): TSignalTag; begin Sink._AddRef; try Sink.Notify; finally Sink._Release; end; exit( 0 ); end; function TMyc2NullState.GetIsSet: Boolean; begin exit( true ); end; procedure TMyc2NullState.Unadvise( Tag: TSignalTag ); begin end; procedure TMyc2NullState.UnadviseAll; begin end; constructor TMyc2NullSink.Create; begin inherited Create; FState := TMyc2NullState.Create; end; destructor TMyc2NullSink.Destroy; begin inherited Destroy; end; function TMyc2NullSink.GetState: IMyc2State; begin Result := FState; end; function TMyc2NullSink.Notify: Boolean; begin Result := false; end; { TMyc2Notifier } function TMyc2Notifier.GetSignal: IMyc2Signal; begin Result := Self; end; { TMyc2Condition } function TMyc2Condition.GetState: IMyc2State; begin Result := Self; end; { TMycSinkList } class constructor TMycSinkList.CreateClass; begin FItems := TMycAtomicStack.Create; FPendingCnt := 0; FUsedCnt := 0; end; class destructor TMycSinkList.DestroyClass; begin Assert( FUsedCnt = 0 ); Assert( FPendingCnt = 0 ); FItems.Free; end; procedure TMycSinkList.Create; begin FFirst := 1; FList := nil; {$ifdef DEBUG_SIGNALS} FCount := 0; {$endif} end; procedure TMycSinkList.Destroy; begin // Because refcounting is thread-safe, this will always be entered once after all references // to Self are dropped. No locking needed! Assert( not IsLocked, 'Signal must not be locked!' ); FFirst := FFirst and not 3; UnadviseAll; end; function TMycSinkList.Advise( const Sink: IMyc2Sink ): TSignalTag; var Item: PItem; begin Assert( IsLocked, 'Signal has to be locked' ); if IsFinalized then exit( 0 ); {$ifdef DEBUG_SIGNALS} inc( FCount ); Assert( FCount < 40000 ); {$endif} if FFirst=0 then begin IMyc2Sink( FFirst ) := Sink; exit( TSignalTag( Sink ) ); end; Item := AllocItem; Item.Sink := Sink; Item.Prev := nil; Item.Next := FList; if Item.Next<>nil then Item.Next.Prev := Item; FList := Item; exit( TSignalTag( Item ) ); end; procedure TMycSinkList.Lock; begin repeat if FFirst and 1 = 0 then begin YieldProcessor; continue; end; until TInterlocked.BitTestAndClear( PInteger( @FFirst )^, 0 ); Assert( IsLocked, 'Locking failed' ); end; procedure TMycSinkList.Notify; var Item, P: PItem; begin Assert( IsLocked, 'Signal has to be locked' ); if IsFinalized then exit; if FFirst<>0 then if not IMyc2Sink( FFirst ).Notify then IMyc2Sink( FFirst ) := nil; Item := FList; while Item<>nil do begin P := Item.Next; if not Item.Sink.Notify then Unadvise( TSignalTag( Item ) ); Item := P; end; end; class function TMycSinkList.AllocItem: PItem; begin GetMem( Result, sizeof( TItem ) ); Pointer( Result.Sink ) := nil; end; procedure TMycSinkList.Finalize; begin Assert( IsLocked, 'Signal has to be locked' ); UnadviseAll; FFirst := FFirst or 2; end; class procedure TMycSinkList.FreeItem( Item: PItem ); begin FreeMem( Item, sizeof( TItem ) ); end; function TMycSinkList.IsLocked: Boolean; begin Result := FFirst and 1 = 0; end; function TMycSinkList.IsFinalized: Boolean; begin Result := FFirst and 2 <> 0; end; procedure TMycSinkList.Release; begin Assert( IsLocked, 'Signal not locked' ); TInterlocked.Exchange( Pointer( FFirst ), Pointer( FFirst or 1 ) ); end; procedure TMycSinkList.Unadvise( Tag: TSignalTag ); var Item: PItem; begin Assert( IsLocked, 'Signal not locked' ); if IsFinalized then exit; {$ifdef DEBUG_SIGNALS} dec( FCount ); {$endif} if Tag = FFirst then begin IMyc2Sink( FFirst ) := nil; exit; end; Item := PItem( Tag ); if Item = FList then FList := Item.Next; if Item.Prev<>nil then Item.Prev.Next := Item.Next; if Item.Next<>nil then Item.Next.Prev := Item.Prev; Item.Sink := nil; FreeItem( Item ); end; procedure TMycSinkList.UnadviseAll; begin Assert( IsLocked, 'Signal has to be locked' ); if IsFinalized then exit; IMyc2Sink( FFirst ) := nil; while FList<>nil do Unadvise( TSignalTag( FList ) ); end; { TMycObserver } class function TMycObserver.CreateObserver( const Signals: array of IMyc2Signal; const Item: T ): IMycObserver; var Arr: TArray; begin {$message hint 'Design-Fehler!! Der Null-Observer ist nicht statisch!!'} if Length( Signals ) = 0 then Result := TNull.Create( Item ) else if ( Length( Signals )=1 ) and not TMyc2Signal.IsStatic( Signals[0] ) then Result := TOne.Create( Signals[0], Item ) else begin Arr := TMyc2Signal.MakeValid( Signals ); if Arr = nil then Result := TNull.Create( Item ) else if Length( Arr )=1 then Result := TOne.Create( Arr[0], Item ) else Result := TArr.Create( Arr, Item ); end; end; { TMycObserver.TNull } constructor TMycObserver.TNull.Create( const ASink: T ); begin inherited Create; FSink := ASink; end; function TMycObserver.TNull.GetItem: T; begin Result := FSink; end; { TMycObserver.TOne } constructor TMycObserver.TOne.Create( const ASignal: IMyc2Signal; const ASink: T ); begin inherited Create( ASink ); FSignal := ASignal; FTag := FSignal.Advise( FSink ); end; destructor TMycObserver.TOne.Destroy; begin FSignal.Unadvise( FTag ); inherited; end; { TMycObserver.TArr } constructor TMycObserver.TArr.Create( const ASignals: TArray; const ASink: T ); var i: Integer; begin inherited Create( ASink ); FSignals := ASignals; SetLength( FTags, Length( FSignals ) ); for i := 0 to High( FTags ) do begin if not Signals.IsStatic( FSignals[i] ) then FTags[i] := FSignals[i].Advise( FSink ) else FTags[i] := 0; end; end; destructor TMycObserver.TArr.Destroy; var i: Integer; begin for i := High( FSignals ) downto 0 do if FTags[i]<>0 then FSignals[i].Unadvise( FTags[i] ); inherited; end; { TMycSignalUnion } constructor TMycSignalUnion.Create( const ASignals: array of IMyc2Signal ); var i: Integer; begin inherited Create; FNotifier := Signals.CreateNotifier; SetLength( FTags, Length( ASignals ) ); SetLength( FSignals, Length( ASignals ) ); for i := 0 to High( FSignals ) do begin FSignals[i] := ASignals[i]; FTags[i] := FSignals[i].Advise( FNotifier ); end; end; destructor TMycSignalUnion.Destroy; var i: Integer; begin for i := High( FTags ) downto 0 do FSignals[i].Unadvise( FTags[i] ); inherited; end; function TMycSignalUnion.Advise( const Sink: IMyc2Sink ): TSignalTag; begin Result := FNotifier.Signal.Advise( Sink ); end; procedure TMycSignalUnion.Unadvise( Tag: TSignalTag ); begin FNotifier.Signal.Unadvise( Tag ); end; { TMyc2Flag } constructor TMyc2Flag.Create( AFlag: Boolean ); begin inherited Create; FFlag := Integer( AFlag ); end; function TMyc2Flag.Notify: Boolean; begin Result := TInterlocked.Exchange( FFlag, 1 ) = 0; end; function TMyc2Flag.Reset: Boolean; begin Result := TInterlocked.Exchange( FFlag, 0 ) = 1; end; end.