LazUtils: Added unit lazcollections with generic class TLaThreadedQueue<T>, for usage in fpdebug

git-svn-id: trunk@48990 -

.gitattributes

@@ -2902,6 +2902,7 @@ components/lazutils/laz_xmlread.pas svneol=native#text/pascal
 components/lazutils/laz_xmlstreaming.pas svneol=native#text/pascal
 components/lazutils/laz_xmlwrite.pas svneol=native#text/pascal
 components/lazutils/lazclasses.pas svneol=native#text/pascal
+components/lazutils/lazcollections.pas svneol=native#text/plain
 components/lazutils/lazconfigstorage.pas svneol=native#text/pascal
 components/lazutils/lazdbglog.pas svneol=native#text/pascal
 components/lazutils/lazfglhash.pas svneol=native#text/plain

components/lazutils/lazcollections.pas

@@ -0,0 +1,300 @@
+unit lazCollections;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  sysutils,
+{$if (defined(ver2))}
+  lazut f8sysutils,
+{$endif}
+  syncobjs;
+
+type
+
+  { TLazMonitor }
+
+  TLazMonitor = class(TCriticalSection)
+  private
+    FSpinCount: integer;
+    class var FDefaultSpinCount: integer;
+    class function GetDefaultSpinCount: integer; static;
+    class procedure SetDefaultSpinCount(AValue: integer); static;
+    function GetSpinCount: integer;
+    procedure SetSpinCount(AValue: integer);
+  public
+    constructor create;
+    procedure Acquire; override;
+    property SpinCount: integer read GetSpinCount write SetSpinCount;
+    class property DefaultSpinCount: integer read GetDefaultSpinCount write SetDefaultSpinCount;
+  end;
+
+  { TThreadedQueue }
+
+  generic TLazThreadedQueue<T> = class
+  private
+    FMonitor: TLazMonitor;
+    FList: array of T;
+    FPushTimeout: Cardinal;
+    FPopTimeout: Cardinal;
+    FQueueSize: integer;
+    FTotalItemsPopped: QWord;
+    FTotalItemsPushed: QWord;
+    FHasRoomEvent: PRTLEvent;
+    FHasItemEvent: PRTLEvent;
+    FShutDown: boolean;
+    function TryPushItem(const AItem: T): boolean;
+    function TryPopItem(out AItem: T): boolean;
+  public
+    constructor create(AQueueDepth: Integer = 10; PushTimeout: cardinal = INFINITE; PopTimeout: cardinal = INFINITE);
+    destructor Destroy; override;
+    procedure Grow(ADelta: integer);
+    function PushItem(const AItem: T): TWaitResult;
+    function PopItem(out AItem: T): TWaitResult;
+    procedure DoShutDown;
+    property QueueSize: integer read FQueueSize;
+    property TotalItemsPopped: QWord read FTotalItemsPopped;
+    property TotalItemsPushed: QWord read FTotalItemsPushed;
+    property ShutDown: boolean read FShutDown;
+  end;
+
+
+implementation
+
+{ TLazMonitor }
+
+function TLazMonitor.GetSpinCount: integer;
+begin
+  result := FSpinCount;
+end;
+
+procedure TLazMonitor.SetSpinCount(AValue: integer);
+begin
+  InterLockedExchange(FSpinCount, AValue);
+end;
+
+class function TLazMonitor.GetDefaultSpinCount: integer; static;
+begin
+  result := FDefaultSpinCount;
+end;
+
+class procedure TLazMonitor.SetDefaultSpinCount(AValue: integer); static;
+begin
+  InterLockedExchange(FDefaultSpinCount, AValue);
+end;
+
+constructor TLazMonitor.create;
+begin
+  FSpinCount:=FDefaultSpinCount;
+  inherited;
+end;
+
+procedure TLazMonitor.Acquire;
+const
+  YieldTreshold = 10;
+  Sleep1Treshold = 20;
+  Sleep0Treshold = 5;
+var
+  i,j: integer;
+  Waitcount: integer;
+  ASpinCount: integer;
+  Sp: integer;
+begin
+  ASpinCount:=FSpinCount;
+  for Sp := 0 to ASpinCount-1 do
+  begin
+    Waitcount:=1;
+    for i := 0 to YieldTreshold-1 do
+      begin
+      if TryEnter then
+        Exit;
+      {$PUSH}
+      {$OPTIMIZATION OFF}
+      for j := 0 to Waitcount-1 do
+        begin
+        end;
+      {$POP}
+      Waitcount:=Waitcount*2;
+      end;
+
+    for i := 0 to Sleep1Treshold-1 do
+      begin
+      if TryEnter then
+        Exit;
+      sleep(1);
+      end;
+
+    for i := 0 to Sleep0Treshold do
+      begin
+      if TryEnter then
+        Exit;
+      sleep(0);
+      end;
+  end;
+
+  inherited Acquire;
+end;
+
+{ TThreadedQueue }
+
+function TLazThreadedQueue.TryPushItem(const AItem: T): boolean;
+begin
+  FMonitor.Enter;
+  try
+    result := FTotalItemsPushed-FTotalItemsPopped<FQueueSize;
+    if result then
+      begin
+      FList[FTotalItemsPushed mod FQueueSize]:=AItem;
+      inc(FTotalItemsPushed);
+      RTLeventSetEvent(FHasItemEvent);
+      end
+    else
+      RTLeventResetEvent(FHasRoomEvent);
+  finally
+    FMonitor.Leave;
+  end;
+end;
+
+function TLazThreadedQueue.TryPopItem(out AItem: T): boolean;
+begin
+  FMonitor.Enter;
+  try
+    result := FTotalItemsPushed>FTotalItemsPopped;
+    if result then
+      begin
+      AItem := FList[FTotalItemsPopped mod FQueueSize];
+      inc(FTotalItemsPopped);
+      RTLeventSetEvent(FHasRoomEvent);
+      end
+    else
+      RTLeventResetEvent(FHasItemEvent);
+  finally
+    FMonitor.Leave;
+  end;
+end;
+
+constructor TLazThreadedQueue.create(AQueueDepth: Integer; PushTimeout: cardinal; PopTimeout: cardinal);
+begin
+  FMonitor:=TLazMonitor.create;
+  Grow(AQueueDepth);
+  FHasRoomEvent:=RTLEventCreate;
+  RTLeventSetEvent(FHasRoomEvent);
+  FHasItemEvent:=RTLEventCreate;
+  FPushTimeout:=PushTimeout;
+  FPopTimeout:=PopTimeout;
+end;
+
+destructor TLazThreadedQueue.Destroy;
+begin
+  DoShutDown;
+  RTLeventdestroy(FHasRoomEvent);
+  RTLeventdestroy(FHasItemEvent);
+  FMonitor.Free;
+  inherited Destroy;
+end;
+
+procedure TLazThreadedQueue.Grow(ADelta: integer);
+begin
+  FMonitor.Enter;
+  try
+    FQueueSize:=FQueueSize+ADelta;
+    setlength(FList, FQueueSize);
+  finally
+    FMonitor.Leave;
+  end;
+end;
+
+function TLazThreadedQueue.PushItem(const AItem: T): TWaitResult;
+var
+  tc, ltc: int64;
+begin
+  if (FPushTimeout<>INFINITE) and (FPushTimeout<>0) then
+    begin
+    tc := GetTickCount64;
+    ltc := 0;
+    end;
+  if TryPushItem(AItem) then
+    result := wrSignaled
+  else
+    begin
+    repeat
+    if FPushTimeout=0 then
+      begin
+      result := wrTimeout;
+      Exit;
+      end
+    else if FPushTimeout=INFINITE then
+      RTLeventWaitFor(FHasRoomEvent)
+    else
+      begin
+      RTLeventWaitFor(FHasRoomEvent, FPushTimeout - ltc);
+      ltc := GetTickCount64-tc;
+      if ltc > FPushTimeout then
+        begin
+        result := wrTimeout;
+        Exit;
+        end;
+      end;
+    if FShutDown then
+      begin
+      result := wrAbandoned;
+      exit;
+      end;
+    until TryPushItem(AItem);
+    result := wrSignaled;
+    end;
+end;
+
+function TLazThreadedQueue.PopItem(out AItem: T): TWaitResult;
+var
+  tc, ltc: int64;
+begin
+  if (FPopTimeout<>INFINITE) and (FPopTimeout<>0) then
+    begin
+    tc := GetTickCount64;
+    ltc := 0;
+    end;
+  if TryPopItem(AItem) then
+    result := wrSignaled
+  else
+    begin
+    repeat
+    if FPopTimeout=0 then
+      begin
+      result := wrTimeout;
+      Exit;
+      end
+    else if FPopTimeout=INFINITE then
+      RTLeventWaitFor(FHasItemEvent)
+    else
+      begin
+      RTLeventWaitFor(FHasItemEvent, FPopTimeout - ltc);
+      ltc := GetTickCount64-tc;
+      if ltc > FPopTimeout then
+        begin
+        result := wrTimeout;
+        Exit;
+        end;
+      end;
+    if FShutDown then
+      begin
+      result := wrAbandoned;
+      exit;
+      end;
+    until TryPopItem(AItem);
+    result := wrSignaled;
+    end;
+end;
+
+procedure TLazThreadedQueue.DoShutDown;
+begin
+  FShutDown:=true;
+  RTLeventSetEvent(FHasRoomEvent);
+  RTLeventResetEvent(FHasItemEvent);
+end;
+
+initialization
+  TLazMonitor.DefaultSpinCount:=3;
+end.
+

components/lazutils/lazutils.lpk

@@ -16,7 +16,7 @@
     <Description Value="Useful units for Lazarus packages."/>
     <License Value="Modified LGPL-2"/>
     <Version Major="1"/>
-    <Files Count="77">
+    <Files Count="78">
       <Item1>
         <Filename Value="laz2_dom.pas"/>
         <UnitName Value="Laz2_DOM"/>
@@ -326,6 +326,10 @@
         <Filename Value="lcsvutils.pas"/>
         <UnitName Value="lcsvutils"/>
       </Item77>
+      <Item78>
+        <Filename Value="lazcollections.pas"/>
+        <UnitName Value="lazcollections"/>
+      </Item78>
     </Files>
     <LazDoc Paths="../../docs/xml/lazutils"/>
     <i18n>

components/lazutils/lazutils.pas

@@ -16,7 +16,7 @@ uses
   TTProfile, TTRASTER, TTTables, TTTypes, EasyLazFreeType, LazLoggerBase, 
   LazLoggerDummy, LazClasses, LazFreeTypeFontCollection, LazConfigStorage, 
   UTF8Process, laz2_xpath, DictionaryStringList, LazLoggerProfiling, FPCAdds, 
-  LazUtilities, lazfglhash, lcsvutils, LazarusPackageIntf;
+  LazUtilities, lazfglhash, lcsvutils, lazCollections, LazarusPackageIntf;
 
 implementation