1{ 2 This file is part of the Free Pascal run time library. 3 Copyright (c) 1999-2005 by Florian Klaempfl and Pavel Ozerski 4 member of the Free Pascal development team. 5 6 FPC Pascal system unit for the Win32 API. 7 8 See the file COPYING.FPC, included in this distribution, 9 for details about the copyright. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 15 **********************************************************************} 16unit System; 17interface 18 19{$ifdef SYSTEMDEBUG} 20 {$define SYSTEMEXCEPTIONDEBUG} 21{$endif SYSTEMDEBUG} 22 23{$ifdef VER3_0} 24{ 3.1.1+ do not require this anymore } 25{$define FPC_HAS_INDIRECT_ENTRY_INFORMATION} 26{$endif VER3_0} 27 28{$ifdef cpui386} 29 {$define Set_i386_Exception_handler} 30{$endif cpui386} 31 32{$define DISABLE_NO_THREAD_MANAGER} 33{$define HAS_WIDESTRINGMANAGER} 34{$define DISABLE_NO_DYNLIBS_MANAGER} 35{$define FPC_SYSTEM_HAS_SYSDLH} 36{$define FPC_HAS_SETCTRLBREAKHANDLER} 37 38{$ifdef FPC_USE_WIN32_SEH} 39 {$define FPC_SYSTEM_HAS_RAISEEXCEPTION} 40 {$define FPC_SYSTEM_HAS_RERAISE} 41 {$define FPC_SYSTEM_HAS_DONEEXCEPTION} 42 {$define FPC_SYSTEM_HAS_SAFECALLHANDLER} 43{$endif FPC_USE_WIN32_SEH} 44 45{ include system-independent routine headers } 46{$I systemh.inc} 47{ include common windows headers } 48{$I syswinh.inc} 49 50var 51 MainInstance : longint; 52 53implementation 54 55var 56 FPCSysInstance : PLongint;public name '_FPC_SysInstance'; 57 58{$define FPC_SYSTEM_HAS_OSSETUPENTRYINFORMATION} 59procedure OsSetupEntryInformation(constref info: TEntryInformation); forward; 60 61{$ifdef FPC_USE_WIN32_SEH} 62function main_wrapper(arg: Pointer; proc: Pointer): ptrint; forward; 63procedure OutermostHandler; external name '__FPC_DEFAULT_HANDLER'; 64{$endif FPC_USE_WIN32_SEH} 65 66{$define FPC_SYSTEM_HAS_STACKTOP} 67function StackTop: pointer; assembler;nostackframe; 68asm 69 movl %fs:(4),%eax 70end; 71 72{ include system independent routines } 73{$I system.inc} 74 75{ include code common with win64 } 76{$I syswin.inc} 77 78procedure OsSetupEntryInformation(constref info: TEntryInformation); 79begin 80 TlsKey := info.OS.TlsKeyAddr; 81 FPCSysInstance := info.OS.SysInstance; 82 WStrInitTablesTable := info.OS.WideInitTables; 83end; 84 85{***************************************************************************** 86 System Dependent Exit code 87*****************************************************************************} 88 89{$ifndef FPC_USE_WIN32_SEH} 90procedure install_exception_handlers;forward; 91procedure remove_exception_handlers;forward; 92{$endif FPC_USE_WIN32_SEH} 93 94Procedure system_exit; 95begin 96 if IsLibrary then 97 begin 98 { If exiting from DLL_PROCESS_ATTACH/DETACH, unwind to DllMain context. } 99 if DllInitState in [DLL_PROCESS_ATTACH,DLL_PROCESS_DETACH] then 100 LongJmp(DLLBuf,1) 101 else 102 { Abnormal termination, Halt has been called from DLL function, 103 put down the entire process (DLL_PROCESS_DETACH will still 104 occur). At this point RTL has been already finalized in InternalExit 105 and shouldn't be finalized another time in DLL_PROCESS_DETACH. 106 Indicate this by resetting MainThreadIdWin32. } 107 MainThreadIDWin32:=0; 108 end; 109 if not IsConsole then 110 begin 111 Close(stderr); 112 Close(stdout); 113 Close(erroutput); 114 Close(Input); 115 Close(Output); 116 { what about Input and Output ?? PM } 117 { now handled, FPK } 118 end; 119{$ifndef FPC_USE_WIN32_SEH} 120 if not IsLibrary then 121 remove_exception_handlers; 122{$endif FPC_USE_WIN32_SEH} 123 124 { do cleanup required by the startup code } 125 EntryInformation.OS.asm_exit(); 126 127 { call exitprocess, with cleanup as required } 128 ExitProcess(exitcode); 129end; 130 131var 132 { value of the stack segment 133 to check if the call stack can be written on exceptions } 134 _SS : Cardinal; 135 136procedure Exe_entry(constref info : TEntryInformation);[public,alias:'_FPC_EXE_Entry']; 137 var 138 xframe: TEXCEPTION_FRAME; 139 begin 140 SetupEntryInformation(info); 141 IsLibrary:=false; 142 { install the handlers for exe only ? 143 or should we install them for DLL also ? (PM) } 144{$ifndef FPC_USE_WIN32_SEH} 145 install_exception_handlers; 146{$endif FPC_USE_WIN32_SEH} 147 { This strange construction is needed to solve the _SS problem 148 with a smartlinked syswin32 (PFV) } 149 asm 150 { movl %esp,%fs:(0) 151 but don't insert it as it doesn't 152 point to anything yet 153 this will be used in signals unit } 154 leal xframe,%eax 155 movl %fs:(0),%ecx 156 movl %ecx,TException_Frame.next(%eax) 157 movl %eax,System_exception_frame 158{$ifndef FPC_USE_WIN32_SEH} 159 movl $0,TException_Frame.handler(%eax) 160{$else} 161 movl $OutermostHandler,TException_Frame.handler(%eax) 162 movl %eax,%fs:(0) 163{$endif FPC_USE_WIN32_SEH} 164 pushl %ebp 165 xorl %eax,%eax 166 movw %ss,%ax 167 movl %eax,_SS 168 xorl %ebp,%ebp 169 end; 170 EntryInformation.PascalMain(); 171 asm 172 popl %ebp 173 end; 174 { if we pass here there was no error ! } 175 system_exit; 176 end; 177 178function is_prefetch(p : pointer) : boolean; 179 var 180 a : array[0..15] of byte; 181 doagain : boolean; 182 instrlo,instrhi,opcode : byte; 183 i : longint; 184 begin 185 result:=false; 186 { read memory savely without causing another exeception } 187 if not(ReadProcessMemory(GetCurrentProcess,p,@a,sizeof(a),nil)) then 188 exit; 189 i:=0; 190 doagain:=true; 191 while doagain and (i<15) do 192 begin 193 opcode:=a[i]; 194 instrlo:=opcode and $f; 195 instrhi:=opcode and $f0; 196 case instrhi of 197 { prefix? } 198 $20,$30: 199 doagain:=(instrlo and 7)=6; 200 $60: 201 doagain:=(instrlo and $c)=4; 202 $f0: 203 doagain:=instrlo in [0,2,3]; 204 $0: 205 begin 206 result:=(instrlo=$f) and (a[i+1] in [$d,$18]); 207 exit; 208 end; 209 else 210 doagain:=false; 211 end; 212 inc(i); 213 end; 214 end; 215 216// 217// Hardware exception handling 218// 219 220{$ifdef Set_i386_Exception_handler} 221 222type 223 PFloatingSaveArea = ^TFloatingSaveArea; 224 TFloatingSaveArea = packed record 225 ControlWord : Cardinal; 226 StatusWord : Cardinal; 227 TagWord : Cardinal; 228 ErrorOffset : Cardinal; 229 ErrorSelector : Cardinal; 230 DataOffset : Cardinal; 231 DataSelector : Cardinal; 232 RegisterArea : array[0..79] of Byte; 233 Cr0NpxState : Cardinal; 234 end; 235 236 PContext = ^TContext; 237 TContext = packed record 238 // 239 // The flags values within this flag control the contents of 240 // a CONTEXT record. 241 // 242 ContextFlags : Cardinal; 243 244 // 245 // This section is specified/returned if CONTEXT_DEBUG_REGISTERS is 246 // set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT 247 // included in CONTEXT_FULL. 248 // 249 Dr0, Dr1, Dr2, 250 Dr3, Dr6, Dr7 : Cardinal; 251 252 // 253 // This section is specified/returned if the 254 // ContextFlags word contains the flag CONTEXT_FLOATING_POINT. 255 // 256 FloatSave : TFloatingSaveArea; 257 258 // 259 // This section is specified/returned if the 260 // ContextFlags word contains the flag CONTEXT_SEGMENTS. 261 // 262 SegGs, SegFs, 263 SegEs, SegDs : Cardinal; 264 265 // 266 // This section is specified/returned if the 267 // ContextFlags word contains the flag CONTEXT_INTEGER. 268 // 269 Edi, Esi, Ebx, 270 Edx, Ecx, Eax : Cardinal; 271 272 // 273 // This section is specified/returned if the 274 // ContextFlags word contains the flag CONTEXT_CONTROL. 275 // 276 Ebp : Cardinal; 277 Eip : Cardinal; 278 SegCs : Cardinal; 279 EFlags, Esp, SegSs : Cardinal; 280 281 // 282 // This section is specified/returned if the ContextFlags word 283 // contains the flag CONTEXT_EXTENDED_REGISTERS. 284 // The format and contexts are processor specific 285 // 286 ExtendedRegisters : array[0..MAXIMUM_SUPPORTED_EXTENSION-1] of Byte; 287 end; 288 289 290 PExceptionPointers = ^TExceptionPointers; 291 TExceptionPointers = packed record 292 ExceptionRecord : PExceptionRecord; 293 ContextRecord : PContext; 294 end; 295 296{ type of functions that should be used for exception handling } 297 TTopLevelExceptionFilter = function (excep : PExceptionPointers) : Longint;stdcall; 298 299{$i seh32.inc} 300 301{$ifndef FPC_USE_WIN32_SEH} 302function SetUnhandledExceptionFilter(lpTopLevelExceptionFilter : TTopLevelExceptionFilter) : TTopLevelExceptionFilter; 303 stdcall;external 'kernel32' name 'SetUnhandledExceptionFilter'; 304 305const 306 MaxExceptionLevel = 16; 307 exceptLevel : Byte = 0; 308 309var 310 exceptEip : array[0..MaxExceptionLevel-1] of Longint; 311 exceptError : array[0..MaxExceptionLevel-1] of Byte; 312 resetFPU : array[0..MaxExceptionLevel-1] of Boolean; 313 314{$ifdef SYSTEMEXCEPTIONDEBUG} 315procedure DebugHandleErrorAddrFrame(error : longint; addr, frame : pointer); 316begin 317 if IsConsole then 318 begin 319 write(stderr,'HandleErrorAddrFrame(error=',error); 320 write(stderr,',addr=',hexstr(ptruint(addr),8)); 321 writeln(stderr,',frame=',hexstr(ptruint(frame),8),')'); 322 end; 323 HandleErrorAddrFrame(error,addr,frame); 324end; 325{$endif SYSTEMEXCEPTIONDEBUG} 326 327procedure JumpToHandleErrorFrame; 328 var 329 eip, ebp, error : Longint; 330 begin 331 // save ebp 332 asm 333 movl (%ebp),%eax 334 movl %eax,ebp 335 end; 336 if (exceptLevel > 0) then 337 dec(exceptLevel); 338 339 eip:=exceptEip[exceptLevel]; 340 error:=exceptError[exceptLevel]; 341{$ifdef SYSTEMEXCEPTIONDEBUG} 342 if IsConsole then 343 writeln(stderr,'In JumpToHandleErrorFrame error=',error); 344{$endif SYSTEMEXCEPTIONDEBUG} 345 if resetFPU[exceptLevel] then 346 SysResetFPU; 347 { build a fake stack } 348 asm 349 movl ebp,%ecx 350 movl eip,%edx 351 movl error,%eax 352 pushl eip 353 movl ebp,%ebp // Change frame pointer 354 355{$ifdef SYSTEMEXCEPTIONDEBUG} 356 jmpl DebugHandleErrorAddrFrame 357{$else not SYSTEMEXCEPTIONDEBUG} 358 jmpl HandleErrorAddrFrame 359{$endif SYSTEMEXCEPTIONDEBUG} 360 end; 361 end; 362 363function syswin32_i386_exception_handler(excep : PExceptionPointers) : Longint;stdcall; 364 var 365 res,ssecode: longint; 366 err: byte; 367 must_reset_fpu: boolean; 368 begin 369 res := EXCEPTION_CONTINUE_SEARCH; 370 if excep^.ContextRecord^.SegSs=_SS then begin 371 err := 0; 372 must_reset_fpu := true; 373{$ifdef SYSTEMEXCEPTIONDEBUG} 374 if IsConsole then Writeln(stderr,'Exception ', 375 hexstr(excep^.ExceptionRecord^.ExceptionCode, 8)); 376{$endif SYSTEMEXCEPTIONDEBUG} 377 case excep^.ExceptionRecord^.ExceptionCode of 378 STATUS_INTEGER_DIVIDE_BY_ZERO : 379 err := 200; 380 STATUS_FLOAT_DIVIDE_BY_ZERO : 381 err := 208; 382 STATUS_ARRAY_BOUNDS_EXCEEDED : 383 begin 384 err := 201; 385 must_reset_fpu := false; 386 end; 387 STATUS_STACK_OVERFLOW : 388 begin 389 err := 202; 390 must_reset_fpu := false; 391 end; 392 STATUS_FLOAT_OVERFLOW : 393 err := 205; 394 STATUS_FLOAT_DENORMAL_OPERAND, 395 STATUS_FLOAT_UNDERFLOW : 396 err := 206; 397 {excep^.ContextRecord^.FloatSave.StatusWord := excep^.ContextRecord^.FloatSave.StatusWord and $ffffff00;} 398 STATUS_FLOAT_INEXACT_RESULT, 399 STATUS_FLOAT_INVALID_OPERATION, 400 STATUS_FLOAT_STACK_CHECK : 401 err := 207; 402 STATUS_INTEGER_OVERFLOW : 403 begin 404 err := 215; 405 must_reset_fpu := false; 406 end; 407 STATUS_ILLEGAL_INSTRUCTION: 408 { if we're testing sse support, simply set the flag and continue } 409 if sse_check then 410 begin 411 os_supports_sse:=false; 412 { skip the offending movaps %xmm7, %xmm6 instruction } 413 inc(excep^.ContextRecord^.Eip,3); 414 excep^.ExceptionRecord^.ExceptionCode := 0; 415 res:=EXCEPTION_CONTINUE_EXECUTION; 416 end 417 else 418 err := 216; 419 STATUS_ACCESS_VIOLATION: 420 { Athlon prefetch bug? } 421 if is_prefetch(pointer(excep^.ContextRecord^.Eip)) then 422 begin 423 { if yes, then retry } 424 excep^.ExceptionRecord^.ExceptionCode := 0; 425 res:=EXCEPTION_CONTINUE_EXECUTION; 426 end 427 else 428 err := 216; 429 430 STATUS_CONTROL_C_EXIT: 431 err := 217; 432 STATUS_PRIVILEGED_INSTRUCTION: 433 begin 434 err := 218; 435 must_reset_fpu := false; 436 end; 437 STATUS_FLOAT_MULTIPLE_FAULTS, 438 STATUS_FLOAT_MULTIPLE_TRAPS: 439 begin 440 { dumping ExtendedRegisters and comparing with the actually value of mxcsr revealed 24 } 441 TranslateMxcsr(excep^.ContextRecord^.ExtendedRegisters[24],ssecode); 442{$ifdef SYSTEMEXCEPTIONDEBUG} 443 if IsConsole then 444 Writeln(stderr,'MXSR: ',hexstr(excep^.ContextRecord^.ExtendedRegisters[24], 2),' SSECODE: ',ssecode); 445{$endif SYSTEMEXCEPTIONDEBUG} 446 err:=-ssecode; 447 end; 448 else 449 begin 450 if ((excep^.ExceptionRecord^.ExceptionCode and SEVERITY_ERROR) = SEVERITY_ERROR) then 451 err := 217 452 else 453 err := 255; 454 end; 455 end; 456 457 if (err <> 0) and (exceptLevel < MaxExceptionLevel) then begin 458 exceptEip[exceptLevel] := excep^.ContextRecord^.Eip; 459 exceptError[exceptLevel] := err; 460 resetFPU[exceptLevel] := must_reset_fpu; 461 inc(exceptLevel); 462 463 excep^.ContextRecord^.Eip := Longint(@JumpToHandleErrorFrame); 464 excep^.ExceptionRecord^.ExceptionCode := 0; 465 466 res := EXCEPTION_CONTINUE_EXECUTION; 467{$ifdef SYSTEMEXCEPTIONDEBUG} 468 if IsConsole then begin 469 writeln(stderr,'Exception Continue Exception set at ', 470 hexstr(exceptEip[exceptLevel],8)); 471 writeln(stderr,'Eip changed to ', 472 hexstr(longint(@JumpToHandleErrorFrame),8), ' error=', err); 473 end; 474{$endif SYSTEMEXCEPTIONDEBUG} 475 end; 476 end; 477 syswin32_i386_exception_handler := res; 478 end; 479 480procedure install_exception_handlers; 481 begin 482 SetUnhandledExceptionFilter(@syswin32_i386_exception_handler); 483 end; 484 485procedure remove_exception_handlers; 486 begin 487 SetUnhandledExceptionFilter(nil); 488 end; 489{$endif not FPC_USE_WIN32_SEH} 490 491{$else not cpui386 (Processor specific !!)} 492procedure install_exception_handlers; 493begin 494end; 495 496procedure remove_exception_handlers; 497begin 498end; 499{$endif Set_i386_Exception_handler} 500 501{$ifdef FPC_SECTION_THREADVARS} 502function fpc_tls_add(addr: pointer): pointer; assembler; nostackframe; 503 [public,alias: 'FPC_TLS_ADD']; compilerproc; 504 asm 505 sub $tls_data_start,%eax 506 cmpb $0,IsLibrary 507 mov _tls_index,%ecx 508 jnz .L1 509 mov %fs:(0x2c),%edx 510 add (%edx,%ecx,4),%eax 511 ret 512.L1: 513 push %ebx 514 mov %eax,%ebx 515 call GetLastError 516 push %eax { save LastError } 517 push _tls_index 518 call TlsGetValue 519 test %eax,%eax 520 jnz .L2 521 { This can happen when a thread existed before DLL was loaded, 522 or if DisableThreadLibraryCalls was called. } 523 call SysAllocateThreadVars 524 mov $0x1000000,%eax 525 call InitThread 526 push _tls_index 527 call TlsGetValue 528.L2: 529 add %eax,%ebx 530 call SetLastError { restore (value is on stack) } 531 mov %ebx,%eax 532 pop %ebx 533 end; 534{$endif FPC_SECTION_THREADVARS} 535 536function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; 537 type 538 tdosheader = packed record 539 e_magic : word; 540 e_cblp : word; 541 e_cp : word; 542 e_crlc : word; 543 e_cparhdr : word; 544 e_minalloc : word; 545 e_maxalloc : word; 546 e_ss : word; 547 e_sp : word; 548 e_csum : word; 549 e_ip : word; 550 e_cs : word; 551 e_lfarlc : word; 552 e_ovno : word; 553 e_res : array[0..3] of word; 554 e_oemid : word; 555 e_oeminfo : word; 556 e_res2 : array[0..9] of word; 557 e_lfanew : longint; 558 end; 559 tpeheader = packed record 560 PEMagic : longint; 561 Machine : word; 562 NumberOfSections : word; 563 TimeDateStamp : longint; 564 PointerToSymbolTable : longint; 565 NumberOfSymbols : longint; 566 SizeOfOptionalHeader : word; 567 Characteristics : word; 568 Magic : word; 569 MajorLinkerVersion : byte; 570 MinorLinkerVersion : byte; 571 SizeOfCode : longint; 572 SizeOfInitializedData : longint; 573 SizeOfUninitializedData : longint; 574 AddressOfEntryPoint : longint; 575 BaseOfCode : longint; 576 BaseOfData : longint; 577 ImageBase : longint; 578 SectionAlignment : longint; 579 FileAlignment : longint; 580 MajorOperatingSystemVersion : word; 581 MinorOperatingSystemVersion : word; 582 MajorImageVersion : word; 583 MinorImageVersion : word; 584 MajorSubsystemVersion : word; 585 MinorSubsystemVersion : word; 586 Reserved1 : longint; 587 SizeOfImage : longint; 588 SizeOfHeaders : longint; 589 CheckSum : longint; 590 Subsystem : word; 591 DllCharacteristics : word; 592 SizeOfStackReserve : longint; 593 SizeOfStackCommit : longint; 594 SizeOfHeapReserve : longint; 595 SizeOfHeapCommit : longint; 596 LoaderFlags : longint; 597 NumberOfRvaAndSizes : longint; 598 DataDirectory : array[1..$80] of byte; 599 end; 600 begin 601 result:=tpeheader((pointer(getmodulehandle(nil))+(tdosheader(pointer(getmodulehandle(nil))^).e_lfanew))^).SizeOfStackReserve; 602 end; 603 604begin 605 { get some helpful informations } 606 GetStartupInfo(@startupinfo); 607 { some misc Win32 stuff } 608 if not IsLibrary then 609 FPCSysInstance^:=getmodulehandle(nil); 610 611 MainInstance:=FPCSysInstance^; 612 613 { pass dummy value } 614 StackLength := CheckInitialStkLen($1000000); 615 StackBottom := StackTop - StackLength; 616 617 cmdshow:=startupinfo.wshowwindow; 618 { Setup heap and threading, these may be already initialized from TLS callback } 619 if not Assigned(CurrentTM.BeginThread) then 620 begin 621 InitHeap; 622 InitSystemThreads; 623 end; 624 SysInitExceptions; 625 { setup fastmove stuff } 626 fpc_cpucodeinit; 627 initunicodestringmanager; 628 InitWin32Widestrings; 629 SysInitStdIO; 630 { Arguments } 631 setup_arguments; 632 InitSystemDynLibs; 633 { Reset IO Error } 634 InOutRes:=0; 635 ProcessID := GetCurrentProcessID; 636 DispCallByIDProc:=@DoDispCallByIDError; 637end. 638