mtprocs: fixed moving group from need thread list after increasing LastRunningIndex, added CurrentThread variable

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1426 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/multithreadprocs/mtprocs.pas

@@ -127,6 +127,7 @@ type
     procedure AddToList(var First: TProcThreadGroup; ListType: TMTPGroupState); inline;
     procedure RemoveFromList(var First: TProcThreadGroup); inline;
     function NeedMoreThreads: boolean; inline;
+    procedure IncreaseLastRunningIndex(Item: TMultiThreadProcItem);
     procedure AddThread(AThread: TProcThread);
     procedure RemoveThread(AThread: TProcThread); inline;
     procedure Run(Index: PtrInt; Data: Pointer; Item: TMultiThreadProcItem); inline;
@@ -203,6 +204,8 @@ type
 var
   ProcThreadPool: TProcThreadPool = nil;
 
+threadvar
+  CurrentThread: TThread; // TProcThread sets this, you can set this for your own TThreads descendants
 
 implementation
 
@@ -338,6 +341,7 @@ var
   ok: Boolean;
   E: Exception;
 begin
+  CurrentThread:=Self;
   aPool:=Item.Group.Pool;
   ok:=false;
   try
@@ -353,8 +357,7 @@ begin
         // find next work
         if Group.LastRunningIndex<Group.EndIndex then begin
           // next index of group
-          inc(Group.FLastRunningIndex);
-          Item.FIndex:=Group.FLastRunningIndex;
+          Group.IncreaseLastRunningIndex(Item);
         end else begin
           // remove from group
           RemoveFromList(Group.FFirstThread,mtptlGroup);
@@ -422,17 +425,23 @@ begin
       and (FState<>mtpgsException);
 end;
 
+procedure TProcThreadGroup.IncreaseLastRunningIndex(Item: TMultiThreadProcItem);
+begin
+  inc(FLastRunningIndex);
+  Item.FIndex:=FLastRunningIndex;
+  if NeedMoreThreads then exit;
+  if FState=mtpgsNeedThreads then begin
+    RemoveFromList(Pool.FFirstGroupNeedThreads);
+    AddToList(Pool.FFirstGroupFinishing,mtpgsFinishing);
+  end;
+end;
+
 procedure TProcThreadGroup.AddThread(AThread: TProcThread);
 begin
   AThread.Item.FGroup:=Self;
   AThread.AddToList(FFirstThread,mtptlGroup);
   inc(FThreadCount);
-  inc(FLastRunningIndex);
-  AThread.Item.FIndex:=FLastRunningIndex;
-  if not NeedMoreThreads then begin
-    RemoveFromList(Pool.FFirstGroupNeedThreads);
-    AddToList(Pool.FFirstGroupFinishing,mtpgsFinishing);
-  end;
+  IncreaseLastRunningIndex(AThread.Item);
 end;
 
 procedure TProcThreadGroup.RemoveThread(AThread: TProcThread);
@@ -856,6 +865,7 @@ end;
 
 initialization
   ProcThreadPool:=TProcThreadPool.Create;
+  CurrentThread:=nil;
 
 finalization
   ProcThreadPool.Free;

components/multithreadprocs/mtputils.pas

@@ -35,7 +35,7 @@ type
     fBlockSize: PtrInt;
     fBlockCntPowOf2Offset: PtrInt;
     FMergeBuffer: PPointer;
-    procedure MTPSort(Index: PtrInt; Data: Pointer; Item: TMultiThreadProcItem);
+    procedure MTPSort(Index: PtrInt; {%H-}Data: Pointer; Item: TMultiThreadProcItem);
   public
     List: PPointer;
     Count: PtrInt;

components/multithreadprocs/multithreadprocslaz.lpk

@@ -2,8 +2,9 @@
 <CONFIG>
   <Package Version="3">
     <Name Value="MultiThreadProcsLaz"/>
+    <Author Value="Mattias Gaertner  mattias@freepascal.org"/>
     <CompilerOptions>
-      <Version Value="8"/>
+      <Version Value="9"/>
       <SearchPaths>
         <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
       </SearchPaths>
@@ -11,7 +12,9 @@
         <CompilerPath Value="$(CompPath)"/>
       </Other>
     </CompilerOptions>
-    <Version Major="1" Release="1"/>
+    <Description Value="Running procedures and methods parallel via a thread pool."/>
+    <License Value="modified LGPL2"/>
+    <Version Major="1" Minor="2" Release="1"/>
     <Files Count="3">
       <Item1>
         <Filename Value="mtprocs.pas"/>
@@ -35,11 +38,12 @@
     </RequiredPkgs>
     <UsageOptions>
       <CustomOptions Value="-dUseCThreads"/>
-      <UnitPath Value="$(PkgOutDir)/"/>
+      <UnitPath Value="$(PkgOutDir)"/>
     </UsageOptions>
     <PublishOptions>
       <Version Value="2"/>
       <IgnoreBinaries Value="False"/>
     </PublishOptions>
+    <Provides Count="2"/>
   </Package>
 </CONFIG>