LazDebuggerFp, FpDebug: Attach and Detach (Windows/Linux)

Attach on Linux does not work for apps started with "run without debugging". (Maybe/Probably because the IDE does a separate waitpid on those, and interferes with the waitpid of the debugger?)

git-svn-id: trunk@61967 -

components/fpdebug/fpdbgclasses.pp

@@ -364,12 +364,14 @@ type
 
     FMainThread: TDbgThread;
     function GetHandle: THandle; virtual;
+    procedure SetThreadId(AThreadId: Integer);
     procedure SetExitCode(AValue: DWord);
     function GetLastEventProcessIdentifier: THandle; virtual;
     function DoBreak(BreakpointAddress: TDBGPtr; AThreadID: integer): Boolean;
 
     function InsertBreakInstructionCode(const ALocation: TDBGPtr; out OrigValue: Byte): Boolean; //virtual;
     function RemoveBreakInstructionCode(const ALocation: TDBGPtr; const OrigValue: Byte): Boolean; //virtual;
+    procedure RemoveAllBreakPoints;
     procedure BeforeChangingInstructionCode(const ALocation: TDBGPtr); virtual;
     procedure AfterChangingInstructionCode(const ALocation: TDBGPtr); virtual;
 
@@ -380,6 +382,7 @@ type
     function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; virtual; abstract;
   public
     class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AFlags: TStartInstanceFlags): TDbgProcess; virtual;
+    class function AttachToInstance(AFileName: string; APid: Integer): TDbgProcess; virtual;
     constructor Create(const AFileName: string; const AProcessID, AThreadID: Integer); virtual;
     destructor Destroy; override;
     function  AddInternalBreak(const ALocation: TDBGPtr): TFpInternalBreakpoint; overload;
@@ -425,6 +428,7 @@ type
     function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean; virtual;
 
     procedure TerminateProcess; virtual; abstract;
+    function Detach(AProcess: TDbgProcess; AThread: TDbgThread): boolean; virtual;
 
     property Handle: THandle read GetHandle;
     property Name: String read FFileName write SetFileName;
@@ -1432,21 +1436,31 @@ begin
   result := 0;
 end;
 
+procedure TDbgProcess.SetThreadId(AThreadId: Integer);
+begin
+  assert(FThreadID = 0, 'TDbgProcess.SetThreadId: FThreadID = 0');
+  FThreadID := AThreadId;
+end;
+
 procedure TDbgProcess.SetExitCode(AValue: DWord);
 begin
   FExitCode:=AValue;
 end;
 
-resourcestring
-  sNoDebugSupport = 'Debug support is not available for this platform .';
-
 class function TDbgProcess.StartInstance(AFileName: string; AParams, AnEnvironment: TStrings;
   AWorkingDirectory, AConsoleTty: string; AFlags: TStartInstanceFlags): TDbgProcess;
 begin
-  DebugLn(DBG_VERBOSE, sNoDebugSupport);
+  DebugLn(DBG_VERBOSE, 'Debug support is not available for this platform.');
   result := nil;
 end;
 
+class function TDbgProcess.AttachToInstance(AFileName: string; APid: Integer
+  ): TDbgProcess;
+begin
+  DebugLn(DBG_VERBOSE, 'Attach not supported');
+  Result := nil;
+end;
+
 procedure TDbgProcess.ThreadDestroyed(const AThread: TDbgThread);
 begin
   if AThread = FMainThread
@@ -1550,6 +1564,22 @@ begin
     AfterChangingInstructionCode(ALocation);
 end;
 
+procedure TDbgProcess.RemoveAllBreakPoints;
+var
+  b: TFpInternalBreakpoint;
+  i: LongInt;
+begin
+  i := FBreakpointList.Count - 1;
+  while i >= 0 do begin
+    b := FBreakpointList[i];
+    b.ResetBreak;
+    b.FProcess := nil;
+    FBreakpointList.Delete(i);
+    dec(i);
+  end;
+  assert(FBreakMap.Count = 0, 'TDbgProcess.RemoveAllBreakPoints: FBreakMap.Count = 0');
+end;
+
 procedure TDbgProcess.BeforeChangingInstructionCode(const ALocation: TDBGPtr);
 begin
   //
@@ -1635,6 +1665,12 @@ begin
   result := false;
 end;
 
+function TDbgProcess.Detach(AProcess: TDbgProcess; AThread: TDbgThread
+  ): boolean;
+begin
+  Result := False;
+end;
+
 { TDbgThread }
 
 function TDbgThread.GetRegisterValueList: TDbgRegisterValueList;

components/fpdebug/fpdbgcontroller.pas

@@ -147,6 +147,8 @@ type
   TDbgController = class
   private
     FRunning, FPauseRequest: cardinal;
+    FAttachToPid: Integer;
+    FDetaching: cardinal;
     FEnvironment: TStrings;
     FExecutableFilename: string;
     FForceNewConsoleWin: boolean;
@@ -186,10 +188,12 @@ type
     procedure Step;
     procedure StepOut;
     function Pause: boolean;
+    function Detach: boolean;
     procedure ProcessLoop;
     procedure SendEvents(out continue: boolean);
 
     property ExecutableFilename: string read FExecutableFilename write SetExecutableFilename;
+    property AttachToPid: Integer read FAttachToPid write FAttachToPid;
     property CurrentProcess: TDbgProcess read FCurrentProcess;
     property CurrentThread: TDbgThread read FCurrentThread;
     property CurrentThreadId: Integer read GetCurrentThreadId write SetCurrentThreadId;
@@ -770,6 +774,9 @@ begin
   Flags := [];
   if RedirectConsoleOutput then Include(Flags, siRediretOutput);
   if ForceNewConsoleWin then Include(Flags, siForceNewConsole);
+  if AttachToPid <> 0 then
+    FCurrentProcess := OSDbgClasses.DbgProcessClass.AttachToInstance(FExecutableFilename, AttachToPid)
+  else
     FCurrentProcess := OSDbgClasses.DbgProcessClass.StartInstance(FExecutableFilename, Params, Environment, WorkingDirectory, FConsoleTty, Flags);
   if assigned(FCurrentProcess) then
     begin
@@ -820,8 +827,26 @@ begin
     Result := FCurrentProcess.Pause;
 end;
 
+function TDbgController.Detach: boolean;
+begin
+  InterLockedExchange(FDetaching, 1);
+  Result := Pause;
+end;
+
 procedure TDbgController.ProcessLoop;
 
+  function MaybeDetach: boolean;
+  begin
+    Result := InterLockedExchange(FDetaching, 0) <> 0;
+    if not Result then
+      exit;
+
+    if Assigned(FCommand) then
+      FreeAndNil(FCommand);
+    FPDEvent := deFinishedStep; // go to pause, if detach fails
+    if FCurrentProcess.Detach(FCurrentProcess, FCurrentThread) then
+      FPDEvent := deExitProcess;
+  end;
 var
   AProcessIdentifier: THandle;
   AThreadIdentifier: THandle;
@@ -843,6 +868,9 @@ begin
   if FCommand <> nil then
     FCommand.DoBeforeLoopStart;
 
+  if MaybeDetach then
+    exit;
+
   repeat
     if assigned(FCurrentProcess) and not assigned(FMainProcess) then begin
       // IF there is a pause-request, we will hit a deCreateProcess.
@@ -858,6 +886,7 @@ begin
       // if Pause() is called right here, an Interrupt-Event is scheduled, even though we do not run (yet)
       if InterLockedExchangeAdd(FPauseRequest, 0) = 1 then begin
         FPDEvent := deBreakpoint;
+        InterLockedExchange(FRunning, 0);
         break; // no event handling. Keep Process/Thread from last run
       end
       else begin
@@ -931,6 +960,7 @@ begin
        this will remove CurrentThread form the list of threads
        CurrentThread is then destroyed in the next call to continue....
     *)
+
     FPDEvent:=FCurrentProcess.ResolveDebugEvent(FCurrentThread);
     DebugLn(DBG_VERBOSE, 'Process stopped with event %s. IP=%s, SP=%s, BSP=%s. HasBreak: %s',
                          [FPDEventNames[FPDEvent],
@@ -938,6 +968,10 @@ begin
                          FCurrentProcess.FormatAddress(FCurrentThread.GetStackPointerRegisterValue),
                          FCurrentProcess.FormatAddress(FCurrentThread.GetStackBasePointerRegisterValue),
                          dbgs(CurrentProcess.CurrentBreakpoint<>nil)]);
+
+    if MaybeDetach then
+      break;
+
     IsHandled:=false;
     IsFinished:=false;
     if FPDEvent=deExitProcess then

components/fpdebug/fpdbglinuxclasses.pas

@@ -293,6 +293,8 @@ type
   public
     class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings;
       AWorkingDirectory, AConsoleTty: string; AFlags: TStartInstanceFlags): TDbgProcess; override;
+    class function AttachToInstance(AFileName: string; APid: Integer
+      ): TDbgProcess; override;
     constructor Create(const AName: string; const AProcessID, AThreadID: Integer); override;
     destructor Destroy; override;
 
@@ -305,6 +307,7 @@ type
 
     procedure TerminateProcess; override;
     function Pause: boolean; override;
+    function Detach(AProcess: TDbgProcess; AThread: TDbgThread): boolean; override;
 
     function Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean; override;
     function WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean; override;
@@ -841,6 +844,17 @@ begin
   end;
 end;
 
+class function TDbgLinuxProcess.AttachToInstance(AFileName: string;
+  APid: Integer): TDbgProcess;
+begin
+  Result := nil;
+  fpPTrace(PTRACE_ATTACH, APid, nil, Pointer(PTRACE_O_TRACECLONE));
+
+  result := TDbgLinuxProcess.Create(AFileName, APid, 0);
+
+  // TODO: change the filename to the actual exe-filename. Load the correct dwarf info
+end;
+
 function TDbgLinuxProcess.ReadData(const AAdress: TDbgPtr;
   const ASize: Cardinal; out AData): Boolean;
 
@@ -1008,6 +1022,14 @@ begin
     end;
 end;
 
+function TDbgLinuxProcess.Detach(AProcess: TDbgProcess; AThread: TDbgThread): boolean;
+begin
+  RemoveAllBreakPoints;
+
+  fpPTrace(PTRACE_DETACH, AThread.ID, nil, pointer(wstopsig(TDbgLinuxThread(AThread).FExceptionSignal)));
+  Result := True;
+end;
+
 function TDbgLinuxProcess.Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean;
   function CheckNoError: Boolean;
   var
@@ -1234,6 +1256,16 @@ begin
       Exit;
       end;
 
+    if (not FProcessStarted) and (wstopsig(FStatus) <> SIGTRAP) then begin
+      // attached, should be SigStop, but may be out of order
+      debugln(DBG_VERBOSE, ['Attached ', wstopsig(FStatus)]);
+      result := deCreateProcess;
+      FProcessStarted:=true;
+      if not wstopsig(FStatus) = SIGSTOP then
+        FPostponedSignals.AddSignal(AThread.Id, FStatus);
+    end
+
+    else
     case wstopsig(FStatus) of
       SIGTRAP:
         begin

components/fpdebug/fpdbglinuxextra.pas

@@ -44,6 +44,8 @@ const
   PTRACE_O_TRACECLONE                          = 1 << PTRACE_EVENT_CLONE;
 {$endif linux}
   PTRACE_ATTACH                                = 16;
+  PTRACE_DETACH                                = 17;
+  PTRACE_SEIZE                                 = $4206;
 
   RIP                                          = 16;
 

components/fpdebug/fpdbgwinclasses.pas

@@ -187,7 +187,9 @@ type
     function  HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
 
     class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; AFlags: TStartInstanceFlags): TDbgProcess; override;
+    class function AttachToInstance(AFileName: string; APid: Integer): TDbgProcess; override;
     function Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean; override;
+    function Detach(AProcess: TDbgProcess; AThread: TDbgThread): boolean; override;
     function WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean; override;
     function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; override;
     function CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread; override;
@@ -291,6 +293,7 @@ var
   _GetFinalPathNameByHandle: function(hFile: HANDLE; lpFilename:LPWSTR; cchFilePath, dwFlags: DWORD):DWORD; stdcall = nil;
   _QueryFullProcessImageName: function (hProcess:HANDLE; dwFlags: DWord; lpExeName:LPWSTR; var lpdwSize:DWORD):BOOL; stdcall = nil;
   _DebugActiveProcessStop: function (ProcessId:DWORD):BOOL; stdcall = nil;
+  _DebugActiveProcess: function (ProcessId:DWORD):BOOL; stdcall = nil;
   _IsWow64Process: function (hProcess:HANDLE; WoW64Process: PBOOL):BOOL; stdcall = nil;
   _Wow64GetThreadContext: function (hThread: THandle; var   lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
   _Wow64SetThreadContext: function (hThread: THandle; const lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
@@ -310,6 +313,7 @@ begin
   Pointer(_CreateRemoteThread) := GetProcAddress(hMod, 'CreateRemoteThread');
   Pointer(_QueryFullProcessImageName) := GetProcAddress(hMod, 'QueryFullProcessImageNameW'); // requires Vista
   Pointer(_DebugActiveProcessStop) := GetProcAddress(hMod, 'DebugActiveProcessStop');
+  Pointer(_DebugActiveProcess) := GetProcAddress(hMod, 'DebugActiveProcess');
   Pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleW');
   {$ifdef cpux86_64}
   Pointer(_IsWow64Process) := GetProcAddress(hMod, 'IsWow64Process');
@@ -320,6 +324,8 @@ begin
   DebugLn(DBG_WARNINGS and (DebugBreakAddr = nil), ['WARNING: Failed to get DebugBreakAddr']);
   DebugLn(DBG_WARNINGS and (_CreateRemoteThread = nil), ['WARNING: Failed to get CreateRemoteThread']);
   DebugLn(DBG_WARNINGS and (_QueryFullProcessImageName = nil), ['WARNING: Failed to get QueryFullProcessImageName']);
+  DebugLn(DBG_WARNINGS and (_DebugActiveProcessStop = nil), ['WARNING: Failed to get DebugActiveProcessStop']);
+  DebugLn(DBG_WARNINGS and (_DebugActiveProcess = nil), ['WARNING: Failed to get DebugActiveProcess']);
   DebugLn(DBG_WARNINGS and (_GetFinalPathNameByHandle = nil), ['WARNING: Failed to get GetFinalPathNameByHandle']);
   {$ifdef cpux86_64}
   DebugLn(DBG_WARNINGS and (_IsWow64Process = nil), ['WARNING: Failed to get IsWow64Process']);
@@ -599,6 +605,18 @@ begin
   end;
 end;
 
+class function TDbgWinProcess.AttachToInstance(AFileName: string; APid: Integer
+  ): TDbgProcess;
+begin
+  Result := nil;
+  if _DebugActiveProcess = nil then
+    exit;
+  if not _DebugActiveProcess(APid) then
+    exit;
+
+  result := TDbgWinProcess.Create(AFileName, APid, 0);
+  // TODO: change the filename to the actual exe-filename. Load the correct dwarf info
+end;
 
 function TDbgWinProcess.Continue(AProcess: TDbgProcess; AThread: TDbgThread;
   SingleStep: boolean): boolean;
@@ -700,6 +718,58 @@ if AThread<>nil then debugln(['## ath.iss ',AThread.NextIsSingleStep]);
   result := true;
 end;
 
+function TDbgWinProcess.Detach(AProcess: TDbgProcess; AThread: TDbgThread
+  ): boolean;
+var
+  t: TDbgWinThread;
+  PendingDebugEvent: TDebugEvent;
+begin
+  Result := _DebugActiveProcessStop <> nil;
+  if not Result then
+    exit;
+
+  RemoveAllBreakPoints;
+
+  // Collect all pending events // Deal with any breakpoint/int3 hit
+  if not GetThread(MDebugEvent.dwThreadId, TDbgThread(AThread)) then begin
+    assert(False, 'TDbgWinProcess.Detach: Missing thread');
+    TDbgThread(AThread) := AddThread(MDebugEvent.dwThreadId);
+  end;
+
+  for TDbgThread(t) in FThreadMap do
+    if not t.ID = MDebugEvent.dwThreadId then
+      t.Suspend;
+
+  TDbgWinThread(AThread).SetSingleStep;
+  Windows.ContinueDebugEvent(MDebugEvent.dwProcessId, MDebugEvent.dwThreadId, DBG_CONTINUE);
+  while Windows.WaitForDebugEvent(PendingDebugEvent, 1) do begin
+    if PendingDebugEvent.dwThreadId = MDebugEvent.dwThreadId then
+      break;
+    case PendingDebugEvent.dwDebugEventCode of
+      CREATE_PROCESS_DEBUG_EVENT: begin
+          if PendingDebugEvent.CreateProcessInfo.hFile <> 0 then
+            CloseHandle(PendingDebugEvent.CreateProcessInfo.hFile);
+          _DebugActiveProcessStop(PendingDebugEvent.dwProcessId);
+        end;
+      EXCEPTION_DEBUG_EVENT:
+        case PendingDebugEvent.Exception.ExceptionRecord.ExceptionCode of
+          EXCEPTION_BREAKPOINT, STATUS_WX86_BREAKPOINT: begin
+            if not GetThread(PendingDebugEvent.dwThreadId, TDbgThread(t)) then
+              TDbgThread(t) := AddThread(PendingDebugEvent.dwThreadId);
+            t.CheckAndResetInstructionPointerAfterBreakpoint;
+          end;
+        end;
+    end;
+    Windows.ContinueDebugEvent(PendingDebugEvent.dwProcessId, PendingDebugEvent.dwThreadId, DBG_CONTINUE);
+  end;
+
+  for TDbgThread(t) in FThreadMap do
+    t.Resume;
+
+  Result := _DebugActiveProcessStop(ProcessID);
+//  Windows.ContinueDebugEvent(MDebugEvent.dwProcessId, MDebugEvent.dwThreadId, DBG_CONTINUE);
+end;
+
 function TDbgWinProcess.WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean;
 var
   t: TDbgWinThread;
@@ -742,7 +812,7 @@ begin
   DebugLn([dbgs(MDebugEvent), ' ', Result]);
   for TDbgThread(t) in FThreadMap do begin
   if t.ReadThreadState then
-    DebugLn('Thr.Id:%d  SSTep %s EF %s     DR6:%x  WP:%x  RegAcc: %d,  SStep: %d  Task: %d, ExcBrk: %d', [t.ID, dbgs(t.FCurrentContext^.def.EFlags and FLAG_TRACE_BIT), dbghex(t.FCurrentContext^.def.EFlags), t.FCurrentContext^.def.Dr6, t.FCurrentContext^.def.Dr6 and 15, t.FCurrentContext^.def.Dr6 and (1<< 13), t.FCurrentContext^.def.Dr6 and (1<< 14), t.FCurrentContext^.def.Dr6 and (1<< 15), t.FCurrentContext^.def.Dr6 and (1<< 16)]);
+    DebugLn('Thr.Id:%d %x  SSTep %s EF %s     DR6:%x  WP:%x  RegAcc: %d,  SStep: %d  Task: %d, ExcBrk: %d', [t.ID, t.GetInstructionPointerRegisterValue, dbgs(t.FCurrentContext^.def.EFlags and FLAG_TRACE_BIT), dbghex(t.FCurrentContext^.def.EFlags), t.FCurrentContext^.def.Dr6, t.FCurrentContext^.def.Dr6 and 15, t.FCurrentContext^.def.Dr6 and (1<< 13), t.FCurrentContext^.def.Dr6 and (1<< 14), t.FCurrentContext^.def.Dr6 and (1<< 15), t.FCurrentContext^.def.Dr6 and (1<< 16)]);
   end;
   {$ENDIF}
 
@@ -1132,6 +1202,8 @@ var
   {$endif}
 begin
   FInfo := AInfo;
+  if ThreadID = 0 then
+    SetThreadId(AThreadID);
   {$ifdef cpui386}
   FBitness := b32; // only 32 bit supported
   {$else}

components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas

@@ -1839,7 +1839,7 @@ begin
     FDbgController.NextOnlyStopOnStartLine := TFpDebugDebuggerProperties(GetProperties).NextOnlyStopOnStartLine;
 
   if (ACommand in [dcRun, dcStepOver, dcStepInto, dcStepOut, dcRunTo, dcJumpto,
-      dcStepOverInstr, dcStepIntoInstr]) and
+      dcStepOverInstr, dcStepIntoInstr, dcAttach]) and
      not assigned(FDbgController.MainProcess)
   then
   begin
@@ -1855,6 +1855,15 @@ begin
     {$ifdef windows}
     FDbgController.ForceNewConsoleWin:=TFpDebugDebuggerProperties(GetProperties).ForceNewConsole;
     {$endif windows}
+    //FDbgController.AttachToPid := 0;
+    if ACommand = dcAttach then begin
+      FDbgController.AttachToPid := StrToIntDef(String(AParams[0].VAnsiString), 0);
+      Result := FDbgController.AttachToPid <> 0;
+      if not Result then begin
+        FileName := '';
+        Exit;
+      end;
+    end;
     FFpDebugThread := TFpDebugThread.Create(Self);
     RTLeventWaitFor(FFpDebugThread.DebugLoopStoppedEvent);
     RTLeventResetEvent(FFpDebugThread.DebugLoopStoppedEvent);
@@ -1947,6 +1956,12 @@ begin
         StartDebugLoop;
         result := true;
       end;
+    dcDetach:
+      begin
+        Result := FDbgController.Detach;
+        if Result and (State in [dsPause, dsInternalPause]) then
+          StartDebugLoop;
+      end;
     dcEvaluate:
       begin
         EvalFlags := TDBGEvaluateFlags(AParams[1].VInteger);
@@ -2001,7 +2016,9 @@ begin
        because any callstack (never mind which to which IDE-thread object it belongs
        will always get the data for the current thread only
      TODO: callstacks need a field with the thread-id to which they belong *)
-    if (Threads <> nil) and (Threads.CurrentThreads <> nil) then
+    if (Threads <> nil) and (Threads.CurrentThreads <> nil) and
+       (FDbgController.CurrentThread <> nil)
+    then
       Threads.CurrentThreads.CurrentThreadId := FDbgController.CurrentThreadId;
 
     FDbgController.SendEvents(Cont); // This may free the TFpDebugDebugger (self)
@@ -2300,7 +2317,10 @@ end;
 function TFpDebugDebugger.GetSupportedCommands: TDBGCommands;
 begin
   Result:=[dcRun, dcStop, dcStepIntoInstr, dcStepOverInstr, dcStepOver,
-           dcRunTo, dcPause, dcStepOut, dcStepInto, dcEvaluate, dcSendConsoleInput];
+           dcRunTo, dcPause, dcStepOut, dcStepInto, dcEvaluate, dcSendConsoleInput
+           {$IFDEF windows} , dcAttach, dcDetach {$ENDIF}
+           {$IFDEF linux} , dcAttach, dcDetach {$ENDIF}
+          ];
   if State = dsStop then
     Result := Result - [dcStepInto, dcStepOver, dcStepOut, dcStepIntoInstr, dcStepOverInstr];
 end;