paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 11:09:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

Rework TlsKey handling on Windows so that it works as intended with indirect main information

Browse Source 
rtl/inc/system.inc:
  * SetupEntryInformation: call new, optional function OSSetupEntryInformation to handle platform specific entry information initialization
rtl/win/sysosh.inc, TEntryInformationOS:
  + new field TlsKeyAddr which will hold the address to the main binary's TlsKey variable
win32/sysinit.inc:
  + provide the variable holding the TlsKey and pass that on to the entry information record
win32/system.pp:
  + new OS specific entry information initialization (currently only the TlsKey)
win/systhrd.inc:
  * declare TlsKey as a pointer to a DWord value instead of a DWord; on non-indirect entry platforms this is initialized with the address of new variable TlsKeyVar, on indirect entry platforms it will be initialized by the entry information initialization
  * adjust usages of TlsKey from DWord to PDWord
win/systlsdir.inc:
  * TlsKey is now a PDWord and (in sysinit) points to TlsKeyVar
win/syswin.inc:
  * adjust TlsKey usage
inc/heaptrc.pp:
  * TlsKey is now a PDWord, thus adjust the import and the usage

git-svn-id: trunk@33091 -
This commit is contained in:
svenbarth 2016-02-12 17:03:52 +00:00
parent 8775897621
commit 6afda909d4
8 changed files with 39 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
rtl/inc/heaptrc.pp
View File

@ -915,7 +915,7 @@ var
edata : ptruint; external name '__data_end__';
sbss : ptruint; external name '__bss_start__';
ebss : ptruint; external name '__bss_end__';
TLSKey : DWord; external name '_FPC_TlsKey';
TLSKey : PDWord; external name '_FPC_TlsKey';
TLSSize : DWord; external name '_FPC_TlsSize';
function TlsGetValue(dwTlsIndex : DWord) : pointer;
@ -989,9 +989,9 @@ begin
if (ptruint(p)>=ptruint(@sbss)) and (ptruint(p)<ptruint(@ebss)) then
exit;
{ is program multi-threaded and p inside Threadvar range? }
if TlsKey<>-1 then
if TlsKey^<>-1 then
begin
datap:=TlsGetValue(tlskey);
datap:=TlsGetValue(tlskey^);
if ((ptruint(p)>=ptruint(datap)) and
(ptruint(p)<ptruint(datap)+TlsSize)) then
exit;

3
rtl/inc/system.inc
View File

@ -126,6 +126,9 @@ begin
EntryInformation := info;
FPCResStrInitTables := info.ResStrInitTables;
FPCResourceStringTables := info.ResourceStringTables;
{$ifdef FPC_SYSTEM_HAS_OSSETUPENTRYINFORMATION}
OSSetupEntryInformation(info);
{$endif FPC_SYSTEM_HAS_OSSETUPENTRYINFORMATION}
end;
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}

1
rtl/win/sysosh.inc
View File

@ -53,6 +53,7 @@ type
{$define HAS_ENTRYINFORMATION_OS}
TEntryInformationOS = record
asm_exit : Procedure;stdcall;
TlsKeyAddr : PDWord;
end;
{$endif Win32}

33
rtl/win/systhrd.inc
View File

@ -94,7 +94,12 @@ var
var
// public names are used by heaptrc unit
threadvarblocksize : dword; public name '_FPC_TlsSize';
TLSKey : DWord = $ffffffff; public name '_FPC_TlsKey';
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
TLSKey : PDword = nil; public name '_FPC_TlsKey';
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
TLSKeyVar : DWord = $ffffffff;
TLSKey : PDWord = @TLSKeyVar; public name '_FPC_TlsKey';
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
var
MainThreadIdWin32 : DWORD;
@ -121,15 +126,15 @@ var
{ these aren't allocated yet ... }
{ allocate room on the heap for the thread vars }
errorsave:=GetLastError;
if tlskey=$ffffffff then
if tlskey^=$ffffffff then
RunError(226);
dataindex:=TlsGetValue(tlskey);
dataindex:=TlsGetValue(tlskey^);
if dataindex=nil then
begin
dataindex:=pointer(LocalAlloc(LMEM_FIXED or LMEM_ZEROINIT,threadvarblocksize));
if dataindex=nil then
RunError(226);
TlsSetValue(tlskey,dataindex);
TlsSetValue(tlskey^,dataindex);
end;
SetLastError(errorsave);
end;
@ -141,10 +146,10 @@ var
{ do not check IsMultiThread, as program could have altered it, out of Delphi habit }
{ the thread attach/detach code uses locks to avoid multiple calls of this }
if TLSKey=$ffffffff then
if TLSKey^=$ffffffff then
begin
{ We're still running in single thread mode, setup the TLS }
TLSKey:=TlsAlloc;
TLSKey^:=TlsAlloc;
InitThreadVars(@SysRelocateThreadvar);
IsMultiThread:=true;
@ -154,9 +159,9 @@ var
procedure SysFiniMultithreading;
begin
if TLSKey<>$ffffffff then
TlsFree(TLSKey);
TLSKey:=$ffffffff;
if TLSKey^<>$ffffffff then
TlsFree(TLSKey^);
TLSKey^:=$ffffffff;
end;
function SysRelocateThreadvar(offset : dword) : pointer;
@ -165,11 +170,11 @@ var
errorsave : dword;
begin
errorsave:=GetLastError;
dataindex:=TlsGetValue(tlskey);
dataindex:=TlsGetValue(tlskey^);
if dataindex=nil then
begin
SysAllocateThreadVars;
dataindex:=TlsGetValue(tlskey);
dataindex:=TlsGetValue(tlskey^);
InitThread($1000000);
end;
SetLastError(errorsave);
@ -181,12 +186,12 @@ var
var
p: pointer;
begin
if TLSKey<>$ffffffff then
if TLSKey^<>$ffffffff then
begin
p:=TlsGetValue(tlskey);
p:=TlsGetValue(tlskey^);
if Assigned(p) then
LocalFree(p);
TlsSetValue(tlskey, nil);
TlsSetValue(tlskey^, nil);
end;
end;

4
rtl/win/systlsdir.inc
View File

@ -33,7 +33,7 @@ Const
DLL_THREAD_DETACH = 3;
var
TlsKey : dword; external name '_FPC_TlsKey';
TlsKey : PDWord = @TlsKeyVar;
type
TTlsDirectory=packed record
@ -107,7 +107,7 @@ procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer
end;
DLL_THREAD_DETACH :
begin
if TlsGetValue(TLSKey)<>nil then
if TlsGetValue(TLSKey^)<>nil then
DoneThread; { Assume everything is idempotent there }
end;
end;

2
rtl/win/syswin.inc
View File

@ -400,7 +400,7 @@ function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntry
if assigned(Dll_Thread_Detach_Hook) then
Dll_Thread_Detach_Hook(DllParam);
{ Release Threadvars }
if TlsGetValue(TLSKey)<>nil then
if TlsGetValue(TLSKey^)<>nil then
DoneThread; { Assume everything is idempotent there }
end;
DLL_PROCESS_DETACH :

3
rtl/win32/sysinit.inc
View File

@ -16,6 +16,7 @@
var
SysInstance : Longint;external name '_FPC_SysInstance';
TlsKeyVar: DWord = $ffffffff;
InitFinalTable : record end; external name 'INITFINAL';
ThreadvarTablesTable : record end; external name 'FPC_THREADVARTABLES';
@ -65,6 +66,7 @@
valgrind_used : false;
OS : (
asm_exit : @asm_exit;
TlsKeyAddr : @TlsKeyVar;
);
);
@ -78,6 +80,7 @@
EntryInformation.ResStrInitTables:=@ResStrInitTables;
EntryInformation.WideInitTables:=@WideInitTables;
EntryInformation.OS.asm_exit:=@asm_exit;
EntryInformation.OS.TlsKeyAddr:=@TlsKeyVar;
EntryInformation.PascalMain:=@PascalMain;}
SysInitEntryInformation.valgrind_used:=valgrind_used;
end;

7
rtl/win32/system.pp
View File

@ -113,6 +113,9 @@ implementation
var
SysInstance : Longint;public name '_FPC_SysInstance';
{$define FPC_SYSTEM_HAS_OSSETUPENTRYINFORMATION}
procedure OsSetupEntryInformation(const info: TEntryInformation); forward;
{$ifdef FPC_USE_WIN32_SEH}
function main_wrapper(arg: Pointer; proc: Pointer): ptrint; forward;
procedure OutermostHandler; external name '__FPC_DEFAULT_HANDLER';
@ -130,6 +133,10 @@ end;
{ include code common with win64 }
{$I syswin.inc}
procedure OsSetupEntryInformation(const info: TEntryInformation);
begin
TlsKey := info.OS.TlsKeyAddr;
end;
{*****************************************************************************
System Dependent Exit code