TThread terminate in FormClose (gelöst)

[mse]

@Hitman
Das hab ich oben schon mehrmals erwähnt. 'WaitFor' funktioniert nur auf Windows, nicht auf Unix (Linux/Mac). Wäre schön, wenn es sowas auch dort gäbe, aber das kneift sich wohl mit der grundsätzlich anderen Organisation von Threads (Prozesse).

Das geht schon, tmsethread nützt ein Semaphor um plattformunabhängig zu sein:

Code: Alles auswählen

function tmsethread.waitfor: integer;
begin
 if ts_started in fstate then begin
  exclude(fstate,ts_started);
  sys_semwait(fwaitforsem,0);
 end;
 result:= fexecresult;
end;

Dann gibt es noch sys_threadwaitfor():

Code: Alles auswählen

function sys_threadwaitfor(var info: threadinfoty): syserrorty;
begin
{$ifdef FPC}
 waitforthreadterminate(info.id,0);
 result:= sye_ok;
{$else}
  result:= syeseterror(pthread_join(info.id,nil));
{$endif}
end;

FPC waitforthreadterminate() für Linux ruft ebenfalls die procedure pthread_join() auf, welche auf das Beenden des thread wartet.

[wolf_z]

@mse "waitforthreadterminate" funktioniert bei mir leider nicht. Während es bei Windows durchläuft, egal ob ein timeout gesetzt ist oder nicht, blockiert es unter Linux komplett. Die Lösung mit dem Semaphore hab ich jetzt nicht weiter verfolgt, weil ich nämlich noch einen kleinen Fehler in meinem Programm gefunden habe und daran lags.

Im Grunde verwende ich jetzt den gleichen Mechanismus wie beim Semaphore nur nicht so doll abgesichert. Ich beende die Threads, und zwar sowohl die Parallelen als auch den Haupt-Thread, indem ich in einer while-Schleife auf terminated (parallele Threads) bzw. das 'onTerminated'-Ereignis des Hauptthreads warte. Der Hauptthread ist ja nur ein einzelner, so dass hier keine CriticalSections oder ähnliches erforderlich sind. Ich muss das mit 'onTerminated' machen, weil terminated 'protected' ist und ich somit im Hauptformular in 'Formclose' nicht darauf zugreifen kann.

Lange Rede kurzer Sinn hier noch mal den fertigen Source-Code, der auf Windows, Linux und Mac läuft. Interessant dabei die Abhängigkeit vom eingestellten Widget-Set. Für gtk2/windows musste ich ein quick&dirty work-around machen, weil 'onTerminated' dort nicht ausgelöst wird. Dafür habe ich einfach in die while-Schleife einen Zähler eingebaut, so dass nach einer bestimmten Zeit nicht mehr auf 'terminated' gewartet wird. Unter Windows ist das nicht so schlimm, weil durch solche Unsauberkeiten in Formclose keine Exception ausgelöst wird.

So jetzt hier nochmal der Source-Code. Meiner Meinung nach das erste Beispiel für FPC-Threads, dass wirklich auf Cross-Compatibilität getestet ist , zumindest, was man so im Internet findet. Das, was ich so an Beispielen gefunden habe, war absoluter Schrott, weil immer nur für eine Plattform. Aber ihr habt ja bestimmt auch tolle Lösungen in der Schublade liegen

Das Beispiel kann man auch downloaden (s. Dateianhang ganz unten). Verbesserungen würden mich schon interessieren

Formular (Es ist noch ein Button 'Overkill' hinzugekommen und ein Tlabel für die Anzahl der 'Leben':

Code: Alles auswählen

unit formworld;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  {$IFDEF FPC}
  LCLIntf, LResources,
  {$ENDIF}
  Classes, SysUtils, eventlog, FileUtil, Forms, Controls, Graphics, Dialogs,
  StdCtrls, ExtCtrls, Spin, Buttons, ComCtrls, ActnList, uthreadworld;
 
type
 
  { Tfrm_god }
 
  Tfrm_god = class(TForm)
    btn_overkill: TButton;
    Label2: TLabel;
    lb_lifes: TLabel;
    Panel1:TPanel;
    Label1:TLabel;
    btn_newLife:TButton;
    btn_fire:TButton;
    btn_terminate:TButton;
    mm_world: TMemo;
    GroupBox1: TGroupBox;
    Timer1: TTimer;
    procedure btn_fireClick(Sender: TObject);
    procedure btn_newLifeClick(Sender: TObject);
    procedure btn_overkillClick(Sender: TObject);
    procedure btn_terminateClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
    procedure Timer1Timer(Sender: TObject);
  private
    FWorld: TWorldThread;
    FDestroyed: boolean;
    procedure worldDestroyed(Sender: TObject);
  public
    { public declarations }
  end; 
 
var
  frm_god: Tfrm_god;
 
implementation
 
{ Tfrm_god }
 
 
procedure Tfrm_god.Timer1Timer(Sender: TObject);
begin
  if FWorld = nil then
     exit;
  mm_World.lines.clear;
  mm_World.lines.text := FWorld.View;
  lb_lifes.caption := IntToStr(FWorld.lifes);
end;
 
procedure Tfrm_god.btn_newLifeClick(Sender: TObject);
begin
  if FWorld = nil then
     begin
     FWorld := TWorldThread.create;
     FDestroyed := false;
     FWorld.OnTerminate := @worldDestroyed;
     FWorld.Resume;
     end;
  if not timer1.enabled then
     timer1.enabled := true;
  FWorld.newLife;
end;
 
procedure Tfrm_god.btn_fireClick(Sender: TObject);
begin
  FWorld.fire;
end;
 
procedure Tfrm_god.btn_terminateClick(Sender: TObject);
begin
  FWorld.terminateAllLifes;
end;
 
// Attention: this 'onTerminated' method will not be reached under:
//            gtk2/Windows
//            No Problems under:
//            gtk2/Linux, win32/win64, qt(beta)/windows, carbon
//            Not testet under:
//            qt(beta)/linux, qt(beta)/Mac
procedure Tfrm_god.worldDestroyed(Sender: TObject);
begin
  FDestroyed := true;
end;
 
 
procedure Tfrm_god.btn_overkillClick(Sender: TObject);
var co:integer; res:DWord;
begin
  timer1.enabled := false;
 
 (*   FWorld.overkill;  // such a solution or similar doesn't work!
    FWorld.terminate;
    res := WaitForThreadTerminate(FWorld.handle, 0);
    freeAndNil(FWorld);
    FWorld := nil;
    exit;    *)
 
  co := -99;
  if FWorld <> nil then
     begin
     FWorld.overkill;
     // freeAndNil(FWorld);  // Very important: not here! If I need
                             // 'onTerminated' then I should not
                             // destroy the object here, because
                             // a destroyed object can't send events !
                             // Therefore I have to terminate 'FWorld' with
                             // 'freeOnTerminate' or to freeAndNil it later!
     co := 1000;
     while not FDestroyed do
        begin
        Application.processMessages;  // Very important!
        sleep(1);
        dec(co);
        if co <= 0 then
           break;
        end;
     Application.processMessages;     // Here too! Very important!
     freeAndNil(FWorld);
     FWorld := nil;
     mm_World.lines.clear;
     lb_lifes.caption := '0';
     end;
  // EventLog1.log('overkillClick exit - co: ' + intToStr(co));
end;
 
procedure Tfrm_god.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
  // EventLog1.active := true;
  btn_overkillClick(nil);
  CanClose := FWorld = nil;
end;
 
 
initialization
  {$I formworld.lrs}
end.

Unit uthreadworld

Code: Alles auswählen

unit uthreadworld;
 
{$mode objfpc}{$H+}
 
interface
 
uses               // -dUseCThreads
  LCLIntf, Classes, Sysutils, Dialogs
  {, Forms // Threads should not use unit forms}
  ;
 
Const
 
  wrSignaled = 0;
  wrTimeout  = 1;
  wrAbandoned= 2;
  wrError    = 3;
 
  tsleep = 1;
 
type
  TWorldThread = class;
 
  { TLifeThread }
 
  // Simple thread model for parallel running
  TLifeThread = class(TThread)
  private
    _fireEvent:pEventState;
    _killEvent:pEventState;
  public
    Value:extended;
    FWorld:TWorldThread;
    constructor create(owner:TWorldThread); overload;
    destructor destroy; override;
    procedure Execute; override;
  end;
 
  // Simple parallel threads
 
  { TWorldThread }
 
  TWorldThread = class(TThread)
  private
    FList:TList;
    FView:TStringList;
    FLocked:boolean;
    FThreadsRunning:integer;
    function getView:string;
    procedure lifeTerminated(Sender: TObject);
  public
    _worldKillEvent:pEventState;
    constructor create; overload;
    destructor destroy; override;
    procedure Execute; override;
    procedure fire;
    procedure overkill;
    procedure terminateAllLifes;
    procedure newLife;
    property View:string read getView;
    property Lifes:integer read FThreadsRunning;
  end;
 
implementation
 
{ TLifeThread }
 
constructor TLifeThread.create(owner:TWorldThread);
begin
  inherited create(true {suspended});
  FWorld := owner;
  _fireEvent := BasicEventCreate(nil,false,false,'');
  _killEvent := BasicEventCreate(nil,false,false,'');
end;
 
destructor TLifeThread.destroy;
begin
  basiceventdestroy(_fireEvent);
  basiceventdestroy(_killEvent);
  inherited;
end;
 
procedure TLifeThread.Execute;
var res:longint;
begin
  while not Terminated do
     begin
     res := basiceventWaitFor(1000, _fireEvent);
     if res = wrSignaled then
        begin
        basiceventResetEvent(_fireEvent);
        Value := 0;
        end
     else
        Value := Value + 1;
     res := basiceventWaitFor(10, _killEvent);
     if res = wrSignaled then
        begin
        basiceventResetEvent(_killEvent);
        terminate;
        break;
        end;
     end;
end;
 
{ TWorldThread }
 
constructor TWorldThread.create;
begin
  FList := TList.create;
  FView := TStringList.create;
  _worldKillEvent := BasicEventCreate(nil,false,false,'');
  inherited create (false {suspended});
end;
 
destructor TWorldThread.destroy;
begin
  basiceventdestroy(_worldKillEvent);
  FList.free;
  FView.free;
  inherited;
end;
 
procedure TWorldThread.Execute;
var res:longint;
begin
  while not Terminated do
     begin
     res := basiceventWaitFor(10, _worldKillEvent);
     if res = wrSignaled then
        begin
        basiceventResetEvent(_worldKillEvent);
        terminate;
        break;
        end;
     end;
end;
 
function TWorldThread.getView:string;
var i:integer;
begin
  if FLocked then
     exit;
  FLocked := true;
  try
    FView.clear;
    For i := 0 to self.FList.count - 1 do
       FView.add(floatToStr(TLifeThread(self.FList[i]).Value));
    Result := FView.text;
  finally
    FLocked := false;
  end;
end;
 
procedure TWorldThread.newLife;
var aNewLife:TLifeThread;
begin
  aNewLife := TLifeThread.Create(self);
  // This code will assure that any exception which occurred during thread
  // creation will be raised in the WorldThread:
  if Assigned(aNewLife.FatalException) then
      raise aNewLife.FatalException;
  aNewLife.onTerminate := @lifeTerminated;
  FList.add(aNewLife);
  inc(FThreadsRunning);
  aNewLife.resume;
end;
 
procedure TWorldThread.fire;
var ix:integer;
begin
  ix := random(FList.count);
  basiceventSetEvent(TLifeThread(self.FList[ix])._fireEvent);
end;
 
procedure TWorldThread.lifeTerminated(Sender: TObject);
begin
  InterLockedDecrement(FThreadsRunning);
  // FList.remove(Sender); // dangerous! unknown position in 'FList'!
end;
 
procedure TWorldThread.terminateAllLifes;
var i, co:integer; aThread:TLifeThread;
begin
  while FLocked do sleep(1);
  try
    FLocked := true;
    for i := FList.count - 1 downto 0 do
       begin
       aThread := TLifeThread(self.FList[i]);
       aThread.freeOnTerminate := true;
 
       // works on Windows but not on Mac / Linux:
       // aThread.terminate;
       // aThread.waitFor;  // -> exception! ThreadExample in Lazarus Wiki is wrong:
                            // http://wiki.lazarus.freepascal.org/Manager_Worker_Threads_System" onclick="window.open(this.href);return false;
 
       // works on both (Windows / Unix)
       basiceventSetEvent(TLifeThread(self.FList[i])._killEvent);
       co := 1000;
       while not aThread.terminated do
          begin
          sleep(1);
          dec(co);
          if co <= 0 then
             break;
          end;
       FList.delete(i);
       end;
  finally
    FLocked := false;
  end;
end;
 
procedure TWorldThread.overkill;
var Res:DWord;
begin
  terminateAllLifes;
  // FWorld.terminate; // unsure here! Place it in the loop of 'execute':
  freeOnTerminate := false;
  basiceventSetEvent(_worldKillEvent);
  while not terminated do sleep(1);
end;
 
end.

Übrigens ist auch bei diesem Beispiel die Anzahl der maximal möglichen Threads beim Mac sehr beschränkt. Ich kann maximal nur etwa 70 Threads erzeugen. Aber mit dem Mac-Lazarus habe ich sowieso noch zur Zeit Schwierigkeiten. Z.B. läuft der Debugger dort nicht und ansonsten ist das Ding auch ziemlich wackelig.

Übrigens. Das Progamm läuft eindeutig am fixesten auf Linux! Das hab ich auf dem gleichen Rechner wie Windows. Linux scheint also effizienter zu sein als Windows, aber das nur nebenbei.

[Patito]

Sorry, aber das sieht für mich jetzt eher noch schlimmer aus als vorher.

Du machst da folgende Sachen:
1) Einem FreeOnTerminate-Thread sein Kill-Event senden und danach noch auf seinen Speicher zugreifen
2) Die Probleme verschleiern mit:
a) Busy-Waits
b) Sleep()
c) Katastrophen wie:

Code: Alles auswählen

Application.processMessages;     // Here too! Very important!

Was den Programmablauf dann endgültig ruiniert.

... so geht das mit den Threads einfach nicht...

[wolf_z]

Du machst da folgende Sachen:
1) Einem FreeOnTerminate-Thread sein Kill-Event senden und danach noch auf seinen Speicher zugreifen
2) Die Probleme verschleiern mit:
a) Busy-Waits
b) Sleep()
c) Katastrophen wie:

Code: Alles auswählen

Application.processMessages;     // Here too! Very important!

Was den Programmablauf dann endgültig ruiniert.

Zu 1: Da hast Du Recht, das habe ich auch schon geändert. Ich bin nur noch nicht dazu gekommen, das hier zu korrigieren.

Code: Alles auswählen

procedure TWorldThread.lifeTerminated(Sender: TObject);
begin
  InterLockedDecrement(FThreadsRunning);
  // FList.remove(Sender); // dangerous! unknown position in 'FList'!
end;   
 
procedure TWorldThread.terminateAllLifes;
var i, co:integer; aThread:TLifeThread;
begin
  while FLocked do sleep(1);
  try
    FLocked := true;
    for i := FList.count - 1 downto 0 do
       begin
       aThread := TLifeThread(self.FList[i]);
       aThread.freeOnTerminate := true;
 
       // works on Windows but not on Mac / Linux:
       // aThread.terminate;
       // aThread.waitFor;  // -> exception! ThreadExample in Lazarus Wiki is wrong:
                            // http://wiki.lazarus.freepascal.org/Manager_Worker_Threads_System" onclick="window.open(this.href);return false;
 
       // works on both (Windows / Unix)
       basiceventSetEvent(TLifeThread(self.FList[i])._killEvent);
       sleep(1);
       end;
    // Don't implement a alternative to 'waitFor' here!
    // Test on 'FThreadsRunning > 0' in a while loop in the mainForm instead!
    // lifeTerminated will be reached on a 'peekMessage' in the applications idle
    // loop. But this method works only on Windows. Therefore you have to do
    // something in the main application before the 'onTerminate'-event from a 
    // terminated thread will be reached.
    FList.clear;
  finally
    FLocked := false;
  end;
end;

Zu 2 - Busy-Waits) Da behalte ich wenigsten den Überblick im Gegensatz zu CriticalSection, Semaphoren, Mutexe und was es da sonst noch für Zeugs gibt. Irgendwo habe ich auch gelesen, dass das gar kein so schlechter Programmierstil ist. Aber man liest ja vieles, das geb ich zu. Eigentlich funktionieren diese Konstrukte ziemlich gut und bewahren das Programm vor jede Menge Zugriffskonflikten. Aber Du könntest insofern Recht haben, als ich vor allem wohl noch das Hochzählen der Threadvaribalen 'Value := Value + 1' bzw 'Value=0' in 'execute' mit EnterCriticalSection, etc absichern muss.

Zu 2 - Sleep) Ok, die habe ich auch nur drin, entweder für timeouts oder weil ich sie vergessen habe Vielleicht auch, weil ich mir was davon versprochen haben, _killEvents nicht so schnell hintereinander abzuschicken. Aber zugegeben, etwas intuitiv gesetzt.

zu 2 - Application.processMessages) Das ist das zentrale Problem, das ich habe. Ich habe meiner Meinung nach nur eine Möglichkeit, festzustellen, ob das Objekt terminiert wurde (was ich ja in FormClose unbedingt wissen muss) und das ist das 'onTerminate'-Event. Das wird aber erst dann ausgeführt, wenn sich die Gui des Hauptprogramms wieder in der Idle-Loop befindet. In Windows dagegen brauche ich nicht erst im Hauptprogramm 'Application.processMessages' im Hauptformular (bzw. dort in einer Whileschleife darauf warten, dass FThreadsRunning = 0 wird), weil ich da mit waitFor oder analogen Methoden arbeiten kann, die ja auch nichts anderes machen, als die interne Botschaften abzuarbeiten. Aber unter Unix kann ich das nicht. Da muss ich quasi die Botschaftsverwaltung des jeweiligen Widgetsets "mißbrauchen", damit überhaupt vom Thread das 'onTerminate' Event ausgelöst wird und ich dann über den Zähler FThreadsRunning = 0 prüfen kann, ob alle Threads beendet sind.

Dass das Quick & Dirty ist, weiß ich auch. Aber wenn mir einer zeigt, wie ich unter Unix korrekt waitFor oder ähnliches in FormClose verwenden kann, geh ich in Sack und Asche!

In sämtlichen Beispielen, die man zu Threads findet, werden überhaupt keine Maßnahmen getroffen, die laufenden Threads im FormClose gezielt zu beenden.

Man kann natürlich Thread-Programme so schreiben, dass keine Threads mehr laufen, wenn der User das Formular schließt. Man kann eventuell auch Threads so schreiben, dass sie gar keine Objekte enthalten, die aufgeräumt werden müssen. Solche Threads verwalten dann Datenobjekte in irgendwelchen Listen des Hauptthreads und bestehen dann quasi nur aus Programmcode, nicht aus Daten und der Zugriff darauf wird mit CriticalSection abgesichert.

Aber wenn es nicht verboten ist, dass Threads parallel laufen und auf Aufgaben warten, anstatt sich nach jeder Task aufzulösen und wenn es nicht verboten ist, dass Threads auch Datenobjekte enthalten können, dann muss es auch eine Möglichkeit geben, festzustellen, dass Threads definitiv terminiert sind. In Windows geht das mit 'waitFor' und ähnlichem. In Unix funktiert das aber nicht

Übrigens wird in dem Beispielcode im Lazarus-Wiki (s. Posting weiter oben) das Programm auch nicht korrekt beendet. Das Beispiel funktioniert nur unter Windows korrekt. Unter Linux wird an der Stelle mit 'waitFor' eine Exception ausgelöst, die im frei laufenden Programm wahrscheinlich nur zufällig keine Folgen hat.

Ich hab das geänderte Programm hier nochmal im Anhang eingestellt (wer mal probieren möchte).

Nachtrag: Die 'FLocks:=true' und die 'sleep(1)' kann man auch überall ausixen. Dann läufts auch. Hab ich aber nur unter Windows getestet jetzt.

[Patito]

Hm. Werde mir das alles wohl doch noch genauer ansehen müssen...

Musst Du wirklich auf das absolute Ende der Threads warten? D.h:
(a) alles komplett freigegeben und alle Stacks sind schon komplett aufgeräumt.
oder reicht
(b) Threads haben ihre Daten komplett aufräumt und interagieren nicht mehr mit der Außenwelt.

Falls (b) reicht könntest Du ja sowas in die Ereignisbehandlung des _killEvent hängen:

Code: Alles auswählen

if res = wrSignaled then
begin
  basiceventResetEvent(_killEvent);
  terminate;
 
   // Alle Daten aufräumen (Daten freigeben, überall abmelden, ...)
  IrgendeinCleanUp();
 
  // Master-Thread über das Ende Informieren. Eventuell einen Threadsicheren Counter hochzählen,
  // damit der Master-Thread weiss, dass alles erledigt ist. FormClose wartet auf Counter = Thread-Anzahl.
  IrgendeinNotifyMasterThread(); 
  break; // Das hier läuft dann eventuell noch nach dem FormClose. Stack aufräumen und Destruktor vom Thread kommen noch etwas später.
end;

[mse]

Ich habe die Diskussion zum Anlass genommen, ein kleines Demo-Programm mit MSEgui tthreadcomp zusammenzustellen:
http://msedocumenting.svn.sourceforge.n ... /multiple/

Benötigt MSEide+MSEgui SVN trunk Version.

Code: Alles auswählen

unit main;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
 mseglob,mseguiglob,mseguiintf,mseapplication,msestat,msemenus,msegui,
 msegraphics,msegraphutils,mseevent,mseclasses,mseforms,msedataedits,mseedit,
 msestrings,msetypes,msesimplewidgets,msewidgets,msegrids,msestatfile,
 msethreadcomp;
 
type
 threadcomparty = array of tthreadcomp;
 
 tmainfo = class(tmainform)
   threadcount: tintegeredit;
   tbutton1: tbutton;
   tbutton2: tbutton;
   threadnum: tintegeredit;
   list: tstringgrid;
   tbutton3: tbutton;
   tstatfile1: tstatfile;
   procedure doexecute(const sender: tthreadcomp);
   procedure dostart(const sender: tthreadcomp);
   procedure doterminate(const sender: tthreadcomp);
   procedure createexe(const sender: TObject);
   procedure destroyexe(const sender: TObject);
   procedure posteventexe(const sender: TObject);
  private
   fthreads: threadcomparty;
   procedure listmessage(const sender: tthreadcomp; const amessage: msestring);
 end;
var
 mainfo: tmainfo;
implementation
uses
 main_mfm,sysutils;
 
procedure tmainfo.listmessage(const sender: tthreadcomp; const amessage: msestring);
begin
 if not application.terminated then begin
  list.appendrow('<'+inttostr(sender.tag)+'>'+' '+amessage+'.');
  list.showlastrow;
 end;
end;
 
procedure tmainfo.doexecute(const sender: tthreadcomp);
var
 event1: tevent;
begin
 with sender do begin
  while not terminated do begin
   event1:= waitevent; 
   if event1 <> nil then begin
    event1.destroy;
    application.lock;
    try
     listmessage(sender,'event received');
    finally
     application.unlock;
    end;
   end;
  end;
 end;
end;
 
procedure tmainfo.dostart(const sender: tthreadcomp);
begin 
 //application is locked in onstart, GUI-elements are accessible
 listmessage(sender,'started');
end;
 
procedure tmainfo.doterminate(const sender: tthreadcomp);
begin
 //application is locked in onterminate, GUI-elements are accessible
 listmessage(sender,'terminated');
end;
 
procedure tmainfo.createexe(const sender: TObject);
var
 int1: integer;
begin
 destroyexe(nil);
 setlength(fthreads,threadcount.value);
 for int1:= 0 to high(fthreads) do begin
  fthreads[int1]:= tthreadcomp.create(self);
  with fthreads[int1] do begin
   tag:= int1;
   onstart:= @dostart;
   onexecute:= @doexecute;
   onterminate:= @doterminate;
   active:= true;
  end;
 end;
end;
 
procedure tmainfo.destroyexe(const sender: TObject);
var
 int1: integer;
begin
 for int1:= 0 to high(fthreads) do begin
  freeandnil(fthreads[int1]);
 end;
 fthreads:= nil;
end;
 
procedure tmainfo.posteventexe(const sender: TObject);
begin
 if (threadnum.value < 0) or (threadnum.value >= high(fthreads)) or
     (fthreads[threadnum.value] = nil) then begin
  showerror('Invalid thread number.');
 end
 else begin
  fthreads[threadnum.value].postevent(tevent.create(ek_none));
 end;
end;
 
end.

Hmm, der highlighter scheint mit den Zeileneinzügen Mühe zu haben.

[wolf_z]

@mse
Ich weiß nicht, was deine Threads genau machen. Aber das Beispiel funktioniert meiner Meinung nach nur, wenn die Threads nicht länger also die FormClose-Bearbeitung "leben". In dem Beispiel wird ja auf 'onTerminate' mit 'listmessage' sogar etwas in dem Grid der GUI ausgebeben. Wenn beispielsweise 'destroyexe' im Formclose des Formulars ausgeführt wird, werden alle Threads einfach unabhängig von ihrem Bearbeitungstatus gelöscht. Falls Du vorher die Threads mit 'terminate' beendest, schicken sie noch ein 'onTerminate' ab. Das kann nach dem Schließen des Programms aktiv werden und schon macht es Zong. Aber vielleicht gibt es ja in der tthreadcomp irgendwelche Gegenmaßnahmen. Wenn es die gibt, würden die mich interessieren. Ich kann nur schlecht eine so spezielle Lazarus-Version mit dieser tthreadcomp installieren.

@Patito

Code: Alles auswählen

// Alle Daten aufräumen (Daten freigeben, überall abmelden, ...)
  IrgendeinCleanUp();

In meinem Beispiel gibt's ja nichts aufzuräumen. Da wird nur eine Integer-Variable hochgezählt.

Code: Alles auswählen

// Master-Thread über das Ende Informieren. Eventuell einen Threadsicheren Counter hochzählen,
  // damit der Master-Thread weiss, dass alles erledigt ist. FormClose wartet auf Counter = Thread-Anzahl.
  IrgendeinNotifyMasterThread();

Wenn ich diese Event in 'execute' abschicke, kann es ja sein, dass es vor dem 'onTerminate' empfangen wird. Dann kann es sein, dass der Thread immer noch nach dem 'Formclose' lebt und den Zong produziert.

Wenn, dann liegt die Lösung darin, irgendwelche unix-spezifische Botschaften für die exakte Beendigung des Threads abzufangen (macht waitFor in Windows ja auch). Und solange es so etwas nicht gibt, bleibt nur das 'onTerminate' und da hängt leider die Behandlung von der GUI-Implementierung ab (z.B. Unterschiede zwischen GTK2 und Win32/win64).

Aber zugegeben, sauber ist die Lösung nicht. Wenn ich z.B. 1000 Threads schließen will, werden 'onTerminate'-Events verschluckt. Mit wenigen Threads funktionierts im Moment noch einigermaßen zuverlässig.

[mse]

@mse
Ich weiß nicht, was deine Threads genau machen. Aber das Beispiel funktioniert meiner Meinung nach nur, wenn die Threads nicht länger also die FormClose-Bearbeitung "leben". In dem Beispiel wird ja auf 'onTerminate' mit 'listmessage' sogar etwas in dem Grid der GUI ausgebeben. Wenn beispielsweise 'destroyexe' im Formclose des Formulars ausgeführt wird, werden alle Threads einfach unabhängig von ihrem Bearbeitungstatus gelöscht. Falls Du vorher die Threads mit 'terminate' beendest, schicken sie noch ein 'onTerminate' ab. Das kann nach dem Schließen des Programms aktiv werden und schon macht es Zong.

Nein, onstart und onterminate laufen im Kontext des thread, gekapselt durch application.lock/application.unlock. onterminate wird aufgerufen bevor tthreadcomp.free() zurückkehrt.

Aber vielleicht gibt es ja in der tthreadcomp irgendwelche Gegenmaßnahmen. Wenn es die gibt, würden die mich interessieren.

Selbstverständlich kümmert sich MSEgui um diese Finessen; oder sollte es wenigstens , threads unter allen Umständen richtig zu behandeln ist so eine Sache...
Der code ist in lib/common/kernel/msethreadcomp.pas und msethread.pas.

http://mseide-msegui.svn.sourceforge.ne ... on/kernel/

[wolf_z]

@mse
Ach, jetzt kapier ich. Daher auch Dein Nickname
Mag sein, dass das in MSE besser funktioniert, aber wie hilft mir das jetzt in Lazarus?
Kann man sich ja mal anschauen - noch 'ne neue IDE-GUI (stöhn!!!) - nach Weihnachten.
Ich schau mir die Threadlösung vielleicht auch mal an. Aber scheint 'ne ganz andere Konstruktion zu sein. Da muss ich ja komplett umdenken. ABer falls alle Stricke reißen!

Ich hab übrigens zu dem Teilproblem, wie man feststellt, wieviele Threads man maximal öffnen kann, noch was rausgefunden. (Stammt jetzt nicht aus dem Beispiel oben, aber auch von mir, deshalb gibt's wahrscheinlich besseres ).

Code: Alles auswählen

// create additional wanted threads
         if i >= count then
            begin
            err_cre := false;
            try
              aThread := TListThread.Create(self,
                TThreadBuzzObj,
                tpLower,
                false{FreeOnTerminate},
                true{CreateSuspended}
              );
              // This code will assure that any exception which occurred
              // during thread creation will be raised in the WorldThread:
              if Assigned(aThread.FatalException) then
                raise aThread.FatalException;
            except
              err_cre := true;
              showMessage('Error: can''t create so many threads');
              aThread := nil;
              initialize(0);        // terminate all running threads
            end;
            if err_cre then
               break;
            add(aThread);              
......

Funktioniert auf Linux sehr gut. Auf Windows bin ich jetzt über 100000 Threads gekommen, ohne dass es Probleme gibt! Deshalb weiß ich nicht, ob es da funktioniert. Aber auf Macintosh leider kackt das Programm sofort komplett ohne Fehlermeldung ab, falls man zuviele Threads aufruft. Also ist das leider immer noch keine Cross-compatible Lösung.

Mann, ist das 'ne Wissenschaft. Aber ich will das gelöst haben

[mse]

Mag sein, dass das in MSE besser funktioniert, aber wie hilft mir das jetzt in Lazarus?

Die Prinzipien kannst du schon übernehmen, die thread Komponenten benutzen ja keine GUI-Elemente. application.lock/unlock und eine event queue hat sicher auch Lazarus.

[wolf_z]

die thread Komponenten benutzen ja keine GUI-Elemente.

Hmmm, ich hab jetzt mal 'nen Blick draufgeworfen und was mich natürlich als erstes interessiert hat war:

Code: Alles auswählen

procedure tthreadcomp.waitfor;
begin
   application.waitforthread(fthread);
end;

'application' ist aber, soviel ich weiß, das oberste 'GUI-Fenster' (unsichtbar) und somit GUI-spezifisch, ansonsten müsste es unter Lazarus ja 'application.waitforthread' geben, was es aber nicht tut! Beißt sich die Katze in den Schwanz, genau sowas bräuchte ich ja!

Der Grund ist meiner Meinung nach: MSE hat ja 'ne eigene GUI, bzw. einen eigenen speziellen Widgetset. Seh ich das richtig? Lazarus arbeitet dagegen mit allen möglichen Widgetsets zusammen. Und genau deshalb fehlt dort dieses 'waitfor'.

Mich würde aber mal die Implementierung von 'application.waitforthread(fthread)' interessieren.

Weist Du zufällig, wo ich da jetzt in dem Repository suchen muss? Das könnte mir vielleicht weiterhelfen? Denn das müsste ja betriebssystemunabhängig (oder mit Compilerflags) gelöst sein, da MSE ja für Windows und Linux ist.

Übrigens: Es gibt in Lazarus auch so einen Locking-Mechanismus und zwar in TThreadList. Darüber werden dann Zugriffe auf die Threads abgesichert. Ich werde das auch noch auf mein Beispielprogramm übertragen und das bringt auch sehr viel (Dort einfach FList:TList durch FList:TThreadList ersetzen, und dann schauen, wo der Code noch geändert werden muss, weil der Zugriff auf die Liste nicht mehr so einfach ist). Aber das hier vorliegende grundsätzliche Problem löst es noch nicht.

[wolf_z]

@mse
Jetzt habe ich nochmal tiefer gebohrt. Ich hab jetzt in mseide-msegui folgende Methode gefunden: waitforthreadterminate

Code: Alles auswählen

function sys_threadwaitfor(var info: threadinfoty): syserrorty;
   begin
   {$ifdef FPC}
    waitforthreadterminate(info.id,0);
    result:= sye_ok;
   {$else}
     result:= syeseterror(pthread_join(info.id,nil));
   {$endif}
   end;
 
// ich verwende das so:
 
waitforthreadterminate(aThread.FThreadID,0);

Du hattest auf den zugehörigen Code-Schnipsel ja schon mal weiter oben hingewiesen. Der wird tatsächlich in MSEGUI für Linux-386i verwendet?

http://mseide-msegui.svn.sourceforge.ne ... iew=markup" onclick="window.open(this.href);return false;

Versteh ich nicht. Bei mir funktioniert er einfach nicht. Er bleibt beim 2 oder 3. Durchlauf hängen. Was mach ich da falsch? Muss ich da irgendetwas besonderes initialisieren?

[mse]

'application' ist aber, soviel ich weiß, das oberste 'GUI-Fenster' (unsichtbar) und somit GUI-spezifisch, ansonsten müsste es unter Lazarus ja 'application.waitforthread' geben, was es aber nicht tut! Beißt sich die Katze in den Schwanz, genau sowas bräuchte ich ja!

MSEgui hat eine eigene tcustomapplication Implementierung. Davon abgeleitet gibt es eine tnoguiapplication für Projekte ohne GUI-Abhängigkeiten und tguiapplication mit zusätzlichen, für GUI-Projekte benötigte Funktionen.
waitforthread() ist in lib/common/kernel/mseapplication.pas in tcustomapplication implementiert:

Code: Alles auswählen

procedure tcustomapplication.waitforthread(athread: tmsethread);
         //does unlock-relock before waiting
var
 int1: integer;
begin
 int1:= unlockall;
 try
  athread.waitfor;
 finally
  relockall(int1);
 end;
end;

und wird im Demo-Projekt nicht benützt. Der Zweck ist, dem thread die Möglichkeit zu geben, auf mainthread Elemente zuzugreifen.

Der Grund ist meiner Meinung nach: MSE hat ja 'ne eigene GUI, bzw. einen eigenen speziellen Widgetset. Seh ich das richtig?

Ja.

Lazarus arbeitet dagegen mit allen möglichen Widgetsets zusammen. Und genau deshalb fehlt dort dieses 'waitfor'.

waitforthread() ist GUI-unabhängig, ein entsprechender Mechanismus liesse sich auch in Lazarus einbauen, denke ich.

Du hattest auf den zugehörigen Code-Schnipsel ja schon mal weiter oben hingewiesen. Der wird tatsächlich in MSEGUI für Linux-386i verwendet?

Ja:

Code: Alles auswählen

destructor tmsethread.destroy;
begin
 if finfo.id <> 0 then begin
  terminate;
  waitfor;
  sys_threadwaitfor(finfo);
  kill;
 end;
 inherited;
end;

Versteh ich nicht. Bei mir funktioniert er einfach nicht. Er bleibt beim 2 oder 3. Durchlauf hängen. Was mach ich da falsch? Muss ich da irgendetwas besonderes initialisieren?

Ich glaube nicht. Bist du sicher, dass der thread nicht an einem synchronize() hängt? Uberprüfen kannst du das, indem du im Threads-Fenster den entsprechenden thread auswählst und den callstack anschaust. Solche Probleme waren übrigens der Anstoss, für MSEgui einen anderen Ansatz zu wählen.

Edit:
Das Threads-Fenster sollte vielleicht nicht mit 100'000 laufenden threads geöffnet werden...

[wolf_z]

@mse
Danke, die Diskussion mit Dir hat in die richtige Richtung geführt, weil ich mich wieder mit 'waitFor' beschäftigt habe. Die Lösung ist viel trivialer, als ich bisher vermutet hatte ( ): waitFor geht nicht mit 'onTerminate' zusammen! Au Mann! Das könnten die auch dabei schreiben. Denn selbstverständlich ist das ja nicht. Vielleicht möchte ich ja auch trotz 'waitFor' noch ein 'onTerminate'-Event haben. Nun gut, habe viel Unsinn geredet oben, aber was gelernt

Übrigens ist der Ansatz von MSE ist ja wirklich nicht schlecht. Ich hätte da noch eine Nachfrage. Sehen denn die Oberflächen nach Compilierung auf Linux oder Windows gleich aus? Was ich bei qt, gtk2, etc als sehr problematisch empfinde, ist, dass die Abstände/Größen von Schriften/Bedienelementen bei gleichem Widgetset auf den verschiedenen Plattformen sehr unterschiedlich sind und man von daher beim Layouten der Oberfläche große Probleme bekommt, wenn man wirklich 'write once, compile anywhere' machen möchte. Man kann zwar irgendwie die Schriften, etc. mit irgendwelchen speziellen Tools irgendwie nachbearbeiten (aber wie genau, damit habe ich mich noch nicht beschäftigt). Außerdem ist das sehr mühsam. Das wäre eventuell der größte Vorteil eines mit der IDE festverbundenen Widgetsets, wenn am Ende alles gleich aussähe.

Hier jetzt nochmal der endgültige Code, bei dem ich jetzt alle meine bisherigen Erkenntnisse berücksichtig haben. Das läuft alles einwandfrei unter Windows, Linux und Macintosh. Trotzdem habe ich auch dazu noch eine grundsätzliche Frage. Ich speichere die Variablen für "CriticalSections" in dem Beispiel in den Threads. In einem anderen Beispiel habe ich gesehen, dass diese Variablen als globale Variablen in einem Array der Größe der Anzahl der Threads gehalten werden. Kann ich das so machen, wie ich es im folgenden mache, oder müssen die Handles für Critical Sections unbedingt in globalen Variablen gehalten werden?

Formular:

Code: Alles auswählen

unit formworld;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  {$IFDEF FPC}
  LCLIntf, LResources,
  {$ENDIF}
  Classes, SysUtils, eventlog, FileUtil, Forms, Controls, Graphics, Dialogs,
  StdCtrls, ExtCtrls, Spin, Buttons, ComCtrls, ActnList, uthreadworld;
 
type
 
  { Tfrm_god }
 
  Tfrm_god = class(TForm)
    Label2: TLabel;
    lb_lifes: TLabel;
    Panel1:TPanel;
    Label1:TLabel;
    btn_newLife:TButton;
    btn_fire:TButton;
    btn_terminate:TButton;
    mm_world: TMemo;
    GroupBox1: TGroupBox;
    Timer1: TTimer;
    procedure btn_fireClick(Sender: TObject);
    procedure btn_newLifeClick(Sender: TObject);
    procedure btn_terminateClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    FWorld: TWorld;
  public
    { public declarations }
  end; 
 
var
  frm_god: Tfrm_god;
 
implementation
 
{ Tfrm_god }
 
procedure Tfrm_god.FormCreate(Sender: TObject);
begin
  FWorld := TWorld.create(self);
  timer1.enabled := true;
end;
 
procedure Tfrm_god.FormDestroy(Sender: TObject);
begin
  freeAndNil(FWorld);
end;
 
// show thread data
procedure Tfrm_god.Timer1Timer(Sender: TObject);
begin
  if FWorld = nil then
     exit;
  Timer1.enabled := false;
  try
    while FWorld.Locked do // prevent overload
       Application.processMessages;
      mm_World.lines.clear;
      mm_World.lines.text := FWorld.View;
      lb_lifes.caption := IntToStr(FWorld.ThreadsRunning);
  finally
    Timer1.enabled := true;
    Application.processMessages;
  end;
end;
 
procedure Tfrm_god.btn_newLifeClick(Sender: TObject);
begin
  while FWorld.Locked do // prevent overload
     Application.processMessages;
  if not timer1.enabled then
     timer1.enabled := true;
  FWorld.newLife;
end;
 
procedure Tfrm_god.btn_fireClick(Sender: TObject);
begin
  while FWorld.Locked do // prevent overload
     Application.processMessages;
  // other possibility:
  // if FWorld.Locked then
  //    exit;
  FWorld.fire;
end;
 
procedure Tfrm_god.btn_terminateClick(Sender: TObject);
begin
  lb_lifes.caption := ('Wait ...');
  Application.processMessages;
  FWorld.terminateAllLifes;
end;
 
procedure Tfrm_god.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
  timer1.enabled := false;
  btn_terminateClick(nil);
end;
 
initialization
  {$I formworld.lrs}
end.

// Thread Unit

Code: Alles auswählen

unit uthreadworld;
 
{$mode objfpc}{$H+}
 
interface
 
uses  // -dUseCThreads
  LCLIntf, Classes, Sysutils, Dialogs
  {, Forms} // Threads should not use unit forms !
  ;
 
Const
 
  wrSignaled = 0;
  wrTimeout  = 1;
  wrAbandoned= 2;
  wrError    = 3;
 
  tsleep = 1;
 
type
  TWorld = class;
 
  { TLifeThread }
 
  // Simple thread model for parallel running
  TLifeThread = class(TThread)
  private
    _fireEvent:pEventState;
    _killEvent:pEventState;
    {$IFDEF USEWINDOWS}
      _CritSect: TRTLCriticalSection; // {windows}
    {$ELSE}
       {$IFDEF WIN64}
         _CritSect: QWORD {Win64};  // TCriticalSection = QWORD for WIN64; ????
       {$ELSE}
         _CritSect: LongWord {Win32, Linux, ...};
       {$ENDIF}
    {$ENDIF}
  public
    Value:extended;
    constructor create(owner:TWorld); overload;
    destructor destroy; override;
    procedure Execute; override;
  end;
 
  // Simple parallel threads
 
  { TWorld }
 
  TWorld = class(TComponent)
  private
    FList:TThreadList;
    FView:TStringList;
    FLock1:boolean;
    FThreadsRunning:integer;
    function getLocked: boolean;
    function getThreadsRunning: integer;
    function getView:string;
  public
    _worldKillEvent:pEventState;
    constructor create(aOwner:TComponent); overload;
    destructor destroy; override;
    procedure fire;
    procedure terminateAllLifes;
    procedure newLife;
    property View:string read getView;
    property ThreadsRunning:integer read getThreadsRunning;
    property Locked:boolean read getLocked;
  end;
 
implementation
 
{ TLifeThread }
 
constructor TLifeThread.create(owner:TWorld);
begin
  inherited create(true {suspended});
  _fireEvent := BasicEventCreate(nil,false,false,'');
  _killEvent := BasicEventCreate(nil,false,false,'');
  InitializeCriticalSection(_CritSect);
end;
 
destructor TLifeThread.destroy;
begin
  basiceventdestroy(_fireEvent);
  basiceventdestroy(_killEvent);
  DeleteCriticalSection(_CritSect);
  inherited;
end;
 
procedure TLifeThread.Execute;
var res:longint;
begin
  while not Terminated do
     begin
     res := basiceventWaitFor(1, _fireEvent);
     if res = wrSignaled then
        begin
        basiceventResetEvent(_fireEvent);
        EnterCriticalSection(_CritSect);
        Value := 0;
        LeaveCriticalSection(_CritSect);
        end
     else
        begin
        EnterCriticalSection(_CritSect);
        Value := Value + 1;
        LeaveCriticalSection(_CritSect);
        end;
     res := basiceventWaitFor(1, _killEvent);
     if res = wrSignaled then
        begin
        basiceventResetEvent(_killEvent);
        terminate;
        break;
        end;
     sleep(998);
     end;
end;
 
{ TWorld }
 
constructor TWorld.create(aOwner:TComponent);
begin
  FList := TThreadList.create;
  FView := TStringList.create;
  _worldKillEvent := BasicEventCreate(nil,false,false,'');
  inherited create(aOwner);
end;
 
destructor TWorld.destroy;
begin
  FList.free;
  FView.free;
  basiceventdestroy(_worldKillEvent);
  inherited;
end;
 
function TWorld.getView:string;
var i:integer; list:TList;
begin
  if FLock1 then   // prevent overloading by gui
     exit;
  FLock1 := true;
  try
    FView.clear;
    list := FList.Locklist;
    For i := 0 to list.count - 1 do
       FView.add(floatToStr(TLifeThread(list[i]).Value));
    Result := FView.text;
  finally
    FList.UnlockList;
    FLock1 := false;
  end;
end;
 
// gui should test on 'Locked' before an gui action
function TWorld.getLocked: boolean;
begin
  Result := FLock1 { or FLock2 or ... };
end;
 
// Locking is not needed here because FThreadsRunning is a 'World'-Variable
function TWorld.getThreadsRunning: integer;
begin
  Result := FThreadsRunning;
end;
 
procedure TWorld.newLife;
var aNewLife:TLifeThread; err_cre:boolean;
begin
  err_cre := false;
  try
    aNewLife := TLifeThread.Create(self);
    // This code will assure that any exception which occurred
    // during thread creation will be raised in the WorldThread:
    if Assigned(aNewLife.FatalException) then
       raise aNewLife.FatalException;
  except
    err_cre := true;
    showMessage('Error: can''t create so many threads');
    aNewLife := nil;
  end;
  if err_cre then
     exit;
 // Does not work together with 'waitFor':   <----- !!!!!
 // aNewLife.onTerminate := @lifeTerminated;
 FList.add(aNewLife);
 Inc(FThreadsRunning);
 aNewLife.resume;
end;
 
procedure TWorld.fire;
var ix:integer; list:TList;
begin
  list := FList.Locklist;
  try
    ix := random(list.count);
    basiceventSetEvent(TLifeThread(List[ix])._fireEvent);
  finally
    FList.Unlocklist
  end;
end;
 
procedure TWorld.terminateAllLifes;
var i, co:integer; aThread:TLifeThread; res:dword; list:TList;
begin
  list := FList.locklist;
  try
    for i := list.count - 1 downto 0 do
       begin
       aThread := TLifeThread(list[i]);
       aThread.freeOnTerminate := false;
       // termination by 'event' (other possibility: 'terminate'):
       basiceventSetEvent(TLifeThread(list[i])._killEvent);
       aThread.waitFor; // don't use 'onTerminate' !!!!
       freeAndNil(aThread);
       Dec(FThreadsRunning);
       list.delete(i);
       end;
  finally
    FList.Unlocklist;
  end;
end;
 
end.

[mse]

Sehen denn die Oberflächen nach Compilierung auf Linux oder Windows gleich aus?

Ja, sofern auf allen Systemen kompatible Fonts installiert sind. Und manchmal noch wichtiger, sie verhalten sich auch gleich, insbesondere Menu-, Focus-, Maus- und Tastatur-Steuerung.