* Implemented basic debug-support for Darwin

git-svn-id: trunk@44413 -

.gitattributes

@@ -1254,6 +1254,7 @@ components/fpcunit/languages/guitestrunner.ru.po svneol=native#text/plain
 components/fpcunit/languages/guitestrunner.uk.po svneol=native#text/plain
 components/fpdebug/README_DUBY.txt svneol=native#text/pascal
 components/fpdebug/README_macho.txt svneol=native#text/pascal
+components/fpdebug/app/fpd/Info.plist svneol=native#text/plain
 components/fpdebug/app/fpd/README.txt svneol=native#text/plain
 components/fpdebug/app/fpd/fpd.lpi svneol=native#text/pascal
 components/fpdebug/app/fpd/fpd.lpr svneol=native#text/pascal
@@ -1265,6 +1266,7 @@ components/fpdebug/app/fpd/fpdtype.pas svneol=native#text/pascal
 components/fpdebug/app/fpdd/fpdumpdwarf.lpi svneol=native#text/plain
 components/fpdebug/app/fpdd/fpdumpdwarf.lpr svneol=native#text/pascal
 components/fpdebug/fpdbgclasses.pp svneol=native#text/pascal
+components/fpdebug/fpdbgdarwinclasses.pas svneol=native#text/plain
 components/fpdebug/fpdbgdisasx86.pp svneol=native#text/plain
 components/fpdebug/fpdbgdwarf.pas svneol=native#text/pascal
 components/fpdebug/fpdbgdwarfconst.pas svneol=native#text/pascal

components/fpdebug/app/fpd/Info.plist

@@ -0,0 +1,20 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+  <dict>
+    <key>CFBundleDevelopmentRegion</key>
+    <string>English</string>
+    <key>CFBundleIdentifier</key>
+    <string>org.freepascal.fpd</string>
+    <key>CFBundleInfoDictionaryVersion</key>
+    <string>6.0</string>
+    <key>CFBundleName</key>
+    <string>tfpexample</string>
+    <key>CFBundleVersion</key>
+    <string>1.0</string>
+    <key>SecTaskAccess</key>
+    <array>
+      <string>allowed</string>
+    </array>
+  </dict>
+</plist>

components/fpdebug/app/fpd/fpd.lpi

@@ -63,6 +63,12 @@
       <IncludeFiles Value="$(ProjOutDir)"/>
       <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
+    <Linking>
+      <Options>
+        <PassLinkerOptions Value="True"/>
+        <LinkerOptions Value="-sectcreate __TEXT __info_plist Info.plist"/>
+      </Options>
+    </Linking>
     <Other>
       <CompilerMessages>
         <MsgFileName Value=""/>

components/fpdebug/app/fpd/fpdloop.pas

@@ -58,6 +58,7 @@ procedure DebugLoop;
     Code, CodeBytes: String;
   begin
     WriteLN('===');
+    {$ifdef windows}
     {$ifdef cpui386}
       a := GCurrentContext^.EIP;
       Write('  [', FormatAddress(a), ']');
@@ -67,6 +68,9 @@ procedure DebugLoop;
       Write('  [', FormatAddress(a), ']');
       Disassemble(GCurrentProcess.Handle, True, a, CodeBytes, Code);
     {$endif}
+    {$else}
+    a := 0;
+    {$endif}
     WriteLN(' ', CodeBytes, '    ', Code);
   end;
   
@@ -78,11 +82,15 @@ procedure DebugLoop;
     Name: String;
   begin
     WriteLN('===');
+    {$ifdef windows}
     {$ifdef cpui386}
       a := GCurrentContext^.EIP;
     {$else}
       a := GCurrentContext^.RIP;
     {$endif}
+    {$else}
+    a := 0;
+    {$endif}
     sym := GCurrentProcess.FindSymbol(a);
     if sym = nil
     then begin
@@ -204,6 +212,10 @@ begin
             then GState := dsPause;
 
           end;
+        deBreakpoint :
+          begin
+            GState:=dsPause;
+          end;
       end; {case}
     end;
   until (GState in [dsStop, dsPause, dsQuit]);

components/fpdebug/fpdbgclasses.pp

@@ -151,7 +151,7 @@ type
     function GetLastEventProcessIdentifier: THandle; virtual;
   public
     class function StartInstance(AFileName: string; AParams: string): TDbgProcess; virtual;
-    constructor Create(const AName: string; const AProcessID, AThreadID: Integer);
+    constructor Create(const AName: string; const AProcessID, AThreadID: Integer); virtual;
     destructor Destroy; override;
     function  AddBreak(const ALocation: TDbgPtr): TDbgBreakpoint;
     function  FindSymbol(const AName: String): TFpDbgSymbol;
@@ -206,6 +206,10 @@ implementation
 uses
   FpDbgWinClasses;
 {$endif}
+{$ifdef darwin}
+uses
+  FpDbgDarwinClasses;
+{$endif}
 
 var
   GOSDbgClasses : TOSDbgClasses;
@@ -221,6 +225,9 @@ begin
     {$ifdef windows}
     RegisterDbgClasses;
     {$endif windows}
+    {$ifdef darwin}
+    RegisterDbgClasses;
+    {$endif darwin}
     end;
   result := GOSDbgClasses;
 end;
@@ -535,7 +542,7 @@ const
 begin
   if not FProcess.ReadData(FLocation, 1, FOrgValue)
   then begin
-    Log('Unable to read breakpoint at $%p', [FLocation]);
+    Log('Unable to read breakpoint at '+FormatAddress(FLocation));
     Exit;
   end;
 

components/fpdebug/fpdbgdarwinclasses.pas

@@ -0,0 +1,278 @@
+unit FpDbgDarwinClasses;
+
+{$mode objfpc}{$H+}
+{$linkframework security}
+
+interface
+
+uses
+  Classes,
+  SysUtils,
+  BaseUnix,
+  FpDbgClasses,
+  FpDbgLoader,
+  DbgIntfBaseTypes,
+  FpDbgLinuxExtra,
+  FpDbgInfo,
+  MacOSAll,
+  FpDbgUtil,
+  LazLoggerBase;
+
+type
+
+  { TDbgDarwinProcess }
+
+  TDbgDarwinProcess = class(TDbgProcess)
+  private
+    FStatus: cint;
+    FProcessStarted: boolean;
+    FTaskPort: mach_port_name_t;
+    function GetDebugAccessRights: boolean;
+  protected
+    function InitializeLoader: TDbgImageLoader; override;
+  public
+    class function StartInstance(AFileName: string; AParams: string): TDbgProcess; override;
+    constructor Create(const AName: string; const AProcessID, AThreadID: Integer); override;
+
+    function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean; override;
+    function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean; override;
+
+    function Continue(AProcess: TDbgProcess; AThread: TDbgThread; AState: TFPDState): boolean; override;
+    function WaitForDebugEvent(out ProcessIdentifier: THandle): boolean; override;
+    function ResolveDebugEvent(AThread: TDbgThread): TFPDEvent; override;
+  end;
+
+procedure RegisterDbgClasses;
+
+implementation
+
+type
+  vm_map_t = mach_port_t;
+  vm_offset_t = UIntPtr;
+  vm_address_t = vm_offset_t;
+  vm_size_t = UIntPtr;
+  vm_prot_t = cint;
+  mach_vm_address_t = uint64;
+  mach_msg_Type_number_t = natural_t;
+  mach_vm_size_t = uint64;
+
+function task_for_pid(target_tport: mach_port_name_t; pid: integer; var t: mach_port_name_t): kern_return_t; cdecl external name 'task_for_pid';
+function mach_task_self: mach_port_name_t; cdecl external name 'mach_task_self';
+function mach_error_string(error_value: mach_error_t): pchar; cdecl; external name 'mach_error_string';
+function vm_protect(target_task: vm_map_t; adress: vm_address_t; size: vm_size_t; set_maximum: boolean_t; new_protection: vm_prot_t): kern_return_t; cdecl external name 'vm_protect';
+function mach_vm_write(target_task: vm_map_t; address: mach_vm_address_t; data: vm_offset_t; dataCnt: mach_msg_Type_number_t): kern_return_t; cdecl external name 'mach_vm_write';
+function mach_vm_read(target_task: vm_map_t; address: mach_vm_address_t; size: mach_vm_size_t; var data: vm_offset_t; var dataCnt: mach_msg_Type_number_t): kern_return_t; cdecl external name 'mach_vm_read';
+
+procedure RegisterDbgClasses;
+begin
+  OSDbgClasses.DbgProcessClass:=TDbgDarwinProcess;
+end;
+
+{ TDbgDarwinProcess }
+
+function TDbgDarwinProcess.GetDebugAccessRights: boolean;
+var
+  authFlags: AuthorizationFlags;
+  stat: OSStatus;
+  author: AuthorizationRef;
+  authItem: AuthorizationItem;
+  authRights: AuthorizationRights;
+begin
+  result := false;
+  authFlags := kAuthorizationFlagExtendRights or kAuthorizationFlagPreAuthorize or kAuthorizationFlagInteractionAllowed or ( 1 << 5);
+
+  stat := AuthorizationCreate(nil, kAuthorizationEmptyEnvironment, authFlags, author);
+  if stat <> errAuthorizationSuccess then
+    begin
+    debugln('Failed to create authorization. Authorization error: ' + inttostr(stat));
+    exit;
+    end;
+
+  authItem.name:='system.privilege.taskport';
+  authItem.flags:=0;
+  authItem.value:=nil;
+  authItem.valueLength:=0;
+
+  authRights.count:=1;
+  authRights.items:=@authItem;
+
+  stat := AuthorizationCopyRights(author, authRights, kAuthorizationEmptyEnvironment, authFlags, nil);
+  if stat <> errAuthorizationSuccess then
+    begin
+    debugln('Failed to get debug-(taskport)-privilege. Authorization error: ' + inttostr(stat));
+    exit;
+    end;
+  result := true;
+end;
+
+function TDbgDarwinProcess.InitializeLoader: TDbgImageLoader;
+begin
+  result := TDbgImageLoader.Create(Name);
+end;
+
+constructor TDbgDarwinProcess.Create(const AName: string; const AProcessID, AThreadID: Integer);
+var
+  aKernResult: kern_return_t;
+begin
+  inherited Create(AName, AProcessID, AThreadID);
+
+  LoadInfo;
+
+  if DbgInfo.HasInfo
+  then FSymInstances.Add(Self);
+
+  GetDebugAccessRights;
+  aKernResult:=task_for_pid(mach_task_self, AProcessID, FTaskPort);
+  if aKernResult <> KERN_SUCCESS then
+    begin
+    DebugLn('Failed to get task for process '+IntToStr(AProcessID)+'. Probably insufficient rights to debug applications. Mach error: '+mach_error_string(aKernResult));
+    end;
+end;
+
+class function TDbgDarwinProcess.StartInstance(AFileName: string; AParams: string): TDbgProcess;
+var
+  PID: TPid;
+  stat: longint;
+begin
+  pid := FpFork;
+  if PID=0 then
+    begin
+    // We are in the child-process
+    fpPTrace(PTRACE_TRACEME, 0, nil, nil);
+    FpExecve(AFileName, nil, nil);
+    end
+  else if PID<>-1 then
+    begin
+    sleep(100);
+    result := TDbgDarwinProcess.Create(AFileName, Pid,-1);
+    end;
+end;
+
+function TDbgDarwinProcess.ReadData(const AAdress: TDbgPtr;
+  const ASize: Cardinal; out AData): Boolean;
+var
+  aKernResult: kern_return_t;
+  cnt: mach_msg_Type_number_t;
+  b: pointer;
+begin
+  result := false;
+
+  aKernResult := mach_vm_read(FTaskPort, AAdress, ASize, PtrUInt(b), cnt);
+  if aKernResult <> KERN_SUCCESS then
+    begin
+    DebugLn('Failed to read data at address '+FormatAddress(ProcessID)+'. Mach error: '+mach_error_string(aKernResult));
+    Exit;
+    end;
+  System.Move(b^, AData, Cnt);
+  result := true;
+end;
+
+function TDbgDarwinProcess.WriteData(const AAdress: TDbgPtr;
+  const ASize: Cardinal; const AData): Boolean;
+var
+  aKernResult: kern_return_t;
+begin
+  result := false;
+  aKernResult:=vm_protect(FTaskPort, PtrUInt(AAdress), ASize, boolean_t(false), 7 {VM_PROT_READ + VM_PROT_WRITE + VM_PROT_COPY});
+  if aKernResult <> KERN_SUCCESS then
+    begin
+    DebugLn('Failed to call vm_protect for address '+FormatAddress(AAdress)+'. Mach error: '+mach_error_string(aKernResult));
+    Exit;
+    end;
+
+  aKernResult := mach_vm_write(FTaskPort, AAdress, vm_offset_t(@AData), ASize);
+  if aKernResult <> KERN_SUCCESS then
+    begin
+    DebugLn('Failed to write data at address '+FormatAddress(AAdress)+'. Mach error: '+mach_error_string(aKernResult));
+    Exit;
+    end;
+
+  result := true;
+end;
+
+function TDbgDarwinProcess.Continue(AProcess: TDbgProcess; AThread: TDbgThread;
+  AState: TFPDState): boolean;
+var
+  e: integer;
+begin
+  fpseterrno(0);
+{$ifdef linux}
+  fpPTrace(PTRACE_CONT, ProcessID, nil, nil);
+{$endif linux}
+{$ifdef darwin}
+  fpPTrace(PTRACE_CONT, ProcessID, pointer(1), nil);
+{$endif darwin}
+  writeln('Cont');
+  e := fpgeterrno;
+  if e <> 0 then
+    begin
+    writeln('Failed to continue process. Errcode: ',e);
+    result := false;
+    end
+  else
+    result := true;
+end;
+
+function TDbgDarwinProcess.WaitForDebugEvent(out ProcessIdentifier: THandle): boolean;
+begin
+  ProcessIdentifier:=FpWaitPid(-1, FStatus, 0);
+  writeln('waited');
+  result := ProcessIdentifier<>-1;
+  if not result then
+    writeln('Failed to wait for debug event. Errcode: ', fpgeterrno);
+end;
+
+function TDbgDarwinProcess.ResolveDebugEvent(AThread: TDbgThread): TFPDEvent;
+
+  Function WIFSTOPPED(Status: Integer): Boolean;
+  begin
+    WIFSTOPPED:=((Status and $FF)=$7F);
+  end;
+
+begin
+  if wifexited(FStatus) then
+    begin
+    SetExitCode(wexitStatus(FStatus));
+    writeln('Exit');
+    result := deExitProcess
+    end
+  else if WIFSTOPPED(FStatus) then
+    begin
+    writeln('Stopped ',FStatus, ' signal: ',wstopsig(FStatus));
+    case wstopsig(FStatus) of
+      SIGTRAP:
+        begin
+        if not FProcessStarted then
+          begin
+          result := deCreateProcess;
+          FProcessStarted:=true;
+          end
+        else
+          begin
+          result := deBreakpoint;
+          writeln('Breakpoint');
+          end;
+        end;
+      SIGBUS:
+        begin
+        writeln('Received SIGBUS');
+        result := deException;
+        end;
+      SIGINT:
+        begin
+        writeln('Received SIGINT');
+        result := deException;
+        end;
+      SIGSEGV:
+        begin
+        writeln('Received SIGSEGV');
+        result := deException;
+        end;
+    end; {case}
+    end
+  else if wifsignaled(FStatus) then
+    writeln('ERROR: ', wtermsig(FStatus));
+end;
+
+end.
+

components/fpdebug/fpdebug.lpk

@@ -34,7 +34,7 @@ File(s) with other licenses (see also header in file(s):
 
   (Any modifications/translations of this file are from duby)
 "/>
-    <Files Count="22">
+    <Files Count="23">
       <Item1>
         <Filename Value="fpdbgclasses.pp"/>
         <UnitName Value="FpDbgClasses"/>
@@ -69,6 +69,7 @@ File(s) with other licenses (see also header in file(s):
       </Item8>
       <Item9>
         <Filename Value="fpdbgwinextra.pp"/>
+        <AddToUsesPkgSection Value="False"/>
         <UnitName Value="FpDbgWinExtra"/>
       </Item9>
       <Item10>
@@ -117,13 +118,18 @@ File(s) with other licenses (see also header in file(s):
         <UnitName Value="FpDbgWinClasses"/>
       </Item20>
       <Item21>
-        <Filename Value="fpdmemorytools.pas"/>
+        <Filename Value="fpdbgdarwinclasses.pas"/>
-        <UnitName Value="FpdMemoryTools"/>
+        <AddToUsesPkgSection Value="False"/>
+        <UnitName Value="fpdbgdarwinclasses"/>
       </Item21>
       <Item22>
-        <Filename Value="fperrormessages.pas"/>
+        <Filename Value="fpdmemorytools.pas"/>
-        <UnitName Value="fperrormessages"/>
+        <UnitName Value="FpdMemoryTools"/>
       </Item22>
+      <Item23>
+        <Filename Value="fperrormessages.pas"/>
+        <UnitName Value="FpErrorMessages"/>
+      </Item23>
     </Files>
     <Type Value="RunAndDesignTime"/>
     <RequiredPkgs Count="3">

components/fpdebug/fpdebug.pas

@@ -7,11 +7,11 @@ unit fpdebug;
 interface
 
 uses
-  FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, FpDbgPETypes, 
+  FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, 
-  FpDbgSymbols, FpDbgUtil, FpDbgWinExtra, FpImgReaderWinPE, FpImgReaderElf, 
+  FpDbgPETypes, FpDbgSymbols, FpDbgUtil, FpImgReaderWinPE, FpImgReaderElf, 
-  FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho, FpImgReaderMachoFile, 
+  FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho, 
-  FpImgReaderMacho, FpPascalBuilder, FpDbgInfo, FpdMemoryTools, FpErrorMessages, 
+  FpImgReaderMachoFile, FpImgReaderMacho, FpPascalBuilder, FpDbgInfo, 
-  LazarusPackageIntf;
+  FpdMemoryTools, FpErrorMessages, LazarusPackageIntf;
 
 implementation