TPowerThread
lazarus / 8-Other

----------------------------------------------------------------------
mercurhyo · 2018-07-06 05:27

I just put here a template that I'am working on, as a case study
around Pascal power
It compiles but it is unfinished yet. I will put a final version
later.

Goal =
- Command to Threads with 'orders/answers records' of data pushed on
queues
- Exec methods in threads
- sync or queue callbacks to main thread after methods ends
- automaticaly THEN free 'orders/answers' records memory

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
PowThread; { MERCVRHYO } {$mode objfpc}{$H+} interface uses  Classes,
SysUtils, contnrs, syncobjs; type   TPowerThread = class;   PThreadCmd
= ^TThreadCmd;   TPowCallback = procedure(ACmd: PThreadCmd; Sender:
TPowerThread) of object;   TThreadCmd = record    msg: shortstring;  
param: longint;    extra: Pointer;    Done: boolean; // always true
when TPowMethod finished    wait: boolean; // false = queue callback -
true = sync callback    callback: TPowCallBack; // called in main
thread, after method finished  end;   TPowMethod = procedure(ACmd:
TThreadCmd) of object;   { TPowCmdQueue }   TPowCmdQueue =
class(TQueue)  private    FLocker: TCriticalSection;    FNotBusy:
TEvent;    FEvName: string;  protected    procedure ClearAll;
virtual;    procedure PushItem(AItem: Pointer); override;    function
PopItem: Pointer; override;    function PeekItem: Pointer; override; 
public    constructor Create;    destructor Destroy; override;  end;  
{ TPowerThread }   TPowerThread = class(TThread)  private    type   
PInternalCmd = ^TInternalCmd;     TInternalCmd = record      method:
TPowMethod;      rec: TThreadCmd;    end;  private  var    FCmdQ:
TPowCmdQueue;    FCBCmd: TThreadCmd;    FCallBack: TPowCallback; 
protected    procedure DoCallBack;    // redefine DefHandler in
derived classes as needed    // DefHandler is called by PostMsg(nil,
aShortString)    procedure DefHandler(aCmd: TThreadCmd); virtual; 
public    procedure Execute; override;    constructor
Create(CreateSuspended: boolean;      const StackSize: SizeUInt =
DefaultStackSize);    destructor Destroy; override;    // usr procs
called from outside the thread    procedure PostCmd(aMethod:
TPowMethod; aCmd: PThreadCmd = nil);    procedure PostMsg(aMethod:
TPowMethod; aMsg: shortstring);    // add here your TPowMethod and
TPowCallback    // or inherit class(TPowerThread) and add them    //
to public section    // TPowMethods will be called inside the thread
while    // TPowCallback will be queued or synced inside the main
thread  end; var  MainThreadID: TThreadID; implementation var 
EvNameFmt: string;  EvRef: smallint; { TPowCmdQueue } procedure
TPowCmdQueue.ClearAll; // in main thread: no need lockbegin  while not
(TQueue(Self).Peek = nil) do   
Dispose(PThreadCmd(TQueue(Self).Pop));end; procedure
TPowCmdQueue.PushItem(AItem: Pointer);var  c: TEvent;begin 
FLocker.Enter;  c := TEvent.Create(nil, True, True, FEvName);  if
c.WaitFor(10) <> wrSignaled then  begin    c.Free;    FLocker.Leave; 
 raise ESyncObjectException.Create('Thread Cmdqueue error');  end; 
c.Free;  FNotBusy.ResetEvent;  inherited PushItem(AItem); 
FNotBusy.SetEvent;  FLocker.Leave;end; function TPowCmdQueue.PopItem:
Pointer;var  c: TEvent;begin  FLocker.Enter;  c := TEvent.Create(nil,
True, True, FEvName);  if c.WaitFor(10) <> wrSignaled then  begin   
c.Free;    FLocker.Leave;    raise ESyncObjectException.Create('Thread
Cmdqueue error');  end;  c.Free;  FNotBusy.ResetEvent;  Result :=
inherited PopItem;  FNotBusy.SetEvent;  FLocker.Leave;end; function
TPowCmdQueue.PeekItem: Pointer;var  c: TEvent;begin  FLocker.Enter;  c
:= TEvent.Create(nil, True, True, FEvName);  if c.WaitFor(10) <>
wrSignaled then  begin    c.Free;    FLocker.Leave;    raise
ESyncObjectException.Create('Thread Cmdqueue error');  end;  c.Free; 
FNotBusy.ResetEvent;  Result := inherited PeekItem; 
FNotBusy.SetEvent;  FLocker.Leave;end; constructor
TPowCmdQueue.Create;begin  FLocker := TCriticalSection.Create; 
Inc(EvRef);  FEvName := Format(EvNameFmt, [EvRef]);  FNotBusy :=
TEvent.Create(nil, True, True, FEvName);  inherited;end; destructor
TPowCmdQueue.Destroy;begin  FNotBusy.Free;  FLocker.Free;  inherited
Destroy;end; { TPowerThread } procedure TPowerThread.DoCallBack;begin 
FCallBack(@FCBCmd,Self);end; procedure TPowerThread.DefHandler(aCmd:
TThreadCmd);begin  aCmd.Done := True;end; procedure
TPowerThread.Execute;var  cmd: PInternalCmd;begin  while not
Terminated do  begin    if FCmdQ.Count > 0 then    begin      cmd :=
FCmdQ.Pop;      if not Assigned(cmd^.method) then        cmd^.method
:= @DefHandler;      cmd^.method(cmd^.rec);      cmd^.rec.Done :=
True;      if Assigned(cmd^.rec.callback) then      begin       
FCBCmd := cmd^.rec;        FCallBack:=cmd^.rec.callback;        if
cmd^.rec.wait then          Synchronize(@DoCallBack)        else     
   Queue(@DoCallBack);      end;      Dispose(cmd);    end;   
Sleep(1);  end;end; constructor TPowerThread.Create(CreateSuspended:
boolean; const StackSize: SizeUInt);begin  FCmdQ :=
TPowCmdQueue.Create;  inherited Create(CreateSuspended,
StackSize);end; destructor TPowerThread.Destroy;begin 
FCmdQ.ClearAll;  FCmdQ.Free;  inherited Destroy;end; procedure
TPowerThread.PostCmd(aMethod: TPowMethod; aCmd: PThreadCmd);var  c:
PInternalCmd;begin  if aCmd = nil then    exit;  new(c);  FillChar(c,
SizeOf(TInternalCmd), #0);  c^.method := aMethod;  if Assigned(aCmd)
then    c^.rec := aCmd^;  FCmdQ.Push(c);end; procedure
TPowerThread.PostMsg(aMethod: TPowMethod; aMsg: shortstring);var  c:
PInternalCmd;begin  new(c);  FillChar(c, SizeOf(TInternalCmd), #0); 
c^.method := aMethod;  c^.rec.msg := aMsg; 
FCmdQ.Push(c);end; initialization  EvNameFmt := 'EvPowThread_%.5d'; 
EvRef := 0;  MainThreadID := TThread.CurrentThread.ThreadID;end.

----------------------------------------------------------------------
mercurhyo · 2018-07-06 05:28

I am not happy with WThread package, so I am working on an alternative
(I hope crossplatform)
Faster (no variant craps)
shorter If possible

----------------------------------------------------------------------
mercurhyo · 2018-07-06 05:34

we'll see

----------------------------------------------------------------------
mercurhyo · 2018-07-06 05:42

1st post modified ->> DoCallBack done

----------------------------------------------------------------------
mercurhyo · 2018-07-07 02:00

Well, ... after some debugging and little corrections, I can put there
a working PowerThread

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
PowThread; { MERCVRHYO }{ version 0.3} {$mode
objfpc}{$H+} interface uses  Classes, SysUtils, contnrs,
syncobjs; type   TPowerThread = class;   PThreadCmd = ^TThreadCmd;  
TPowCallback = procedure(ACmd: PThreadCmd; Sender: TPowerThread) of
object;   TThreadCmd = record    msg: shortstring;    param: longint; 
  extra: Pointer;    Done: boolean; // always true when TPowMethod
finished    wait: boolean; // false = queue callback - true = sync
callback    callback: TPowCallBack; // called in main thread, after
method finished  end;   TPowMethod = procedure(ACmd: TThreadCmd) of
object;   { TPowCmdQueue }   TPowCmdQueue = class(TQueue)  private   
FLocker: TCriticalSection;    FNotBusy: TEvent;    FEvName: string; 
protected    procedure ClearAll; virtual;    procedure PushItem(AItem:
Pointer); override;    function PopItem: Pointer; override;   
function PeekItem: Pointer; override;  public    constructor Create; 
 destructor Destroy; override;  end;   { TPowerThread }   TPowerThread
= class(TThread)  private    type    PInternalCmd = ^TInternalCmd;   
TInternalCmd = record      method: TPowMethod;      rec: PThreadCmd; 
 end;  private  var    FCmdQ, FcbQ: TPowCmdQueue;    FSyncCmd:
PThreadCmd;  protected    procedure DoSyncCallBack;    procedure
DoAsyncCallBack;    // redefine DefHandler in derived classes as
needed    // called when PostCmd(nil,aCmd)    procedure
DefHandler(aCmd: TThreadCmd); virtual;  public    procedure Execute;
override;    constructor Create(CreateSuspended: boolean;      const
StackSize: SizeUInt = DefaultStackSize);    destructor Destroy;
override;    // usr proc called from outside the thread    procedure
PostCmd(aMethod: TPowMethod; var aCmd: TThreadCmd);    // add here
your TPowMethod and TPowCallback    // or inherit class(TPowerThread)
and add them    // to public section    // TPowMethods will be called
inside the thread while    // TPowCallback will be queued or synced
inside the main thread  end; var  MainThreadID:
TThreadID; implementation var  EvNameFmt: string;  EvRef: smallint; {
TPowCmdQueue } procedure TPowCmdQueue.ClearAll; // in main thread: no
need lockbegin  while not (TQueue(Self).Peek = nil) do   
Dispose(PThreadCmd(TQueue(Self).Pop));end; procedure
TPowCmdQueue.PushItem(AItem: Pointer);var  c: TEvent;begin 
FLocker.Enter;  c := TEvent.Create(nil, True, True, FEvName);  if
c.WaitFor(10) <> wrSignaled then  begin    c.Free;    FLocker.Leave; 
 raise ESyncObjectException.Create('Thread Cmdqueue error');  end; 
c.Free;  FNotBusy.ResetEvent;  inherited;  FNotBusy.SetEvent; 
FLocker.Leave;end; function TPowCmdQueue.PopItem: Pointer;var  c:
TEvent;begin  FLocker.Enter;  c := TEvent.Create(nil, True, True,
FEvName);  if c.WaitFor(10) <> wrSignaled then  begin    c.Free;   
FLocker.Leave;    raise ESyncObjectException.Create('Thread Cmdqueue
error');  end;  c.Free;  FNotBusy.ResetEvent;  Result := inherited; 
FNotBusy.SetEvent;  FLocker.Leave;end; function TPowCmdQueue.PeekItem:
Pointer;var  c: TEvent;begin  FLocker.Enter;  c := TEvent.Create(nil,
True, True, FEvName);  if c.WaitFor(10) <> wrSignaled then  begin   
c.Free;    FLocker.Leave;    raise ESyncObjectException.Create('Thread
Cmdqueue error');  end;  c.Free;  FNotBusy.ResetEvent;  Result :=
inherited;  FNotBusy.SetEvent;  FLocker.Leave;end; constructor
TPowCmdQueue.Create;begin  FLocker := TCriticalSection.Create; 
Inc(EvRef);  FEvName := Format(EvNameFmt, [EvRef]);  FNotBusy :=
TEvent.Create(nil, True, True, FEvName);  inherited;end; destructor
TPowCmdQueue.Destroy;begin  FNotBusy.Free;  FLocker.Free; 
inherited;end; { TPowerThread } procedure
TPowerThread.DoSyncCallBack;begin  FSyncCmd^.callback(FSyncCmd,
Self);end; procedure TPowerThread.DoAsyncCallBack;var  c:
TThreadCmd;begin  if FcbQ.Count > 0 then  begin    c :=
PThreadCmd(FcbQ.Pop)^;    c.callback(@c, Self);  end;end; procedure
TPowerThread.DefHandler(aCmd: TThreadCmd);begin  // nothing to
doend; procedure TPowerThread.Execute;var  cmd: PInternalCmd;begin 
while not Terminated do  begin    if FCmdQ.Count > 0 then    begin   
 cmd := FCmdQ.Pop;      if not Assigned(cmd^.method) then       
cmd^.method := @DefHandler;      cmd^.method(cmd^.rec^);     
cmd^.rec^.Done := True;      if Assigned(cmd^.rec^.callback) then    
begin        if cmd^.rec^.wait then        begin         
New(FSyncCmd);          FSyncCmd^ := cmd^.rec^;         
Synchronize(@DoSyncCallBack);          Dispose(FSyncCmd);        end 
     else          FcbQ.Push(@cmd^.rec);      end;      while
FcbQ.Count > 0 do        Queue(@DoAsyncCallBack);      Dispose(cmd); 
 end;    Sleep(1);  end;end; constructor
TPowerThread.Create(CreateSuspended: boolean; const StackSize:
SizeUInt);begin  FCmdQ := TPowCmdQueue.Create;  FcbQ :=
TPowCmdQueue.Create;  inherited;end; destructor
TPowerThread.Destroy;begin  FCmdQ.ClearAll;  FCmdQ.Free;  FcbQ.Free; 
inherited;end; procedure TPowerThread.PostCmd(aMethod: TPowMethod; var
aCmd: TThreadCmd);var  c: PInternalCmd;begin  new(c);  FillChar(c^,
SizeOf(TInternalCmd), #0);  c^.method := aMethod;  c^.rec:=@aCmd; 
FCmdQ.Push(c);end; initialization  EvNameFmt := 'EvPowThread_%.5d'; 
EvRef := 0;  MainThreadID := TThread.CurrentThread.ThreadID;end.
I started testing as follow, with synapse

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
TestClient; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
blcksock, PowThread; const  STK_SZ = $10000; type   { TClientThread
}   TClientThread = class(TPowerThread)  private    FSock:
TTCPBlockSocket;  public    // this will be general Handler parsing
aCmd inside the worker thread    procedure Handler(aCmd: TThreadCmd); 
end;   { TPlug }   TPlug = class(TComponent)  private  var    FWorker:
TClientThread;  public    constructor Create(AOwner: TComponent);
override;    destructor Destroy; override;  end; implementation {
TClientThread } procedure TClientThread.Handler(aCmd:
TThreadCmd);begin  // todo interpretation of aCmdend; { TPlug
} constructor TPlug.Create(AOwner: TComponent);var  cmd:
TThreadCmd;begin  inherited Create(AOwner);  FWorker :=
TClientThread.Create(False, STK_SZ);  //    // testing  // 
Sleep(10);  FillChar(cmd,SizeOf(TThreadCmd),#0); 
cmd.msg:='testing';// POST JOB TO DO  
FWorker.PostCmd(@FWorker.Handler,cmd); // WAITFOR job done  while not
cmd.Done do Sleep(1);end; destructor TPlug.Destroy;begin 
FWorker.Free;  inherited Destroy;end; end.
I used GDB with breakpoints inside the Worker thread and around the
calling, all went good so far

----------------------------------------------------------------------
mercurhyo · 2018-07-07 02:03

it's a bit different from the 1st post, because I found out I needed
another queue to manage desync callbacks. I will rework that
while synchronize pauses the thread, queue() does not. thats problem
for data at callbacks. I need to prevent race conditions. I think my
programming is going that way, but ok.. need deep checks

----------------------------------------------------------------------
mercurhyo · 2018-07-14 01:08

yet a better Working version

[todo, replace Sleep(1) in the thread's loop by a TEvent driven in
'Post' method

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
PowerThread; { MERCVRHYO }{ version 0.5 } {$mode
objfpc}{$H+} interface uses  Classes, SysUtils, contnrs,
syncobjs; type   PThreadParams = ^TThreadParams;  TThreadParams =
array of TVarRec;  TThreadMethod = procedure(Args: TThreadParams) of
object;  TThreadCallBack = procedure(Data: Pointer) of object;    {
TPowerThread }   TPowerThread = class(TThread)  private    type   
PCmdRec = ^TcmdRec;     TCmdRec = record      method: TThreadMethod; 
   params: TThreadParams;      Done: PBoolean;      CallBack:
TThreadCallBack;      Data: Pointer;    end;     { TLockQueue }    
TLockQueue = class(TQueue)    private      FLock: TCriticalSection;  
  FReady: TEvent;      FEvName: string;    protected      procedure
PushItem(AItem: Pointer); override;      function PopItem: Pointer;
override;      function PeekItem: Pointer; override;    public     
constructor Create;      destructor Destroy; override;    end;  
private  var    FJobQueue: TLockQueue;    FSyncCall: TThreadCallBack; 
  FData: Pointer;     procedure DoSyncCallBack;  protected   
procedure Execute; override;  public    constructor
Create(CreateSuspended: boolean;      const StackSize: SizeUInt =
DefaultStackSize);    destructor Destroy; override;    procedure
Post(aMethod: TThreadMethod; Args: array of const;      var Done:
boolean; aCallBack: TThreadCallBack = nil; aData: Pointer = nil); 
end;   { TThreadedComponent }   TThreadedComponent =
class(TComponent)  private    FThread: TPowerThread;    function
GetSuspended: boolean; inline;    procedure SetSuspended(AValue:
boolean); inline;  public    constructor Create(AOwner: TComponent;
CreateSuspended: boolean;      const StackSize: SizeUInt =
DefaultStackSize); virtual;    destructor Destroy; override;   
procedure Post(aMethod: TThreadMethod; Args: array of const;      var
Done: boolean; aCallBack: TThreadCallBack = nil; aData: Pointer =
nil);    property Suspended: boolean read GetSuspended write
SetSuspended;  end; implementation var  EvQueueFmt: PChar =
'EvPTQ_%.5d';  EvRef: smallint; { TPowerThread.TCmdQueue } procedure
TPowerThread.TLockQueue.PushItem(AItem: Pointer);var  chkev:
TEvent;begin  FLock.Enter;  chkev := TEvent.Create(nil, True, True,
FEvName);  if chkev.WaitFor(10) <> wrSignaled then  begin   
chkev.Free;    FLock.Leave;    raise
ESyncObjectException.Create('PowerThread Queue error');  end; 
FReady.ResetEvent;  chkev.Free;  inherited PushItem(AItem); 
FReady.SetEvent;  FLock.Leave;end; function
TPowerThread.TLockQueue.PopItem: Pointer;var  chkev: TEvent;begin 
FLock.Enter;  chkev := TEvent.Create(nil, True, True, FEvName);  if
chkev.WaitFor(10) <> wrSignaled then  begin    chkev.Free;   
FLock.Leave;    raise ESyncObjectException.Create('PowerThread Queue
error');  end;  FReady.ResetEvent;  chkev.Free;  Result := inherited
PopItem;  FReady.SetEvent;  FLock.Leave;end; function
TPowerThread.TLockQueue.PeekItem: Pointer;var  chkev: TEvent;begin 
FLock.Enter;  chkev := TEvent.Create(nil, True, True, FEvName);  if
chkev.WaitFor(10) <> wrSignaled then  begin    chkev.Free;   
FLock.Leave;    raise ESyncObjectException.Create('PowerThread Queue
error');  end;  FReady.ResetEvent;  chkev.Free;  Result := inherited
PeekItem;  FReady.SetEvent;  FLock.Leave;end; constructor
TPowerThread.TLockQueue.Create;begin  FLock :=
TCriticalSection.Create;  Inc(EvRef);  FEvName := Format(EvQueueFmt,
[EvRef]);  FReady := TEvent.Create(nil, True, True, FEvName); 
inherited Create;end; destructor
TPowerThread.TLockQueue.Destroy;begin  FReady.Free;  FLock.Free; 
inherited Destroy;end; { TPowerThread } procedure
TPowerThread.DoSyncCallBack;begin  FSyncCall(FData);end; procedure
TPowerThread.Execute;var  c: PCmdRec;begin  while not Terminated do 
begin    c := FJobQueue.Pop;    if Assigned(c) then    begin     
c^.method(c^.params);      c^.Done^ := True;      if
Assigned(c^.CallBack) then      begin        FSyncCall :=
c^.CallBack;        FData := c^.Data;       
Synchronize(@DoSyncCallBack);      end;      SetLength(c^.params,0); 
   Dispose(c);    end;    Sleep(1); // ThreadSwitch doesn't work on
all platforms  end;end; constructor
TPowerThread.Create(CreateSuspended: boolean; const StackSize:
SizeUInt);begin  FJobQueue := TLockQueue.Create;  inherited
Create(CreateSuspended, StackSize);end; destructor
TPowerThread.Destroy;var  c: PCmdRec;begin  while FJobQueue.Count > 0
do  begin    c := FJobQueue.Pop;    SetLength(c^.params, 0); // ;-)  
Dispose(c);  end;  inherited Destroy;end; procedure
TPowerThread.Post(aMethod: TThreadMethod; Args: array of const;  var
Done: boolean; aCallBack: TThreadCallBack; aData: Pointer);var  c:
PCmdRec;  i: smallint;begin  New(c);  with c^ do  begin    method :=
aMethod;    SetLength(params, 1 + High(Args));    for i := 0 to
High(Args) do      params[i] := Args[i];    CallBack := aCallBack;   
Data := aData;  end;  c^.Done := @Done;  c^.Done^ := False; 
FJobQueue.Push(c);end; { TThreadedComponent } function
TThreadedComponent.GetSuspended: boolean;begin  Result :=
FThread.Suspended;end; procedure
TThreadedComponent.SetSuspended(AValue: boolean);begin 
FThread.Suspended := AValue;end; constructor
TThreadedComponent.Create(AOwner: TComponent;  CreateSuspended:
boolean; const StackSize: SizeUInt);begin  inherited Create(AOwner); 
FThread := TPowerThread.Create(True, StackSize); 
FThread.FreeOnTerminate := True;  FThread.Suspended :=
CreateSuspended;end; destructor TThreadedComponent.Destroy;begin 
FThread.Terminate;  inherited Destroy;end; procedure
TThreadedComponent.Post(aMethod: TThreadMethod; Args: array of const; 
var Done: boolean; aCallBack: TThreadCallBack; aData: Pointer);begin 
FThread.Post(aMethod, Args, Done, aCallBack, aData);end; end.
usage change

- no more fixed record but variable 'arrays of consts'
- removed desync callbacks, only sychronized at the moment (I read
some delphi articles around the difficulty/hell to manage
desynchronized callbacks while results may change in returned values
if Queued)
- added a TThreadedComponent template to be derived from ;-)

----------------------------------------------------------------------
mercurhyo · 2018-07-14 01:37

line 209.    SetLength(c^.params, 0); // ;-) thanks Mr. sam708 :

----------------------------------------------------------------------
marcov · 2018-07-15 12:10

Why do you create/release a tevent for every push?

----------------------------------------------------------------------
mercurhyo · 2018-07-15 23:14

Quote from: marcov on July 15, 2018, 02:10:09 pmWhy do you
create/release a tevent for every push?
easy :
when you 1st create a TEvent, you are the owner (depending platform
and murky PSecurityAttributes)
when you want to read the state it is a good habit to create a
checker, and not modify what the owner have set or reset (it is the
'safe' way). I know I can use the original FReady in that particular
case directly. But as it is a case study made to be
extended/improved... it is far from optimized (also I do not need
PeekItem yet but I wrote it)

----------------------------------------------------------------------
mercurhyo · 2018-07-15 23:26

so... I do NOT create a TEvent every push but an acccessor to FReady 
in a safe way, at that point of non optimized template

nothing to do with that post, I say hello here to my son Alexandre
P.-C.

----------------------------------------------------------------------
mercurhyo · 2018-07-16 15:31

fresh compiled version 0.6.
- removed unnecessary TEvent to please @marcov
- commented PeekItem for now
- replaced 'Sleep(1)' with an Event triggered in Post Method and
checked in PowerThread's loop
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
PowerThread; { MERCVRHYO }{ version 0.6 } {$mode
objfpc}{$H+} interface uses  Classes, SysUtils, contnrs,
syncobjs; type   PThreadParams = ^TThreadParams;  TThreadParams =
array of TVarRec;  TThreadMethod = procedure(Args: TThreadParams) of
object;  TThreadCallBack = procedure(Data: Pointer) of object;    {
TPowerThread }   TPowerThread = class(TThread)  private    type   
PCmdRec = ^TcmdRec;     TCmdRec = record      method: TThreadMethod; 
   params: TThreadParams;      Done: PBoolean;      CallBack:
TThreadCallBack;      Data: Pointer;    end;     { TLockQueue }    
TLockQueue = class(TQueue)    private      FLock: TCriticalSection;  
  FReady: TEvent;    protected      procedure PushItem(AItem:
Pointer); override;      function PopItem: Pointer; override;      //
function PeekItem: Pointer; override; --- no need yet    public     
constructor Create;      destructor Destroy; override;    end;  
private  var    FWake: TEvent;    FJobQueue: TLockQueue;    FSyncCall:
TThreadCallBack;    FData: Pointer;     procedure DoSyncCallBack; 
protected    procedure Execute; override;  public    constructor
Create(CreateSuspended: boolean;      const StackSize: SizeUInt =
DefaultStackSize);    destructor Destroy; override;    procedure
Post(aMethod: TThreadMethod; Args: array of const;      var Done:
boolean; aCallBack: TThreadCallBack = nil; aData: Pointer = nil); 
end;   { TThreadedComponent }   TThreadedComponent =
class(TComponent)  private    FThread: TPowerThread;    function
GetSuspended: boolean; inline;    procedure SetSuspended(AValue:
boolean); inline;  public    constructor Create(AOwner: TComponent;
CreateSuspended: boolean;      const StackSize: SizeUInt =
DefaultStackSize); virtual; overload;    destructor Destroy;
override;    procedure Post(aMethod: TThreadMethod; Args: array of
const;      var Done: boolean; aCallBack: TThreadCallBack = nil;
aData: Pointer = nil);    property Suspended: boolean read
GetSuspended write SetSuspended;  end; implementation var  EvQueueFmt:
PChar = 'EvPTQ_%.5d';  EvWakeFmt: PChar = 'EvPTW_%.5d';  EvQRef,
EvWRef: smallint; { TPowerThread.TCmdQueue } procedure
TPowerThread.TLockQueue.PushItem(AItem: Pointer);begin  FLock.Enter; 
if FReady.WaitFor(10) <> wrSignaled then  begin    FLock.Leave;   
raise ESyncObjectException.Create('PowerThread Queue error');  end; 
FReady.ResetEvent;  inherited PushItem(AItem);  FReady.SetEvent; 
FLock.Leave;end; function TPowerThread.TLockQueue.PopItem:
Pointer;begin  FLock.Enter;  if FReady.WaitFor(10) <> wrSignaled then 
begin    FLock.Leave;    raise
ESyncObjectException.Create('PowerThread Queue error');  end; 
FReady.ResetEvent;  Result := inherited PopItem;  FReady.SetEvent; 
FLock.Leave;end; { *=* no need yetfunction
TPowerThread.TLockQueue.PeekItem: Pointer;begin  FLock.Enter;  if
FReady.WaitFor(10) <> wrSignaled then  begin    FLock.Leave;    raise
ESyncObjectException.Create('PowerThread Queue error');  end; 
FReady.ResetEvent;  Result := inherited PeekItem;  FReady.SetEvent; 
FLock.Leave;end;*=* } constructor
TPowerThread.TLockQueue.Create;begin  FLock :=
TCriticalSection.Create;  Inc(EvQRef);  FReady := TEvent.Create(nil,
True, True, Format(EvQueueFmt, [EvQRef]));  inherited
Create;end; destructor TPowerThread.TLockQueue.Destroy;begin 
FReady.Free;  FLock.Free;  inherited Destroy;end; { TPowerThread
} procedure TPowerThread.DoSyncCallBack;begin 
FSyncCall(FData);end; procedure TPowerThread.Execute;var  c: PCmdRec; 
w: TWaitResult;begin  while not Terminated do  begin    w :=
FWake.WaitFor(100);    if w = wrTimeout then      Continue;    if w =
wrSignaled then    begin      c := FJobQueue.Pop;      if Assigned(c)
then      begin        c^.method(c^.params);        c^.Done^ := True; 
      if Assigned(c^.CallBack) then        begin          FSyncCall :=
c^.CallBack;          FData := c^.Data;         
Synchronize(@DoSyncCallBack);        end;        SetLength(c^.params,
0);        Dispose(c);      end      else        FWake.ResetEvent;   
end    else      raise ESyncObjectException.Create('TPowerThread
WakeUp error');  end;end; constructor
TPowerThread.Create(CreateSuspended: boolean; const StackSize:
SizeUInt);begin  FJobQueue := TLockQueue.Create;  Inc(EvWRef);  FWake
:= TEvent.Create(nil, True, False, Format(EvWakeFmt, [EvWRef])); 
inherited Create(CreateSuspended, StackSize);end; destructor
TPowerThread.Destroy;var  c: PCmdRec;begin  while FJobQueue.Count > 0
do  begin    c := FJobQueue.Pop;    SetLength(c^.params, 0); // ;-)  
Dispose(c);  end;  FWake.Free;  inherited Destroy;end; procedure
TPowerThread.Post(aMethod: TThreadMethod; Args: array of const;  var
Done: boolean; aCallBack: TThreadCallBack; aData: Pointer);var  c:
PCmdRec;  i: smallint;begin  New(c);  with c^ do  begin    method :=
aMethod;    SetLength(params, 1 + High(Args));    for i := 0 to
High(Args) do      params[i] := Args[i];    CallBack := aCallBack;   
Data := aData;  end;  c^.Done := @Done;  c^.Done^ := False; 
FJobQueue.Push(c);  FWake.SetEvent;end; { TThreadedComponent
} function TThreadedComponent.GetSuspended: boolean;begin  Result :=
FThread.Suspended;end; procedure
TThreadedComponent.SetSuspended(AValue: boolean);begin 
FThread.Suspended := AValue;end; constructor
TThreadedComponent.Create(AOwner: TComponent;  CreateSuspended:
boolean; const StackSize: SizeUInt);begin  inherited Create(AOwner); 
FThread := TPowerThread.Create(True, StackSize); 
FThread.FreeOnTerminate := True;  FThread.Suspended :=
CreateSuspended;end; destructor TThreadedComponent.Destroy;begin 
FThread.Terminate;  if FThread.Suspended then    FThread.Suspended :=
False;  FThread.WaitFor;  inherited Destroy;end; procedure
TThreadedComponent.Post(aMethod: TThreadMethod; Args: array of const; 
var Done: boolean; aCallBack: TThreadCallBack; aData: Pointer);begin 
FThread.Post(aMethod, Args, Done, aCallBack, aData);end; end. 
usage :

1) create a procedure in a class that way:

procedure MyProc(Args: TThreadParams);
your procedures are responsible to parse parameters as 'array of const

2) create a TPowerThread, a boolean 'Done' VARiable

3) to run 'MyProc' in the thread:
MyThread.Post(@MyProc,['hello',Now],Done);

as you see, you pass parameters just like with 'Format' method.
more advanced programmers can use a synchronized callback using a
pointer to wanted results
while the callback running in the mainthread, the 'powerthread' is
suspended

----------------------------------------------------------------------
mercurhyo · 2018-07-16 15:44

not tested, I am going to use my TPowerThread with synapse
TTCPBlockSocket

procedure Connect(Args: TThreadParams,Done)
with Args[0] as string url or ip address
and Args[1] as integer port number
something like

procedure TClient.Connect(Args: TThreadParams);
var
  addr, port: string;
begin
  addr := FSock.ResolveName(string(Args[0].VAnsiString));
  port := IntToStr(Args[1].VInteger);
  FSock.Connect(addr, port);

----------------------------------------------------------------------
mercurhyo · 2018-07-16 15:50

This should be a cool way to 'communicate'   upon communications

----------------------------------------------------------------------
marcov · 2018-07-16 16:36

Maybe it is the choice for named events. I have no experience/need for
those.

----------------------------------------------------------------------
mercurhyo · 2018-07-17 01:50

Quote from: marcov on July 16, 2018, 06:36:56 pmMaybe it is the choice
for named events. I have no experience/need for those.

It does not matter as long as pSecurityAttributes is NIL and you
access Events LOCALY in the same Process. named TEvent is a Global
systemwide stuff (can be used interprocess way), so I have my safe
habits   while writing code from scratch and on the fly

----------------------------------------------------------------------
mercurhyo · 2018-07-17 03:33

with my TPowerThread template as starting point, you can parallelize :
- offscreen bitmaps drawings
- blocking sockets and ports
- heavy maths computations
- compilation of files
- ... and damn much more if applied to game engines IA programming

Enjoy!

just a draft idea to let you imagine...

...Post(@TPowThreadDerived.Compile, [SourceName[idx],
OutFileName[idx], CompilerPath, options], Done, @MyCallBack,
ErrorsPointerBuffer);

assuming you have an array[0..Pred(cpucount)] of TPowerThread ... the
speedup could be awesome around compilation

TPowerThread is a NICE TOY

----------------------------------------------------------------------
mercurhyo · 2018-07-18 13:33

Quote from: GetMem on July 17, 2018, 06:19:30 amLooks promising. You
should create a runtime package and add a few examples so other people
can test.
NO
- I Give away what I want, when I want
- I did never obey to morons, SO don't count on me @getmom
- As i read some of your posts (some are hilarious due to your messed
up level), you have definitely no ability to critcize me, jealous
paranoid @getmom

----------------------------------------------------------------------
howardpc · 2018-07-18 15:36

@mercurhyo
You are stepping way over the bounds of civilised discourse in your
last post.
GetMem did not criticize you. "Looks promising" is criticism?
You may not want to follow his suggestion of creating a runtime
package and examples. OK. It was merely a suggestion, made in good
faith. To accuse him of jealousy and paranoia is completely
unwarranted.
If you continue in this vein, no matter how exalted your coding skills
and programming insights, I think the moderators will be down on you.

----------------------------------------------------------------------
mercurhyo · 2018-07-18 21:47

@howardpc

- I am not afraid of any kind of ban, because I have already been
banned here when I was gulyone, and I already mentioned it (nothing to
hide)
- no matter if i get banned and banned again, I also mentioned, that I
am NEVER the looser one
- to let you know what is going on with @gotmom, you can follow
https://forum.lazarus.freepascal.org/index.php/topic,41867.15.html
and his stupid "reflexions"
- finaly = if people do not want what I give, no problem... as
usually, I can sell it in final products!!! what is FUNNY: the fact
that i am pretty sure that some "jealous idiots" buy them HAHAHAHA

----------------------------------------------------------------------
mercurhyo · 2018-07-18 21:58

here is all my "disorder" LOL

----------------------------------------------------------------------
mercurhyo · 2018-07-19 02:56

patch to v0.6
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i destructor
TThreadedComponent.Destroy;begin  FThread.Suspended := True; 
FThread.Terminate;  FThread.FWake.SetEvent; // don't wait 
FThread.Suspended := False;  inherited Destroy;end;