Blocage dans un DoParallel

**der§en** · 27/11/2019, 09h20

Bonjour,

Pour un besoin particulier, je cherche à dénombrer le nombre de couleurs et leurs quantités dans une image qui fait 4000 X 200 pixels.

Pour optimiser le traitement, j’ai utilisé la méthode DoParallel, mais hélas arrivé a 120 lignes de traitées, le programme se bloque sans que je comprenne ou et surtout pourquoi !

Je vous soumets mon code dans l'espoir que vous y trouviez l’énormité que j'y aurai mise ou me dire quelle est la meilleure manière de trouver ou cela bloque

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
 
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    Label1: TLabel;
    Label2: TLabel;
    ListBox1: TListBox;
    Panel1: TPanel;
    Panel2: TPanel;
    ScrollBox1: TScrollBox;
    ValueListEditor1: TValueListEditor;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure ControleUneLigne(Index: PtrInt; Data: Pointer; Item: TMultiThreadProcItem);
    procedure CompteurDeLignes;
  public
     iCpt: Integer;
     MaCS: TRTLCriticalSection;
  end;
 
/////////////////////////////////////////////////////////////////////////////////////////////////
 
procedure TForm1.Button1Click(Sender: TObject);
var
  SL: TStringList;
begin
  iCpt := 0;
 
  SL := TStringList.create;
  try
    InitCriticalSection(MaCS);
 
    ProcThreadPool.DoParallel(@ControleUneLigne, 0, Image1.Picture.Height - 1, SL); // , ProcThreadPool.MaxThreadCount);
 
    DoneCriticalSection(MaCS);
 
    ValueListEditor1.Strings.CommaText := SL.CommaText;
 
    ListBox1.Items.CommaText := SL.CommaText;
  finally
    SL.Free;
  end;
 
  Label2.Caption := 'Contrôle des couleurs terminés';
end;
 
procedure TForm1.ControleUneLigne(Index: PtrInt; Data: Pointer; Item: TMultiThreadProcItem);
var
  X: DWord;
  L: PRGBQUAD;
  S: String;
  I: Integer;
  SL: TStringList;
begin
  SL := TStringList(Data);
 
  L := PRGBQUAD(Image1.Picture.PNG.RawImage.GetLineStart(Index));
 
  For X := 0 to Image1.Picture.Width - 1 do
  begin
    S := ColorToString(RGBToColor(L^.rgbRed, L^.rgbGreen, L^.rgbBlue));
 
    I := SL.IndexOfName(S);
 
    if  I = -1 then
    begin
      SL.Add(S + '=1');
    end
    else
    begin
      EnterCriticalSection(MaCS);
      try
        SL.ValueFromIndex[I] := IntToStr(SL.ValueFromIndex[I].ToInteger + 1);
      finally
        LeaveCriticalSection(MaCS);
      end;
    end;
 
    Inc(L);
  end;
 
  TThread.Synchronize(CurrentThread, @CompteurDeLignes);
end;
 
procedure TForm1.CompteurDeLignes;
begin
  Inc(iCpt);
 
  Label2.Caption := IntToStr(iCpt);
 
  Application.ProcessMessages;
end;

**BeanzMaster** · 27/11/2019, 16h20

Salut

A mon avis c'est cette ligne TThread.Synchronize(CurrentThread, @CompteurDeLignes); qui doit poser problème car en principe tous les Threads sont déja occupés et appeler la classe TThread comme ça, hum pour ma part je ne recommande pas.
La fonction ProcThreadPool.DoParallel va créer plusieurs thread donc à mon avis, il me semble que le couple InitCriticalSection(MaCS);/DoneCriticalSection(MaCS); n'a pas vraiment de sens dans ces circonstances, mais c'est peut-être une fausse idée de ma part.
Pour l'affichage de la progression je passerai plus part un Timer qui se chargerai juste de lire la variable "iCpt"

Sinon, je te met l'unité que je me sert dans mon projet (aucunes dépendances) Et en plus ça fonctionne presque comme l'original, mais en plus simple

: BZParallelThread.pas

Exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Uses BZParallelThread;
 
Type
 TMyBuffer = record
    A, B, C : Int64;
  end;
  PMyBuffer = ^TMyBuffer;
 
Type
   TForm1 = class(TForm)
   private
      FMyBitmap : TBitmap;
      FMyBuffer : PMyBuffer;
 
      procedure ProcessLine(y : Integer; var Source : TMyBuffer);
      procedure MyParalelleProc(Sender: TObject; Index: Integer; Data : Pointer);
 
      procedure Run;
   end;
 
implementration
 
procedure TMainForm.ProcessLine(y : Integer; var Source : TMyBuffer);
var
  L: PRGBQUAD;
begin
  L := PRGBQUAD(FMyBitmap.RawImage.GetLineStart(y));
  Source.A := Source.A + 1;
   ....
 
 
  Inc(iCpt);
  // Les 2 appels suivant peuvent être problématique. J'utiliserai plus un timer qui récupère la valeur iCpt toutes les X secondes et qui s'occuperait de l'affichage. Cela serait à mon avis une meilleur solution que de faire appel 
  //a Application.ProcessMessages; directement ici d'appeler le Synchronize d'un autre thread et vue que le travail  se fait sur mini 2 threads en même temps, ce n'est pas une bonne idée
  //Label2.Caption := IntToStr(iCpt); 
 // Application.ProcessMessages;
end;
 
procedure TMainForm.MyParalelleProc(Sender : TObject; Index : Integer; Data : Pointer);
begin
  ProcessLine(Index mod MyBitmap.Height, TMyBuffer(Data^));
end;
 
procedure Run;
var
   ResultA : Int64;
begin
   GetMem(FMyBuffer, Sizeof(TMyBuffer));
   FMyBuffer^.B := 0;
   ParallelFor(0, FMyBitmap.Height, @MyParalelleProc, Pointer(FMyBuffer));
   ResultA := FMyBuffer^.A;
   FreeMem(FMyBuffer);
end;

pour info,si jamais le Thread en cours d'éxécution se trouve dans cette varaibale globale : "BZCurrentParallelThread" pour la synchronisation (cf petit commentaire dans le code

)

Une solution que je viens de m'auto suggérer serait de modifier un peu la classe " TBZParallelThread" en publiant "FCount" et "FTaskCount" pour pouvoi récupérer directement l'avancement ~~via "BZCurrentParallelThread"~~

A+
Jérôme

EDIT : Oups,

dans l'unité j'ai oublié de commenter {$i ..\bzscene_options.inc} tout au début

**der§en** · 27/11/2019, 16h54

Merci, je m'en vais décortiquer ton source, et essayer d'y trouver mon bonheur

**BeanzMaster** · 27/11/2019, 20h11

Re

Je viens de relire deux trois truc sur les threads

Pour la synchro avec mon unité (je n'ai pas testé) en faisant
comme tu l'as fait avec la fonction de classe synchronize (je n'avais pas fait attention à cette petite subtilité) cela devrait fonctionner

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
procedure TMainForm.CompteurDeLignes;
begin
  Label2.Caption := IntToStr(iCpt); 
  Application.ProcessMessages;
end;
 
procedure TMainForm.MyParalelleProc(Sender : TObject; Index : Integer; Data : Pointer);
begin
  ProcessLine(Index mod MyBitmap.Height, TMyBuffer(Data^));
  TThread.Synchronize(BZCurrentParallelThread, @CompteurDeLignes);
end;

Sinon essayes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Type
  TThreadUpdateGUI = class(TThread)
  protected
     procedure Execute;
  end;
 
Implmentation
 
procedure TThreadUpdateGUI.Execute;
begin
   BZCurrentParallelThread := self;
   Label2.Caption := IntToStr(iCpt);
   Application.ProcessMessages;
end;
 
procedure TMainForm.MyParalelleProc(Sender : TObject; Index : Integer; Data : Pointer);
begin
  ProcessLine(Index mod MyBitmap.Height, TMyBuffer(Data^));
end;

cela devrait être bon, normalement

A+

**der§en** · 28/11/2019, 11h58

Je vais regarder tes suggestions

J'ai essayer de creuser de mon coté et j'ai l'impression de mon blocage, viendrais peux-être de l'usage de la TStringList par les différents threads

**BeanzMaster** · 28/11/2019, 12h56

Places putôt ta string list dans la definition de la form en protected en tant que variable globale plutôt qu'en local dans buttonclick

**BeanzMaster** · 28/11/2019, 17h25

Salut

J'ai effectué quelques tests. Le problème vient bien de la StringList, pour ce genre de travail tu ne peux pas utiliser "DoParallel". Il te faut créer un système de thread personnalisé et utiliser l'instruction "WaitFor".

Je m'explique : imaginons que le thread n°1 traite un pixel avec la couleur X et que le Thread n°2 traite un autre pixel avec la même couleur. Les 2 threads tentent d'écrire dans la StringList en même temps !!! Et c'est là que le problème survient.
Pour bien faire il faut que le Thread n°2 attende que le Thread n°1 finisse d'écrire dans la stringlist. Les sections critiques ne servent à rien ici dans ton code et avec "DoParallel".

Il y a une demo dans les exemples de projet : Example/multithreading/waitforexample1 et voir ici.

Dans la solution proposée par défaut par Lazarus il y a une fonction "WaitFor" mais elle n'est pas adaptée ici.

A+

**BeanzMaster** · 28/11/2019, 17h54

Bon me revoilà, j'ai poussé les recherches sur les sections critiques et les stringlists, qui sont normalement "Thread-safe" donc on peut utiliser les sections critiques.

À la place de TRLCriticalSection utilise TCriticalSection qui se trouve dans l'unité SyncObjs et enfin à la place de Enter/Leave utilise Acquire/Release.

Essaye comme ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
uses SyncObjs;
 
  TForm1 = class(TForm)
    Button1: TButton;
   //....
  public
     iCpt: Integer;
     MaCS: TCriticalSection;
  end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  SL: TStringList;
begin
  iCpt := 0;
 
  SL := TStringList.create;
  try
    MaCS := TCriticalSection.Create;
 
    ProcThreadPool.DoParallel(@ControleUneLigne, 0, Image1.Picture.Height - 1, SL); // , ProcThreadPool.MaxThreadCount);
 
    DoneCriticalSection(MaCS);
 
    ValueListEditor1.Strings.CommaText := SL.CommaText;
 
    ListBox1.Items.CommaText := SL.CommaText;
  finally
    SL.Free;
    FreeAndNil(maCS);   
  end;
 
  Label2.Caption := 'Contrôle des couleurs terminés';
end;
 
procedure TForm1.ControleUneLigne(Index: PtrInt; Data: Pointer; Item: TMultiThreadProcItem);
var
  X: DWord;
  L: PRGBQUAD;
  S: String;
  I: Integer;
  SL: TStringList;
begin
  SL := TStringList(Data);
 
  L := PRGBQUAD(Image1.Picture.PNG.RawImage.GetLineStart(Index));
 
  For X := 0 to Image1.Picture.Width - 1 do
  begin
    S := ColorToString(RGBToColor(L^.rgbRed, L^.rgbGreen, L^.rgbBlue));
 
    I := SL.IndexOfName(S);
 
    if  I = -1 then
    begin
     MaCS.Aquire;
      try
        SL.Add(S + '=1');
      finally
        MaCS.Release;
      end;
    end
    else
    begin
     MaCS.Aquire;
      try
        SL.ValueFromIndex[I] := IntToStr(SL.ValueFromIndex[I].ToInteger + 1);
      finally
        MaCS.Release;
      end;
    end;
 
    Inc(L);
  end;
 
  TThread.Synchronize(CurrentThread, @CompteurDeLignes);
end;

A+

**BeanzMaster** · 28/11/2019, 18h38

Bon j'ai testé (avec ma bibliothèque) ça fonctionne

Ici le traitement est plutôt rapide car l'image ne fait que 300x300 et n'utilise pas beaucoup de couleur. Car plus il y a de couleur et plus c'est long.... je n'imagine même pas avec ton image de 4000x200

Nom : countcolors.gif
Affichages : 409
Taille : 67,9 Ko

A+

**der§en** · 28/11/2019, 21h09

Merci, vraiment, pour les explications et le temps que tu as accordé à mon PB

**BeanzMaster** · 29/11/2019, 16h49

Envoyé par der§en

Merci, vraiment, pour les explications et le temps que tu as accordé à mon PB

Pas de soucis

car cela rejoint mon projet et que ce genre de chose m'intéresse aussi beaucoup

**der§en** · 29/11/2019, 17h28

Pas moyen, même en reprenant ton code, mon programme se bloque avec 136 au compteur

Je vais essayer avec ta bibliothèque dés fois que...

**BeanzMaster** · 29/11/2019, 19h06

Envoyé par der§en

Pas moyen, même en reprenant ton code, mon programme se bloque avec 136 au compteur

Je vais essayer avec ta bibliothèque dés fois que...

Je continue de m'amuser avec ce comptage de couleurs et même avec ma bibliothèque ça se bloque par moment et suivant les images.
Après investigation, le coupable c'est Thread.Synchronize avec la méthode de mise à jour de l'affichage. Il doit se passer quelque chose d'obscure.
J'ai essayé en compilant sans débogage et c'est la même. En le supprimant plus de problème, mais plus de compteur. Est-ce vraiment important ????

Si j'ai un peu de temps ce we je testerai avec Delphi pour voir si ça coince

En attendant voici une petite optimisation de l'algorithme de comptage (je te laisse le soin de retranscrire pour les TBitmap et les TStringList

Ici j'utilise mon TBZBitmap et une TBZStringList une StringList améliorée basée sur les "Hash" (il suffit d'une simple comparaison pour retrouver une couleur. Ce qui est plus rapide que de balayer toute la liste) :

1) On ne prend pas en compte les couleurs noire ( et totalement transparente. Je travail uniquement avec un format de 32 bits par pixel, quelques soit le bit d'origine 8,16,24...)
2) Si la couleur du pixel précédent est le même que celui du pixel en cours de lecture on incrémente le compteur de la couleur (on évite la recherche dans la stringlist)

Et a la fin, suffit juste d'un petit calcul pour connaitre le nombre de pixel noir : (WidthxHeight) - somme de toutes les couleurs et hop

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
procedure TForm1.ProcessLine(y : Integer);
var
  X: DWord;
  L : PBZColor;
  Current : TBZColor;
  S: String;
  I, J: Integer;
begin
  Current := clrBlack;
  L := BZImageViewer1.Picture.Bitmap.GetScanLine(y);
  For X := 0 to BZImageViewer1.Picture.Bitmap.MaxWidth do
  begin
    if (L^<>clrBlack) and (l^<>clrTransparent) then
    begin
      if L^<>Current then
      begin
        S := L^.ToString;
        I := SL.IndexOf(S);
        if  I < 0 then
        begin
          maCS.Acquire;
          Try
            J := SL.Add(S);
            SL.Items[J].Tag := 1;
            Current := L^;
            I := J;
          finally
            maCS.Release;
          end;
        end
        else
        begin
          maCS.Acquire;
          try
            SL.Items[I].Tag := + SL.Items[I].Tag + 1;
          finally
            maCS.Release;
          end;
        end;
      end
      else
      begin
        maCS.Acquire;
        try
          SL.Items[I].Tag := + SL.Items[I].Tag + 1;
        finally
          maCS.Release;
        end;
      end;
    end;
    inc(L);
  end;
end;

A+
Jérôme

**der§en** · 29/11/2019, 20h50

En fait, le synchronise, vu que le programme mets du temps pour traiter mes images volumineuses, il me sert à voir ou en est la progression.

**BeanzMaster** · 30/11/2019, 10h12

Envoyé par der§en

En fait, le synchronise, vu que le programme mets du temps pour traiter mes images volumineuses, il me sert à voir ou en est la progression.

C'est ce que je pensais, mais je t'ai quand même posé la question.

Bref, j'ai essayé plusieurs trucs avec TThread.Synchronize mais à chaque fois suivant les images ça bloquait de façon anarchique.
J'ai modifié mon unité BZParallelThread en conséquence et maintenant tout fonctionne

Voilà le code de l'application test (toujours en utilisant ma bibliothèque. Désolé

) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
unit uMainForm;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ValEdit, ExtDlgs, ExtCtrls,SyncObjs,
  BZCLasses, BZGraphic, BZBitmap, {%H-}BZBitmapIO, BZParallelThread, BZImageViewer;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    BZImageViewer1 : TBZImageViewer;
    Button1 : TButton;
    Button2 : TButton;
    ListBox1 : TListBox;
    ValueListEditor1 : TValueListEditor;
    OPD : TOpenPictureDialog;
    Label1 : TLabel;
    Label2 : TLabel;
    Label3 : TLabel;
    procedure Button1Click(Sender : TObject);
    procedure Button2Click(Sender : TObject);
    procedure FormCreate(Sender : TObject);
    procedure FormClose(Sender : TObject; var CloseAction : TCloseAction);
  private
 
  protected
    SL: TBZStringList;
 
    MaCS: TCriticalSection;
 
    procedure CompteurDeLignes(Sender : TObject; Index : Integer);
    procedure ProcessLine(y : Integer);
    procedure MyParalelleProc(Sender: TObject; Index: Integer; Data : Pointer);
  public
 
  end;
 
var
  Form1 : TForm1;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender : TObject);
begin
  if OPD.Execute then
  begin
    BZImageViewer1.Picture.LoadFromFile(OPD.FileName);
    BZImageViewer1.Invalidate;
  end;
end;
 
procedure TForm1.Button2Click(Sender : TObject);
var
  i : Integer;
  SLOut : TStringList;
begin
 
   Screen.Cursor := crHourGlass;
   MaCS := TCriticalSection.Create;
 
   ParallelFor(0, BZImageViewer1.Picture.Bitmap.MaxHeight, @MyParalelleProc,@CompteurDeLignes, nil); // nb MaxHeigtht = Height-1 
   SLOut := TStringList.Create;
   for i := 0 to SL.Count-1 do
   begin
     SLOut.Add(SL.Strings[i]+ '=' + SL.Items[i].Tag.ToString);
   end;
   ValueListEditor1.Strings.CommaText := SLOut.CommaText;
   ListBox1.Items.CommaText := SLOut.CommaText;
   Label1.Caption := 'Terminé';
   Label3.Caption := SL.Count.ToString;
   FreeAndNil(SLOut);
 
   FreeAndNil(MaCS);
   Screen.Cursor := crDefault;
 
end;
 
procedure TForm1.FormCreate(Sender : TObject);
begin
  SL := TBZStringList.Create(Nil);
  SL.CaseSensitive := True;
end;
 
procedure TForm1.FormClose(Sender : TObject; var CloseAction : TCloseAction);
begin
  FreeAndNil(SL);
end;
 
procedure TForm1.ProcessLine(y : Integer);
var
  X: DWord;
  L : PBZColor;
  Current : TBZColor;
  S: String;
  I, J: Integer;
begin
  Current := clrBlack;
  L := BZImageViewer1.Picture.Bitmap.GetScanLine(y);
  For X := 0 to BZImageViewer1.Picture.Bitmap.MaxWidth do
  begin
    if (L^<>clrBlack) and (l^<>clrTransparent) then
    begin
      if L^<>Current then
      begin
        S := L^.ToHexString;
        I := SL.IndexOf(S);
        if  I < 0 then
        begin
          maCS.Acquire;
          Try
            J := SL.Add(S);
            SL.Items[J].Tag := 1;
            Current := L^;
            I := J;
          finally
            maCS.Release;
          end;
        end
        else
        begin
          maCS.Acquire;
          try
            SL.Items[I].Tag := SL.Items[I].Tag + 1;
          finally
            maCS.Release;
          end;
        end;
      end
      else
      begin
        maCS.Acquire;
        try
          SL.Items[I].Tag := SL.Items[I].Tag + 1;
        finally
          maCS.Release;
        end;
      end;
    end;
    inc(L);
  end;
end;
 
procedure TForm1.MyParalelleProc(Sender : TObject; Index : Integer; Data : Pointer);
begin
  ProcessLine(Index mod BZImageViewer1.Picture.Bitmap.Height);
end;
 
procedure TForm1.CompteurDeLignes(Sender : TObject; Index : Integer);
begin
  Label1.Caption := IntToStr(Index);
  Application.ProcessMessages;
end;
 
end.

Et la nouvelle unité : BZParallelThread.pas

Teste et dis-moi

A+
Jérôme

**Andnotor** · 30/11/2019, 16h00

L'erreur est clairement au niveau de la section critique. Il faut protéger l'écriture mais également la lecture.

Sinon quelques trucs à améliorer :

Un point qui va se montrer pénalisant est de créer autant de thread que l'image a de ligne ; dans ton cas @der§en : 2000 !
Il peut être justifié de créer plus de tâches que le nombre de processeurs pour autant que celles-ci soient en attente d'un événement mais pas dans le cas d'une utilisation intensive comme ici.

Travailler avec une stringlist est très gourmand en temps : décortiquer la chaîne pour retrouver les nom=valeur, réallouer la liste à chaque ajout (si dépassement de capacité de la zone mémoire actuelle), etc.
Un tableau statique d'entier de [0..$FFFFFF] permettrait non seulement un accès immédiat à la bonne donnée/couleur mais également son incrémentation thread-safe par InterlockedIncrement.

Une petite démo (Delphi) afin d'illustrer tout cela.

Une tâches est créée par cœur.
Chaque tâche tourne en boucle et récupère la prochaine ligne à traiter par InterlockedIncrement.
La couleur du pixel est l'indice dans la table des couleurs. On incrémente aussi cette table par InterlockedIncrement.
La tâche envoie un message par PostMessage à chaque fois qu'une ligne a été traitée (pas de synchronize).

Lorsque la dernière ligne est traitée, la tâche principale parcours la table des couleurs d'un traite et rempli un mémo.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
const
  ON_LINEREADY = WM_APP;
 
type
  TPixelThread = class(TThread)
  private
    Wnd   :hWnd;
    Image :TBitmap;
  protected
    procedure Execute; override;
  public
    constructor Create(aWnd :hWnd; aImage :TBitmap);
  end;
 
  TForm1 = class(TForm)
    Button1: TButton;
    OpenPictureDialog1: TOpenPictureDialog;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    Image     :TBitmap;
    Progress  :integer;
    procedure OnLineReady(var Message :TMessage); message ON_LINEREADY;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
var CurLine :integer;
    Colors  :array[0..$FFFFFF] of integer;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  WICImage :TWICImage;
  i        :integer;
 
begin
  if OpenPictureDialog1.Execute then
  begin
    Caption := 'Démarré...';
 
    Button1.Enabled := FALSE;
 
    CurLine   := -1;
    Progress  := 0;
 
    FillChar(Colors, SizeOf(Colors), #0);
 
    //TWICImage permet de charger différents types d'image (png, jpg, tif, etc.)
    WICImage := TWICImage.Create;
    Image    := TBitmap.Create;
 
    try
      WICImage.LoadFromFile(OpenPictureDialog1.FileName);
      Image.Assign(WICImage);
      Image.PixelFormat := pf32bit;
 
    finally
      WICImage.Free;
    end;
 
    //Ne crée pas plus de tâches que le nombre de coeurs
    for i := 1 to TThread.ProcessorCount do
      TPixelThread.Create(Handle, Image);
  end;
end;
 
procedure TForm1.OnLineReady(var Message: TMessage);
var
  Stream :TStringStream;
  i :integer;
 
begin
  inc(Progress);
 
  //Dernière ligne => traitement
  if Progress = Image.Height then
  begin
    Caption := 'Traitement résultat...';
    Application.ProcessMessages;
 
    //Charger le mémo depuis un stream est autrement
    //plus rapide que d'ajouter ligne par ligne.
    Stream := TStringStream.Create;
 
    try
      for i := 0 to High(Colors) do
        if Colors[i] > 0 then
          Stream.WriteString(Format('%.6x=%d'#13#10, [i, Colors[i]]));
 
      Stream.Position := 0;
      Memo1.Lines.LoadFromStream(Stream);
 
    finally
      Stream.Free;
    end;
 
    Caption := 'Terminé';
 
    Image.Free;
    Button1.Enabled := TRUE;
  end;
end;
 
{ TPixelThread }
 
constructor TPixelThread.Create(aWnd: hWnd; aImage: TBitmap);
begin
  inherited Create;
 
  Wnd   := aWnd;
  Image := aImage;
 
  FreeOnTerminate := TRUE;
end;
 
procedure TPixelThread.Execute;
var
  P    :PInteger;
  Line :integer;
  i    :integer;
 
begin
  while TRUE do
  begin
    //Récupère le n° de la prochaine ligne à traiter
    Line := InterlockedIncrement(CurLine);
 
    if Line >= Image.Height then Break;
 
    P := Image.ScanLine[Line];
 
    for i := 0 to Image.Width -1 do
    begin
      //Incrémente la couleur
      InterlockedIncrement(Colors[P^ and $FFFFFF]);
      inc(P);
    end;
 
    PostMessage(Wnd, ON_LINEREADY, 0, 0);
  end;
end;

**BeanzMaster** · 30/11/2019, 18h52

Bonjour

Envoyé par Andnotor

L'erreur est clairement au niveau de la section critique. Il faut protéger l'écriture mais également la lecture.

Ici, tu parles aussi de la ligne I:= SL.IndexOf(NomCouleur) ?

Envoyé par Andnotor

Sinon quelques trucs à améliorer :

Un point qui va se montrer pénalisant est de créer autant de thread que l'image a de ligne ; dans ton cas @der§en : 2000 !
Il peut être justifié de créer plus de tâches que le nombre de processeurs pour autant que celles-ci soient en attente d'un événement mais pas dans le cas d'une utilisation intensive comme ici.

Ici les "procedure DoParallel" ne créent pas plus de thread que de nombre de processeur. Pourquoi tu dis ça ? un truc dans ce sens que tu as vu ?

Envoyé par Andnotor

Travailler avec une stringlist est très gourmand en temps : décortiquer la chaîne pour retrouver les nom=valeur, réallouer la liste à chaque ajout (si dépassement de capacité de la zone mémoire actuelle), etc.
Un tableau statique d'entier de [0..$FFFFFF] permettrait non seulement un accès immédiat à la bonne donnée/couleur mais également son incrémentation thread-safe par InterlockedIncrement.

Très bonne idée, pour ma part j'ai utilsé ma StringList avec les Hash dont tu m'avais appris comment cela fonctionnait

Envoyé par Andnotor

Une petite démo (Delphi) afin d'illustrer tout cela.

Avec

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
var
  SLColors : Array[0..$FFFFFF] of integer; 
 
procedure TForm1.ProcessLine(y : Integer);
var
  X: DWord;
  L : PBZColor;
begin
  L := BZImageViewer1.Picture.Bitmap.GetScanLine(y);
  For X := 0 to BZImageViewer1.Picture.Bitmap.MaxWidth do
  begin
    InterlockedIncrement(SLColors[L^.AsInteger and $FFFFFF]);
    inc(L);
  end;
end;

C'est clairement plus rapide

Connaissais pas ton astuce avec le TStringStream. Par contre avec Lazarus ListBox1.Items.LoadFromStream(Stream); ne fonctionne pas

mais c'est bon avec La ValueListEditor

@der§en Avec mon exemple, il faut compiler sans le debug. Sinon tu auras un exception de DBG

**der§en** · 30/11/2019, 19h09

Merci à vous de m’éclairer sur tout ces côtés du Multithreads.

Pas trop eu le temps de faire des tests aujourd’hui, mais je regarde tout cela demain

**der§en** · 02/12/2019, 10h31

En adaptant a mes besoins vos routines BeanzMaster et Andnotor dans un traitement DoParallel, cela a été quasi instantané

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
 
var
  Form1: TForm1;
  Colors: array[0..$FFFFFF] of integer;   
 
////////////////////////////////////////////////////////
 
procedure TForm1.FormCreate(Sender: TObject);
var
  Y: integer;
begin
  for Y := 0 to  High(Colors) do
    Colors[Y] := 0;
end;
 
procedure TForm1.Button3Click(Sender: TObject);
var
  Stream: TStringStream;
  i: integer;
begin
  ProcThreadPool.DoParallel(@TraiterUneLigne, 0, Image1.Picture.Height - 1, Image1);
 
  Stream := TStringStream.Create('');
  try
    for i := 0 to High(Colors) do
      if Colors[i] > 0 then
        Stream.WriteString(Format('%.6x=%d'#13#10, [i, Colors[i]]));
 
    Stream.Position := 0;
 
    ValueListEditor1.Strings.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
 
  Label2.Caption := 'Contrôle des couleurs terminés';
end;
 
procedure TForm1.TraiterUneLigne(Index: PtrInt; Data: Pointer; Item: TMultiThreadProcItem);
var
  X: DWord;
  L : PInteger;
begin
  L := Pinteger(TImage(Data).Picture.PNG.RawImage.GetLineStart(Index));
 
  For X := 0 to TImage(Data).Picture.Width - 1 do
  begin
    InterlockedIncrement(Colors[L^ and $FFFFFF]);
 
    inc(L);
  end;
end;

Encore merci a vous

**Andnotor** · 02/12/2019, 12h40

Envoyé par BeanzMaster

Ici, tu parles aussi de la ligne I:= SL.IndexOf(NomCouleur) ?

Oui et cela doit englober tout le code depuis la première lecture jusqu'à la fin de l'écriture.

IndexOf récupère le pointeur sur un tableau dynamique (array of) avant de l'incrémenter pour comparer les chaînes. Si dans le même temps un autre thread ajoute un élément, ce tableau peut être déplacé si la zone mémoire actuelle est trop petite.
Dans le meilleur des cas, IndexOf travaillera alors sur des données obsolètes (si cette zone mémoire n'a pas encore été réallouée) et dans le pire, ben... je te laisse imaginer

Et même si le tableau n'a pas été déplacé, plusieurs tâches pourraient traiter la même couleur au même instant et IndexOf retourner -1 dans plusieurs d'entre elles, la couleur sera alors ajoutée plusieurs fois !

Envoyé par BeanzMaster

Ici les "procedure DoParallel" ne créent pas plus de thread que de nombre de processeur.

Au temps pour moi ! J'ai mal interprété les paramètres (ThreadPool aurait dû faire Tilt! pourtant)