Przeglądaj źródła

* set stack margin on windows, so there is stack space left for exception handling in case of a stack overflow, resolves #40589

florian 1 rok temu
rodzic
commit
14ab1cfb71
5 zmienionych plików z 31 dodań i 1 usunięć
  1. 2 0
      rtl/win/sysos.inc
  2. 4 1
      rtl/win/systhrd.inc
  3. 1 0
      rtl/win32/system.pp
  4. 2 0
      rtl/win64/system.pp
  5. 22 0
      tests/webtbs/tw40589.pp

+ 2 - 0
rtl/win/sysos.inc

@@ -273,6 +273,8 @@ type
   function GetModuleHandle(p : PAnsiChar) : THandle;
   function GetModuleHandle(p : PAnsiChar) : THandle;
     stdcall;external KernelDLL name 'GetModuleHandleA';
     stdcall;external KernelDLL name 'GetModuleHandleA';
 
 
+  function SetThreadStackGuarantee(StackSizeInBytes : PPtrUint) : BOOL;
+    stdcall;external KernelDLL name 'SetThreadStackGuarantee';
 {$else WINCE}
 {$else WINCE}
 
 
    { module functions }
    { module functions }

+ 4 - 1
rtl/win/systhrd.inc

@@ -227,7 +227,10 @@ var
           - static threadvars, no callback: ThreadID remains 0 and
           - static threadvars, no callback: ThreadID remains 0 and
             initialization happens here. }
             initialization happens here. }
         if ThreadID=TThreadID(0) then
         if ThreadID=TThreadID(0) then
-          InitThread(ti.stklen);
+          begin
+            InitThread(ti.stklen);
+            SetThreadStackGuarantee(@StackMargin);
+          end;
 
 
         dispose(pthreadinfo(param));
         dispose(pthreadinfo(param));
 
 

+ 1 - 0
rtl/win32/system.pp

@@ -619,6 +619,7 @@ initialization
   { pass dummy value }
   { pass dummy value }
   StackLength := CheckInitialStkLen($1000000);
   StackLength := CheckInitialStkLen($1000000);
   StackBottom := StackTop - StackLength;
   StackBottom := StackTop - StackLength;
+  SetThreadStackGuarantee(@StackMargin);
 
 
   cmdshow:=startupinfo.wshowwindow;
   cmdshow:=startupinfo.wshowwindow;
   { Setup heap and threading, these may be already initialized from TLS callback }
   { Setup heap and threading, these may be already initialized from TLS callback }

+ 2 - 0
rtl/win64/system.pp

@@ -478,6 +478,8 @@ initialization
   { pass dummy value }
   { pass dummy value }
   StackLength := CheckInitialStkLen($1000000);
   StackLength := CheckInitialStkLen($1000000);
   StackBottom := StackTop - StackLength;
   StackBottom := StackTop - StackLength;
+  SetThreadStackGuarantee(@StackMargin);
+  
   { get some helpful informations }
   { get some helpful informations }
   GetStartupInfo(@startupinfo);
   GetStartupInfo(@startupinfo);
   { some misc Win32 stuff }
   { some misc Win32 stuff }

+ 22 - 0
tests/webtbs/tw40589.pp

@@ -0,0 +1,22 @@
+{ %RESULT=202 }
+{ %opt=gl }
+
+{$mode objfpc}
+
+type
+  TForm1 = class
+    procedure Button1Click(Sender: TObject);
+  end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+  Button1Click(self);
+end;
+
+var
+  Form1 : TForm1;
+
+begin
+  Form1:=TForm1.Create;
+  Form1.Button1Click(nil);
+end.