freepascal.compiler/rtl/win/systlsdir.inc

{
    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';
procedure InitHeap; external name '_FPC_InitHeap';
{$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:
         begin
           InitHeap;
           InitSystemThreads;
         end;

       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}