sysinit.pas

这是不可多得的源代码

{ *********************************************************************** }
{                                                                         }
{ Delphi / Kylix Cross-Platform Runtime Library                           }
{ System Initialization Unit                                              }
{                                                                         }
{ Copyright (c) 1997-2002 Borland Software Corporation                   }
{                                                                         }
{  This file may be distributed and/or modified under the terms of the    }
{  GNU General Public License version 2 as published by the Free Software }
{  Foundation and appearing at http://www.borland.com/kylix/gpl.html.     }
{                                                                         }
{  Licensees holding a valid Borland No-Nonsense License for this         }
{  Software may use this file in accordance with such license, which      }
{  appears in the file license.txt that came with this software.          }
{                                                                         }
{ *********************************************************************** }

unit SysInit;

interface

{$H+,I-,R-,S-,O+,W-}
{$WARN SYMBOL_PLATFORM OFF}

{$IFDEF LINUX}
const
  ExeBaseAddress = Pointer($8048000) platform;
{$ENDIF}

var
  ModuleIsLib: Boolean;         { True if this module is a dll (a library or a package) }
  ModuleIsPackage: Boolean;     { True if this module is a package }
  ModuleIsCpp: Boolean;         { True if this module is compiled using C++ Builder }
  TlsIndex: Integer = -1;       { Thread local storage index }
  TlsLast: Byte;                { Set by linker so its offset is last in TLS segment }
  HInstance: LongWord;          { Handle of this instance }
  {$EXTERNALSYM HInstance}
  (*$HPPEMIT 'namespace Sysinit' *)
  (*$HPPEMIT '{' *)
  (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *)
  (*$HPPEMIT '} /* namespace Sysinit */' *)
  DllProc: TDLLProc;            { Called whenever DLL entry point is called }
  { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit }
  DllProcEx: TDLLProcEx absolute DllProc;
  DataMark: Integer = 0;        { Used to find the virtual base of DATA seg }
  CoverageLibraryName: array [0..128] of char = '*'; { initialized by the linker! }
{$IFDEF ELF}
  TypeImportsTable: array [0..0] of Pointer platform;  { VMT and RTTI imports table for exes }
  _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform;
  (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *)
{$IFDEF PC_MAPPED_EXCEPTIONS}
  TextStartAdj: Byte platform;            { See GetTextStart }
  CodeSegSize: Byte platform;             { See GetTextStart }
function GetTextStart : LongInt; platform;
{$ENDIF}
{$ENDIF}

const
  PtrToNil: Pointer = nil;     // provides pointer to nil for compiler codegen

function _GetTls: Pointer;
{$IFDEF LINUX}
procedure _InitLib(Context: PInitContext);
procedure _GetCallerEIP;
procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer);
procedure _start; cdecl;
function _ExitLib: Integer; cdecl;
function _InitPkg: LongBool;
{$ENDIF}
{$IFDEF MSWINDOWS}
procedure _InitLib;
procedure _InitExe(InitTable: Pointer);
function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall;
{$ENDIF}
procedure _PackageLoad(const Table: PackageInfo);
procedure _PackageUnload(const Table: PackageInfo);

{ Invoked by C++ startup code to allow initialization of VCL global vars }
procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl;
procedure VclExit; cdecl;

{$IFDEF LINUX}
function GetThisModuleHandle: LongWord;
{$ENDIF}

implementation

{$IFDEF MSWINDOWS}
const
  kernel = 'kernel32.dll';

function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
  external kernel name 'FreeLibrary';

function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall;
  external kernel name 'GetModuleFileNameA';

function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
  external kernel name 'GetModuleHandleA';

function LocalAlloc(flags, size: Integer): Pointer; stdcall;
  external kernel name 'LocalAlloc';

function LocalFree(addr: Pointer): Pointer; stdcall;
  external kernel name 'LocalFree';

function TlsAlloc: Integer; stdcall;
  external kernel name 'TlsAlloc';

function TlsFree(TlsIndex: Integer): Boolean; stdcall;
  external kernel name 'TlsFree';

function TlsGetValue(TlsIndex: Integer): Pointer; stdcall;
  external kernel name 'TlsGetValue';

function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall;
  external kernel name 'TlsSetValue';

function GetCommandLine: PChar; stdcall;
  external kernel name 'GetCommandLineA';

const
  tlsArray      = $2C;    { offset of tls array from FS: }
  LMEM_ZEROINIT = $40;

function AllocTlsBuffer(Size: Integer): Pointer;
begin
  Result := LocalAlloc(LMEM_ZEROINIT, Size);
end;

var
  tlsBuffer: Pointer;    // RTM32 DOS support
{$ENDIF}

{$IFDEF LINUX}

{$IFDEF PIC}
function GetGOT: Pointer; export;
begin
  asm
  MOV Result,EBX
  end;
end;
{$ENDIF}

const
  RTLD_LAZY = 1;
  RTLD_NOW  = 2;
  RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW;
  RTLD_GLOBAL = $100;
  RTLD_LOCAL  = 0;
  RTLD_NEXT = Pointer(-1);
  RTLD_DEFAULT = nil;

type
  TDLInfo = record
    Filename: PChar;
    BaseAddress: Pointer;
    NearestSymbolName: PChar;
    NearestSymbolAddr: Pointer;
  end;

const
  libcmodulename = 'libc.so.6';
  libdlmodulename = 'libdl.so.2';
  libpthreadmodulename = 'libpthread.so.0';
  tlsSizeName = '@Sysinit@tlsSize';

function malloc(Size: LongWord): Pointer; cdecl;
  external libcmodulename name 'malloc';

procedure free(P: Pointer); cdecl;
  external libcmodulename name 'free';

function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl;
  external libdlmodulename name 'dlopen';

function dlerror: PChar; cdecl;
  external libdlmodulename name 'dlerror';

function dlsym(Handle: LongWord; Symbol: PChar): Pointer;  cdecl;
  external libdlmodulename name 'dlsym';

function dlclose(Handle: LongWord): Integer;  cdecl;
  external libdlmodulename name 'dlclose';

function FreeLibrary(Handle: LongWord): Integer; cdecl;
  external libdlmodulename name 'dlclose';

function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl;
  external libdlmodulename name 'dladdr';

type
  TInitOnceProc = procedure; cdecl;
  TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl;

function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl;
  external libpthreadmodulename name 'pthread_once';

function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl;
  external libpthreadmodulename name 'pthread_key_create';

function pthread_key_delete(Key: Integer): Integer; cdecl;
  external libpthreadmodulename name 'pthread_key_delete';

function TlsGetValue(Key: Integer): Pointer; cdecl;
  external libpthreadmodulename name 'pthread_getspecific';

function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl;
  external libpthreadmodulename name 'pthread_setspecific';

function AllocTlsBuffer(Size: Cardinal): Pointer;
begin
  // The C++ rtl handles all tls in a C++ module
  if ModuleIsCpp then
    RunError(226);

  Result := malloc(Size);
  if Result <> nil then
    FillChar(Result^, Size, 0);
end;

procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl;
begin
  // The C++ rtl handles all tls in a C++ module
  if ModuleIsCpp then
    RunError(226);
  free(ValueInKey);
end;

procedure AllocTlsIndex; cdecl export;
begin
  // guaranteed to reach here only once per process
  // The C++ rtl handles all tls in a C++ module
  if ModuleIsCpp then
    RunError(226);
  if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then
  begin
    TlsIndex := -1;
    RunError(226);
  end;
end;

function GetThisModuleHandle: LongWord;
var
  Info: TDLInfo;
begin
  if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then
    Info.FileName := nil; // if we're not in a library, we must be main exe
  Result := LongWord(dlopen(Info.Filename, RTLD_LAZY));
  if Result <> 0 then
    dlclose(Result);
end;

var
  InitOnceSemaphore: Integer;
{$ENDIF}

var
  Module: TLibModule = (
    Next: nil;
    Instance: 0;
    CodeInstance: 0;
    DataInstance: 0;
    ResInstance: 0;
    Reserved: 0
{$IFDEF LINUX}
    ; InstanceVar: nil;
    GOT: 0;
    CodeSegStart: 0;
    CodeSegEnd: 0
    );
{$ELSE}
    );
{$ENDIF}

function GetTlsSize: Integer;
{$IFDEF LINUX}
asm
        MOV  EAX, offset TlsLast
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
begin
  Result := Integer(@TlsLast);
end;
{$ENDIF}

procedure       InitThreadTLS;
var
  p: Pointer;
  tlsSize: Integer;
begin
  tlsSize := GetTlsSize;
  if tlsSize = 0 then  Exit;
{$IFDEF LINUX}
  pthread_once(InitOnceSemaphore, AllocTlsIndex);
{$ENDIF}
  if TlsIndex = -1 then  RunError(226);
  p := AllocTlsBuffer(tlsSize);
  if p = nil then
    RunError(226)
  else
    TlsSetValue(TlsIndex, p);
end;

{$IFDEF MSWINDOWS}
procedure       InitProcessTLS;
begin
  if @TlsLast = nil then
    Exit;
  TlsIndex := TlsAlloc;
  InitThreadTLS;
  tlsBuffer := TlsGetValue(TlsIndex);  // RTM32 DOS support
end;

procedure       ExitThreadTLS;
var
  p: Pointer;
begin
  if @TlsLast = nil then
    Exit;
  if TlsIndex <> -1 then begin
    p := TlsGetValue(TlsIndex);
    if p <> nil then
      LocalFree(p);
  end;
end;

procedure       ExitProcessTLS;
begin
  if @TlsLast = nil then
    Exit;
  ExitThreadTLS;
  if TlsIndex <> -1 then
    TlsFree(TlsIndex);
end;
{$ENDIF}

const
  DLL_PROCESS_DETACH = 0;
  DLL_PROCESS_ATTACH = 1;
  DLL_THREAD_ATTACH  = 2;
  DLL_THREAD_DETACH  = 3;

function _GetTls: Pointer;
{$IFDEF LINUX}
begin
  Result := TlsGetValue(TlsIndex);
  if Result = nil then
  begin
    InitThreadTLS;
    Result := TlsGetValue(TlsIndex);
  end;
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
asm
        MOV     CL,ModuleIsLib
        MOV     EAX,TlsIndex
        TEST    CL,CL
        JNE     @@isDll
        MOV     EDX,FS:tlsArray
        MOV     EAX,[EDX+EAX*4]
        RET

@@initTls:
        CALL    InitThreadTLS
        MOV     EAX,TlsIndex
        PUSH    EAX
        CALL    TlsGetValue
        TEST    EAX,EAX
        JE      @@RTM32
        RET

@@RTM32:
        MOV     EAX, tlsBuffer
        RET

@@isDll:
        PUSH    EAX
        CALL    TlsGetValue
        TEST    EAX,EAX
        JE      @@initTls
end;

const
  TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure =
    (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS);
{$ENDIF}

{$IFDEF PC_MAPPED_EXCEPTIONS}
const
  UNWINDFI_TOPOFSTACK =   $BE00EF00;

{
  The linker sets the value of TextStartAdj to be the delta between GetTextStart
  and the start of the text segment.  This allows us to get the pointer to the
  start of the text segment in a position independent fashion.
}
function GetTextStart : LongInt;
asm
        CALL  @@label1
@@label1:
        POP   EAX
        SUB   EAX, 5 + offset TextStartAdj
end;

{
  The linker sets the value of CodeSegSize to the length of the text segment,
  excluding the PC map.  This allows us to get the pointer to the exception
  information that we need at runtime, also in a position independent fashion.
}
function GetTextEnd : LongInt;
asm
        CALL  GetTextStart
        ADD   EAX, offset CodeSegSize
end;
{$ENDIF}

procedure InitializeModule;
begin