AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren

Multithreading lastet nur 1 Kern aus

Ein Thema von Pussyranger · begonnen am 8. Feb 2012 · letzter Beitrag vom 10. Feb 2012
Antwort Antwort
Seite 1 von 2  1 2   
Benutzerbild von Pussyranger
Pussyranger

Registriert seit: 15. Mär 2011
25 Beiträge
 
Delphi XE2 Architect
 
#1

Multithreading lastet nur 1 Kern aus

  Alt 8. Feb 2012, 22:18
Hallo,

ich arbeite an einem Programm, welches Unterschiede zwischen verschiedenen Bildern zeigen soll.
Da das Vergleichen der Bilder recht rechenaufwendig ist, habe ich das ganze in eine Threadklasse geschrieben, welche die Arbeit auf 4 Threads (so viele Kerne hat meine CPU) aufteilen und die CPU somit voll auslastet soll - so weit der Plan.
Nach etlichem rumprogrammieren (oder eher rumprobieren ) funktioniert das Programm jetzt zumindest.
Ich habe festgestellt, dass ich die zu vergleichenden Bilder nicht als TBitmap übergeben kann, da dieser Typ nicht threadsafe ist. Deshalb habe ich einen Typ Colorarray = array of array of TColor deklariert, in dem die Farbinfos geschrieben werden.
Das Problem ist nun, dass die Threads scheinbar nur im Hauptthread ausgeführt werden, da die CPU-Belastung nie über 25% steigt.
Liegt das daran, dass ich mit dynamischen Arrays arbeite?
LG,

Pussyranger
  Mit Zitat antworten Zitat
Namenloser

Registriert seit: 7. Jun 2006
Ort: Karlsruhe
3.724 Beiträge
 
FreePascal / Lazarus
 
#2

AW: Multithreading lastet nur 1 Kern aus

  Alt 8. Feb 2012, 22:50
Wie startest du die Threads? Meine Vermutung ist, dass du entweder Execute direkt aufrufst oder an den falschen Stellen Synchronize verwendest.
  Mit Zitat antworten Zitat
generic

Registriert seit: 24. Mär 2004
Ort: bei Hannover
2.405 Beiträge
 
Delphi XE5 Professional
 
#3

AW: Multithreading lastet nur 1 Kern aus

  Alt 8. Feb 2012, 23:05
Evtl. Probleme mit dem Speichermanager!

Empfehlung: Nutze die Omnithread Lib. und fastMM4
Coding BOTT - Video Tutorials rund um das Programmieren - https://www.youtube.com/channel/UCUG...aXLclwO9qA-lzA
  Mit Zitat antworten Zitat
Benutzerbild von Sir Rufo
Sir Rufo

Registriert seit: 5. Jan 2005
Ort: Stadthagen
9.454 Beiträge
 
Delphi 10 Seattle Enterprise
 
#4

AW: Multithreading lastet nur 1 Kern aus

  Alt 8. Feb 2012, 23:17
Ich weiß ja nicht wo du die Probleme mit den Bitmaps und dem ThreadSafe hast, es sei denn, du willst jeden Thread auf die gleichen Bitmap-Instanzen zugreifen lassen.

Nehmen wir an die Klasse TBitmap wäre threadsafe und jeder Thread greift auf die beiden TBitmap-Instanzen zu, so können sich diese "gleichzeitigen" Zugriffe gegenseitig blockieren, so dass worst case am Ende immer nur ein Thread arbeitet und die anderen warten, bis sie auf die Instanzen zugreifen dürfen.

Um so eine Aufgabe zu lösen teilt man diese Aufgaben in (in sich abgeschlossene) Unteraufgaben auf und verwaltet diese in einer Warteschlange. Die Threads holen sich jetzt jeweils eine Unteraufgabe ab, verarbeiten diese und liefern das Ergebnis zurück.

Bei einem Bitmap-Vergleich könnte man ja die Ursprungs-Bitmaps in kleine Bitmaps unterteilen und diese vergleichen. Dann ist die Frage, ob TBitmap threadsafe ist, obsolet.
Kaum macht man's richtig - schon funktioniert's
Zertifikat: Sir Rufo (Fingerprint: ‎ea 0a 4c 14 0d b6 3a a4 c1 c5 b9 dc 90 9d f0 e9 de 13 da 60)
  Mit Zitat antworten Zitat
Benutzerbild von Bernhard Geyer
Bernhard Geyer

Registriert seit: 13. Aug 2002
17.103 Beiträge
 
Delphi 10.4 Sydney
 
#5

AW: Multithreading lastet nur 1 Kern aus

  Alt 8. Feb 2012, 23:27
Empfehlung: Nutze die Omnithread Lib. und fastMM4
XE2 - Da ist FastMM4 eingebaut!
Windows Vista - Eine neue Erfahrung in Fehlern.
  Mit Zitat antworten Zitat
generic

Registriert seit: 24. Mär 2004
Ort: bei Hannover
2.405 Beiträge
 
Delphi XE5 Professional
 
#6

AW: Multithreading lastet nur 1 Kern aus

  Alt 9. Feb 2012, 09:35
Empfehlung: Nutze die Omnithread Lib. und fastMM4
XE2 - Da ist FastMM4 eingebaut!
Na ja, in den alten war der auch schon drin, allerdings in einer Sparfassung.

In der FastMM-Config gibt es auch einige Parameter zu Multithreading.
Coding BOTT - Video Tutorials rund um das Programmieren - https://www.youtube.com/channel/UCUG...aXLclwO9qA-lzA
  Mit Zitat antworten Zitat
Medium

Registriert seit: 23. Jan 2008
3.676 Beiträge
 
Delphi 2007 Enterprise
 
#7

AW: Multithreading lastet nur 1 Kern aus

  Alt 9. Feb 2012, 11:28
Ich vermute hier doch eher oberflächlichere Gründe als den MM. Aber so lange wir hier keinen Code sehen, unterstelle ich dem TE einfach mal, dass er an einer Lösung so interessiert dann doch nicht ist
"When one person suffers from a delusion, it is called insanity. When a million people suffer from a delusion, it is called religion." (Richard Dawkins)
  Mit Zitat antworten Zitat
Benutzerbild von Pussyranger
Pussyranger

Registriert seit: 15. Mär 2011
25 Beiträge
 
Delphi XE2 Architect
 
#8

AW: Multithreading lastet nur 1 Kern aus

  Alt 9. Feb 2012, 20:49
Ich weiß ja nicht wo du die Probleme mit den Bitmaps und dem ThreadSafe hast, es sei denn, du willst jeden Thread auf die gleichen Bitmap-Instanzen zugreifen lassen.
Ich weiß nicht mehr, wieso es mit Bitmaps nicht funktioniert hat. Aber als ich es mit Colorarrays probiert habe und das sogar schneller war als mit Bitmaps, war mir das auch egal.

Hier der Quellocode:

Unit1 (Threadaufruf):
Delphi-Quellcode:
var
  Thread: array of TDifference_Finder;
  ThreadsRunning,ges,Durchzaehler: integer;

{...}

function BitmapToArrayofColor(Bitmap: TBitmap):Colorarray;
VAR i,j: integer;
begin
  SetLength(result, Bitmap.Width, Bitmap.Height);
  for i := 0 to Bitmap.Width-1 do
    for j := 0 to Bitmap.Height-1 do
      result[i,j]:=Bitmap.Canvas.Pixels[i,j];
end;

function ArrayofColorToBitmap(AoC: ColorArray):TBitmap;
VAR i,j: integer;
begin
  result:=TBitmap.Create;
  result.Width:=Length(AoC);
  result.Height:=Length(AoC[0]);
  for i := 0 to Length(AoC)-1 do
    for j := 0 to Length(AoC[0])-1 do
      result.Canvas.Pixels[i,j]:=AoC[i,j];
end;

procedure TForm1.ThreadDoneD(Sender: TObject);
begin
  Dec(ThreadsRunning);
end;

function Unterschiede_markieren(Bild1, Bild2: TBitmap; Blend: Real; Toleranz: Byte):TBitmap;
VAR i,j,Breite,Hoehe,Itert: integer;
begin
  ThreadCount:=4;
  SetLength(Thread, ThreadCount);

  result:=TBitmap.Create;
  SetLength(fertig_bild,Min(Bild1.Width,Bild2.Width),Min(Bild1.Height,Bild2.Height));
  ThreadsRunning:=ThreadCount;

  for i := 0 to ThreadCount-1 do
  begin
    Thread[i]:=TDifference_Finder.Create(BitmapToArrayofColor(Bild1), BitmapToArrayofColor(Bild2), Round(i*(Min(Bild1.Width,Bild2.Width))/ThreadCount), Round((i+1)*(Min(Bild1.Width,Bild2.Width)-1)/ThreadCount), Blend, Toleranz, true);
    Thread[i].OnTerminate:=Form1.ThreadDoneD;
    Thread[i].FreeOnTerminate:=true;
    Thread[i].Resume;
  end;
  while ThreadsRunning > 0 do Application.ProcessMessages;
  result:=ArrayofcolorToBitmap(fertig_Bild);
end;
TDifference_Finder:
Delphi-Quellcode:
unit Difference_Finder;

interface

uses
  Windows,Classes, SysUtils, Graphics, Math, JPEG, Unit3;
type
  TDifference_Finder = class(TThread)
  private
    Bild1t, Bild2t, Finish: Colorarray;
    StartXt, EndXt: integer;
    Blendt: Real;
    Toleranzt: Byte;
  protected
    procedure Execute; override;
    procedure fertig;
    procedure Diff;
    function Toleranz_pruefen(C1, C2: TColor; Toleranz: Byte):boolean;
    function ColorBetween(C1, C2: TColor; blend: Real):TColor;
    procedure TColor2RGB(Color: TColor; VAR R, G, B: Byte);
    function RGB2TColor(R, G, B: Byte): Integer;
    function Differenz_finden(C1, C2: TColor; Blend: real; Toleranz: Byte):TColor;
  public
    constructor Create(Bild1, Bild2: Colorarray; StartX, EndX: integer; Blend: Real; Toleranz: Byte; CreateSuspended: Boolean);
  end;

implementation

constructor TDifference_Finder.Create(Bild1, Bild2: Colorarray; StartX, EndX: integer; Blend: Real; Toleranz: Byte; CreateSuspended: Boolean);
begin
  Bild1t:=Bild1;
  Bild2t:=Bild2;
  StartXt:=StartX;
  EndXt:=EndX;
  Blendt:=Blend;
  Toleranzt:=Toleranz;
  inherited Create(True);
end;

function TDifference_Finder.ColorBetween(C1, C2: TColor; blend: Real):TColor;
VAR R, G, B, y1, y2: Byte;
begin
   C1:=ColorToRGB(C1);
   C2:=ColorToRGB(C2);
   y1:=GetRValue(C1);
   y2:=GetRValue(C2);
   R:=Round(y1 + (y2-y1)*blend);
   y1:=GetGValue(C1);
   y2:=GetGValue(C2);
   G:=Round(y1 + (y2-y1)*blend);
   y1:=GetBValue(C1);
   y2:=GetBValue(C2);
   B := Round(y1 + (y2-y1)*blend);
   result:=RGB(r, g, b);
end;

procedure TDifference_Finder.TColor2RGB(Color: TColor; VAR R, G, B: Byte);
begin
  if Color SHR 24 = $FF then Color:=GetSysColor(Color AND $FF)
  else if Color SHR 24 > $02 then Color := 0;
  R:=Color;
  G:=(Color SHR 8);
  B:=(Color SHR 16);
end;

function TDifference_Finder.RGB2TColor(R, G, B: Byte): Integer;
begin
  result:=R OR (G SHL 8) OR (B SHL 16);
end;

function TDifference_Finder.Differenz_finden(C1, C2: TColor; Blend: real; Toleranz: Byte):TColor;
VAR R1,G1,B1,R2,G2,B2: Byte; Proz: extended;
begin
  TColor2RGB(C1,R1,G1,B1);
  TColor2RGB(C2,R2,G2,B2);
  Proz:=0;
  Proz:=Proz+33.33*(((Abs(R1-R2)))/255);
  Proz:=Proz+33.33*(((Abs(G1-G2)))/255);
  Proz:=Proz+33.33*(((Abs(B1-B2)))/255);

  Proz:=Proz-Toleranz;
  if Proz < 0 then Proz:=0;

  if Proz < 50 then result:=RGB2TColor(Round(Proz/100*255),255,0)
  else if Proz > 50 then result:=RGB2TColor(255,255-Round(Proz/100*255),0);
  result:=ColorBetween(result, C2, 1-Blend);
end;

function TDifference_Finder.Toleranz_pruefen(C1, C2: TColor; Toleranz: Byte):boolean;
VAR R1,G1,B1,R2,G2,B2: Byte; Proz: extended;
begin
  TColor2RGB(C1,R1,G1,B1);
  TColor2RGB(C2,R2,G2,B2);
  Proz:=0;
  Proz:=Proz+33.33*(((Abs(R1-R2)))/255);
  Proz:=Proz+33.33*(((Abs(G1-G2)))/255);
  Proz:=Proz+33.33*(((Abs(B1-B2)))/255);

  if Proz <=Toleranz then result:=true else result:=false;
end;

procedure TDifference_Finder.fertig;
VAR i,j:integer;
begin
  for i := StartXt to EndXt do
    for j := 0 to Length(fertig_Bild[0]) do
      fertig_Bild[i,j]:=Finish[i-StartXt,j];
end;

procedure TDifference_Finder.Diff; //<---------------- hier findet der Vergleich statt
VAR i,j: integer;
begin
  SetLength(Finish, EndXt-StartXt+1, Min(Length(Bild1t[0]),Length(Bild2t[0])));

  for i := StartXt to EndXt do
    for j := 0 to Length(Bild2t[0]) do
      if Toleranz_pruefen(Bild1t[i,j], Bild2t[i,j], Toleranzt) then Finish[i-StartXt,j]:=Bild2t[i,j]
      else Finish[i-StartXt,j]:=Differenz_finden(Bild1t[i,j],Bild2t[i,j], Blendt, Toleranzt);
end;

procedure TDifference_Finder.Execute;
begin
  Diff;
  Synchronize(fertig);
end;

end.
Unit3 (Unit1 und TDifference_Finder haben darauf zugriff):
Delphi-Quellcode:
unit Unit3;

interface

uses Vcl.Graphics;

type Colorarray = array of array of TColor;

VAR fertig_Bild: Colorarray; ThreadCount: integer;

implementation

end.
Angehängte Dateien
Dateityp: rar Difference Finder.rar (4,63 MB, 10x aufgerufen)

Geändert von Pussyranger ( 9. Feb 2012 um 20:52 Uhr)
  Mit Zitat antworten Zitat
Namenloser

Registriert seit: 7. Jun 2006
Ort: Karlsruhe
3.724 Beiträge
 
FreePascal / Lazarus
 
#9

AW: Multithreading lastet nur 1 Kern aus

  Alt 9. Feb 2012, 21:13
Hast du mal gemessen, welcher Teil des Codes welchen Anteil an der Gesamtlaufzeit hat? Vielleicht sind die Threads so schnell fertig, dass du davon gar nichts bemerkst, aber der Rest, der im Main-Thread läuft, braucht die meiste Zeit. Kann sein, dass du hier die völlig falsche Stelle optimiert hast! Ein Tipp, um in Zukunft gleich den Flaschenhals zu finden: Sampling Profiler. (Bei Benutzung in den Compiler-Optionen unbedingt die Mapfile-Generierung aktivieren, sonst hast du sehr wenig davon).

Delphi-Quellcode:
function BitmapToArrayofColor(Bitmap: TBitmap):Colorarray;
VAR i,j: integer;
begin
  SetLength(result, Bitmap.Width, Bitmap.Height);
  for i := 0 to Bitmap.Width-1 do
    for j := 0 to Bitmap.Height-1 do
      result[i,j]:=Bitmap.Canvas.Pixels[i,j];
end;

function ArrayofColorToBitmap(AoC: ColorArray):TBitmap;
VAR i,j: integer;
begin
  result:=TBitmap.Create;
  result.Width:=Length(AoC);
  result.Height:=Length(AoC[0]);
  for i := 0 to Length(AoC)-1 do
    for j := 0 to Length(AoC[0])-1 do
      result.Canvas.Pixels[i,j]:=AoC[i,j];
end;
Das wären so Kandidaten. Der Zugriff über TCanvas.Pixels ist nämlich unheimlich lahm. Schau dir mal TBitmap.Scanline an. Damit kannst du dir wahrscheinlich auch dein ColorArray sparen. Allerdings musst du das Bitmap dann zeilenweise bearbeiten – aktuell scheinst du ja spaltenweise vorzugehen (was übrigens auch aus Caching-Gründen ineffizient ist, da das Bitmap zeilenweise im Speicher liegt. Sprich: eine Bildzeile kann einfach „in einem Rutsch“ eingelesen werden, während bei Pixeln aus verschiedenen Zeilen immer hin und her gesprungen werden muss. Das dürfte hier zwar kaum ins Gewicht fallen, weil andere Stellen viel stärker bremsen, aber dennoch kann man es mal erwähnen).
  Mit Zitat antworten Zitat
Benutzerbild von Pussyranger
Pussyranger

Registriert seit: 15. Mär 2011
25 Beiträge
 
Delphi XE2 Architect
 
#10

AW: Multithreading lastet nur 1 Kern aus

  Alt 10. Feb 2012, 14:25
Danke! Ich hatte überhaupt nicht damit gerechnet, dass es an der Umwandlung liegt :O
Der Geschwindigkeitsunterschied ist gigantisch Leider sind die Threads jetzt absolut überflüssig ^^

Habe den Code jetzt angespasst, aber bei der Rückumwandlung vom Colorarray zum Bitmap gibts jedoch noch einen kleinen Fehler, da das Bild einen gelbstich hat:
Delphi-Quellcode:
procedure TColor2RGB(Color: TColor; VAR R, G, B: Byte);
begin
  if Color SHR 24 = $FF then Color:=GetSysColor(Color AND $FF)
  else if Color SHR 24 > $02 then Color := 0;
  R := Color;
  G := (Color shr 8);
  B := (Color shr 16);
end;

function ArrayofColorToBitmap(AoC: ColorArray):TBitmap;
type
  PixArray = Array [1..3] of Byte;
VAR i,j:integer; p: ^PixArray; R,G,B: Byte;
begin
  result:=TBitmap.Create;
  result.PixelFormat := pf24Bit;
  result.Width:=Length(AoC);
  result.Height:=Length(AoC[0]);
  for i := 0 to Length(AoC[0])-1 do
  begin
    p:= result.ScanLine[i];
    for j := 0 to Length(AoC)-1 do
    begin
      TColor2RGB(Aoc[j,i], R, G, B);
      p^[1]:=B; //<-------- die Kanäle sind schon vertauscht
      p^[2]:=G;
      p^[3]:=R;
      Inc(p);
    end;
  end;
end;
Woran liegt das?
  Mit Zitat antworten Zitat
Antwort Antwort
Seite 1 von 2  1 2   

Themen-Optionen Thema durchsuchen
Thema durchsuchen:

Erweiterte Suche
Ansicht

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 09:54 Uhr.
Powered by vBulletin® Copyright ©2000 - 2022, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2021 by Daniel R. Wolf