* handle lineinfo in dlls correctly, resolves #4171 and #10797 for windows

git-svn-id: trunk@11004 -

rtl/inc/exeinfo.pp

@@ -46,12 +46,64 @@ function FindExeSection(var e:TExeFile;const secname:string;var secofs,seclen:lo
 function CloseExeFile(var e:TExeFile):boolean;
 function ReadDebugLink(var e:TExeFile;var dbgfn:string):boolean;
 
+procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
+
 
 implementation
 
 uses
-  strings;
+  strings{$ifdef windows},windows{$endif windows};
+
+{$ifdef unix}
+
+  var
+    dlinfo: dl_info;
+
+  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
+    begin
+      baseaddr:= nil;
+      filename:=ParamStr(0);
+      {
+      FillChar(dlinfo, sizeof(dlinfo), 0);
+      dladdr(addr, @dlinfo);
+      baseaddr:= dlinfo.dli_fbase;
+      filename:= String(dlinfo.dli_fname);
+      if ExtractFileName(filename) = ExtractFileName(ParamStr(0)) then
+        baseaddr:= nil;
+      }
+    end;
+
+{$else unix}
+{$ifdef windows}
+
+  var
+    Tmm: TMemoryBasicInformation;
+    TST: array[0..Max_Path] of Char;
+
+  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
+    begin
+      baseaddr:= nil;
+      if VirtualQuery(addr, @Tmm, SizeOf(Tmm))<>sizeof(Tmm) then
+        filename:=ParamStr(0)
+      else
+        begin
+          baseaddr:=Tmm.AllocationBase;
+          TST[0]:= #0;
+          GetModuleFileName(THandle(Tmm.AllocationBase), TST, SizeOf(TST));
+          filename:= String(PChar(@TST));
+        end;
+    end;
+
+{$else windows}
+
+  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
+    begin
+      baseaddr:= nil;
+      filename:=ParamStr(0);
+    end;
 
+{$endif windows}
+{$endif unix}
 
 {****************************************************************************
                              Executable Loaders

rtl/inc/lineinfo.pp

@@ -22,7 +22,7 @@ interface
 {$S-}
 {$Q-}
 
-procedure GetLineInfo(addr:ptruint;var func,source:string;var line:longint);
+function GetLineInfo(addr:ptruint;var func,source:string;var line:longint) : boolean;
 
 
 implementation
@@ -71,16 +71,26 @@ var
   linestab,             { stab with current line info }
   dirstab,              { stab with current directory info }
   filestab   : tstab;   { stab with current file info }
+  filename,
+  dbgfn : string;
 
 
-function OpenStabs:boolean;
-var
-  dbgfn : string;
+function OpenStabs(addr : pointer) : boolean;
+  var
+    baseaddr : pointer;
 begin
   OpenStabs:=false;
   if staberr then
     exit;
-  if not OpenExeFile(e,paramstr(0)) then
+
+  GetModuleByAddr(addr,baseaddr,filename);
+{$ifdef DEBUG_LINEINFO}
+  writeln(stderr,filename);
+{$endif DEBUG_LINEINFO}
+
+  e.processaddress:=e.processaddress-dword(baseaddr);
+
+  if not OpenExeFile(e,filename) then
     exit;
   if ReadDebugLink(e,dbgfn) then
     begin
@@ -109,7 +119,7 @@ begin
 end;
 
 
-procedure GetLineInfo(addr:ptruint;var func,source:string;var line:longint);
+function GetLineInfo(addr:ptruint;var func,source:string;var line:longint) : boolean;
 var
   res,
   stabsleft,
@@ -117,6 +127,10 @@ var
   found : boolean;
   lastfunc : tstab;
 begin
+  GetLineInfo:=false;
+{$ifdef DEBUG_LINEINFO}
+  writeln(stderr,'GetLineInfo called');
+{$endif DEBUG_LINEINFO}
   fillchar(func,high(func)+1,0);
   fillchar(source,high(source)+1,0);
   line:=0;
@@ -124,7 +138,7 @@ begin
     exit;
   if not e.isopen then
    begin
-     if not OpenStabs then
+     if not OpenStabs(pointer(addr)) then
       exit;
    end;
 
@@ -230,6 +244,9 @@ begin
      if i>0 then
       Delete(func,i,255);
    end;
+  if e.isopen then
+    CloseStabs;
+  GetLineInfo:=true;
 end;
 
 
@@ -240,11 +257,16 @@ var
   hs     : string[32];
   line   : longint;
   Store  : TBackTraceStrFunc;
+  Success : boolean;
 begin
+{$ifdef DEBUG_LINEINFO}
+  writeln(stderr,'StabBackTraceStr called');
+{$endif DEBUG_LINEINFO}
   { reset to prevent infinite recursion if problems inside the code PM }
+  Success:=false;
   Store:=BackTraceStrFunc;
   BackTraceStrFunc:=@SysBackTraceStr;
-  GetLineInfo(ptruint(addr),func,source,line);
+  Success:=GetLineInfo(ptruint(addr),func,source,line);
 { create string }
 {$ifdef netware}
   { we need addr relative to code start on netware }
@@ -254,7 +276,7 @@ begin
   StabBackTraceStr:='  $'+HexStr(ptruint(addr),sizeof(ptruint)*2);
 {$endif}
   if func<>'' then
-   StabBackTraceStr:=StabBackTraceStr+'  '+func;
+    StabBackTraceStr:=StabBackTraceStr+'  '+func;
   if source<>'' then
    begin
      if func<>'' then
@@ -266,7 +288,7 @@ begin
       end;
      StabBackTraceStr:=StabBackTraceStr+' of '+source;
    end;
-  if e.IsOpen then
+  if Success then
     BackTraceStrFunc:=Store;
 end;
 
@@ -277,5 +299,4 @@ initialization
 finalization
   if e.isopen then
    CloseStabs;
-
 end.

rtl/inc/lnfodwrf.pp

@@ -25,7 +25,7 @@ interface
 
 {$S-}
 
-procedure GetLineInfo(addr:ptruint;var func,source:string;var line:longint);
+function GetLineInfo(addr:ptruint;var func,source:string;var line:longint) : boolean;
 
 implementation
 
@@ -129,15 +129,23 @@ type
 var
   base, limit : SizeInt;
   index : SizeInt;
-
-function Opendwarf:boolean;
-var
+  baseaddr : pointer;
+  filename,
   dbgfn : string;
+
+function Opendwarf(addr : pointer) : boolean;
 begin
   Opendwarf:=false;
   if dwarferr then
     exit;
-  if not OpenExeFile(e,paramstr(0)) then
+
+  GetModuleByAddr(addr,baseaddr,filename);
+{$ifdef DEBUG_LINEINFO}
+  writeln(stderr,filename);
+{$endif DEBUG_LINEINFO}
+
+  e.processaddress:=e.processaddress-dword(baseaddr);
+  if not OpenExeFile(e,filename) then
     exit;
   if ReadDebugLink(e,dbgfn) then
     begin
@@ -666,7 +674,7 @@ begin
   end;
 end;
 
-procedure GetLineInfo(addr : ptruint; var func, source : string; var line : longint);
+function GetLineInfo(addr : ptruint; var func, source : string; var line : longint) : boolean;
 var
   current_offset : QWord;
   end_offset : QWord;
@@ -677,12 +685,12 @@ begin
   func := '';
   source := '';
   found := false;
-
+  GetLineInfo:=false;
   if DwarfErr then
     exit;
   if not e.isopen then
    begin
-     if not OpenDwarf then
+     if not OpenDwarf(pointer(addr)) then
       exit;
    end;
 
@@ -694,6 +702,9 @@ begin
     current_offset := ParseCompilationUnit(addr, current_offset,
       source, line, found);
   end;
+  if e.isopen then
+    CloseDwarf;
+  GetLineInfo:=true;
 end;
 
 
@@ -704,11 +715,13 @@ var
   hs     : string[32];
   line   : longint;
   Store  : TBackTraceStrFunc;
+  Success : boolean;
 begin
   { reset to prevent infinite recursion if problems inside the code }
+  Success:=false;
   Store := BackTraceStrFunc;
   BackTraceStrFunc := @SysBackTraceStr;
-  GetLineInfo(ptruint(addr), func, source, line);
+  Success:=GetLineInfo(ptruint(addr), func, source, line);
   { create string }
   DwarfBackTraceStr :='  $' + HexStr(ptruint(addr), sizeof(ptruint) * 2);
   if func<>'' then
@@ -723,7 +736,7 @@ begin
     end;
     DwarfBackTraceStr := DwarfBackTraceStr + ' of ' + source;
   end;
-  if e.IsOpen then
+  if Success then
     BackTraceStrFunc := Store;
 end;