How to fix TSparseArray?

Question

Because of an unfixed bug with System.Generics.Collections.TArray.Copy<T> (depending on already reported bug in System.CopyArray) there will sometimes raise an exception using the threading library.

The exception is raised in method System.Threading.TSparseArray<T>.Add:

function TSparseArray<T>.Add(const Item: T): Integer;
var
  I: Integer;
  LArray, NewArray: TArray<T>;
begin
  ...
          TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
  ...
end;

Well that is expected with the bug in System.CopyArray. So when trying to fix this my first thought was to simply copy the array with:

// TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
for LIdx := Low( LArray ) to High( LArray ) do
  NewArray[LIdx] := LArray[LIdx];

Works like a charm. But after that I was wondering, why the array copy is needed:

LArray := FArray; // copy array reference from field
...
SetLength(NewArray, Length(LArray) * 2);
TArray.Copy<T>(LArray, NewArray, I + 1);
NewArray[I + 1] := Item;
Exit(I + 1);

The elements are copied to NewArray (local variable) and thats it. There is no assignment back to FArray, so to me the NewArray will be finalized when out of scope.

Now I have three bugfix choices:

1. Just replace TArray.Copy

   SetLength(NewArray, Length(LArray) * 2);
   // TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
   for LIdx := Low( LArray ) to High( LArray ) do
     NewArray[LIdx] := LArray[LIdx];
   NewArray[I + 1] := Item;
   Exit(I + 1);
   

2. Replace TArray.Copy and save NewArray

   SetLength(NewArray, Length(LArray) * 2);
   // TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
   for LIdx := Low( LArray ) to High( LArray ) do
     NewArray[LIdx] := LArray[LIdx];
   NewArray[I + 1] := Item;
   FArray := NewArray;
   Exit(I + 1);
   

3. Comment out all the unnecessary code parts (because they are just wasting time)

   // SetLength(NewArray, Length(LArray) * 2);
   // TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
   // NewArray[I + 1] := Item;
   Exit(I + 1);
   

I checked all three fixes with a bunch of tasks looking for unused worker threads or not executed tasks. But I did not find any of them. The library works as expected (and now without any exception).

Can you please point me to what I am missing here?

---

To get to this exception, you have run a bunch of tasks and let the TTaskPool create more and more TWorkerQueueThreads. Check the count of threads by TaskManager and use a breakpoint on TArray.Copy line in TSparseArray<T>.Add method. Here I get this exception when the thread count of the application goes beyond 25 threads.

// Hit the button very fast until the debugger stops 
// at TSparseArray<T>.Add method to copy the array
procedure TForm1.Button1Click( Sender : TObject );
var
  LIdx : Integer;
begin
  for LIdx := 1 to 20 do
    TTask.Run( 
      procedure 
      begin
        Sleep( 50 );
      end );
end;

Answer 1

This is not a bug in System.CopyArray. By design it only supports managed types. The bug is in fact in TArray.Copy<T>. That is mistaken in calling System.CopyArray without discriminating on whether or not T is a managed type.

However, the latest version of TArray.Copy<T>, from XE7 update 1 does not appear to suffer from the problem you describe. The code looks like this:

class procedure TArray.Copy<T>(const Source, Destination: array of T; 
  SourceIndex, DestIndex, Count: NativeInt);
begin
  CheckArrays(Pointer(@Source[0]), Pointer(@Destination[0]), SourceIndex, 
    Length(Source), DestIndex, Length(Destination), Count);
  if IsManagedType(T) then
    System.CopyArray(Pointer(@Destination[SourceIndex]), 
      Pointer(@Source[SourceIndex]), TypeInfo(T), Count)
  else
    System.Move(Pointer(@Destination[SourceIndex])^, Pointer(@Source[SourceIndex])^, 
      Count * SizeOf(T));
end;

Unless I am mistaken in my analysis, you simply need to apply update 1 to resolve the problems with System.CopyArray.

---

But as Uwe points out in comments below, this code is still bogus. It uses SourceIndex erroneously where DestIndex should be used. And the source and destination parameters are passed in the wrong order. One also wonders why the author wrote Pointer(@Destination[SourceIndex])^ rather than Destination[SourceIndex]. I find this whole situation terribly depressing. How can Embarcadero release code of such appalling quality?

---

Deeper than the above are the problems with TSparseArray<T>. Which looks like this:

function TSparseArray<T>.Add(const Item: T): Integer;
var
  I: Integer;
  LArray, NewArray: TArray<T>;
begin
  while True do
  begin
    LArray := FArray;
    TMonitor.Enter(FLock);
    try
      for I := 0 to Length(LArray) - 1 do
      begin
        if LArray[I] = nil then
        begin
          FArray[I] := Item;
          Exit(I);
        end else if I = Length(LArray) - 1 then
        begin
          if LArray <> FArray then
            Continue;
          SetLength(NewArray, Length(LArray) * 2);
          TArray.Copy<T>(LArray, NewArray, I + 1);
          NewArray[I + 1] := Item;
          Exit(I + 1);
        end;
      end;
    finally
      TMonitor.Exit(FLock);
    end;
  end;
end;

The only time FArray is initialized is in the TSparseArray<T> constructor. This means that if the array becomes full, then items are added and lost. Presumably the I = Length(LArray) - 1 is meant to extend the length of FArray and capture the new item. However, note also that TSparseArray<T> exposes FArray through the Current property. And this exposure is not protected by the lock. So, I cannot see how this class can behave in any useful way once FArray becomes full.

I suggest that you construct an example where FArray becomes full an demonstrate that items which are added are lost. Submit a bug report demonstrating that, and linking to this question.

Answer 2

It does not matter if the items are written to TSparseArray<T>, because it is only needed if a worker thread has finished all of the tasks delegated to him and another worker thread has not finished yet. At this point the idle thread is looking at the queues of the other treads inside the pool and tries to steal some work.

If any queue did not get into this array there are not visible to the idle threads and therefore the working load cannot be shared.

To fix that I choose option 2

function TSparseArray<T>.Add(const Item: T): Integer;
...
SetLength(NewArray, Length(LArray) * 2);
TArray.Copy<T>(LArray, NewArray, I + 1); // <- No Exception here with XE7U1
NewArray[I + 1] := Item;
{$IFDEF USE_BUGFIX}
FArray := NewArray;
{$ENDIF}
Exit(I + 1);

But that stealing part is risky implemented without any locking

procedure TThreadPool.TQueueWorkerThread.Execute;

...

if Signaled then
begin
  I := 0;
  while I < Length(ThreadPool.FQueues.Current) do
  begin
    if (ThreadPool.FQueues.Current[I] <> nil) 
      and (ThreadPool.FQueues.Current[I] <> WorkQueue)
      and ThreadPool.FQueues.Current[I].TrySteal(Item) 
    then
      Break;
    Inc(I);
  end;
  if I <> Length(ThreadPool.FQueues.Current) then
    Break;
  LookedForSteals := True;
end

The array length is only growing so

while I < Length(ThreadPool.FQueues.Current) do

and

if I <> Length(ThreadPool.FQueues.Current) then

should be safe enough.

if Signaled then
begin
  I := 0;
  while I < Length(ThreadPool.FQueues.Current) do
  begin
    {$IFDEF USE_BUGFIX}
    TMonitor.Enter(ThreadPool.FQueues);
    try
    {$ENDIF}
      if (ThreadPool.FQueues.Current[I] <> nil) and (ThreadPool.FQueues.Current[I] <> WorkQueue) and ThreadPool.FQueues.Current[I].TrySteal(Item) then
        Break;
    {$IFDEF USE_BUGFIX}
    finally
      TMonitor.Exit(ThreadPool.FQueues);
    end;
    {$ENDIF}
    Inc(I);
  end;
  if I <> Length(ThreadPool.FQueues.Current) then
    Break;
  LookedForSteals := True;
end

Now we need a test environment to watch the stealing:

program WatchStealingTasks;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  Winapi.Windows,
  System.SysUtils,
  System.Threading,
  System.Classes,
  System.Math;

procedure OutputDebugStr( const AStr: string ); overload;
begin
  OutputDebugString( PChar( AStr ) );
end;

procedure OutputDebugStr( const AFormat: string; const AParams: array of const ); overload;
begin
  OutputDebugStr( Format( AFormat, AParams ) );
end;

function CreateInnerTask( AThreadId: Cardinal; AValue: Integer; APool: TThreadPool ): ITask;
begin
  Result := TTask.Run(
      procedure
    begin
      Sleep( AValue );
      if AThreadId <> TThread.CurrentThread.ThreadID
      then
        OutputDebugStr( '[%d] executed stolen task from [%d]', [TThread.CurrentThread.ThreadID, AThreadId] )
      else
        OutputDebugStr( '[%d] executed task', [TThread.CurrentThread.ThreadID] );
    end, APool );
end;

function CreateTask( AValue: Integer; APool: TThreadPool ): ITask;
begin
  Result := TTask.Run(
    procedure
    var
      LIdx: Integer;
      LTasks: TArray<ITask>;
    begin
      // Create three inner tasks per task
      SetLength( LTasks, 3 );
      for LIdx := Low( LTasks ) to High( LTasks ) do
        begin
          LTasks[LIdx] := CreateInnerTask( TThread.CurrentThread.ThreadID, AValue, APool );
        end;
      OutputDebugStr( '[%d] waiting for tasks completion', [TThread.CurrentThread.ThreadID] );
      TTask.WaitForAll( LTasks );
      OutputDebugStr( '[%d] task finished', [TThread.CurrentThread.ThreadID] );
    end, APool );
end;

procedure Test;
var
  LPool: TThreadPool;
  LIdx: Integer;
  LTasks: TArray<ITask>;
begin
  OutputDebugStr( 'Test started' );
  try
    LPool := TThreadPool.Create;
    try
      // Create three tasks
      SetLength( LTasks, 3 );
      for LIdx := Low( LTasks ) to High( LTasks ) do
        begin
          // Let's put some heavy work (200ms) on the first tasks shoulder
          // and the other tasks just some light work (20ms) to do
          LTasks[LIdx] := CreateTask( IfThen( LIdx = 0, 200, 20 ), LPool );
        end;
      TTask.WaitForAll( LTasks );
    finally
      LPool.Free;
    end;
  finally
    OutputDebugStr( 'Test completed' );
  end;
end;

begin
  try
    Test;
  except
    on E: Exception do
      Writeln( E.ClassName, ': ', E.Message );
  end;
  ReadLn;

end.

And the debug log is

Debug-Ausgabe: Test started Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 2104. Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 2188. Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 4948. Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] waiting for tasks completion Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2104] waiting for tasks completion Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 2212. Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] waiting for tasks completion Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] task finished Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] task finished Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2104] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed stolen task from [2104] Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed stolen task from [2104] Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2104] task finished Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: Thread Exiting: 2188 Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: Thread Exiting: 4948 Prozess WatchStealingTasks.exe (4532)
Thread-Ende: Thread-ID: 4948. Prozess WatchStealingTasks.exe (4532)
Thread-Ende: Thread-ID: 2188. Prozess WatchStealingTasks.exe (4532)
Thread-Ende: Thread-ID: 2212. Prozess WatchStealingTasks.exe (4532)

Ok, stealing should be working now with any number of worker threads, so everything is alright?

No

This small test application will not come to an end, because now it freezes inside the destructor of the thread pool. The last worker thread will not terminate caused by

procedure TThreadPool.TQueueWorkerThread.Execute;

...

if ThreadPool.FWorkerThreadCount = 1 then
begin
  // it is the last thread after all tasks executed, but
  // FQueuedRequestCount is still on 7 - WTF
  if ThreadPool.FQueuedRequestCount = 0 then
  begin

One more bug to fix here ... because when waiting for tasks with Task.WaitForAll then all of the tasks you are now waiting for, were executed internally but will not decrease the FQueuedRequestCount.

Fixing that

function TThreadPool.TryRemoveWorkItem(const WorkerData: IThreadPoolWorkItem): Boolean;
begin
  Result := (QueueThread <> nil) and (QueueThread.WorkQueue <> nil);
  if Result then
    Result := QueueThread.WorkQueue.LocalFindAndRemove(WorkerData);
  {$IFDEF USE_BUGFIX}
  if Result then
    DecWorkRequestCount;
  {$ENDIF}
end;

and now it runs like it should have done at once.

---

Update

As a comment by Uwe we also need to fix the fixed System.Generics.Collections.TArray.Copy<T>

class procedure TArray.Copy<T>(const Source, Destination: array of T; SourceIndex, DestIndex, Count: NativeInt);
{$IFDEF USE_BUGFIX}
begin
  CheckArrays(Pointer(@Source[0]), Pointer(@Destination[0]), SourceIndex, Length(Source), DestIndex, Length(Destination), Count);
  if IsManagedType(T) then
    System.CopyArray(Pointer(@Destination[DestIndex]), Pointer(@Source[SourceIndex]), TypeInfo(T), Count)
  else
    System.Move(Pointer(@Source[SourceIndex])^,Pointer(@Destination[DestIndex])^, Count * SizeOf(T) );
end;
{$ELSE}
begin
  CheckArrays(Pointer(@Source[0]), Pointer(@Destination[0]), SourceIndex, Length(Source), DestIndex, Length(Destination), Count);
  if IsManagedType(T) then
    System.CopyArray(Pointer(@Destination[SourceIndex]), Pointer(@Source[SourceIndex]), TypeInfo(T), Count)
  else
    System.Move(Pointer(@Destination[SourceIndex])^, Pointer(@Source[SourceIndex])^, Count * SizeOf(T));
end;
{$ENDIF}

A simple check to test:

procedure TestArrayCopy;
var
  LArr1, LArr2: TArray<Integer>;
begin
  LArr1 := TArray<Integer>.Create( 10, 11, 12, 13 );
  LArr2 := TArray<Integer>.Create( 20, 21 );
  // copy the last 2 elements from LArr1 to LArr2
  TArray.Copy<Integer>( LArr1, LArr2, 2, 0, 2 );
end;

• with XE7 you will get an exception
• with XE7 Update1 you will get

  LArr1 = ( 10, 11, 0, 0 )
  LArr2 = ( 20, 21 )
  

• with that fix above will get

  LArr1 = ( 10, 11, 12, 13 )
  LArr2 = ( 12, 13 )