diff --git a/.gitattributes b/.gitattributes index da833c0b9e..ebf6df6cb3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8162,6 +8162,7 @@ rtl/win/sysheap.inc svneol=native#text/plain rtl/win/sysos.inc svneol=native#text/plain rtl/win/sysosh.inc svneol=native#text/plain rtl/win/systhrd.inc svneol=native#text/plain +rtl/win/systlsdir.inc svneol=native#text/plain rtl/win/sysutils.pp svneol=native#text/plain rtl/win/syswin.inc svneol=native#text/plain rtl/win/tthread.inc svneol=native#text/plain diff --git a/rtl/inc/thread.inc b/rtl/inc/thread.inc index d8622057dc..93adce84fe 100644 --- a/rtl/inc/thread.inc +++ b/rtl/inc/thread.inc @@ -603,7 +603,7 @@ begin SetThreadManager(NoThreadManager); end; -Procedure InitSystemThreads; +Procedure InitSystemThreads; public name '_FPC_InitSystemThreads'; begin { This should be changed to a real value during thread driver initialization if appropriate. } diff --git a/rtl/win/systhrd.inc b/rtl/win/systhrd.inc index 1d5551996e..ee528f88ee 100644 --- a/rtl/win/systhrd.inc +++ b/rtl/win/systhrd.inc @@ -95,7 +95,8 @@ var threadvarblocksize : dword = 0; const - TLSKey : DWord = $ffffffff; + TLSKey : DWord = $ffffffff; public name '_FPC_TlsKey'; + var MainThreadIdWin32 : DWORD; @@ -110,7 +111,7 @@ var end; - procedure SysAllocateThreadVars; + procedure SysAllocateThreadVars; public name '_FPC_SysAllocateThreadVars'; var dataindex : pointer; errorsave : dword; @@ -482,7 +483,7 @@ end; Var WinThreadManager : TThreadManager; -Procedure InitSystemThreads; +Procedure InitSystemThreads;public name '_FPC_InitSystemThreads'; {$IFDEF SUPPORT_WIN95} var KernelHandle : THandle; diff --git a/rtl/win/systlsdir.inc b/rtl/win/systlsdir.inc new file mode 100644 index 0000000000..d959fab813 --- /dev/null +++ b/rtl/win/systlsdir.inc @@ -0,0 +1,148 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2008 by Florian Klaempfl and Pavel Ozerski + member of the Free Pascal development team. + + FPC Pascal system unit part shared by win32/win64. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{ TLS Directory code } + +{$ifdef FPC_USE_TLS_DIRECTORY} +{ Process TLS callback function } +{ This is only useful for executables + for DLLs, DLL_Entry gets called. PM } +{ The consts are the same as for DDL_Entry, + but as this file can be either in system unit or sysinitXXX + we need to rename them with EXEC prefix + to avoid duplicate entries. } +Const + EXEC_PROCESS_ATTACH = 1; + EXEC_THREAD_ATTACH = 2; + EXEC_PROCESS_DETACH = 0; + EXEC_THREAD_DETACH = 3; +{$ifdef FPC_INSSIDE_SYSINIT} +var + TlsKey : dword; external name '_FPC_TlsKey'; + +type + TTlsDirectory=packed record + data_start, data_end : pointer; + index_pointer, callbacks_pointer : pointer; + zero_fill_size : dword; + flags : dword; + end; + + +function TlsGetValue(dwTlsIndex : DWord) : pointer; stdcall; + external 'kernel32' name 'TlsGetValue'; + +procedure InitSystemThreads; external name '_FPC_InitSystemThreads'; +procedure SysAllocateThreadVars; external name '_FPC_SysAllocateThreadVars'; +{$endif FPC_INSSIDE_SYSINIT} + +procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer); + stdcall; [public,alias:'_FPC_Tls_Callback']; + begin + if IsLibrary then + Exit; + case reason of + { For executables, EXEC_PROCESS_ATTACH is called *before* the entry point, + and EXEC_PROCESS_DETACH is called *after* RTL shuts down and calls ExitProcess. + It isn't a good idea to handle resources of the main thread at these points. + InitSystemThreads is necessary however, because if some statically loaded + DLL creates a thread, it will invoke EXEC_THREAD_ATTACH before anything else is + initialized. + TODO: The problem is that InitSystemThreads depends (in case of Win32) + on EntryInformation which is not available at this point. + Solving it properly needs to move this routine + to sysinit unit or something like that. + Exec_Tls_Callback is now part of sysinit unit for win32 + and the EntryInformation is a constant which sholud prevent troubles } + EXEC_PROCESS_ATTACH: + InitSystemThreads; + + EXEC_THREAD_ATTACH : + begin + { !!! SysInitMultithreading must NOT be called here. Windows guarantees that + the main thread invokes PROCESS_ATTACH, not THREAD_ATTACH. So this always + executes in non-main thread. SysInitMultithreading() here will cause + initial threadvars to be copied to TLS of non-main thread, and threadvars + of the main thread will be reinitialized upon the next access with zeroes, + ending up in a delayed failure which is very hard to debug. + Fortunately this nasty scenario can happen only when the first non-main thread + was created outside of RTL (Sergei). + } + { Allocate Threadvars } + SysAllocateThreadVars; + + { 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; + EXEC_THREAD_DETACH : + begin + if TlsGetValue(TLSKey)<>nil then + DoneThread; { Assume everything is idempotent there } + end; + end; + end; + + +{ Mingw tlssup.c source code has + _CRTALLOC(".CRT$XLA") PIMAGE_TLS_CALLBACK __xl_a = 0; + _CRTALLOC(".CRT$XLZ") PIMAGE_TLS_CALLBACK __xl_z = 0; + and the callback pointer is set to: + (&__xl_a+1), (+1 meaning =+sizeof(pointer)) + I am not sure this can be compatible with +} + +const + FreePascal_TLS_callback : pointer = @Exec_Tls_callback; + public name '__FPC_tls_callbacks' section '.CRT$XLFPC'; + FreePascal_end_of_TLS_callback : pointer = nil; + public name '__FPC_end_of_tls_callbacks' section '.CRT$XLZZZ'; +var + tls_callbacks : pointer; external name '___crt_xl_start__'; + tls_data_start : pointer; external name '___tls_start__'; + tls_data_end : pointer; external name '___tls_end__'; + + _tls_index : dword; cvar; external; + +const + _tls_used : TTlsDirectory = ( + data_start : @tls_data_start; + data_end : @tls_data_end; + index_pointer : @_tls_index; + callbacks_pointer : @tls_callbacks; + zero_fill_size : 0; + flags : 0; + ); cvar; public; + +{$ifdef win64} + { This is a hack to support external linking. + All released win64 versions of GNU binutils miss proper prefix handling + when searching for _tls_used and expect two leading underscores. + The issue has been fixed in binutils snapshots, but not released yet. + + TODO: This should be removed as soon as next version of binutils (>2.21) is + released and we upgrade to it. } + __tls_used : TTlsDirectory = ( + data_start : @tls_data_start; + data_end : @tls_data_end; + index_pointer : @_tls_index; + callbacks_pointer : @tls_callbacks; + zero_fill_size : 0; + flags : 0; + ); cvar; public; +{$endif win64} +{$endif FPC_USE_TLS_DIRECTORY} + diff --git a/rtl/win/syswin.inc b/rtl/win/syswin.inc index df5a588368..df1fbd5bb6 100644 --- a/rtl/win/syswin.inc +++ b/rtl/win/syswin.inc @@ -327,104 +327,9 @@ Procedure ExitDLL(Exitcode : longint); LongJmp(DLLBuf,1); end; -{$ifdef FPC_USE_TLS_DIRECTORY} -{ Process TLS callback function } -{ This is only useful for executables - for DLLs, DLL_Entry gets called. PM } - -procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer); - stdcall; [public,alias:'_FPC_Tls_Callback']; - begin - if IsLibrary then - Exit; - case reason of - { For executables, DLL_PROCESS_ATTACH is called *before* the entry point, - and DLL_PROCESS_DETACH is called *after* RTL shuts down and calls ExitProcess. - It isn't a good idea to handle resources of the main thread at these points. - InitSystemThreads is necessary however, because if some statically loaded - DLL creates a thread, it will invoke DLL_THREAD_ATTACH before anything else is - initialized. - TODO: The problem is that InitSystemThreads depends (in case of Win32) on EntryInformation - which is not available at this point. Solving it properly needs to move this routine - to sysinit unit or something like that. } -// DLL_PROCESS_ATTACH: -// InitSystemThreads; - - DLL_THREAD_ATTACH : - begin - { !!! SysInitMultithreading must NOT be called here. Windows guarantees that - the main thread invokes PROCESS_ATTACH, not THREAD_ATTACH. So this always - executes in non-main thread. SysInitMultithreading() here will cause - initial threadvars to be copied to TLS of non-main thread, and threadvars - of the main thread will be reinitialized upon the next access with zeroes, - ending up in a delayed failure which is very hard to debug. - Fortunately this nasty scenario can happen only when the first non-main thread - was created outside of RTL (Sergei). - } - { Allocate Threadvars } - SysAllocateThreadVars; - - { 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; - DLL_THREAD_DETACH : - begin - if TlsGetValue(TLSKey)<>nil then - DoneThread; { Assume everything is idempotent there } - end; - end; - end; - - -{ Mingw tlssup.c source code has - _CRTALLOC(".CRT$XLA") PIMAGE_TLS_CALLBACK __xl_a = 0; - _CRTALLOC(".CRT$XLZ") PIMAGE_TLS_CALLBACK __xl_z = 0; - and the callback pointer is set to: - (&__xl_a+1), (+1 meaning =+sizeof(pointer)) - I am not sure this can be compatible with -} - -const - FreePascal_TLS_callback : pointer = @Exec_Tls_callback; - public name '__FPC_tls_callbacks' section '.CRT$XLFPC'; - FreePascal_end_of_TLS_callback : pointer = nil; - public name '__FPC_end_of_tls_callbacks' section '.CRT$XLZZZ'; -var - tls_callbacks : pointer; external name '___crt_xl_start__'; - tls_data_start : pointer; external name '___tls_start__'; - tls_data_end : pointer; external name '___tls_end__'; - - _tls_index : dword; cvar; external; - -const - _tls_used : TTlsDirectory = ( - data_start : @tls_data_start; - data_end : @tls_data_end; - index_pointer : @_tls_index; - callbacks_pointer : @tls_callbacks; - zero_fill_size : 0; - flags : 0; - ); cvar; public; - {$ifdef win64} - { This is a hack to support external linking. - All released win64 versions of GNU binutils miss proper prefix handling - when searching for _tls_used and expect two leading underscores. - The issue has been fixed in binutils snapshots, but not released yet. - - TODO: This should be removed as soon as next version of binutils (>2.21) is - released and we upgrade to it. } - __tls_used : TTlsDirectory = ( - data_start : @tls_data_start; - data_end : @tls_data_end; - index_pointer : @_tls_index; - callbacks_pointer : @tls_callbacks; - zero_fill_size : 0; - flags : 0; - ); cvar; public; +{$include systlsdir.inc} {$endif win64} -{$endif FPC_USE_TLS_DIRECTORY} {**************************************************************************** @@ -681,7 +586,7 @@ var {$endif} function GetACP:UINT; stdcall; external 'kernel32' name 'GetACP'; -function GetConsoleCP:UINT; stdcall; external 'kernel32' name 'GetConsoleCP'; +function GetConsoleCP:UINT; stdcall; external 'kernel32' name 'GetConsoleCP'; function Win32GetStandardCodePage(const stdcp: TStandardCodePageEnum): TSystemCodePage; begin diff --git a/rtl/win32/sysinit.inc b/rtl/win32/sysinit.inc index e852a13395..c2d1f6e8aa 100644 --- a/rtl/win32/sysinit.inc +++ b/rtl/win32/sysinit.inc @@ -13,10 +13,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} - + var SysInstance : Longint;external name '_FPC_SysInstance'; - EntryInformation : TEntryInformation; InitFinalTable : record end; external name 'INITFINAL'; ThreadvarTablesTable : record end; external name 'FPC_THREADVARTABLES'; @@ -46,12 +45,25 @@ const STD_INPUT_HANDLE = dword(-10); + SysInitEntryInformation : TEntryInformation = ( + InitFinalTable : @InitFinalTable; + ThreadvarTablesTable : @ThreadvarTablesTable; + asm_exit : @asm_exit; + PascalMain : @PascalMain; + valgrind_used : false; + ); + procedure SetupEntryInformation; begin + { valgind_used is the only thng that can change at startup EntryInformation.InitFinalTable:=@InitFinalTable; EntryInformation.ThreadvarTablesTable:=@ThreadvarTablesTable; EntryInformation.asm_exit:=@asm_exit; - EntryInformation.PascalMain:=@PascalMain; - EntryInformation.valgrind_used:=valgrind_used; + EntryInformation.PascalMain:=@PascalMain;} + SysInitEntryInformation.valgrind_used:=valgrind_used; end; + +{$define FPC_INSSIDE_SYSINIT} +{$include systlsdir.inc} + diff --git a/rtl/win32/sysinitcyg.pp b/rtl/win32/sysinitcyg.pp index 69e2fcfbbd..b7fba0e024 100644 --- a/rtl/win32/sysinitcyg.pp +++ b/rtl/win32/sysinitcyg.pp @@ -41,7 +41,7 @@ unit sysinitcyg; {$ifdef FPC_USE_TLS_DIRECTORY} LinkIn(@tlsdir,@tls_callback_end,@tls_callback); {$endif} - EXE_Entry(EntryInformation); + EXE_Entry(SysInitEntryInformation); end; @@ -53,7 +53,7 @@ unit sysinitcyg; end; __main; SetupEntryInformation; - DLL_Entry(EntryInformation); + DLL_Entry(SysInitEntryInformation); end; diff --git a/rtl/win32/sysinitgprof.pp b/rtl/win32/sysinitgprof.pp index 448356b611..217c5372fb 100644 --- a/rtl/win32/sysinitgprof.pp +++ b/rtl/win32/sysinitgprof.pp @@ -75,7 +75,7 @@ unit sysinitgprof; {$ifdef FPC_USE_TLS_DIRECTORY} LinkIn(@tlsdir,@tls_callback_end,@tls_callback); {$endif} - EXE_Entry(EntryInformation); + EXE_Entry(SysInitEntryInformation); end; @@ -88,7 +88,7 @@ unit sysinitgprof; DLLgmon_start; __main; SetupEntryInformation; - DLL_Entry(EntryInformation); + DLL_Entry(SysInitEntryInformation); end; diff --git a/rtl/win32/sysinitpas.pp b/rtl/win32/sysinitpas.pp index 8d8d707c4f..2fea8d6bd8 100644 --- a/rtl/win32/sysinitpas.pp +++ b/rtl/win32/sysinitpas.pp @@ -35,7 +35,7 @@ unit sysinitpas; LinkIn(@tlsdir,@tls_callback_end,@tls_callback); {$endif} SetupEntryInformation; - Exe_entry(EntryInformation); + Exe_entry(SysInitEntryInformation); end; @@ -46,7 +46,7 @@ unit sysinitpas; LinkIn(@tlsdir,@tls_callback_end,@tls_callback); {$endif} SetupEntryInformation; - Exe_entry(EntryInformation); + Exe_entry(SysInitEntryInformation); end; @@ -57,7 +57,7 @@ unit sysinitpas; dllreason:=_dllreason; dllparam:=_dllparam; SetupEntryInformation; - DLL_Entry(EntryInformation); + DLL_Entry(SysInitEntryInformation); end; @@ -68,7 +68,7 @@ unit sysinitpas; dllreason:=_dllreason; dllparam:=_dllparam; SetupEntryInformation; - DLL_Entry(EntryInformation); + DLL_Entry(SysInitEntryInformation); end; end. diff --git a/rtl/win32/system.pp b/rtl/win32/system.pp index 9a241d7cd9..148b2b5d4a 100644 --- a/rtl/win32/system.pp +++ b/rtl/win32/system.pp @@ -123,8 +123,19 @@ Const implementation var - EntryInformation : TEntryInformation; SysInstance : Longint;public name '_FPC_SysInstance'; + InitFinalTable : record end; external name 'INITFINAL'; + ThreadvarTablesTable : record end; external name 'FPC_THREADVARTABLES'; + procedure PascalMain;stdcall;external name 'PASCALMAIN'; + procedure asm_exit;stdcall;external name 'asm_exit'; +const + EntryInformation : TEntryInformation = ( + InitFinalTable : @InitFinalTable; + ThreadvarTablesTable : @ThreadvarTablesTable; + asm_exit : @asm_exit; + PascalMain : @PascalMain; + valgrind_used : false; + ); { include system independent routines } {$I system.inc} @@ -142,7 +153,6 @@ procedure PascalMain;stdcall;external name 'PASCALMAIN'; {$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} procedure fpc_do_exit;stdcall;external name 'FPC_DO_EXIT'; Procedure ExitDLL(Exitcode : longint); forward; -procedure asm_exit;stdcall;external name 'asm_exit'; Procedure system_exit; begin @@ -653,7 +663,12 @@ function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; DataDirectory : array[1..$80] of byte; end; begin - result:=tpeheader((pointer(SysInstance)+(tdosheader(pointer(SysInstance)^).e_lfanew))^).SizeOfStackReserve; + if (SysInstance=0) and not IsLibrary then + SysInstance:=getmodulehandle(nil); + if (SysInstance=0) then + result:=stklen + else + result:=tpeheader((pointer(SysInstance)+(tdosheader(pointer(SysInstance)^).e_lfanew))^).SizeOfStackReserve; end;