* Darwin support for printing line info for backtraces when using Dwarf,

    based on patches by Colin Western, mantis #38483)
   o requires that the program/library is compiled with -Xg (or that
     dsymutil is run on it after compiling), and that the .dSYM bundle
     is in the same directory as the program/library
   o always use the "dl" unit in exeinfo for Darwin, as that's needed for
     dynamic library support, and this does not cause an extra dependency
     since on Darwin we always use libc
   o cleaned up the exeinfo unit for Darwin, and sped it up by using mmap
     instead of small reads
   o fixed unit dependencies for exeinfo, lineinfo and lnfodwarf in Darwin
     RTL Makefile
  * use the process address info from the original exe even when reading
    the debug information from an external file
  - removed outdated ifdef'd darwin code from dl.pp (no longer needed now
    that processaddress gets set correctly in exeinfo for that platform)

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@49140 3ad0048d-3df7-0310-abae-a5850022a9f2

4 files changed, 373 insertions, 69 deletions

diff --git a/rtl/darwin/Makefile.fpc b/rtl/darwin/Makefile.fpc
index 4af975b91f..1a0e19d6a3 100644
--- a/rtl/darwin/Makefile.fpc
+++ b/rtl/darwin/Makefile.fpc
@@ -268,10 +268,13 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMUNIT)$(PPUEXT)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
         $(COMPILER) -Sg $(INC)/heaptrc.pp
 
-lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT) strings$(PPUEXT) $(INC)/exeinfo.pp sysutils$(PPUEXT)
+exeinfo$(PPUEXT) : $(INC)/exeinfo.pp $(SYSTEMUNIT)$(PPUEXT) strings$(PPUEXT) ctypes$(PPUEXT) dl$(PPUEXT) baseunix$(PPUEXT)
 	$(COMPILER) $<
 
-lnfodwrf$(PPUEXT) : $(INC)/lnfodwrf.pp $(SYSTEMUNIT)$(PPUEXT) strings$(PPUEXT) $(INC)/exeinfo.pp lineinfo$(PPUEXT) sysutils$(PPUEXT)
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT) strings$(PPUEXT) exeinfo$(PPUEXT) sysutils$(PPUEXT)
+	$(COMPILER) $<
+
+lnfodwrf$(PPUEXT) : $(INC)/lnfodwrf.pp $(SYSTEMUNIT)$(PPUEXT) strings$(PPUEXT) exeinfo$(PPUEXT) lineinfo$(PPUEXT) sysutils$(PPUEXT) baseunix$(PPUEXT) ctypes$(PPUEXT)
 	$(COMPILER) $<
 
 lnfogdb$(PPUEXT) : $(UNIXINC)/lnfogdb.pp $(SYSTEMUNIT)$(PPUEXT) ctypes$(PPUEXT) baseunix$(PPUEXT) unix$(PPUEXT)
diff --git a/rtl/inc/exeinfo.pp b/rtl/inc/exeinfo.pp
index 97755935f1..589344bd46 100644
--- a/rtl/inc/exeinfo.pp
+++ b/rtl/inc/exeinfo.pp
@@ -22,13 +22,15 @@
   might be seen as invalid by heaptrc unit CheckPointer function }
 
 {$checkpointer off}
-
+{$modeswitch out}
 unit exeinfo;
 interface
 
 {$S-}
 
 type
+  TExeProcessAddress = {$ifdef cpui8086}word{$else}ptruint{$endif};
+  TExeOffset = {$ifdef cpui8086}longword{$else}ptruint{$endif};
   TExeFile=record
     f : file;
     // cached filesize
@@ -36,14 +38,18 @@ type
     isopen    : boolean;
     nsects    : longint;
     sechdrofs,
-    secstrofs : {$ifdef cpui8086}longword{$else}ptruint{$endif};
-    processaddress : {$ifdef cpui8086}word{$else}ptruint{$endif};
+    secstrofs : TExeOffset;
+    processaddress : TExeProcessAddress;
 {$ifdef cpui8086}
     processsegment : word;
 {$endif cpui8086}
+{$ifdef darwin}
+    { total size of all headers }
+    loadcommandssize: ptruint;
+{$endif}
     FunctionRelative: boolean;
     // Offset of the binary image forming permanent offset to all retrieved values
-    ImgOffset: {$ifdef cpui8086}longword{$else}ptruint{$endif};
+    ImgOffset: TExeOffset;
     filename  : string;
     // Allocate static buffer for reading data
     buf       : array[0..4095] of byte;
@@ -65,6 +71,9 @@ procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: st
 implementation
 
 uses
+{$ifdef darwin}
+  ctypes, baseunix, dl,
+{$endif}
   strings{$ifdef windows},windows{$endif windows};
 
 {$if defined(unix) and not defined(beos) and not defined(haiku)}
@@ -1098,89 +1107,316 @@ end;
 ****************************************************************************}
 
 {$ifdef darwin}
+{$push}
+{$packrecords c}
 type
-  MachoFatHeader= packed record
-    magic: longint;
-    nfatarch: longint;
+  tmach_integer = cint;
+  tmach_cpu_type = tmach_integer;
+  tmach_cpu_subtype = tmach_integer;
+  tmach_cpu_threadtype = tmach_integer;
+
+
+  tmach_fat_header=record
+    magic: cuint32;
+    nfatarch: cuint32;
+  end;
+
+  tmach_fat_arch=record
+    cputype: tmach_cpu_type;
+    cpusubtype: tmach_cpu_subtype;
+    offset: cuint32;
+    size: cuint32;
+    align: cuint32;
+  end;
+  pmach_fat_arch = ^tmach_fat_arch;
+
+(* not yet supported (only needed for slices or combined slice size > 4GB; unrelated to 64 bit processes)
+  tmach_fat_arch_64=record
+    cputype: tmach_cpu_type;
+    cpusubtype: tmach_cpu_subtype;
+    offset: cuint64;
+    size: cuint64;
+    align: cuint32;
+    reserved: cuint32;
   end;
-  MachoHeader=packed record
-    magic: longword;
-    cpu_type_t: longint;
-    cpu_subtype_t: longint;
-    filetype: longint;
-    ncmds: longint;
-    sizeofcmds: longint;
-    flags: longint;
+*)
+
+  { note: always big endian }
+  tmach_header=record
+    magic: cuint32;
+    cputype: tmach_cpu_type;
+    cpusubtype: tmach_cpu_subtype;
+    filetype: cuint32;
+    ncmds: cuint32;
+    sizeofcmds: cuint32;
+    flags: cuint32;
+    {$IFDEF CPU64}
+    reserved: cuint32;
+    {$ENDIF}
   end;
-  cmdblock=packed record
-    cmd: longint;
-    cmdsize: longint;
+  pmach_header = ^tmach_header;
+
+  tmach_load_command=record
+    cmd: cuint32;
+    cmdsize: cuint32;
   end;
-  symbSeg=packed record
-    symoff :      longint;
-    nsyms  :      longint;
-    stroff :      longint;
-    strsize:      longint;
+  pmach_load_command=^tmach_load_command;
+
+  tmach_symtab_command=record
+    cmd    :      cuint32;
+    cmdsize:      cuint32;
+    symoff :      cuint32;
+    nsyms  :      cuint32;
+    stroff :      cuint32;
+    strsize:      cuint32;
   end;
-  tstab=packed record
-    strpos  : longint;
+  pmach_symtab_command = ^tmach_symtab_command;
+
+  tstab=record
+    strpos  : longword;
     ntype   : byte;
     nother  : byte;
     ndesc   : word;
-    nvalue  : dword;
+    nvalue  : longword;
+  end;
+  pstab = ^tstab;
+
+  tmach_vm_prot = cint;
+
+  tmach_segment_command = record
+    cmd     : cuint32;
+    cmdsize : cuint32;
+    segname : array [0..15] of Char;
+    vmaddr  : {$IFDEF CPU64}cuint64{$ELSE}cuint32{$ENDIF};
+    vmsize  : {$IFDEF CPU64}cuint64{$ELSE}cuint32{$ENDIF};
+    fileoff : {$IFDEF CPU64}cuint64{$ELSE}cuint32{$ENDIF};
+    filesize: {$IFDEF CPU64}cuint64{$ELSE}cuint32{$ENDIF};
+    maxprot : tmach_vm_prot;
+    initptot: tmach_vm_prot;
+    nsects  : cuint32;
+    flags   : cuint32;
+  end;
+  pmach_segment_command = ^tmach_segment_command;
+
+  tmach_uuid_command = record
+    cmd     : cuint32;
+    cmdsize : cuint32;
+    uuid    : array[0..15] of cuint8;
   end;
+  pmach_uuid_command = ^tmach_uuid_command;
+
+  tmach_section = record
+    sectname : array [0..15] of Char;
+    segname  : array [0..15] of Char;
+    addr     : {$IFDEF CPU64}cuint64{$ELSE}cuint32{$ENDIF};
+    size     : {$IFDEF CPU64}cuint64{$ELSE}cuint32{$ENDIF};
+    offset   : cuint32;
+    align    : cuint32;
+    reloff   : cuint32;
+    nreloc   : cuint32;
+    flags    : cuint32;
+    reserved1: cuint32;
+    reserved2: cuint32;
+    {$IFDEF CPU64}
+    reserved3: cuint32;
+    {$ENDIF}
+  end;
+  pmach_section = ^tmach_section;
+
+  tmach_fat_archs = array[1..high(longint) div sizeof(tmach_header)] of tmach_fat_arch;
+  tmach_fat_header_archs = record
+    header: tmach_fat_header;
+    archs: tmach_fat_archs;
+  end;
+  pmach_fat_header_archs = ^tmach_fat_header_archs;
 
+{$pop}
+
+const
+  MACH_MH_EXECUTE = $02;
+
+  MACH_FAT_MAGIC = $cafebabe;
+// not yet supported: only for binaries with slices > 4GB, or total size > 4GB
+//  MACH_FAT_MAGIC_64 = $cafebabf;
+{$ifdef cpu32}
+  MACH_MAGIC = $feedface;
+{$else}
+  MACH_MAGIC = $feedfacf;
+{$endif}
+  MACH_CPU_ARCH_MASK = cuint32($ff000000);
+
+{$ifdef cpu32}
+  MACH_LC_SEGMENT = $01;
+{$else}
+  MACH_LC_SEGMENT = $19;
+{$endif}
+  MACH_LC_SYMTAB  = $02;
+  MACH_LC_UUID    = $1b;
+
+{ the in-memory mapping of the mach header of the main binary }
+function _NSGetMachExecuteHeader: pmach_header; cdecl; external 'c';
+
+function getpagesize: cint; cdecl; external 'c';
+
+function MapMachO(const h: THandle; offset, len: SizeUInt; out addr: pointer; out memoffset, mappedsize: SizeUInt): boolean;
+var
+  pagesize: cint;
+begin
+  pagesize:=getpagesize;
+  addr:=fpmmap(nil, len+(offset and (pagesize-1)), PROT_READ, MAP_PRIVATE, h, offset and not(pagesize-1));
+  if addr=MAP_FAILED then
+    begin
+      addr:=nil;
+      memoffset:=0;
+      mappedsize:=0;
+    end
+  else
+    begin
+       memoffset:=offset and (pagesize - 1);
+       mappedsize:=len+(offset and (pagesize-1));
+    end;
+end;
+
+procedure UnmapMachO(p: pointer; size: SizeUInt);
+begin
+  fpmunmap(p,size);
+end;
 
-function OpenMachO32PPC(var e:TExeFile):boolean;
+function OpenMachO(var e:TExeFile):boolean;
 var
-   mh:MachoHeader;
+  mh         : tmach_header;
+  processmh  : pmach_header;
+  cmd: pmach_load_command;
+  segmentcmd: pmach_segment_command;
+  mappedexe: pointer;
+  mappedoffset, mappedsize: SizeUInt;
+  i: cuint32;
+  foundpagezero: boolean;
 begin
-  OpenMachO32PPC:= false;
+  OpenMachO:=false;
   E.FunctionRelative:=false;
   if e.size<sizeof(mh) then
     exit;
   blockread (e.f, mh, sizeof(mh));
+  case mh.magic of
+    MACH_FAT_MAGIC:
+      begin
+        { todo }
+        exit
+      end;
+    MACH_MAGIC:
+      begin
+        // check that at least the architecture matches (we should also check the subarch,
+        // but that's harder because of architecture-specific backward compatibility rules)
+        processmh:=_NSGetMachExecuteHeader;
+        if (mh.cputype and not(MACH_CPU_ARCH_MASK)) <> (processmh^.cputype and not(MACH_CPU_ARCH_MASK)) then
+          exit;
+      end;
+    else
+      exit;
+  end;
   e.sechdrofs:=filepos(e.f);
   e.nsects:=mh.ncmds;
-  OpenMachO32PPC:=true;
+  e.loadcommandssize:=mh.sizeofcmds;
+  if mh.filetype = MACH_MH_EXECUTE then
+    begin
+      foundpagezero:= false;
+      { make sure to unmap again on all exit paths }
+      if not MapMachO(filerec(e.f).handle, e.sechdrofs, e.loadcommandssize, mappedexe, mappedoffset, mappedsize) then
+        exit;
+      cmd:=pmach_load_command(mappedexe+mappedoffset);
+      for i:= 1 to e.nsects do
+        begin
+          case cmd^.cmd of
+            MACH_LC_SEGMENT:
+              begin
+                segmentcmd:=pmach_segment_command(cmd);
+                if segmentcmd^.segname='__PAGEZERO' then
+                  begin
+                    e.processaddress:=segmentcmd^.vmaddr+segmentcmd^.vmsize;
+                    OpenMachO:=true;
+                    break;
+                  end;
+              end;
+          end;
+          cmd:=pmach_load_command(pointer(cmd)+cmd^.cmdsize);
+        end;
+      UnmapMachO(mappedexe, mappedsize);
+    end
+  else
+    OpenMachO:=true;
 end;
 
 
-function FindSectionMachO32PPC(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
+function FindSectionMachO(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
 var
-   i: longint;
-   block:cmdblock;
-   symbolsSeg: symbSeg;
+   i, j: cuint32;
+   cmd: pmach_load_command;
+   symtabcmd: pmach_symtab_command;
+   segmentcmd: pmach_segment_command;
+   section: pmach_section;
+   mappedexe: pointer;
+   mappedoffset, mappedsize: SizeUInt;
+   dwarfsecname: string;
 begin
-  FindSectionMachO32PPC:=false;
-  seek(e.f,e.sechdrofs);
+  FindSectionMachO:=false;
+  { make sure to unmap again on all exit paths }
+  if not MapMachO(filerec(e.f).handle, e.sechdrofs, e.loadcommandssize, mappedexe, mappedoffset, mappedsize) then
+    exit;
+  cmd:=pmach_load_command(mappedexe+mappedoffset);
   for i:= 1 to e.nsects do
     begin
-      {$I-}
-      blockread (e.f, block, sizeof(block));
-      {$I+}
-      if IOResult <> 0 then
-        Exit;
-      if block.cmd = $2   then
-      begin
-          blockread (e.f, symbolsSeg, sizeof(symbolsSeg));
-          if asecname='.stab' then
-            begin
-              secofs:=symbolsSeg.symoff;
-              { the caller will divide again by sizeof(tstab) }
-              seclen:=symbolsSeg.nsyms*sizeof(tstab);
-              FindSectionMachO32PPC:=true;
-            end
-          else if asecname='.stabstr' then
-            begin
-              secofs:=symbolsSeg.stroff;
-              seclen:=symbolsSeg.strsize;
-              FindSectionMachO32PPC:=true;
-            end;
-          exit;
+      case cmd^.cmd of
+        MACH_LC_SEGMENT:
+          begin
+            segmentcmd:=pmach_segment_command(cmd);
+            if segmentcmd^.segname='__DWARF' then
+              begin
+                if asecname[1]='.' then
+                  dwarfsecname:='__'+copy(asecname,2,length(asecname))
+                else
+                  dwarfsecname:=asecname;
+                section:=pmach_section(pointer(segmentcmd)+sizeof(segmentcmd^));
+                for j:=1 to segmentcmd^.nsects do
+                  begin
+                    if section^.sectname = dwarfsecname then
+                      begin
+                        secofs:=section^.offset;
+                        seclen:=section^.size;
+                        FindSectionMachO:=true;
+                        UnmapMachO(mappedexe, mappedsize);
+                        exit;
+                      end;
+                    inc(section);
+                  end;
+              end;
+          end;
+        MACH_LC_SYMTAB:
+          begin
+            symtabcmd:=pmach_symtab_command(cmd);
+            if asecname='.stab' then
+              begin
+                secofs:=symtabcmd^.symoff;
+                { the caller will divide again by sizeof(tstab) }
+                seclen:=symtabcmd^.nsyms*sizeof(tstab);
+                FindSectionMachO:=true;
+              end
+            else if asecname='.stabstr' then
+              begin
+                secofs:=symtabcmd^.stroff;
+                seclen:=symtabcmd^.strsize;
+                FindSectionMachO:=true;
+              end;
+            if FindSectionMachO then
+              begin
+                UnmapMachO(mappedexe, mappedsize);
+                exit;
+              end;
+          end;
       end;
-      Seek(e.f, FilePos (e.f) + block.cmdsize - sizeof(block));
+      cmd:=pmach_load_command(pointer(cmd)+cmd^.cmdsize);
     end;
+  UnmapMachO(mappedexe, mappedsize);
 end;
 {$endif darwin}
 
@@ -1260,8 +1496,8 @@ const
      findproc : @FindSectionElf;
 {$endif ELF32 or ELF64}
 {$ifdef darwin}
-     openproc : @OpenMachO32PPC;
-     findproc : @FindSectionMachO32PPC;
+     openproc : @OpenMachO;
+     findproc : @FindSectionMachO;
 {$endif darwin}
 {$IFDEF EMX}
      openproc : @OpenEMXaout;
@@ -1351,7 +1587,7 @@ begin
   CheckDbgFile:=(dbgcrc=c);
 end;
 
-
+{$ifndef darwin}
 function ReadDebugLink(var e:TExeFile;var dbgfn:string):boolean;
 var
   dbglink : array[0..255] of char;
@@ -1395,6 +1631,71 @@ begin
         end;
     end;
 end;
+{$else}
+function ReadDebugLink(var e:TExeFile;var dbgfn:string):boolean;
+var
+   dsymexefile: TExeFile;
+   execmd, dsymcmd: pmach_load_command;
+   exeuuidcmd, dsymuuidcmd: pmach_uuid_command;
+   mappedexe, mappeddsym: pointer;
+   mappedexeoffset, mappedexesize, mappeddsymoffset, mappeddsymsize: SizeUInt;
+   i, j: cuint32;
+   filenamestartpos, b: byte;
+begin
+  ReadDebugLink:=false;
+  if not MapMachO(filerec(e.f).handle, e.sechdrofs, e.loadcommandssize, mappedexe, mappedexeoffset, mappedexesize) then
+    exit;
+  execmd:=pmach_load_command(mappedexe+mappedexeoffset);
+  for i:=1 to e.nsects do
+    begin
+      case execmd^.cmd of
+        MACH_LC_UUID:
+          begin
+            exeuuidcmd:=pmach_uuid_command(execmd);
+            filenamestartpos:=1;
+            for b:=1 to length(e.filename) do
+              begin
+                if e.filename[b] = '/' then
+                  filenamestartpos:=b+1;
+              end;
+            if not OpenExeFile(dsymexefile,e.filename+'.dSYM/Contents/Resources/DWARF/'+copy(e.filename,filenamestartpos,length(e.filename))) then
+              begin
+                UnmapMachO(mappedexe, mappedexesize);
+                exit;
+              end;
+            if not MapMachO(filerec(dsymexefile.f).handle, dsymexefile.sechdrofs, dsymexefile.loadcommandssize, mappeddsym, mappeddsymoffset, mappeddsymsize) then
+              begin
+                CloseExeFile(dsymexefile);
+                UnmapMachO(mappedexe, mappedexesize);
+                exit;
+              end;
+            dsymcmd:=pmach_load_command(mappeddsym+mappeddsymoffset);
+            for j:=1 to dsymexefile.nsects do
+              begin
+                case dsymcmd^.cmd of
+                  MACH_LC_UUID:
+                    begin
+                      dsymuuidcmd:=pmach_uuid_command(dsymcmd);
+                      if comparebyte(exeuuidcmd^.uuid, dsymuuidcmd^.uuid, sizeof(exeuuidcmd^.uuid)) = 0 then
+                        begin
+                          dbgfn:=dsymexefile.filename;
+                          ReadDebugLink:=true;
+                        end;
+                      break;
+                    end;
+                end;
+              end;
+            UnmapMachO(mappeddsym, mappeddsymsize);
+            CloseExeFile(dsymexefile);
+            UnmapMachO(mappedexe, mappedexesize);
+            exit;
+          end;
+      end;
+      execmd:=pmach_load_command(pointer(execmd)+execmd^.cmdsize);
+    end;
+  UnmapMachO(mappedexe, mappedexesize);
+end;
+{$endif}
 
 
 begin
diff --git a/rtl/inc/lnfodwrf.pp b/rtl/inc/lnfodwrf.pp
index 2a0de65da6..d6ed1b4b75 100644
--- a/rtl/inc/lnfodwrf.pp
+++ b/rtl/inc/lnfodwrf.pp
@@ -267,6 +267,8 @@ type
 {$endif cpui8086}
 
 function OpenDwarf(addr : codepointer) : boolean;
+var
+  oldprocessaddress: TExeProcessAddress;
 begin
   // False by default
   OpenDwarf:=false;
@@ -308,9 +310,11 @@ begin
     exit;
   if ReadDebugLink(e,dbgfn) then
     begin
+      oldprocessaddress:=e.processaddress;
       CloseExeFile(e);
       if not OpenExeFile(e,dbgfn) then
         exit;
+      e.processaddress:=oldprocessaddress;
     end;
 
   // Find debug data section
diff --git a/rtl/unix/dl.pp b/rtl/unix/dl.pp
index fe789d4a72..2db2ef3533 100644
--- a/rtl/unix/dl.pp
+++ b/rtl/unix/dl.pp
@@ -136,7 +136,7 @@ uses
     begin
       SimpleExtractFilename:=Copy(s,PosLastSlash(s)+1,Length(s)-PosLastSlash(s));
     end;
-      
+
 
   procedure UnixGetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: openstring);
     var
@@ -147,10 +147,6 @@ uses
       dladdr(addr, @dlinfo);
       baseaddr:=dlinfo.dli_fbase;
       filename:=String(dlinfo.dli_fname);
-    {$ifdef darwin}
-      if SimpleExtractFilename(filename)=SimpleExtractFilename(ParamStr(0)) then
-        baseaddr:=nil;
-    {$endif darwin}
     end;
 
 {$ifdef aix}