--- Merging r29678 into '.':

U    rtl/win64/seh64.inc
--- Recording mergeinfo for merge of r29678 into '.':
 U   .
--- Merging r29692 into '.':
U    rtl/inc/system.inc
U    rtl/win64/system.pp
G    rtl/win64/seh64.inc
--- Recording mergeinfo for merge of r29692 into '.':
 G   .
--- Merging r29713 into '.':
U    rtl/inc/systemh.inc
G    rtl/inc/system.inc
U    rtl/inc/heaptrc.pp
--- Recording mergeinfo for merge of r29713 into '.':
 G   .
--- Merging r29733 into '.':
G    rtl/inc/system.inc
--- Recording mergeinfo for merge of r29733 into '.':
 G   .
--- Merging r29739 into '.':
G    rtl/inc/system.inc
--- Recording mergeinfo for merge of r29739 into '.':
 G   .

# revisions: 29678,29692,29713,29733,29739
------------------------------------------------------------------------
r29678 | sergei | 2015-02-13 06:02:20 +0100 (vr, 13 feb 2015) | 2 lines
Changed paths:
   M /trunk/rtl/win64/seh64.inc

* Win64 SEH: don't call RunError in exception handler, because it always prints backtrace from caller's context. Instead, print the correct backtrace explicitly.

------------------------------------------------------------------------
------------------------------------------------------------------------
r29692 | sergei | 2015-02-14 12:41:33 +0100 (za, 14 feb 2015) | 1 line
Changed paths:
   M /trunk/rtl/inc/system.inc
   M /trunk/rtl/win64/seh64.inc
   M /trunk/rtl/win64/system.pp

* Win64: Use separate implementation of CaptureBacktrace that calls RtlCaptureStackBackTrace. This way it does not require non-optimized code to work correctly.
------------------------------------------------------------------------
------------------------------------------------------------------------
r29713 | sergei | 2015-02-15 21:00:24 +0100 (zo, 15 feb 2015) | 2 lines
Changed paths:
   M /trunk/rtl/inc/heaptrc.pp
   M /trunk/rtl/inc/system.inc
   M /trunk/rtl/inc/systemh.inc

+ Overloaded procedure dump_stack that calls CaptureBacktrace, thus encapsulating internals of stack traversing.
* Use this new procedure in heaptrc unit.
------------------------------------------------------------------------
------------------------------------------------------------------------
r29733 | sergei | 2015-02-16 23:05:54 +0100 (ma, 16 feb 2015) | 7 lines
Changed paths:
   M /trunk/rtl/inc/system.inc

* Finalize units after printing the runtime error message. Rationale:
  * Unit finalization executes arbitrarily large amount of code. Doing it when error occurred can cause
    other errors, overwriting the original error information.
  * Code that prints error message depends on everything and a kitchen sink (most notably, Unicode manager
    and lineinfo unit). Running it after finalizing units can be successful only by coincidence.
  * Last but not least, this sequence (ExitProc -> print RTE -> finalize units) is same as one used in Delphi.

------------------------------------------------------------------------
------------------------------------------------------------------------
r29739 | pierre | 2015-02-17 08:35:31 +0100 (di, 17 feb 2015) | 1 line
Changed paths:
   M /trunk/rtl/inc/system.inc

 Revert aligntoptr to RTTIAlign rename
------------------------------------------------------------------------

git-svn-id: branches/fixes_3_0@33410 -

rtl/inc/heaptrc.pp

@@ -334,23 +334,14 @@ end;
 
 
 procedure dump_already_free(p : pheap_mem_info;var ptext : text);
-var
-  bp : pointer;
-  pcaddr : codepointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
   call_free_stack(p,ptext);
   Writeln(ptext,'freed again at');
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext,bp,pcaddr);
+  dump_stack(ptext,1);
 end;
 
 procedure dump_error(p : pheap_mem_info;var ptext : text);
-var
-  bp : pointer;
-  pcaddr : codepointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
@@ -359,10 +350,7 @@ begin
       write(ptext, 'Block content: ');
       printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
     end;
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext,bp,pcaddr);
+  dump_stack(ptext,1);
 end;
 
 {$ifdef EXTRA}
@@ -382,16 +370,10 @@ end;
 {$endif EXTRA}
 
 procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
-var
-  bp : pointer;
-  pcaddr : codepointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext,bp,pcaddr);
+  dump_stack(ptext,1);
   { the check is done to be sure that the procvar is not overwritten }
   if assigned(p^.extra_info) and
      (p^.extra_info^.check=$12345678) and
@@ -961,8 +943,6 @@ var
 {$ifdef windows}
   datap : pointer;
 {$endif windows}
-  bp : pointer;
-  pcaddr : codepointer;
   ptext : ^text;
 begin
   if p=nil then
@@ -1117,10 +1097,7 @@ begin
       end;
    end;
   writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext^,bp,pcaddr);
+  dump_stack(ptext^,1);
   runerror(204);
 end;
 

rtl/inc/system.inc

@@ -557,8 +557,6 @@ const
 
 VAR
   mt : tMT19937StateArray;
-
-const
   mti: longint=MT19937N+1; // mti=MT19937N+1 means mt[] is not initialized
 
 { Initializing the array with a seed }
@@ -973,8 +971,6 @@ Begin
      exitProc:=nil;
      current_exit();
    End;
-  { Finalize units }
-  FinalizeUnits;
 
 {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
   { the embedded system unit itself contains no routines for console i/o
@@ -998,6 +994,9 @@ Begin
 {$endif EMBEDDED}
 {$endif FPC_HAS_FEATURE_CONSOLEIO}
 
+  { Finalize units }
+  FinalizeUnits;
+
 {$if defined(MSWINDOWS) or defined(OS2)}
   { finally release the heap if possible, especially
     important for DLLs.
@@ -1070,6 +1069,7 @@ begin
 end;
 
 
+{$ifndef FPC_SYSTEM_HAS_CAPTUREBACKTRACE}
 function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
 var
   curr_frame,prev_frame: pointer;
@@ -1098,6 +1098,7 @@ begin
   else
     result:=i;
 end;
+{$endif FPC_SYSTEM_HAS_CAPTUREBACKTRACE}
 
 
 Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
@@ -1213,6 +1214,28 @@ Begin
 End;
 
 
+procedure dump_stack(var f: text; skipframes: longint);
+var
+  i,count: longint;
+  frames: array [0..255] of codepointer;
+begin
+  if do_isdevice(textrec(f).handle) then
+    count:=max_frame_dump
+  else
+    count:=255;
+{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
+  try
+{$endif FPC_HAS_FEATURE_EXCEPTIONS}
+    count:=CaptureBacktrace(skipframes+1,count,@frames[0]);
+    for i:=0 to count-1 do
+      writeln(f,BackTraceStrFunc(frames[i]));
+{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
+  except
+  end;
+{$endif FPC_HAS_FEATURE_EXCEPTIONS}
+end;
+
+
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 procedure DumpExceptionBackTrace(var f:text);
 var

rtl/inc/systemh.inc

@@ -1398,6 +1398,7 @@ Function  ParamStr(l:Longint):string;
 {$endif FPC_HAS_FEATURE_COMMANDARGS}
 
 Procedure Dump_Stack(var f : text;fp:pointer;addr : codepointer = nil);
+procedure Dump_Stack(var f : text;skipframes : longint);
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 procedure DumpExceptionBackTrace(var f:text);
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}

rtl/win64/seh64.inc

@@ -213,6 +213,12 @@ type
   end;
 
 
+function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
+begin
+  { skipframes is increased because this function adds a call level }
+  Result:=RtlCaptureStackBackTrace(skipframes+1,count,frames^,nil);
+end;
+
 { note: context must be passed by value, so modifications are made to a local copy }
 function GetBacktrace(Context: TContext; StartingFrame: Pointer; out Frames: PPointer): Longint;
 var
@@ -375,6 +381,8 @@ label L1;
 var
   exc: PExceptObject;
   obj: TObject;
+  hstdout: ^text;
+  i,code: Longint;
 begin
   if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
   begin
@@ -391,7 +399,19 @@ begin
   begin
     Exc:=ExceptObjectStack;
     if Exc^.FObject=nil then
-      RunError(abs(RunErrorCodex64(rec,context)))  // !!prints wrong backtrace
+    begin
+      hstdout:=@stdout;
+      code:=abs(RunErrorCodex64(rec,context));
+      Writeln(hstdout^,'Runtime error ',code,' at $',hexstr(Exc^.addr));
+      Writeln(hstdout^,BackTraceStrFunc(Exc^.Addr));
+      if (Exc^.FrameCount>0) then
+      begin
+        for i:=0 to Exc^.FrameCount-1 do
+          Writeln(hstdout^,BackTraceStrFunc(Exc^.Frames[i]));
+      end;
+      Writeln(hstdout^,'');
+      Halt(code);
+    end
     else
     begin
       { if ExceptObjProc=nil, ExceptProc is typically also nil,
@@ -404,8 +424,10 @@ begin
 L1:
       { RtlUnwindEx above resets execution context to the point where the handler
         was installed, i.e. main_wrapper. It makes exiting this procedure no longer
-        possible, halting is the only possible action here. }
-      RunError(217);
+        possible. Halting is the only possible action here.
+        Furthermore, this is not expected to execute at all, because the above block
+        definitely halts. }
+      Halt(217);
     end;
   end;
   result:=ExceptionContinueSearch;

rtl/win64/system.pp

@@ -29,6 +29,7 @@ interface
 {$ifdef FPC_USE_WIN64_SEH}
   {$define FPC_SYSTEM_HAS_RAISEEXCEPTION}
   {$define FPC_SYSTEM_HAS_RERAISE}
+  {$define FPC_SYSTEM_HAS_CAPTUREBACKTRACE}
 {$endif FPC_USE_WIN64_SEH}
 
 { include system-independent routine headers }