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. var
46.   I: Integer; 
47. begin
48.   if (Thread = nil) then exit;
49.   FSem.Lock;
50.   try
51.     if (FWorkers.IndexOf(Thread) < 0) then
52.       exit
53.     else begin
54.       if (not Thread.Terminated) then Thread.Terminate;
55.       if (Thread.Suspended) then Thread.Start;
56.     end;
57.   finally
58.     FSem.Unlock;
59.   end;
60.   repeat
61.     FSem.Lock;
62.     try
63.       I := FWorkers.IndexOf(Thread); 
64.       if (I < 0) then exit;
65.       if (Thread.Finished or (Thread.ThreadId = 0)) then
66.       begin
67.         FWorkers.Remove(Thread); 
68.         Thread.FOwner := nil;
69.         Thread.Free; 
70.         exit; 
71.       end; 
72.     finally
73.       FSem.Unlock;
74.     end;
75.     Sleep(1);
76.   until (False);
77. end;
78.  
79. procedure TWorkerThreadList.UnregisterWorkerThread(AThread: TWorkerThread);
80. begin
81.   if ((AThread = nil) or (AThread.FOwner <> Self)) then
82.     exit;
83.   FSem.Lock;
84.   try
85.     FWorkers.Remove(AThread);
86.     AThread.FOwner := nil;
87.   finally
88.     FSem.Unlock;
89.   end;
90. end;
91.  
92. procedure TWorkerThreadList.TerminateWorkerThreads(Wait: Boolean);
93. var
94.   I, J: Integer;
95. begin
96.   repeat
97.     FSem.Lock;
98.     try
99.       J := 0;
100.       for I := FWorkers.Count-1 downto 0 do
101.       begin
102.         with TWorkerThread(FWorkers[I]) do
103.         begin
104.           if (not Finished and (ThreadId <> 0)) then
105.           begin 
106.             if (not Terminated) then Terminate;
107.             if (Suspended) then Start;
108.             Inc(J); 
109.           end; 
110.         end;
111.       end;
112.     finally
113.       FSem.Unlock;
114.     end; 
115.     if (J > 0) then Sleep(70);
116.   until ((J = 0) or not Wait);
117.  
118.   FSem.Lock; 
119.   try
120.     for I := FWorkers.Count-1 downto 0 do 
121.     begin
122.       try 
123.         TWorkerThread(FWorkers[I]).FOwner := nil;
124.         TWorkerThread(FWorkers[I]).Free; 
125.       except
126.         // 
127.       end; 
128.     end; 
129.     FWorkers.Clear; 
130.   finally
131.     FSem.Unlock; 
132.   end; 
133. end;
134.  
135. { TWorkerThread }
136.  
137. procedure TWorkerThread.Execute;
138. begin
139.   try
140.     if (Assigned(FOnWork)) then FOnWork(Self);
141.   except
142.   end;
143.   if (FOwner <> nil) then FOwner.UnregisterWorkerThread(Self);
144. end;
145.  
146. constructor TWorkerThread.Create(AOwner: TWorkerThreadList; AOnWork: TWorkEvent;
147.   AParam: Pointer);
148. begin
149.   inherited Create(True);
150.   FreeOnTerminate := True;
151.   Priority := tpIdle;
152.   FOwner := AOwner;
153.   FOnWork := AOnWork;
154.   FParam := AParam;
155. end;
156.  
157. destructor TWorkerThread.Destroy;
158. begin
159.   if (FOwner <> nil) then FOwner.UnregisterWorkerThread(Self);
160.   inherited Destroy;
161. end;
162.  
163. { TSemaphore }
165. constructor TSemaphore.Create;
166. begin
167.   FSem := 0;
168. end;
170. destructor TSemaphore.Destroy;
171. begin
172.   Unlock;
173.   inherited Destroy;
174. end;
     
176. procedure TSemaphore.Lock;
177. begin
178.   while (InterLockedExchange(FSem, 1) = 1) do Sleep(1);
179. end;
180.  
181. procedure TSemaphore.Unlock;
182. begin
183.   InterLockedExchange(FSem, 0);
184. 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.     { do handle exceptions }
  7.   end;
  8. 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.