paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-25 23:51:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix from Nikolay Samofatov for #12987: initialize thread vars in libraries on windows correctly

Browse Source 
* unified dll entry code between win32 and win64

git-svn-id: trunk@13445 -
This commit is contained in:
florian 2009-07-25 21:08:36 +00:00
parent 9856e548ed
commit 380f3ac78f
7 changed files with 163 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -9144,6 +9144,8 @@ tests/webtbs/tw12894.pp svneol=native#text/plain
tests/webtbs/tw12942.pp svneol=native#text/plain
tests/webtbs/tw1295.pp svneol=native#text/plain
tests/webtbs/tw12985.pp svneol=native#text/plain
tests/webtbs/tw12987a.pp svneol=native#text/plain
tests/webtbs/tw12987b.pp svneol=native#text/plain
tests/webtbs/tw1299.pp svneol=native#text/plain
tests/webtbs/tw12993.pp svneol=native#text/plain
tests/webtbs/tw13015.pp svneol=native#text/plain

30
rtl/win/systhrd.inc
View File

@ -138,6 +138,7 @@ CONST
procedure SysReleaseThreadVars;
begin
LocalFree(TlsGetValue(tlskey));
TlsSetValue(tlskey, nil);
end;
@ -175,6 +176,26 @@ CONST
ThreadMain:=ti.f(ti.p);
end;
procedure SysInitMultithreading;
begin
{ do not check IsMultiThread, as program could have altered it, out of Delphi habit }
if TLSKey = 0 then
begin
{ We're still running in single thread mode, setup the TLS }
TLSKey:=TlsAlloc;
InitThreadVars(@SysRelocateThreadvar);
IsMultiThread:=true;
end;
end;
procedure SysFiniMultithreading;
begin
if IsMultiThread then
begin
TlsFree(TLSKey);
TLSKey := 0;
end;
end;
function SysBeginThread(sa : Pointer;stacksize : ptruint;
ThreadFunction : tthreadfunc;p : pointer;
@ -187,13 +208,8 @@ CONST
writeln('Creating new thread');
{$endif DEBUG_MT}
{ Initialize multithreading if not done }
if not IsMultiThread then
begin
{ We're still running in single thread mode, setup the TLS }
TLSKey:=TlsAlloc;
InitThreadVars(@SysRelocateThreadvar);
IsMultiThread:=true;
end;
SysInitMultithreading;
{ the only way to pass data to the newly created thread
in a MT safe way, is to use the heap }
new(ti);

95
rtl/win/syswin.inc
View File

@ -14,6 +14,97 @@
**********************************************************************}
Const
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_PROCESS_DETACH = 0;
DLL_THREAD_DETACH = 3;
DLLExitOK : boolean = true;
Var
DLLBuf : Jmp_buf;
MainThreadIdWin32 : DWORD;
function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntryInformation){$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} : longbool; [public,alias:'_FPC_DLL_Entry'];
var
res : longbool;
begin
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
EntryInformation:=info;
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
IsLibrary:=true;
Dll_entry:=false;
case DLLreason of
DLL_PROCESS_ATTACH :
begin
MainThreadIdWin32 := Win32GetCurrentThreadId;
If SetJmp(DLLBuf) = 0 then
begin
if assigned(Dll_Process_Attach_Hook) then
begin
res:=Dll_Process_Attach_Hook(DllParam);
if not res then
exit(false);
end;
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
EntryInformation.PascalMain();
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
PascalMain;
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
Dll_entry:=true;
end
else
Dll_entry:=DLLExitOK;
end;
DLL_THREAD_ATTACH :
begin
inclocked(Thread_count);
if (Win32GetCurrentThreadId <> MainThreadIdWin32) then
begin
{ Set up TLS slot for the DLL }
SysInitMultiThreading;
{ Allocate Threadvars }
{ NS : no idea what is correct to pass here - pass dummy value for now }
{ passing a dummy is ok, the correct value is read from the coff header of SysInstance (FK) }
InitThread($1000000); { Assume everything is idempotent there, as the thread could have been created with BeginThread... }
end;
if assigned(Dll_Thread_Attach_Hook) then
Dll_Thread_Attach_Hook(DllParam);
Dll_entry:=true; { return value is ignored }
end;
DLL_THREAD_DETACH :
begin
declocked(Thread_count);
if assigned(Dll_Thread_Detach_Hook) then
Dll_Thread_Detach_Hook(DllParam);
{ Release Threadvars }
if (Win32GetCurrentThreadId <> MainThreadIdWin32) then
DoneThread; { Assume everything is idempotent there }
Dll_entry:=true; { return value is ignored }
end;
DLL_PROCESS_DETACH :
begin
Dll_entry:=true; { return value is ignored }
If SetJmp(DLLBuf) = 0 then
FPC_Do_Exit;
if assigned(Dll_Process_Detach_Hook) then
Dll_Process_Detach_Hook(DllParam);
{ Free TLS resources used by ThreadVars }
SysFiniMultiThreading;
end;
end;
end;
Procedure ExitDLL(Exitcode : longint);
begin
DLLExitOK:=ExitCode=0;
LongJmp(DLLBuf,1);
end;
{****************************************************************************
Error Message writing using messageboxes
****************************************************************************}
@ -120,7 +211,7 @@ function GetProcessID: SizeUInt;
begin
GetProcessID := ProcessID;
end;
{******************************************************************************
Unicode
@ -168,7 +259,7 @@ function Win32UnicodeLower(const s : UnicodeString) : UnicodeString;
CharLowerBuff(LPWSTR(result),length(result));
end;
{ there is a similiar procedure in sysutils which inits the fields which
are only relevant for the sysutils units }
procedure InitWin32Widestrings;

74
rtl/win32/system.pp
View File

@ -380,80 +380,6 @@ procedure Exe_entry(const info : TEntryInformation);[public,alias:'_FPC_EXE_Entr
system_exit;
end;
Const
{ DllEntryPoint }
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_PROCESS_DETACH = 0;
DLL_THREAD_DETACH = 3;
Var
DLLBuf : Jmp_buf;
Const
DLLExitOK : boolean = true;
function Dll_entry(const info : TEntryInformation) : longbool; [public,alias:'_FPC_DLL_Entry'];
var
res : longbool;
begin
EntryInformation:=info;
IsLibrary:=true;
Dll_entry:=false;
case DLLreason of
DLL_PROCESS_ATTACH :
begin
If SetJmp(DLLBuf) = 0 then
begin
if assigned(Dll_Process_Attach_Hook) then
begin
res:=Dll_Process_Attach_Hook(DllParam);
if not res then
exit(false);
end;
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
EntryInformation.PascalMain();
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
PascalMain;
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
Dll_entry:=true;
end
else
Dll_entry:=DLLExitOK;
end;
DLL_THREAD_ATTACH :
begin
inclocked(Thread_count);
{ Allocate Threadvars ?!}
if assigned(Dll_Thread_Attach_Hook) then
Dll_Thread_Attach_Hook(DllParam);
Dll_entry:=true; { return value is ignored }
end;
DLL_THREAD_DETACH :
begin
declocked(Thread_count);
if assigned(Dll_Thread_Detach_Hook) then
Dll_Thread_Detach_Hook(DllParam);
{ Release Threadvars ?!}
Dll_entry:=true; { return value is ignored }
end;
DLL_PROCESS_DETACH :
begin
Dll_entry:=true; { return value is ignored }
If SetJmp(DLLBuf) = 0 then
FPC_Do_Exit;
if assigned(Dll_Process_Detach_Hook) then
Dll_Process_Detach_Hook(DllParam);
end;
end;
end;
Procedure ExitDLL(Exitcode : longint);
begin
DLLExitOK:=ExitCode=0;
LongJmp(DLLBuf,1);
end;
function GetCurrentProcess : dword;
stdcall;external 'kernel32' name 'GetCurrentProcess';

77
rtl/win64/system.pp
View File

@ -409,7 +409,7 @@ procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
movl %eax,_SS(%rip)
{$else}
movl %eax,_SS
{$endif}
{$endif}
xorl %rbp,%rbp
call PASCALMAIN
popq %rbp
@ -420,77 +420,7 @@ procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
end;
Const
{ DllEntryPoint }
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_PROCESS_DETACH = 0;
DLL_THREAD_DETACH = 3;
Var
DLLBuf : Jmp_buf;
Const
DLLExitOK : boolean = true;
function Dll_entry : longbool;
var
res : longbool;
begin
IsLibrary:=true;
Dll_entry:=false;
case DLLreason of
DLL_PROCESS_ATTACH :
begin
If SetJmp(DLLBuf) = 0 then
begin
if assigned(Dll_Process_Attach_Hook) then
begin
res:=Dll_Process_Attach_Hook(DllParam);
if not res then
exit(false);
end;
PASCALMAIN;
Dll_entry:=true;
end
else
Dll_entry:=DLLExitOK;
end;
DLL_THREAD_ATTACH :
begin
inclocked(Thread_count);
{$warning Allocate Threadvars !}
if assigned(Dll_Thread_Attach_Hook) then
Dll_Thread_Attach_Hook(DllParam);
Dll_entry:=true; { return value is ignored }
end;
DLL_THREAD_DETACH :
begin
declocked(Thread_count);
if assigned(Dll_Thread_Detach_Hook) then
Dll_Thread_Detach_Hook(DllParam);
{$warning Release Threadvars !}
Dll_entry:=true; { return value is ignored }
end;
DLL_PROCESS_DETACH :
begin
Dll_entry:=true; { return value is ignored }
If SetJmp(DLLBuf) = 0 then
begin
FPC_DO_EXIT;
end;
if assigned(Dll_Process_Detach_Hook) then
Dll_Process_Detach_Hook(DllParam);
end;
end;
end;
Procedure ExitDLL(Exitcode : longint);
begin
DLLExitOK:=ExitCode=0;
LongJmp(DLLBuf,1);
end;
{$ifndef VER2_0}
function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntryInformation){$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} : longbool;forward;
procedure _FPC_mainCRTStartup;stdcall;public name '_mainCRTStartup';
begin
@ -525,9 +455,6 @@ begin
DLL_Entry;
end;
{$endif VER2_0}
function GetCurrentProcess : dword;
stdcall;external 'kernel32' name 'GetCurrentProcess';

23
tests/webtbs/tw12987a.pp Normal file
View File

@ -0,0 +1,23 @@
{ %norun }
library tw12987a;
procedure test;
var
p1,p2 : pointer;
i : longint;
begin
for i:=1 to 200000 do
begin
getmem(p1,random(1000));
getmem(p2,random(100));
freemem(p1);
freemem(p2);
end;
end;
exports
test;
begin
end.

20
tests/webtbs/tw12987b.pp Normal file
View File

@ -0,0 +1,20 @@
{ %needlibrary }
procedure test;external 'tw12987a' name 'test';
function ThreadTest(p : pointer) : PtrInt;
begin
test;
end;
var
t1,t2,t3 : TThreadID;
begin
t1:=BeginThread(@ThreadTest);
t2:=BeginThread(@ThreadTest);
t3:=BeginThread(@ThreadTest);
WaitForThreadTerminate(t1,0);
WaitForThreadTerminate(t2,0);
WaitForThreadTerminate(t3,0);
writeln('Finished');
end.