1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
{ %target=win32,win64 }
{ %needlibrary }
{
Win32 DLL usage example. It needs testdll.pp DLL
The use of threads creates RTE problems with compilers
up to 2.4.4 release at least.
}
program ttdlltest;
uses
Windows;
procedure p1(var S : string);
external 'testdll' name 'P1';
procedure proc2(x:longint);
external 'testdll' name 'Proc2';
function GetTestStr : string;
external 'testdll' name 'GetTestStr';
const
GlobalThreadIndex : longint = 0;
ThreadCount = 8;
StackSize = $100000;
function ThreadMain (Param : pointer) : DWord; stdcall;
var
ThreadIndex : longint;
begin
ThreadMain:=0;
ThreadIndex:=InterlockedIncrement(GlobalThreadIndex);
Writeln('Main: Starting new thread ',hexstr(PtrUint(Param),2*sizeof(pointer)),' ',ThreadIndex);
Writeln('Main: Thread Id=',GetCurrentTHreadID);
Proc2(GlobalThreadIndex);
Sleep (3000);
Write('Main: Finishing thread ',ThreadIndex);
Writeln(' Thread Id=',GetCurrentTHreadID);
InterlockedDecrement(GlobalThreadIndex);
end;
procedure LaunchThreads;
var
i : longint;
ThreadResult : Handle;
_threadid : DWord;
begin
for i:=1 to ThreadCount do
begin
ThreadResult:=CreateThread(nil,stacksize,@ThreadMain,
@GlobalThreadIndex,0,_threadid);
end;
end;
var
s : string;external 'testdll' name 'FPC_string';
s2 : string;
procedure MyMainHook(DllParma : PtrInt);
begin
Writeln('Main: Thread Detach Hook called with DLLParam=',DllParam);
end;
begin
Dll_Thread_Detach_Hook:=@MyMainHook;
writeln('Main: Hello!');
s2:='Test before';
p1(s2);
if s2<>'New value' then
begin
Writeln('Main: Error while calling P1');
Halt(1);
end;
writeln('Main: ',Hinstance,' ',Hprevinst);
writeln('Main: testdll s string = ',s);
s:='Changed by program';
if GetTestStr<>'Changed by program' then
begin
Writeln('Error in DLL variable handling');
Halt(1);
end;
proc2(1234);
LaunchThreads;
Sleep(2000);
While GlobalThreadIndex>0 do
begin
Writeln('Main: Waiting for threads to finish');
Sleep(2000);
end;
end.
|
