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