Creating Thread from Procedure to simplify thread programming in Free Pascal and Delphi

 

Thread in Free Pascal and Delphi is a process that run simutanously with main program. This is very useful when we need to process data in background while user doing his own work. And is needed to maximize processing in multicore processor because a process including main process can only use 1 core and a quad core processor require a minimum of 4 threads to use all 4 cores.

Basically to create a thread we need to create the thread class and override the execute procedure with the thread code. To minimize work I create WorkerThreadList class, a very simple class to run a procedure of object as a thread.

First the class definition: 

1. type 
2.   { TSemaphore }
3.   TSemaphore = class(TObject) 
4.   private
5.     FSem: Integer;
6.   public
7.     constructor Create;
8.     destructor Destroy; override;
9.     procedure Lock;
10.     procedure Unlock;
11.   end;
12.  
13.   { WorkerThreads Routines }
14.   TWorkerThread = class;
15.   TWorkerThreadList = class;
16.  
17.   TWorkEvent = procedure(WT: TWorkerThread) of object;
18.  
19.   { TWorkerThread }
20.   TWorkerThread = class(TThread)
21.   private
22.     FOwner: TWorkerThreadList;
23.     FOnWork: TWorkEvent;
24.     FParam: Pointer;
25.   protected
26.     procedure Execute; override;
27.   public
28.     constructor Create(AOwner: TWorkerThreadList; AOnWork: TWorkEvent;
29.       AParam: Pointer);
30.     destructor Destroy; override;
31.     property OnWork: TWorkEvent read FOnWork write FOnWork;
32.     property Param: Pointer read FParam;
33.     property Terminated;
34.   end;
35.  
36.   { TWorkerThreadList }
37.   TWorkerThreadList = class(TObject)
38.   private
39.     FWorkers: TObjectList;
40.     FSem: TSemaphore;
41.     function GetItems(Index: Integer): TWorkerThread;
42.   public
43.     constructor Create;
44.     destructor Destroy; override;
45.     function AddNew(AOnWork: TWorkEvent; AParam: Pointer=nil): TWorkerThread;
46.     procedure TerminateWait(Thread: TWorkerThread);
47.     procedure UnregisterWorkerThread(AThread: TWorkerThread);
48.     procedure TerminateWorkerThreads(Wait: Boolean);
49.     property Items[Index: Integer]: TWorkerThread read GetItems; default;
50.   end;

Then I create the class definition like this:

1. { TWorkerThreadList }
2.  
3. function TWorkerThreadList.GetItems(Index: Integer): TWorkerThread;
4. begin
5.   Result := TWorkerThread(FWorkers[Index]);
6. end;
7.  
8. constructor TWorkerThreadList.Create;
9. begin
10.   inherited;
11.   FWorkers := TObjectList.Create(False);
12.   FSem := TSemaphore.Create;
13. end;
14.  
15. destructor TWorkerThreadList.Destroy;
16. begin
17.   TerminateWorkerThreads(True);
18.   FWorkers.Free;
19.   FSem.Free;
20.   inherited Destroy;
21. end;
22.  
23. function TWorkerThreadList.AddNew(AOnWork: TWorkEvent;
24.   AParam: Pointer): TWorkerThread;
25. var
26.   N: TWorkerThread;
27. begin
28.   N := TWorkerThread.Create(Self, AOnWork, AParam);
29.   try
30.     FSem.Lock;
31.     try
32.       FWorkers.Add(N);
33.     finally
34.       FSem.Unlock;
35.     end;
36.     Result := N;
37.     N.Start;
38.   except
39.     N.Free;
40.     raise;
41.   end;
42. end;
43.  
44. procedure TWorkerThreadList.TerminateWait(Thread: TWorkerThread);
45. begin
46.   if (Thread = nil) then exit;
47.   FSem.Lock;
48.   try
49.     if (FWorkers.IndexOf(Thread) < 0) then
50.       exit
51.     else begin
52.       if (not Thread.Terminated) then Thread.Terminate;
53.       if (Thread.Suspended) then Thread.Start;
54.     end;
55.   finally
56.     FSem.Unlock;
57.   end;
58.   repeat
59.     FSem.Lock;
60.     try
61.       if (FWorkers.IndexOf(Thread) < 0) then exit;
62.     finally
63.       FSem.Unlock;
64.     end;
65.     Sleep(1);
66.   until (False);
67. end;
68.  
69. procedure TWorkerThreadList.UnregisterWorkerThread(AThread: TWorkerThread);
70. begin
71.   if ((AThread = nil) or (AThread.FOwner <> Self)) then
72.     exit;
73.   FSem.Lock;
74.   try
75.     FWorkers.Remove(AThread);
76.     AThread.FOwner := nil;
77.   finally
78.     FSem.Unlock;
79.   end;
80. end;
81.  
82. procedure TWorkerThreadList.TerminateWorkerThreads(Wait: Boolean);
83. var
84.   I, J: Integer;
85. begin
86.   repeat
87.     FSem.Lock;
88.     try
89.       J := FWorkers.Count;
90.       for I := 0 to J-1 do
91.       begin
92.         with TWorkerThread(FWorkers[I]) do
93.         begin
94.           if (not Terminated) then Terminate;
95.           if (Suspended) then Start;
96.         end;
97.       end;
98.     finally
99.       FSem.Unlock;
100.     end;
101.     Sleep(1);
102.   until ((J = 0) or not Wait);
103. end;
104.  
105. { TWorkerThread }
106.  
107. procedure TWorkerThread.Execute;
108. begin
109.   try
110.     if (Assigned(FOnWork)) then FOnWork(Self);
111.   except
112.   end;
113.   if (FOwner <> nil) then FOwner.UnregisterWorkerThread(Self);
114. end;
115.  
116. constructor TWorkerThread.Create(AOwner: TWorkerThreadList; AOnWork: TWorkEvent;
117.   AParam: Pointer);
118. begin
119.   inherited Create(True);
120.   FreeOnTerminate := True;
121.   Priority := tpIdle;
122.   FOwner := AOwner;
123.   FOnWork := AOnWork;
124.   FParam := AParam;
125. end;
126.  
127. destructor TWorkerThread.Destroy;
128. begin
129.   if (FOwner <> nil) then FOwner.UnregisterWorkerThread(Self);
130.   inherited Destroy;
131. end;
132.  
133. { TSemaphore }
135. constructor TSemaphore.Create;
136. begin
137.   FSem := 0;
138. end;
140. destructor TSemaphore.Destroy;
141. begin
142.   Unlock;
143.   inherited Destroy;
144. end;
     
146. procedure TSemaphore.Lock;
147. begin
148.   while (InterLockedExchange(FSem, 1) = 1) do Sleep(1);
149. end;
150.  
151. procedure TSemaphore.Unlock;
152. begin
153.   InterLockedExchange(FSem, 0);
154. end; 

Using this class I can run a procedure of object with this parameter using TWorkerThreadList object:

  TWorkEvent = procedure(WT: TWorkerThread) of object;

How to use the TWorkerThreadList class:

• Define WorkerThreads variable as global variable or in the data module:
  
      WorkerThreads: TWorkerThreadList;
  
  
•  Add object create and free for the WorkerThreads object in the data module on create and on destroy:
  
  1. procedure TDaemon1.DataModuleCreate(Sender: TObject);
  2. begin
  3.   WorkerThreads := TWorkerThreadList.Create;
  4. end;
  5.  
  6. procedure TDaemon1.DataModuleDestroy(Sender: TObject);
  7. begin
  8.   WorkerThreads.Free;
  9. end;
• Create the thread procedure:
  
  1. procedure TDaemon1.WorkServerListener(Thread: TWorkerThread);
  2. begin
  3.   try
  4.     { do something } 
  5.   except
  6.     on E: Exception do
  7.       DebugLog('Daemon process terminated by error '+E.ClassName+': '+
  8.         E.Message);
  9.   end;
  10. end;
•  Create thread for the procedure:
  
  1. procedure TDaemon1.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean
  2.   );
  3. begin
  4.   WorkerThreads.AddNew(@WorkServerListener, nil);
  5.   OK := True; 
  6. end;

WorkerThreadList object can be created and destroyed as needed. A WorkerThreadList object can run alot of procedures.

Working with thread can be tricky, You have to be carefull with race condition, some objects that is not thread safe you need to put semaphore so that only one thread can access it at a time. Memory leak is not the only bugs.

Thats all for the WorkerThreadList object, and I hope this article can be useful.