diff --git a/.gitattributes b/.gitattributes index 7b403626e3..4344e39a91 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1416,10 +1416,12 @@ components/fpdebug/app/fpdserver/debugthreadcommand.pas svneol=native#text/plain components/fpdebug/app/fpdserver/fpdserver.lpi svneol=native#text/plain components/fpdebug/app/fpdserver/fpdserver.lpr svneol=native#text/plain components/fpdebug/app/fpdserver/readme.txt svneol=native#text/plain +components/fpdebug/fpdbgavrclasses.pas svneol=native#text/pascal components/fpdebug/fpdbgclasses.pp svneol=native#text/pascal components/fpdebug/fpdbgcommon.pas svneol=native#text/pascal components/fpdebug/fpdbgcontroller.pas svneol=native#text/plain components/fpdebug/fpdbgdarwinclasses.pas svneol=native#text/plain +components/fpdebug/fpdbgdisasavr.pp svneol=native#text/pascal components/fpdebug/fpdbgdisasx86.pp svneol=native#text/plain components/fpdebug/fpdbgdwarf.pas svneol=native#text/pascal components/fpdebug/fpdbgdwarfconst.pas svneol=native#text/pascal @@ -1431,6 +1433,7 @@ components/fpdebug/fpdbglinuxclasses.pas svneol=native#text/plain components/fpdebug/fpdbglinuxextra.pas svneol=native#text/plain components/fpdebug/fpdbgloader.pp svneol=native#text/pascal components/fpdebug/fpdbgpetypes.pp svneol=native#text/pascal +components/fpdebug/fpdbgrsp.pas svneol=native#text/pascal components/fpdebug/fpdbgsymbols.pas svneol=native#text/pascal components/fpdebug/fpdbgsymtable.pas svneol=native#text/plain components/fpdebug/fpdbgsymtablecontext.pas svneol=native#text/plain diff --git a/components/fpdebug/fpdbgavrclasses.pas b/components/fpdebug/fpdbgavrclasses.pas new file mode 100644 index 0000000000..1ad88cd8e5 --- /dev/null +++ b/components/fpdebug/fpdbgavrclasses.pas @@ -0,0 +1,954 @@ +unit FpDbgAvrClasses; + +// Connects to gdbserver instance and communicate over gdb's remote serial protocol (RSP) +// in principle possible to connect over any serial text capabile interface such as +// tcp/ip, RS-232, pipes etc. +// Support only tcp/ip connection for now. + +{$mode objfpc}{$H+} +{$packrecords c} +{$modeswitch advancedrecords} + +interface + +uses + Classes, + SysUtils, + FpDbgClasses, + FpDbgLoader, + DbgIntfBaseTypes, DbgIntfDebuggerBase, + LazLoggerBase, Maps, + FpDbgRsp, FpDbgCommon; + +const + // RSP commands + Rsp_Status = '?'; // Request break reason - returns either S or T + lastCPURegIndex = 31; // After this are SREG, SP and PC + SREGindex = 32; + SPindex = 33; + PCindex = 34; + RegArrayLength = 35; + + // Byte level register indexes + SPLindex = 33; + SPHindex = 34; + PC0 = 35; + PC1 = 36; + PC2 = 37; + PC3 = 38; + RegArrayByteLength = 39; + +type + { TDbgAvrThread } + + TDbgAvrThread = class(TDbgThread) + private + FRegs: TInitializedRegisters; + FRegsUpdated: boolean; // regs read from target + FRegsChanged: boolean; // write regs to target + FExceptionSignal: integer; + FIsPaused, FInternalPauseRequested, FIsInInternalPause: boolean; + FIsSteppingBreakPoint: boolean; + FDidResetInstructionPointer: Boolean; + FHasThreadState: boolean; + function ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean; + function WriteDebugReg(ind: byte; AVal: PtrUInt): boolean; + + // Cache registers if reported in event + // Only cache if all reqisters are reported + // if not, request registers from target + procedure FUpdateStatusFromEvent(event: TStatusEvent); + procedure InvalidateRegisters; + protected + function ReadThreadState: boolean; + + function RequestInternalPause: Boolean; + function CheckSignalForPostponing(AWaitedStatus: integer): Boolean; + procedure ResetPauseStates; + public + constructor Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle); override; + function ResetInstructionPointerAfterBreakpoint: boolean; override; + procedure ApplyWatchPoints(AWatchPointData: TFpWatchPointData); override; + function DetectHardwareWatchpoint: Pointer; override; + procedure BeforeContinue; override; + procedure LoadRegisterValues; override; + + function GetInstructionPointerRegisterValue: TDbgPtr; override; + function GetStackBasePointerRegisterValue: TDbgPtr; override; + function GetStackPointerRegisterValue: TDbgPtr; override; + end; + + { TDbgAvrProcess } + + TDbgAvrProcess = class(TDbgProcess) + private + FStatus: integer; + FProcessStarted: boolean; + FIsTerminating: boolean; + // RSP communication + FConnection: TRspConnection; + + procedure OnForkEvent(Sender : TObject); + protected + procedure InitializeLoaders; override; + function CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread; override; + function AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; override; + function CreateWatchPointData: TFpWatchPointData; override; + public + // TODO: Optional download to target as parameter DownloadExecutable=true + //class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; + // AWorkingDirectory, AConsoleTty: string; AFlags: TStartInstanceFlags): TDbgProcess; override; + + class function StartInstance(AFileName: string; AParams, AnEnvironment: TStrings; + AWorkingDirectory, AConsoleTty: string; AFlags: TStartInstanceFlags; + AnOsClasses: TOSDbgClasses): TDbgProcess; override; + + // Not supported, returns false + //class function AttachToInstance(AFileName: string; APid: Integer + // ): TDbgProcess; override; + class function AttachToInstance(AFileName: string; APid: Integer; AnOsClasses: TOSDbgClasses): TDbgProcess; override; + + class function isSupported(target: TTargetDescriptor): boolean; override; + + constructor Create(const AFileName: string; const AProcessID, AThreadID: Integer; AnOsClasses: TOSDbgClasses); override; + destructor Destroy; override; + + // FOR AVR target AAddress could be program or data (SRAM) memory (or EEPROM) + // Gnu tools masks data memory with $800000 + function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean; override; + function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean; override; + + 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; + // Wait for -S or -T response from target, or if connection to target is lost + function WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean; override; + + // Insert/Delete break points on target + // TODO: if target doesn't support break points or have limited break points + // then debugger needs to manage insertion/deletion of break points in target memory + function InsertBreakInstructionCode(const ALocation: TDBGPtr; out OrigValue: Byte): Boolean; override; + function RemoveBreakInstructionCode(const ALocation: TDBGPtr; const OrigValue: Byte): Boolean; override; + end; + + // Lets stick with points 4 for now + + { TFpRspWatchPointData } + + TRspBreakWatchPoint = record + Owner: Pointer; + Address: TDBGPtr; + Kind: TDBGWatchPointKind; + end; + + TFpRspWatchPointData = class(TFpWatchPointData) + private + FData: array of TRspBreakWatchPoint; + function FBreakWatchPoint(AnIndex: Integer): TRspBreakWatchPoint; + function FCount: integer; + public + function AddOwnedWatchpoint(AnOwner: Pointer; AnAddr: TDBGPtr; ASize: Cardinal; AReadWrite: TDBGWatchPointKind): boolean; override; + function RemoveOwnedWatchpoint(AnOwner: Pointer): boolean; override; + property Data[AnIndex: Integer]: TRspBreakWatchPoint read FBreakWatchPoint; + property Count: integer read FCount; + end; + +var + // Difficult to see how this can be encapsulated except if + // added methods are introduced that needs to be called after .Create + HostName: string = 'localhost'; + Port: integer = 12345; + +implementation + +uses + FpDbgDisasAvr; + +var + DBG_VERBOSE, DBG_WARNINGS: PLazLoggerLogGroup; + +{ TFpRspWatchPointData } + +function TFpRspWatchPointData.FBreakWatchPoint(AnIndex: Integer + ): TRspBreakWatchPoint; +begin + if AnIndex < length(FData) then + result := FData[AnIndex]; +end; + +function TFpRspWatchPointData.FCount: integer; +begin + result := length(FData); +end; + +function TFpRspWatchPointData.AddOwnedWatchpoint(AnOwner: Pointer; + AnAddr: TDBGPtr; ASize: Cardinal; AReadWrite: TDBGWatchPointKind): boolean; +var + idx: integer; +begin + Result := false; + idx := length(FData); + SetLength(FData, idx+1); + FData[idx].Address := AnAddr; + FData[idx].Kind := AReadWrite; + FData[idx].Owner := AnOwner; + Changed := true; + Result := true; +end; + +function TFpRspWatchPointData.RemoveOwnedWatchpoint(AnOwner: Pointer): boolean; +var + i, j: integer; +begin + Result := False; + i := 0; + while (i < length(FData)) and (FData[i].Owner <> AnOwner) do + inc(i); + + if i < length(FData) then begin + for j := i+1 to length(FData)-1 do begin + FData[j-1] := FData[j]; + Changed := True; + Result := True; + end; + + SetLength(FData, length(FData)-1); + Changed := True; + Result := True; + end; +end; + +{ TDbgAvrThread } + +procedure TDbgAvrProcess.OnForkEvent(Sender: TObject); +begin +end; + +function TDbgAvrThread.ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean; +begin + if TDbgAvrProcess(Process).FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspThread.GetDebugReg called while FIsTerminating is set.'); + Result := false; + end + else + begin + DebugLn(DBG_VERBOSE, ['TDbgRspThread.GetDebugReg requesting register: ',ind]); + if FRegs[ind].Initialized then + begin + AVal := FRegs[ind].Value; + result := true; + end + else + begin + result := TDbgAvrProcess(Process).FConnection.ReadDebugReg(ind, AVal); + FRegs[ind].Value := AVal; + FRegs[ind].Initialized := true; + end; + end; +end; + +function TDbgAvrThread.WriteDebugReg(ind: byte; AVal: PtrUInt): boolean; +begin + if TDbgAvrProcess(Process).FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspThread.WriteDebugReg called while FIsTerminating is set.'); + Result := false; + end + else + result := TDbgAvrProcess(Process).FConnection.WriteDebugReg(ind, AVal); +end; + +procedure TDbgAvrThread.FUpdateStatusFromEvent(event: TStatusEvent); +var + i: integer; +begin + for i := 0 to high(FRegs) do + begin + FRegs[i].Initialized := event.registers[i].Initialized; + if event.registers[i].Initialized then + FRegs[i].Value := event.registers[i].Value; + end; +end; + +procedure TDbgAvrThread.InvalidateRegisters; +var + i: integer; +begin + for i := 0 to high(FRegs) do + FRegs[i].Initialized := false; +end; + +function TDbgAvrThread.ReadThreadState: boolean; +begin + assert(FIsPaused, 'TDbgRspThread.ReadThreadState: FIsPaused'); + result := true; + if FHasThreadState then + exit; + FRegisterValueListValid := false; +end; + +function TDbgAvrThread.RequestInternalPause: Boolean; +begin + if TDbgAvrProcess(Process).FIsTerminating then + DebugLn(DBG_WARNINGS, 'TDbgRspThread.RequestInternalPause called while FIsTerminating is set.'); + + Result := False; + if FInternalPauseRequested or FIsPaused then + exit; + + DebugLn(DBG_VERBOSE, 'TDbgRspThread.RequestInternalPause requesting Ctrl-C.'); + + FInternalPauseRequested := true; + // Send SIGSTOP/break + TDbgAvrProcess(Process).FConnection.Break(); +end; + +function TDbgAvrThread.CheckSignalForPostponing(AWaitedStatus: integer): Boolean; +begin + Assert(not FIsPaused, 'Got WaitStatus while already paused'); + assert(FExceptionSignal = 0, 'TDbgLinuxThread.CheckSignalForPostponing: FExceptionSignal = 0'); + Result := FIsPaused; + DebugLn(DBG_VERBOSE and (Result), ['Warning: Thread already paused', ID]); + + DebugLn(DBG_VERBOSE, ['TDbgRspThread.CheckSignalForPostponing called with ', AWaitedStatus]); + + if Result then + exit; + + FIsPaused := True; + FIsInInternalPause := False; +end; + +procedure TDbgAvrThread.ResetPauseStates; +begin + FIsInInternalPause := False; + FIsPaused := False; + FExceptionSignal := 0; + FHasThreadState := False; + FDidResetInstructionPointer := False; +end; + +constructor TDbgAvrThread.Create(const AProcess: TDbgProcess; + const AID: Integer; const AHandle: THandle); +begin + inherited; + SetLength(FRegs, RegArrayLength); +end; + +function TDbgAvrThread.ResetInstructionPointerAfterBreakpoint: boolean; +begin + if not ReadThreadState then + exit(False); + result := true; + if FDidResetInstructionPointer then + exit; + FDidResetInstructionPointer := True; + + // This is not required for gdbserver + // since remote stub should ensure PC points to break address + //Dec(FRegs.cpuRegs[PCindex]); + //FRegsChanged:=true; +end; + +procedure TDbgAvrThread.ApplyWatchPoints(AWatchPointData: TFpWatchPointData); +var + i: integer; + r: boolean; + addr: PtrUInt; +begin + // Skip this for now... + exit; + + // TODO: Derive a custom class from TFpWatchPointData to manage + // break/watchpoints and communicate over rsp + r := True; + for i := 0 to TFpRspWatchPointData(AWatchPointData).Count-1 do begin // TODO: make size dynamic + addr := PtrUInt(TFpRspWatchPointData(AWatchPointData).Data[i].Address); + + r := r and WriteDebugReg(i, addr); + end; +end; + +function TDbgAvrThread.DetectHardwareWatchpoint: Pointer; +begin + result := nil; +end; + +procedure TDbgAvrThread.BeforeContinue; +var + regs: TBytes; +begin + if not FIsPaused then + exit; + + inherited; + InvalidateRegisters; + + // TODO: currently nothing changes registers locally? + + // Update registers if changed locally + //if FRegsChanged then + //begin + // SetLength(regs, RegArrayByteLength); + // for i := 0 to lastCPURegIndex do + // regs[i] := + // FRegsChanged:=false; + //end; +end; + +procedure TDbgAvrThread.LoadRegisterValues; +var + i: integer; + regs: TBytes; +begin + if TDbgAvrProcess(Process).FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspThread.LoadRegisterValues called while FIsTerminating is set.'); + exit; + end; + + if not ReadThreadState then + exit; + + if not FRegsUpdated then + begin + SetLength(regs, RegArrayByteLength); + FRegsUpdated := TDbgAvrProcess(Process).FConnection.ReadRegisters(regs[0], length(regs)); + // repack according to target endianness + FRegs[SPindex].Value := regs[SPLindex] + (regs[SPHindex] shl 8); + FRegs[SPHindex].Initialized := true; + FRegs[PCindex].Value := regs[PC0] + (regs[PC1] shl 8) + (regs[PC2] shl 16) + (regs[PC3] shl 24); + FRegs[PCindex].Initialized := true; + end; + + if FRegsUpdated then + begin + for i := 0 to lastCPURegIndex do + FRegisterValueList.DbgRegisterAutoCreate['r'+IntToStr(i)].SetValue(FRegs[i].Value, IntToStr(FRegs[i].Value),1, i); // confirm dwarf index + + FRegisterValueList.DbgRegisterAutoCreate['sreg'].SetValue(FRegs[SREGindex].Value, IntToStr(FRegs[SREGindex].Value),1,0); + FRegisterValueList.DbgRegisterAutoCreate['sp'].SetValue(FRegs[SPindex].Value, IntToStr(FRegs[SPindex].Value),2,0); + FRegisterValueList.DbgRegisterAutoCreate['pc'].SetValue(FRegs[PCindex].Value, IntToStr(FRegs[PCindex].Value),4,0); + FRegisterValueListValid := true; + end + else + DebugLn(DBG_WARNINGS, 'Warning: Could not update registers'); +end; + +function TDbgAvrThread.GetInstructionPointerRegisterValue: TDbgPtr; +begin + Result := 0; + if TDbgAvrProcess(Process).FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspThread.GetInstructionPointerRegisterValue called while FIsTerminating is set.'); + exit; + end; + + if not ReadThreadState then + exit; + + DebugLn(DBG_VERBOSE, 'TDbgRspThread.GetInstructionPointerRegisterValue requesting PC.'); + ReadDebugReg(PCindex, result); +end; + +function TDbgAvrThread.GetStackBasePointerRegisterValue: TDbgPtr; +var + lval, hval: QWord; +begin + Result := 0; + if TDbgAvrProcess(Process).FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgAvrThread.GetStackBasePointerRegisterValue called while FIsTerminating is set.'); + exit; + end; + + if not ReadThreadState then + exit; + + DebugLn(DBG_VERBOSE, 'TDbgAvrThread.GetStackBasePointerRegisterValue requesting base registers.'); + // Y-pointer (r28..r29) + ReadDebugReg(28, lval); + ReadDebugReg(29, hval); + result := byte(lval) + (byte(hval) shl 8); +end; + +function TDbgAvrThread.GetStackPointerRegisterValue: TDbgPtr; +begin + Result := 0; + if TDbgAvrProcess(Process).FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspThread.GetStackPointerRegisterValue called while FIsTerminating is set.'); + exit; + end; + + if not ReadThreadState then + exit; + + DebugLn(DBG_VERBOSE, 'TDbgRspThread.GetStackPointerRegisterValue requesting stack registers.'); + ReadDebugReg(SPindex, result); +end; + +{ TDbgAvrProcess } + +procedure TDbgAvrProcess.InitializeLoaders; +begin + TDbgImageLoader.Create(Name).AddToLoaderList(LoaderList); +end; + +function TDbgAvrProcess.CreateThread(AthreadIdentifier: THandle; out IsMainThread: boolean): TDbgThread; +begin + IsMainThread:=False; + if AthreadIdentifier<>feInvalidHandle then + begin + IsMainThread := AthreadIdentifier=ProcessID; + result := TDbgAvrThread.Create(Self, AthreadIdentifier, AthreadIdentifier) + end + else + result := nil; +end; + +function TDbgAvrProcess.CreateWatchPointData: TFpWatchPointData; +begin + DebugLn(DBG_VERBOSE, 'TDbgRspProcess.CreateWatchPointData called.'); + Result := TFpRspWatchPointData.Create; +end; + +constructor TDbgAvrProcess.Create(const AFileName: string; const AProcessID, + AThreadID: Integer; AnOsClasses: TOSDbgClasses); +begin + inherited Create(AFileName, AProcessID, AThreadID, AnOsClasses); +end; + +destructor TDbgAvrProcess.Destroy; +begin + if Assigned(FConnection) then + FreeAndNil(FConnection); + inherited Destroy; +end; + +class function TDbgAvrProcess.StartInstance(AFileName: string; AParams, + AnEnvironment: TStrings; AWorkingDirectory, AConsoleTty: string; + AFlags: TStartInstanceFlags; AnOsClasses: TOSDbgClasses): TDbgProcess; +var + AnExecutabeFilename: string; + dbg: TDbgAvrProcess; +begin + result := nil; + + AnExecutabeFilename:=ExcludeTrailingPathDelimiter(AFileName); + if DirectoryExists(AnExecutabeFilename) then + begin + DebugLn(DBG_WARNINGS, 'Can not debug %s, because it''s a directory',[AnExecutabeFilename]); + Exit; + end; + + if not FileExists(AFileName) then + begin + DebugLn(DBG_WARNINGS, 'Can not find %s.',[AnExecutabeFilename]); + Exit; + end; + + dbg := TDbgAvrProcess.Create(AFileName, 0, 0, AnOsClasses); + try + dbg.FConnection := TRspConnection.Create(HostName, Port); + dbg.FConnection.RegisterCacheSize := RegArrayLength; + result := dbg; + dbg.FStatus := dbg.FConnection.Init; + dbg := nil; + except + on E: Exception do + begin + if Assigned(dbg) then + dbg.Free; + DebugLn(DBG_WARNINGS, Format('Failed to start remote connection. Errormessage: "%s".', [E.Message])); + end; + end; +end; + +class function TDbgAvrProcess.AttachToInstance(AFileName: string; + APid: Integer; AnOsClasses: TOSDbgClasses): TDbgProcess; +begin + result := nil; +end; + +class function TDbgAvrProcess.isSupported(target: TTargetDescriptor): boolean; +begin + result := (target.OS = osEmbedded) and + (target.machineType = mtAVR8); +end; + +function TDbgAvrProcess.ReadData(const AAdress: TDbgPtr; + const ASize: Cardinal; out AData): Boolean; +begin + if FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspProcess.ReadData called while FIsTerminating is set.'); + Result := false; + exit; + end; + + result := FConnection.ReadData(AAdress, ASize, AData); + MaskBreakpointsInReadData(AAdress, ASize, AData); +end; + +function TDbgAvrProcess.WriteData(const AAdress: TDbgPtr; + const ASize: Cardinal; const AData): Boolean; +begin + if FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspProcess.WriteData called while FIsTerminating is set.'); + Result := false; + exit; + end; + + result := FConnection.WriteData(AAdress,AAdress, AData); +end; + +procedure TDbgAvrProcess.TerminateProcess; +begin + // Try to prevent access to the RSP socket after it has been closed + if not FIsTerminating then + begin + DebugLn(DBG_VERBOSE, 'Removing all break points'); + RemoveAllBreakPoints; + DebugLn(DBG_VERBOSE, 'Sending kill command from TDbgRspProcess.TerminateProcess'); + FConnection.Kill(); + FIsTerminating:=true; + end; +end; + +function TDbgAvrProcess.Pause: boolean; +begin + if FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspProcess.Pause called while FIsTerminating is set.'); + Result := false; + exit; + end; + + // Target should automatically respond with T or S reply after processing the break + result := true; + if not PauseRequested then + begin + FConnection.Break(); + PauseRequested := true; + DebugLn(DBG_VERBOSE, 'TDbgRspProcess.Pause called.'); + end + else + begin + result := true; + DebugLn(DBG_WARNINGS, 'TDbgRspProcess.Pause called while PauseRequested is set.'); + end; +end; + +function TDbgAvrProcess.Detach(AProcess: TDbgProcess; AThread: TDbgThread): boolean; +begin + RemoveAllBreakPoints; + DebugLn(DBG_VERBOSE, 'Sending detach command from TDbgRspProcess.Detach'); + Result := FConnection.Detach(); +end; + +function TDbgAvrProcess.Continue(AProcess: TDbgProcess; AThread: TDbgThread; SingleStep: boolean): boolean; +var + ThreadToContinue: TDbgAvrThread; + PC: word; + s: string; + tempState: integer; + initRegs: TInitializedRegisters; +begin + // Terminating process and all threads + if FIsTerminating then + begin + AThread.BeforeContinue; + TDbgAvrThread(AThread).InvalidateRegisters; + DebugLn(DBG_VERBOSE, 'TDbgRspProcess.Continue called while terminating.'); + + // The kill command should have been issued earlier (if using fpd), calling SendKill again will lead to an exception since the connection should be terminated already. + // FConnection.Kill(); + + TDbgAvrThread(AThread).ResetPauseStates; + if not FThreadMap.HasId(AThread.ID) then + AThread.Free; + exit; + end; + + if TDbgAvrThread(AThread).FIsPaused then // in case of deInternal, it may not be paused and can be ignored + AThread.NextIsSingleStep:=SingleStep; + + // check other threads if they need a singlestep + for TDbgThread(ThreadToContinue) in FThreadMap do + if (ThreadToContinue <> AThread) and ThreadToContinue.FIsPaused then + begin + PC := ThreadToContinue.GetInstructionPointerRegisterValue; + if HasInsertedBreakInstructionAtLocation(PC) then + begin + TempRemoveBreakInstructionCode(PC); + ThreadToContinue.BeforeContinue; + + while (ThreadToContinue.GetInstructionPointerRegisterValue = PC) do + begin + result := FConnection.SingleStep(); + TDbgAvrThread(ThreadToContinue).ResetPauseStates; // So BeforeContinue will not run again + ThreadToContinue.FIsPaused := True; + if result then + begin + tempState := FConnection.WaitForSignal(s, initRegs); // TODO: Update registers cache for this thread + if (tempState = SIGTRAP) then + break; // if the command jumps back an itself.... + end + else + begin + DebugLn(DBG_WARNINGS, ['Error single stepping other thread ', ThreadToContinue.ID]); + break; + end; + end; + end; + end; + + if TDbgAvrThread(AThread).FIsPaused then // in case of deInternal, it may not be paused and can be ignored + if HasInsertedBreakInstructionAtLocation(AThread.GetInstructionPointerRegisterValue) then + begin + TempRemoveBreakInstructionCode(AThread.GetInstructionPointerRegisterValue); + TDbgAvrThread(AThread).FIsSteppingBreakPoint := True; + AThread.BeforeContinue; + result := FConnection.SingleStep(); // TODO: pass thread ID once it is supported in FConnection - also signals not yet passed through + TDbgAvrThread(AThread).ResetPauseStates; + FStatus := 0; // need to call WaitForSignal to read state after single step + exit; + end; + + RestoreTempBreakInstructionCodes; + + ThreadsBeforeContinue; + + // start all other threads + for TDbgThread(ThreadToContinue) in FThreadMap do + begin + if (ThreadToContinue <> AThread) and (ThreadToContinue.FIsPaused) then + begin + FConnection.Continue(); + ThreadToContinue.ResetPauseStates; + end; + end; + + if TDbgAvrThread(AThread).FIsPaused then // in case of deInternal, it may not be paused and can be ignored + if not FIsTerminating then + begin + AThread.BeforeContinue; + if SingleStep then + result := FConnection.SingleStep() + else + result := FConnection.Continue(); + TDbgAvrThread(AThread).ResetPauseStates; + FStatus := 0; // should update status by calling WaitForSignal + end; + + if not FThreadMap.HasId(AThread.ID) then + AThread.Free; +end; + +function TDbgAvrProcess.WaitForDebugEvent(out ProcessIdentifier, ThreadIdentifier: THandle): boolean; +var + s: string; + initRegs: TInitializedRegisters; +begin + debugln(DBG_VERBOSE, ['Entering WaitForDebugEvent, FStatus = ', FStatus]); + // Currently only single process/thread + // TODO: Query and handle process/thread states of target + ThreadIdentifier := self.ThreadID; + ProcessIdentifier := Self.ProcessID; + + if FIsTerminating then + begin + DebugLn(DBG_VERBOSE, 'TDbgRspProcess.WaitForDebugEvent called while FIsTerminating is set.'); + FStatus := SIGKILL; + end + else + // Wait for S or T response from target, or if connection to target is lost + if FStatus = 0 then + repeat + try + FStatus := FConnection.WaitForSignal(s, initRegs); // TODO: Update registers cache + except + FStatus := 0; + end; + until FStatus <> 0; // should probably wait at lower level... + + if FStatus <> 0 then + begin + if FStatus in [SIGINT, SIGTRAP] then + begin + RestoreTempBreakInstructionCodes; + end; + end; + + result := true; +end; + +function TDbgAvrProcess.InsertBreakInstructionCode(const ALocation: TDBGPtr; + out OrigValue: Byte): Boolean; +begin + if FIsTerminating then + DebugLn(DBG_WARNINGS, 'TDbgRspProcess.InsertBreakInstruction called while FIsTerminating is set.'); + + result := ReadData(ALocation, SizeOf(OrigValue), OrigValue); + if result then + begin + // HW break... + result := FConnection.SetBreakWatchPoint(ALocation, wkpExec); + if not result then + DebugLn(DBG_WARNINGS, 'Failed to set break point.', []); + end + else + DebugLn(DBG_WARNINGS, 'Failed to read memory.', []); +end; + +function TDbgAvrProcess.RemoveBreakInstructionCode(const ALocation: TDBGPtr; + const OrigValue: Byte): Boolean; +begin + if FIsTerminating then + begin + DebugLn(DBG_WARNINGS, 'TDbgRspProcess.RemoveBreakInstructionCode called while FIsTerminating is set'); + result := false; + end + else + result := FConnection.DeleteBreakWatchPoint(ALocation, wkpExec); +end; + +function TDbgAvrProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent; +var + ThreadToPause: TDbgAvrThread; +begin + debugln(DBG_VERBOSE, ['Entering TDbgRspProcess.AnalyseDebugEvent, FStatus = ', FStatus, ' PauseRequested = ', PauseRequested]); + if FIsTerminating then begin + result := deExitProcess; + exit; + end; + + if AThread = nil then begin // should not happen... / just assume the most likely safe failbacks + result := deInternalContinue; + exit; + end; + + TDbgAvrThread(AThread).FExceptionSignal:=0; + TDbgAvrThread(AThread).FIsPaused := True; + TDbgAvrThread(AThread).FUpdateStatusFromEvent(FConnection.lastStatusEvent); + + if FStatus in [SIGHUP, SIGKILL] then // not sure which signals is relevant here + begin + if AThread.ID=ProcessID then + begin + // Main thread stop -> application exited + SetExitCode(FStatus); + result := deExitProcess + end + else + begin + // Thread stopped, just continue + RemoveThread(AThread.Id); + result := deInternalContinue; + end; + end + else if FStatus <> 0 then + begin + TDbgAvrThread(AThread).ReadThreadState; + + if (not FProcessStarted) and (FStatus <> SIGTRAP) then + begin + // attached, should be SigStop, but may be out of order + debugln(DBG_VERBOSE, ['Attached ', FStatus]); + result := deCreateProcess; + FProcessStarted:=true; + end + else + case FStatus of + SIGTRAP: + begin + if not FProcessStarted then + begin + result := deCreateProcess; + FProcessStarted:=true; + DebugLn(DBG_VERBOSE, ['Creating process - SIGTRAP received for thread: ', AThread.ID]); + end + else if TDbgAvrThread(AThread).FInternalPauseRequested then + begin + DebugLn(DBG_VERBOSE, ['???Received late SigTrap for thread ', AThread.ID]); + result := deBreakpoint;//deInternalContinue; // left over signal + end + else + begin + DebugLn(DBG_VERBOSE, ['Received SigTrap for thread ', AThread.ID, + ' PauseRequest=', PauseRequested]); + if PauseRequested then // Hack to work around Pause problem + result := deFinishedStep + else + result := deBreakpoint; + + if not TDbgAvrThread(AThread).FIsSteppingBreakPoint then + AThread.CheckAndResetInstructionPointerAfterBreakpoint; + end; + end; + SIGINT: + begin + ExceptionClass:='SIGINT'; + TDbgAvrThread(AThread).FExceptionSignal:=SIGINT; + result := deException; + end; + SIGKILL: + begin + if FIsTerminating then + result := deInternalContinue + else + begin + ExceptionClass:='SIGKILL'; + TDbgAvrThread(AThread).FExceptionSignal:=SIGKILL; + result := deException; + end; + end; + SIGSTOP: + begin + // New thread (stopped within the new thread) + result := deInternalContinue; + end + else + begin + ExceptionClass:='Unknown exception code ' + inttostr(FStatus); + TDbgAvrThread(AThread).FExceptionSignal := FStatus; + result := deException; + end; + end; {case} + if result=deException then + ExceptionClass:='External: '+ExceptionClass; + end; + + debugln(DBG_VERBOSE, ['Leaving AnalyseDebugEvent, result = ', result]); + + TDbgAvrThread(AThread).FIsSteppingBreakPoint := False; + + if Result in [deException, deBreakpoint, deFinishedStep] then // deFinishedStep will not be set here + begin + // Signal all other threads to pause + for TDbgThread(ThreadToPause) in FThreadMap do + begin + if (ThreadToPause <> AThread) then + begin + DebugLn(DBG_VERBOSE and (ThreadToPause.FInternalPauseRequested), ['Re-Request Internal pause for ', ThreadToPause.ID]); + ThreadToPause.FInternalPauseRequested:=false; + if not ThreadToPause.RequestInternalPause then // will fail, if already paused + break; + end; + end; + end; +end; + +initialization + DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} ); + DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} ); + RegisterDbgOsClasses(TOSDbgClasses.Create( + TDbgAvrProcess, + TDbgAvrThread, + TAvrDisassembler)); +end. diff --git a/components/fpdebug/fpdbgdisasavr.pp b/components/fpdebug/fpdbgdisasavr.pp new file mode 100644 index 0000000000..3fda5ad438 --- /dev/null +++ b/components/fpdebug/fpdbgdisasavr.pp @@ -0,0 +1,863 @@ +{ $Id$ } +{ + --------------------------------------------------------------------------- + fpdbgdisasavr.pp - Native Freepascal debugger - avr Disassembler + --------------------------------------------------------------------------- + + This unit contains an avr disassembler for the Native Freepascal debugger + + --------------------------------------------------------------------------- + + @created(Mon Oct 18th 2019) + @lastmod($Date$) + @author() + + *************************************************************************** + * * + * This source is free software; you can redistribute it and/or modify * + * it under the terms of the GNU General Public License as published by * + * the Free Software Foundation; either version 2 of the License, or * + * (at your option) any later version. * + * * + * This code is distributed in the hope that it will be useful, but * + * WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * + * General Public License for more details. * + * * + * A copy of the GNU General Public License is available on the World * + * Wide Web at . You can also * + * obtain it by writing to the Free Software Foundation, * + * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. * + * * + *************************************************************************** +} +unit FpDbgDisasAvr; +{$mode objfpc}{$H+} +interface + +uses + SysUtils, + FpDbgUtil, FpDbgInfo, DbgIntfBaseTypes, FpdMemoryTools, LazLoggerBase, + FpDbgClasses; + +type + //The function Disassemble decodes the instruction at the given address. + //Unrecognized instructions are assumed to be data statements [dw XXXX] + + TAvrDisassembler = class; + + { TX86DisassemblerInstruction } + + { TAvrDisassemblerInstruction } + + TAvrDisassemblerInstruction = class(TDbgDisassemblerInstruction) + private const + INSTR_CODEBIN_LEN = 4; + private + FDisassembler: TAvrDisassembler; + FAddress: TDBGPtr; + FCodeBin: array[0..INSTR_CODEBIN_LEN-1] of byte; + FInstrLen: Integer; + FFlags: set of (diCodeRead, diCodeReadError); + protected + procedure ReadCode; inline; + public + constructor Create(ADisassembler: TAvrDisassembler); + procedure SetAddress(AnAddress: TDBGPtr); + function IsCallInstruction: boolean; override; + function IsReturnInstruction: boolean; override; + function IsLeaveStackFrame: boolean; override; + function InstructionLength: Integer; override; + end; + +{ TAvrDisassembler } + + TAvrDisassembler = class(TDbgDisassembler) + private const + MAX_CODEBIN_LEN = 50; + private + FProcess: TDbgProcess; + FLastErrWasMem: Boolean; + FCodeBin: array[0..MAX_CODEBIN_LEN-1] of byte; + FLastInstr: TAvrDisassemblerInstruction; + protected + function GetLastErrorWasMemReadErr: Boolean; override; + function ReadCodeAt(AnAddress: TDBGPtr; var ALen: Cardinal): Boolean; inline; + procedure Disassemble(var AAddress: Pointer; out ACodeBytes: String; out ACode: String); override; + function GetInstructionInfo(AnAddress: TDBGPtr): TDbgDisassemblerInstruction; override; + + // returns byte len of call instruction at AAddress // 0 if not a call intruction + function GetFunctionFrameInfo(AnAddress: TDBGPtr; out + AnIsOutsideFrame: Boolean): Boolean; override; + + constructor Create(AProcess: TDbgProcess); override; + destructor Destroy; + end; + + +implementation + +uses + StrUtils, LazClasses; + +const + opRegReg = '%s r%d, r%d'; + opRegConst = '%s r%d, %d'; + opRegConstHex8 = '%s r%d, $%.2X'; + opRegConstHex16 = '%s r%d, $%.4X'; + opRegConstHex32 = '%s r%d, $%.8X'; + opConstReg = '%s %d, r%d'; + opConstHex8Reg = '%s $%.2X, r%d'; + opConstHex16Reg = '%s $%.4X, r%d'; + opConstHex32Reg = '%s $%.4X, r%d'; + opRegStr = '%s r%d, %s'; + opStrReg = '%s %s, r%d'; + opOnly = '%s'; + opStr = '%s %s'; + opConst = '%s %d'; + opConstHex8 = '%s $%.2X'; + opConstHex16 = '%s $%.4X'; + opConstHex8Const = '%s $%.2X, %d'; + opReg = '%s r%d'; + + statusFlagNames: array[0..7] of char = ('c', 'z', 'n', 'v', 's', 'h', 't', 'i'); + branchIfSetNames: array[0..7] of string = ('brcs', 'breq', 'brmi', 'brvs', 'brlt', 'brhs', 'brts', 'brie'); + branchIfClrNames: array[0..7] of string = ('brcc', 'brne', 'brpl', 'brvc', 'brge', 'brhc', 'brtc', 'brid'); + +var + DBG_WARNINGS: PLazLoggerLogGroup; + +procedure get_r_d_10(o: word; out r, d: byte); +begin + r := ((o shr 5) and $10) or (o and $f); + d := (o shr 4) and $1f; +end; + +procedure get_k_r16(o: word; out r, k: byte); +begin + r := 16 + ((o shr 4) and $f); + k := byte((o and $0f00) shr 4) or (o and $f); +end; + +// If non-valid opcode, assume it is a data statement +function InvalidOpCode(instr: word): string; +begin + result := format(opConstHex16, ['dw', instr]); +end; + +{ TAvrDisassemblerInstruction } + +procedure TAvrDisassemblerInstruction.ReadCode; +begin + if not (diCodeRead in FFlags) then begin + if not FDisassembler.FProcess.ReadData(FAddress, INSTR_CODEBIN_LEN, FCodeBin) then + Include(FFlags, diCodeReadError); + Include(FFlags, diCodeRead); + end; +end; + +constructor TAvrDisassemblerInstruction.Create(ADisassembler: TAvrDisassembler); +begin + FDisassembler := ADisassembler; + inherited Create; + AddReference; +end; + +procedure TAvrDisassemblerInstruction.SetAddress(AnAddress: TDBGPtr); +begin + FAddress := AnAddress; + FFlags := []; +end; + +function TAvrDisassemblerInstruction.IsCallInstruction: boolean; +var + LoByte, HiByte: byte; +begin + Result := False; + ReadCode; + LoByte := FCodeBin[0]; + HiByte := FCodeBin[1]; + if ((HiByte and $FE) = $94) and ((LoByte and $0E) = $0E) or // call + ((HiByte = $95) and (LoByte in [$09, $19])) or // icall / eicall + ((HiByte and $D0) = $D0) then // rcall + Result := true; +end; + +function TAvrDisassemblerInstruction.IsReturnInstruction: boolean; +var + LoByte, HiByte: byte; +begin + Result := False; + ReadCode; + LoByte := FCodeBin[0]; + HiByte := FCodeBin[1]; + if ((HiByte = $95) and (LoByte in [$08, $18])) then // ret / reti + Result := true; +end; + +function TAvrDisassemblerInstruction.IsLeaveStackFrame: boolean; +begin + Result := false; +end; + +function TAvrDisassemblerInstruction.InstructionLength: Integer; +var + LoByte, HiByte: byte; +begin + Result := 2; + ReadCode; + LoByte := FCodeBin[0]; + HiByte := FCodeBin[1]; + if ((HiByte and $FE) = $94) and ((LoByte and $0E) in [$0C, $0E]) or // jmp / call + ((HiByte and $FE) in [$90, $92]) and ((LoByte and $0F) = $0) then // lds / sts + Result := 4; +end; + +function TAvrDisassembler.GetLastErrorWasMemReadErr: Boolean; +begin + Result := FLastErrWasMem; +end; + +function TAvrDisassembler.ReadCodeAt(AnAddress: TDBGPtr; var ALen: Cardinal + ): Boolean; +begin + FLastErrWasMem := not FProcess.ReadData(AnAddress, ALen, FCodeBin[0], ALen); + Result := FLastErrWasMem; +end; + +procedure TAvrDisassembler.Disassemble(var AAddress: Pointer; out + ACodeBytes: String; out ACode: String); +var + CodeIdx, r, d, k, q: byte; + a: SmallInt; + pcode: PByte; + code, addr16: word; + s1: string; + _set: boolean; +begin + pcode := AAddress; + CodeIdx := 0; + code := pcode[CodeIdx]; + inc(CodeIdx); + code := code or (pcode[CodeIdx] shl 8); + inc(CodeIdx); + + case (code and $f000) of + $0000: + begin + case (code) of + $0000: ACode := 'nop'; + else + begin + case (code and $fc00) of + $0400: + begin // CPC compare with carry 0000 01rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['cpc', d, r]); + end; + $0c00: + begin // ADD without carry 0000 11 rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['add', d, r]); + end; + $0800: + begin // SBC subtract with carry 0000 10rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['sbc', d, r]); + end; + else + case (code and $ff00) of + $0100: + begin // MOVW – Copy Register Word 0000 0001 dddd rrrr + d := ((code shr 4) and $f) shl 1; + r := ((code) and $f) shl 1; + ACode := format(opRegReg, ['movw', d, r]); + end; + $0200: + begin // MULS – Multiply Signed 0000 0010 dddd rrrr + r := 16 + (code and $f); + d := 16 + ((code shr 4) and $f); + ACode := format(opRegReg, ['muls', d, r]); + end; + $0300: + begin // MUL Multiply 0000 0011 fddd frrr + r := 16 + (code and $7); + d := 16 + ((code shr 4) and $7); + case (code and $88) of + $00: ACode := format(opRegReg, ['mulsu', d, r]); + $08: ACode := format(opRegReg, ['fmul', d, r]); + $80: ACode := format(opRegReg, ['fmuls', d, r]); + $88: ACode := format(opRegReg, ['fmulsu', d, r]); + end; + end; + else + ACode := InvalidOpCode(code); + end; + end; + end; + end; + end; + $1000: + begin + case (code and $fc00) of + $1800: + begin // SUB without carry 0000 10 rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['sub', d, r]); + end; + $1000: + begin // CPSE Compare, skip if equal 0000 00 rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['cpse', d, r]); + end; + $1400: + begin // CP Compare 0000 01 rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['cp', d, r]); + end; + $1c00: + begin // ADD with carry 0001 11 rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['adc', d, r]); + end; + else + ACode := InvalidOpCode(code); + end; + end; + $2000: + begin + case (code and $fc00) of + $2000: + begin // AND 0010 00rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['and', d, r]); + end; + $2400: + begin // EOR 0010 01rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['eor', d, r]); + end; + $2800: + begin // OR Logical OR 0010 10rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['or', d, r]); + end; + $2c00: + begin // MOV 0010 11rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['mov', d, r]); + end; + else + ACode := InvalidOpCode(code); + end; + end; + $3000: + begin // CPI 0011 KKKK rrrr KKKK + get_k_r16(code, d, k); + ACode := format(opRegConstHex8, ['cpi', d, k]); + end; + $4000: + begin // SBCI Subtract Immediate With Carry 0101 10 kkkk dddd kkkk + get_k_r16(code, d, k); + ACode := format(opRegConstHex8, ['sbci', d, k]); + end; + $5000: + begin // SUB Subtract Immediate 0101 10 kkkk dddd kkkk + get_k_r16(code, d, k); + ACode := format(opRegConstHex8, ['subi', d, k]); + end; + $6000: + begin // ORI aka SBR Logical AND with Immediate 0110 kkkk dddd kkkk + get_k_r16(code, d, k); + ACode := format(opRegConstHex8, ['ori', d, k]); + end; + $7000: + begin // ANDI Logical AND with Immediate 0111 kkkk dddd kkkk + get_k_r16(code, d, k); + ACode := format(opRegConstHex8, ['andi', d, k]); + end; + $a000, + $8000: + begin + case (code and $d008) of + $a000, + $8000: + begin // LD (LDD) – Load Indirect using Z 10q0 qq0r rrrr 0qqq + d := (code shr 4) and $1f; + q := ((code and $2000) shr 8) or ((code and $0c00) shr 7) or (code and $7); + if (code and $0200) <> 0 then // store + begin + if q > 0 then + ACode := format(opStrReg, ['std', 'Z+'+IntToStr(q), d]) + else + begin + case (code and 3) of + 0: s1 := 'Z'; + 1: s1 := 'Z+'; + 3: s1 := '-Z'; + end; + ACode := format(opStrReg, ['st', s1, d]); + end; + end + else // load + begin + if q > 0 then + ACode := format(opRegStr, ['ldd', d, 'Z+'+IntToStr(q)]) + else + begin + case (code and 3) of + 0: s1 := 'Z'; + 1: s1 := 'Z+'; + 3: s1 := '-Z'; + end; + ACode := format(opRegStr, ['ld', d, s1]); + end; + end; + end; + $a008, + $8008: + begin // LD (LDD) – Load Indirect using Y 10q0 qq0r rrrr 1qqq + d := (code shr 4) and $1f; + q := ((code and $2000) shr 8) or ((code and $0c00) shr 7) or (code and $7); + if (code and $0200) <> 0 then // store + begin + if q > 0 then + ACode := format(opStrReg, ['std', 'Y+'+IntToStr(q), d]) + else + begin + case (code and 3) of + 0: s1 := 'Y'; + 1: s1 := 'Y+'; + 3: s1 := '-Y'; + end; + ACode := format(opStrReg, ['st', s1, d]); + end; + end + else // load + begin + if q > 0 then + ACode := format(opRegStr, ['ldd', d, 'Y+'+IntToStr(q)]) + else + begin + case (code and 3) of + 0: s1 := 'Y'; + 1: s1 := 'Y+'; + 3: s1 := '-Y'; + end; + ACode := format(opRegStr, ['ld', d, s1]); + end; + end; + end; + else + ACode := InvalidOpCode(code); + end; + end; + $9000: + begin + if ((code and $ff0f) = $9408) then // clear/set SREG flags + begin + k := (code shr 4) and 7; + if ((code and $0080) = 0) then + s1 := 'se' + else + s1 := 'cl'; + ACode := format(opOnly, [s1 + statusFlagNames[k]]); + end + else + case (code) of + $9409: ACode := format(opOnly, ['ijmp']); + $9419: ACode := format(opOnly, ['eijmp']); + $9508: ACode := format(opOnly, ['ret']); + $9509: ACode := format(opOnly, ['icall']); + $9519: ACode := format(opOnly, ['eicall']); + $9518: ACode := format(opOnly, ['reti']); + $9588: ACode := format(opOnly, ['sleep']); + $9598: ACode := format(opOnly, ['break']); + $95a8: ACode := format(opOnly, ['wdr']); + $95c8: ACode := format(opOnly, ['lpm']); + $95d8: ACode := format(opOnly, ['elpm']); + $95e8: ACode := format(opOnly, ['spm']); + $95f8: ACode := format(opStr, ['spm', 'Z+']); + + $9408, $9418, $9428, $9438, $9448, $9458, $9468, + $9478: + begin // BSET 1001 0100 0ddd 1000 + d := (code shr 4) and 7; + ACode := format(opConst, ['bset', d]); + end; + $9488, $9498, $94a8, $94b8, $94c8, $94d8, $94e8, + $94f8: // bit 7 is 'clear vs set' + begin // BCLR 1001 0100 1ddd 1000 + d := (code shr 4) and 7; + ACode := format(opConst, ['bclr', d]); + end; + else + begin + case (code and $fe0f) of + $9000: + begin // LDS Load Direct from fData Space, 32 bits + r := (code shr 4) and $1f; + addr16 := pcode[CodeIdx]; + inc(CodeIdx); + addr16 := addr16 or (pcode[CodeIdx] shl 8); + inc(CodeIdx); + ACode := format(opRegConstHex16, ['lds', r, addr16]); + end; + $9005, + $9004: + begin // LPM Load Program Memory 1001 000d dddd 01oo + r := (code shr 4) and $1f; + if (code and 1 = 1) then + s1 := 'Z+' + else + s1 := 'Z'; + ACode := format(opRegStr, ['lpm', r, s1]); + end; + $9006, + $9007: + begin // ELPM Extended Load Program Memory 1001 000d dddd 01oo + r := (code shr 4) and $1f; + if (code and 1 = 1) then + s1 := 'Z+' + else + s1 := 'Z'; + ACode := format(opRegStr, ['elpm', r, s1]); + end; + $900c, + $900d, + $900e: + begin // LD Load Indirect from fData using X 1001 000r rrrr 11oo + r := (code shr 4) and $1f; + if (code and 3 = 1) then + s1 := 'X+' + else if (code and 3 = 2) then + s1 := '-X' + else + s1 := 'X'; + ACode := format(opRegStr, ['ld', r, s1]); + end; + $920c, + $920d, + $920e: + begin // ST Store Indirect fData Space X 1001 001r rrrr 11oo + r := (code shr 4) and $1f; + if (code and 3 = 1) then + s1 := 'X+' + else if (code and 3 = 2) then + s1 := '-X' + else + s1 := 'X'; + ACode := format(opStrReg, ['st', s1, r]); + end; + $9009, + $900a: + begin // LD Load Indirect from fData using Y 1001 000r rrrr 10oo + r := (code shr 4) and $1f; + if (code and 3 = 1) then + s1 := 'Y+' + else if (code and 3 = 2) then + s1 := '-Y'; + ACode := format(opRegStr, ['ld', r, s1]); + end; + $9209, + $920a: + begin // ST Store Indirect fData Space Y 1001 001r rrrr 10oo + r := (code shr 4) and $1f; + if (code and 3 = 1) then + s1 := 'Y+' + else if (code and 3 = 2) then + s1 := '-Y'; + ACode := format(opStrReg, ['st', s1, r]); + end; + $9200: + begin // STS Store Direct to Data Space, 32 bits + r := (code shr 4) and $1f; + addr16 := pcode[CodeIdx]; + inc(CodeIdx); + addr16 := addr16 or (pcode[CodeIdx] shl 8); + inc(CodeIdx); + ACode := format(opConstHex16Reg, ['sts', addr16, r]); + end; + $9001, + $9002: + begin // LD Load Indirect from Data using Z 1001 001r rrrr 00oo + r := (code shr 4) and $1f; + if (code and 3 = 1) then + s1 := 'Z+' + else + s1 := '-Z'; + ACode := format(opRegStr, ['ld', r, s1]); + end; + $9201, + $9202: + begin // ST Store Indirect Data Space Z 1001 001r rrrr 0Xoo X=0 or XMega instructions X=1 + r := (code shr 4) and $1f; + if (code and 4) = 0 then // normal AVR8 instruction + begin + if (code and 3 = 1) then + s1 := 'Z+' + else + s1 := '-Z'; + ACode := format(opStrReg, ['st', s1, r]); + end + else + begin // AVR8X instructions + case (code and 3) of + 0: s1 := 'xch'; + 1: s1 := 'las'; + 2: s1 := 'lac'; + 3: s1 := 'lat'; + end; + ACode := format(opStrReg, [s1, 'Z', r]); + end; + end; + $900f: + begin // POP 1001 000d dddd 1111 + r := (code shr 4) and $1f; + ACode := format(opReg, ['pop', r]); + end; + $920f: + begin // PUSH 1001 001d dddd 1111 + r := (code shr 4) and $1f; + ACode := format(opReg, ['push', r]); + end; + $9400: + begin // COM – One’s Complement + r := (code shr 4) and $1f; + ACode := format(opReg, ['com', r]); + end; + $9401: + begin // NEG – Two’s Complement + r := (code shr 4) and $1f; + ACode := format(opReg, ['neg', r]); + end; + $9402: + begin // SWAP – Swap Nibbles + r := (code shr 4) and $1f; + ACode := format(opReg, ['swap', r]); + end; + $9403: + begin // INC – Increment + r := (code shr 4) and $1f; + ACode := format(opReg, ['inc', r]); + end; + $9405: + begin // ASR – Arithmetic Shift Right 1001 010d dddd 0101 + r := (code shr 4) and $1f; + ACode := format(opReg, ['asr', r]); + end; + $9406: + begin // LSR 1001 010d dddd 0110 + r := (code shr 4) and $1f; + ACode := format(opReg, ['lsr', r]); + end; + $9407: + begin // ROR 1001 010d dddd 0111 + r := (code shr 4) and $1f; + ACode := format(opReg, ['ror', r]); + end; + $940a: + begin // DEC – Decrement + r := (code shr 4) and $1f; + ACode := format(opReg, ['dec', r]); + end; + $940c, + $940d: + begin // JMP Long Call to sub, 32 bits + k := ((code and $01f0) shr 3) or (code and 1); + addr16 := pcode[CodeIdx]; + inc(CodeIdx); + addr16 := addr16 or (pcode[CodeIdx] shl 8); + inc(CodeIdx); + ACode := format(opConstHex8, ['jmp', (dword(k shl 16) or dword(addr16)) shl 1]); + end; + $940e, + $940f: + begin // CALL Long Call to sub, 32 bits + k := ((code and $01f0) shr 3) or (code and 1); + addr16 := pcode[CodeIdx]; + inc(CodeIdx); + addr16 := addr16 or (pcode[CodeIdx] shl 8); + inc(CodeIdx); + ACode := format(opConstHex8, ['call', (dword(k shl 16) or dword(addr16)) shl 1]); + end; + else + begin + case (code and $ff00) of + $9600: + begin // ADIW - Add Immediate to Word 1001 0110 KKdd KKKK + r := 24 + ((code shr 3) and $6); + k := ((code and $00c0) shr 2) or (code and $f); + ACode := format(opRegConstHex8, ['adiw', r, k]); + end; + $9700: + begin // SBIW - Subtract Immediate from Word 1001 0110 KKdd KKKK + r := 24 + ((code shr 3) and $6); + k := ((code and $00c0) shr 2) or (code and $f); + ACode := format(opRegConstHex8, ['sbiw', r, k]); + end; + $9800: + begin // CBI - Clear Bit in I/O Register 1001 1000 AAAA Abbb + d := (code shr 3) and $1f; + k := code and $7; + ACode := format(opConstHex8Const, ['cbi', d, k]); + end; + $9900: + begin // SBIC - Skip if Bit in I/O Register is Cleared 1001 0111 AAAA Abbb + d := (code shr 3) and $1f; + k := code and $7; + ACode := format(opConstHex8Const, ['sbic', d, k]); + end; + $9a00: + begin // SBI - Set Bit in I/O Register 1001 1000 AAAA Abbb + d := (code shr 3) and $1f; + k := code and $7; + ACode := format(opConstHex8Const, ['sbi', d, k]); + end; + $9b00: + begin // SBIS - Skip if Bit in I/O Register is Set 1001 1011 AAAA Abbb + d := (code shr 3) and $1f; + k := code and $7; + ACode := format(opConstHex8Const, ['sbis', d, k]); + end; + else + case (code and $fc00) of + $9c00: + begin // MUL - Multiply Unsigned 1001 11rd dddd rrrr + get_r_d_10(code, r, d); + ACode := format(opRegReg, ['mul', d, r]); + end; + else + ACode := InvalidOpCode(code); + end; + end; + end; + end; + end; + end; + end; + $b000: + begin + case (code and $f800) of + $b800: + begin // OUT A,Rr 1011 1AAr rrrr AAAA + r := (code shr 4) and $1f; + d := ((((code shr 9) and 3) shl 4) or ((code) and $f)); + ACode := format(opConstHex8Reg, ['out', d, r]); + end; + $b000: + begin // IN Rd,A 1011 0AAr rrrr AAAA + r := (code shr 4) and $1f; + d := ((((code shr 9) and 3) shl 4) or ((code) and $f)); + ACode := format(opRegConstHex8, ['in', r, d]); + end; + else + ACode := InvalidOpCode(code); + end; + end; + $c000: + begin // RJMP 1100 kkkk kkkk kkkk + a := smallint((word(code) shl 4) and $ffff) div 16; + ACode := format(opStr, ['rjmp', '.'+IntToStr(a shl 1)]); + end; + $d000: + begin // RCALL 1100 kkkk kkkk kkkk + a := smallint((word(code) shl 4) and $ffff) div 16; + ACode := format(opStr, ['rcall', '.'+IntToStr(a shl 1)]); + end; + $e000: + begin // LDI Rd, K 1110 KKKK RRRR KKKK -- aka SER (LDI r, $ff) + d := 16 + ((code shr 4) and $f); + k := ((code and $0f00) shr 4) or (code and $f); + ACode := format(opRegConstHex8, ['ldi', d, k]); + end; + $f000: + begin + case (code and $fe00) of + $f000, + $f200, + $f400, + $f600: + begin // All the fSREG branches + a := smallint(smallint(code shl 6) shr 9) * 2; // offset + k := code and 7; + _set := (code and $0400) = 0; // this bit means BRXC otherwise BRXS + if (_set) then + ACode := format(opStr, [branchIfSetNames[k], '.'+IntToStr(a)]) + else + ACode := format(opStr, [branchIfClrNames[k], '.'+IntToStr(a)]); + end; + $f800, + $f900: + begin // BLD – Bit Load from T into a Bit in Register 1111 100r rrrr 0bbb + d := (code shr 4) and $1f; // register index + k := code and 7; + ACode := format(opRegConst, ['bld', d, k]); + end; + $fa00, + $fb00: + begin // BST – Bit Store into T from bit in Register 1111 100r rrrr 0bbb + r := (code shr 4) and $1f; // register index + k := code and 7; + ACode := format(opRegConst, ['bst', r, k]); + end; + $fc00, + $fe00: + begin // SBRS/SBRC – Skip if Bit in Register is Set/Clear 1111 11sr rrrr 0bbb + r := (code shr 4) and $1f; // register index + k := code and 7; + _set := (code and $0200) <> 0; + if _set then + ACode := format(opRegConst, ['sbrs', r, k]) + else + ACode := format(opRegConst, ['sbrc', r, k]); + end; + else + ACode := InvalidOpCode(code); + end; + end; + else + ACode := InvalidOpCode(code); + end; + + // memory + ACodeBytes := ''; + for k := 0 to CodeIdx - 1 do + ACodeBytes := ACodeBytes + HexStr(pcode[k], 2); + + Inc(AAddress, CodeIdx); +end; + +function TAvrDisassembler.GetInstructionInfo(AnAddress: TDBGPtr + ): TDbgDisassemblerInstruction; +begin + if (FLastInstr = nil) or (FLastInstr.RefCount > 1) then begin + ReleaseRefAndNil(FLastInstr); + FLastInstr := TAvrDisassemblerInstruction.Create(Self); + end; + + FLastInstr.SetAddress(AnAddress); + Result := FLastInstr; +end; + +function TAvrDisassembler.GetFunctionFrameInfo(AnAddress: TDBGPtr; out + AnIsOutsideFrame: Boolean): Boolean; +begin + result := false; +end; + +constructor TAvrDisassembler.Create(AProcess: TDbgProcess); +begin + FProcess := AProcess; +end; + +destructor TAvrDisassembler.Destroy; +begin + ReleaseRefAndNil(FLastInstr); + inherited Destroy; +end; + +initialization + DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} ); + +end. diff --git a/components/fpdebug/fpdbgrsp.pas b/components/fpdebug/fpdbgrsp.pas new file mode 100644 index 0000000000..49bdced0cc --- /dev/null +++ b/components/fpdebug/fpdbgrsp.pas @@ -0,0 +1,744 @@ +unit FpDbgRsp; + +interface + +uses + Classes, SysUtils, ssockets, DbgIntfDebuggerBase, DbgIntfBaseTypes; + +const + // Possible signal numbers that can be expected over rsp + // for now only cater for posix like signals + SIGHUP = 1; + SIGINT = 2; + SIGQUIT = 3; + SIGILL = 4; + SIGTRAP = 5; + SIGABRT = 6; + SIGIOT = 6; + SIGBUS = 7; + SIGFPE = 8; + SIGKILL = 9; + SIGUSR1 = 10; + SIGSEGV = 11; + SIGUSR2 = 12; + SIGPIPE = 13; + SIGALRM = 14; + SIGTERM = 15; + SIGSTKFLT = 16; + SIGCHLD = 17; + SIGCONT = 18; + SIGSTOP = 19; + SIGTSTP = 20; + SIGTTIN = 21; + SIGTTOU = 22; + SIGURG = 23; + SIGXCPU = 24; + SIGXFSZ = 25; + SIGVTALRM = 26; + SIGPROF = 27; + SIGWINCH = 28; + SIGIO = 29; + SIGPOLL = SIGIO; + SIGPWR = 30; + SIGUNUSED = 31; + +type + TInitializedRegister = record + Initialized: boolean; + Value: qword; // sized to handle largest register, should truncate as required to smaller registers + end; + TInitializedRegisters = array of TInitializedRegister; + + TStopReason = (srNone, srSWBreakPoint, srHWBreakPoint, srWriteWatchPoint, srReadWatchPoint, srAnyWatchPoint); + + TStatusEvent = record + signal: integer; + coreID: integer; + threadID: integer; + stopReason: TStopReason; + watchPointAddress: qword; // contains address which triggered watch point + registers: TInitializedRegisters; + end; + + { TRspConnection } + + TRspConnection = class(TInetSocket) + private + FState: integer; + FStatusEvent: TStatusEvent; + procedure FSetRegisterCacheSize(sz: cardinal); + procedure FResetStatusEvent; + // Blocking + function FWaitForData(): boolean; overload; + function FWaitForData(timeout_ms: integer): boolean; overload; + + function FReadReply(out retval: string): boolean; + function FSendCommand(const cmd: string): boolean; + // Send command and wait for acknowledge + function FSendCommandOK(const cmd: string): boolean; + // Return reply to cmd + function FSendCmdWaitForReply(const cmd: string; out reply: string): boolean; + + // Note that numbers are transmitted as hex characters in target endian sequence + // For little endian targets this creates an endian swap if the string is parsed by Val + // because a hex representation of a number is interpreted as big endian + function convertHexWithLittleEndianSwap(constref hextext: string; out value: qword): boolean; + public + constructor Create(const AHost: String; APort: Word; AHandler: TSocketHandler = Nil); Overload; + destructor Destroy; override; + // Wait for async signal - blocking + function WaitForSignal(out msg: string; out registers: TInitializedRegisters): integer; + + procedure Break(); + function Kill(): boolean; + function Detach(): boolean; + function MustReplyEmpty: boolean; + function SetBreakWatchPoint(addr: PtrUInt; BreakWatchKind: TDBGWatchPointKind; watchsize: integer = 1): boolean; + function DeleteBreakWatchPoint(addr: PtrUInt; BreakWatchKind: TDBGWatchPointKind; watchsize: integer = 1): boolean; + // TODO: no support thread ID or different address + function Continue(): boolean; + function SingleStep(): boolean; + + // Data exchange + function ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean; + function WriteDebugReg(ind: byte; AVal: PtrUInt): boolean; + function ReadRegisters(out regs; const sz: integer): boolean; // size is not required by protocol, but is used to preallocate memory for the response + function WriteRegisters(constref regs; const sz: integer): boolean; + function ReadData(const AAddress: TDbgPtr; const ASize: cardinal; out AData + ): boolean; + function WriteData(const AAdress: TDbgPtr; + const ASize: Cardinal; const AData): Boolean; + + // check state of target - ? + function Init: integer; + + property State: integer read FState; + property RegisterCacheSize: cardinal write FSetRegisterCacheSize; + property lastStatusEvent: TStatusEvent read FStatusEvent; + end; + + +implementation + +uses + LazLoggerBase, StrUtils, + {$IFNDEF WINDOWS}BaseUnix; + {$ELSE}winsock2, windows; + {$ENDIF} + +var + DBG_VERBOSE, DBG_WARNINGS: PLazLoggerLogGroup; + +procedure TRspConnection.FSetRegisterCacheSize(sz: cardinal); +begin + SetLength(FStatusEvent.registers, sz); +end; + +procedure TRspConnection.FResetStatusEvent; +var + i: integer; +begin + with FStatusEvent do + begin + signal := 0; + coreID := 0; + threadID := 0; + stopReason := srNone; + watchPointAddress := 0; + for i := low(registers) to high(registers) do + begin + registers[i].Initialized := false; + registers[i].Value := 0; + end; + end; +end; + +function TRspConnection.FWaitForData({timeout: integer}): boolean; +{$if defined(unix) or defined(windows)} +var + FDS: TFDSet; + //TimeV: TTimeVal; +{$endif} +begin + Result:=False; +//{$if defined(unix) or defined(windows)} +// TimeV.tv_usec := timeout * 1000; // 1 msec +// TimeV.tv_sec := 0; +//{$endif} +{$ifdef unix} + FDS := Default(TFDSet); + fpFD_Zero(FDS); + fpFD_Set(self.Handle, FDS); + Result := fpSelect(self.Handle + 1, @FDS, nil, nil, nil{@TimeV}) > 0; +{$else} +{$ifdef windows} + FDS := Default(TFDSet); + FD_Zero(FDS); + FD_Set(self.Handle, FDS); + Result := Select(self.Handle + 1, @FDS, nil, nil, nil{@TimeV}) > 0; +{$endif} +{$endif} +end; + +function TRspConnection.FWaitForData(timeout_ms: integer): boolean; +{$if defined(unix) or defined(windows)} +var + FDS: TFDSet; + TimeV: TTimeVal; +{$endif} +begin + Result:=False; +//{$if defined(unix) or defined(windows)} + TimeV.tv_usec := timeout_ms * 1000; // 1 msec + TimeV.tv_sec := 0; +//{$endif} +{$ifdef unix} + FDS := Default(TFDSet); + fpFD_Zero(FDS); + fpFD_Set(self.Handle, FDS); + Result := fpSelect(self.Handle + 1, @FDS, nil, nil, @TimeV) > 0; +{$else} +{$ifdef windows} + FDS := Default(TFDSet); + FD_Zero(FDS); + FD_Set(self.Handle, FDS); + Result := Select(self.Handle + 1, @FDS, nil, nil, @TimeV) > 0; +{$endif} +{$endif} +end; + +function TRspConnection.FSendCommand(const cmd: string): boolean; +var + checksum: byte; + i, totalSent: integer; + s: string; +begin + checksum := 0; + for i := 1 to length(cmd) do + checksum := byte(checksum + ord(cmd[i])); + + s := '$'+cmd+'#'+IntToHex(checksum, 2); + totalSent := Write(s[1], length(s)); + + // Debugging + //system.WriteLn(s); + + result := (totalSent = length(s)); + if not result then + begin + //WriteLn('* FSendRspCommand error'); + DebugLn(DBG_WARNINGS, ['Warning: TRspConnection.FSendRspCommand error.']) + end + else + begin + DebugLn(DBG_VERBOSE, ['RSP -> ', cmd]); + end; +end; + +function TRspConnection.FSendCommandOK(const cmd: string): boolean; +var + c: char; + retryCount: integer; +begin + result := false; + retryCount := 0; + + repeat + if FSendCommand(cmd) then + begin + // now check if target returned error, resend ('-') or ACK ('+') + // No support for ‘QStartNoAckMode’, i.e. always expect a -/+ + c := char(ReadByte); + result := c = '+'; + if not result then + inc(retryCount); + end + else + inc(retryCount); + // Abort this command if no ACK after 5 attempts + until result or (retryCount > 5); +end; + +function TRspConnection.FReadReply(out retval: string): boolean; +const failcountmax = 1000; +var + c: char; + s: string; + i: integer; + cksum, calcSum: byte; +begin + i := 0; + s := ''; + //IOTimeout := 10; // sometimes an empty response needs to be swallowed to + repeat + c := chr(ReadByte); + inc(i); + s := s + c; + until (c = '$') or (i = failcountmax); // exit loop after start or count expired + + if c <> '$' then + begin + //WriteLn('* Timeout waiting for RSP reply'); + DebugLn(DBG_WARNINGS, ['Warning: Timeout waiting for RSP reply']); + result := false; + retval := ''; + exit; + end + else if i > 1 then + begin + //WriteLn('* Discarding data before start of message: ', s); + DebugLn(DBG_WARNINGS, ['Warning: Discarding unexpected data before start of new message', s]); + end; + + c := chr(ReadByte); + s := ''; + calcSum := 0; + while c <> '#' do + begin + calcSum := byte(calcSum+byte(c)); + + if c=#$7D then // escape marker, unescape data + begin + c := char(ReadByte); + + // Something weird happened + if c = '#' then + begin + //WriteLn('* Received end of packet marker in escaped sequence: ', c); + DebugLn(DBG_WARNINGS, ['Warning: Received end of packet marker in escaped sequence: ', c]); + break; + end; + + calcSum := byte(calcSum + byte(c)); + + c := char(byte(c) xor $20); + end; + + s := s + c; + c := char(ReadByte); + end; + + cksum := StrToInt('$' + char(ReadByte) + char(ReadByte)); + + // Ignore checksum for now + WriteByte(byte('+')); + result := true; + retval := s; + if not (calcSum = cksum) then + begin + //WriteLn('* Reply packet with invalid checksum: ', s); + DebugLn(DBG_WARNINGS, ['Warning: Reply packet with invalid checksum: ', s]); + end; + + //WriteLn('RSP <- ', retval); + DebugLn(DBG_VERBOSE, ['RSP <- ', retval]); +end; + +function TRspConnection.FSendCmdWaitForReply(const cmd: string; out reply: string + ): boolean; +var + retryCount: integer; +begin + reply := ''; + retryCount := 0; + + if FSendCommandOK(cmd) then + begin + // Read reply, with retry if no success + repeat + result := FReadReply(reply); + if not result then + begin + inc(retryCount); + WriteByte(ord('-')); + end; + until result or (retryCount > 5); + end; + + if retryCount > 5 then + DebugLn(DBG_WARNINGS, ['Warning: Retries exceeded in TRspConnection.FSendCmdWaitForReply for cmd: ', cmd]); +end; + +function TRspConnection.convertHexWithLittleEndianSwap(constref + hextext: string; out value: qword): boolean; +var + err: integer; +begin + Val('$'+hextext, value, err); + if (err = 0) then + begin + result := true; + case length(hextext) of + 2: ; // no conversion required + 4: value := SwapEndian(word(value)); + 8: value := SwapEndian(dword(value)); + 16: value := SwapEndian(value); + else + begin + result := false; + DebugLn(DBG_WARNINGS, ['Warning: Unexpected hex length: ', IntToStr(length(hextext))]); + end; + end; + end + else + result := false; +end; + +procedure TRspConnection.Break(); +begin + WriteByte(3); // Ctrl-C +end; + +function TRspConnection.Kill(): boolean; +var + c: char; +begin + result := FSendCommand('k'); + // Swallow the last ack if send + result := FWaitForData(1000); + if result then + begin + c := char(ReadByte); + Result := c = '+'; + end; +end; + +function TRspConnection.Detach(): boolean; +var + reply: string; +begin + result := FSendCmdWaitForReply('D', reply); + result := pos('OK', reply) = 1; +end; + +constructor TRspConnection.Create(const AHost: String; APort: Word; + AHandler: TSocketHandler); +begin + inherited Create(AHost, APort); + //self.IOTimeout := 1000; // socket read timeout = 1000 ms +end; + +destructor TRspConnection.Destroy; +begin + inherited; +end; + +function TRspConnection.WaitForSignal(out msg: string; out + registers: TInitializedRegisters): integer; +var + res: boolean; + startIndex, colonIndex, semicolonIndex: integer; + tmp, tmp2: qword; + part1, part2: string; +begin + result := 0; + res := false; + SetLength(registers, 0); + + // False if no data available, e.g. socket is closed + if not FWaitForData() then + begin + msg := ''; + exit; + end; + + try + res := FReadReply(msg); + except + on E: Exception do + DebugLn(DBG_WARNINGS, ['Warning: WaitForSignal exception: ', E.Message]); + end; + + if res then + begin + if (length(msg) > 2) and (msg[1] in ['S', 'T']) then + begin + try + FResetStatusEvent; + result := StrToInt('$' + copy(msg, 2, 2)); + FState := result; + FStatusEvent.signal := result; + if (msg[1] = 'T') and (length(msg) > 6) then // not much meaning can be returned in less than 2 bytes + begin + startIndex := 4; // first part of message TAA... is already parsed, rest should be nn:rr; pairs + repeat + colonIndex := posex(':', msg, startIndex); + semicolonIndex := posex(';', msg, startIndex); + // Check if there is a first part + if colonIndex > startIndex then + part1 := copy(msg, startIndex, colonIndex-startIndex) + else + part1 := ''; + + if (part1 <> '') and (semicolonIndex > colonIndex + 1) then + part2 := copy(msg, colonIndex+1, semicolonIndex - colonIndex - 1) + else + part2 := ''; + + // Check for stop reason + case part1 of + 'watch','rwatch','awatch': + begin + case part1 of + 'watch': FStatusEvent.stopReason := srWriteWatchPoint; + 'rwatch': FStatusEvent.stopReason := srReadWatchPoint; + 'awatch': FStatusEvent.stopReason := srAnyWatchPoint; + end; + if convertHexWithLittleEndianSwap(part2, tmp) then + FStatusEvent.watchPointAddress := tmp + else + DebugLn(DBG_WARNINGS, format('Invalid value received for %s: %s ', [part1, part2])); + end; + 'swbreak': + begin + FStatusEvent.stopReason := srSWBreakPoint; + end; + 'hwbreak': + begin + FStatusEvent.stopReason := srHWBreakPoint; + end; + else // catch valid hex numbers - will be register info + begin + // check if part1 is a number, this should then be a register index + if convertHexWithLittleEndianSwap(part1, tmp) and convertHexWithLittleEndianSwap(part2, tmp2) then + begin + if tmp < length(FStatusEvent.registers) then + begin + FStatusEvent.registers[tmp].Value := tmp2; + FStatusEvent.registers[tmp].Initialized := true; + end + else + DebugLn(DBG_WARNINGS, format('Register index exceeds total number of registers (%d > %d] ', + [tmp, length(FStatusEvent.registers)])); + end + else + DebugLn(DBG_WARNINGS, format('Ignoring stop reply pair [%s:%s] ', [part1, part2])); + end; + end; + startIndex := semicolonIndex + 1; + until (semicolonIndex = 0) or (semicolonIndex = length(msg)); + end; + except + DebugLn(DBG_WARNINGS, ['Error converting signal number from reply: ', msg]); + end; + end + else + DebugLn(DBG_WARNINGS, ['Unexpected WaitForSignal reply: ', msg]); + end; +end; + +function TRspConnection.MustReplyEmpty: boolean; +var + reply: string; +begin + FSendCmdWaitForReply('vMustReplyEmpty', reply); + result := reply = ''; + if not result then + DebugLn(DBG_WARNINGS, ['Warning: vMustReplyEmpty command returned unexpected result: ', reply]); +end; + +function TRspConnection.SetBreakWatchPoint(addr: PtrUInt; + BreakWatchKind: TDBGWatchPointKind; watchsize: integer): boolean; +var + cmd, reply: string; +begin + cmd := 'Z'; + case BreakWatchKind of + wpkWrite: cmd := cmd + '2,' + IntToHex(addr, 4) + ',' + IntToHex(watchsize, 4); + wpkRead: cmd := cmd + '3,' + IntToHex(addr, 4) + ',' + IntToHex(watchsize, 4); + wpkReadWrite: cmd := cmd + '4,' + IntToHex(addr, 4) + ',' + IntToHex(watchsize, 4); + // NOTE: Not sure whether hardware break is better than software break, depends on gdbserver implementation... + wkpExec: cmd := cmd + '1,' + IntToHex(addr, 4) + ',00'; + end; + + result := FSendCmdWaitForReply(cmd, reply); + if result then + result := pos('OK', reply) > 0; +end; + +function TRspConnection.DeleteBreakWatchPoint(addr: PtrUInt; + BreakWatchKind: TDBGWatchPointKind; watchsize: integer): boolean; +var + cmd, reply: string; +begin + cmd := 'z'; + case BreakWatchKind of + wpkWrite: cmd := cmd + '2,' + IntToHex(addr, 4) + ',' + IntToHex(watchsize, 4); + wpkRead: cmd := cmd + '3,' + IntToHex(addr, 4) + ',' + IntToHex(watchsize, 4); + wpkReadWrite: cmd := cmd + '4,' + IntToHex(addr, 4) + ',' + IntToHex(watchsize, 4); + // NOTE: Not sure whether hardware break is better than software break, depends on gdbserver implementation... + wkpExec: cmd := cmd + '1,' + IntToHex(addr, 4) + ',00'; + end; + + result := FSendCmdWaitForReply(cmd, reply); + if result then + result := pos('OK', reply) > 0; +end; + +function TRspConnection.Continue(): boolean; +begin + DebugLn(DBG_VERBOSE, ['TRspConnection.Continue() called']); + result := FSendCommandOK('c'); + if not result then + DebugLn(DBG_WARNINGS, ['Warning: Continue command failure in TRspConnection.Continue()']); +end; + +function TRspConnection.SingleStep(): boolean; +begin + result := FSendCommandOK('s'); + if not result then + DebugLn(DBG_WARNINGS, ['Warning: SingleStep command failure in TRspConnection.SingleStep()']); +end; + +function TRspConnection.ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean; +var + cmd, reply: string; +begin + cmd := 'p'+IntToHex(ind, 2); + result := FSendCmdWaitForReply(cmd, reply); + if result then + result := convertHexWithLittleEndianSwap(reply, aval); + + if not result then + DebugLn(DBG_WARNINGS, ['Warning: "p" command returned unexpected result: ', reply]); +end; + +function TRspConnection.WriteDebugReg(ind: byte; AVal: PtrUInt): boolean; +var + cmd, reply: string; +begin + cmd := 'P'+IntToHex(ind, 2); + result := FSendCmdWaitForReply(cmd, reply) and (reply = 'OK'); + + if not result then + DebugLn(DBG_WARNINGS, ['Warning: "P" command returned unexpected result: ', reply]); +end; + +function TRspConnection.ReadRegisters(out regs; const sz: integer): boolean; +var + reply: string; + b: array of byte; + i: integer; +begin + reply := ''; + setlength(b, sz); + // Normal receive error, or an error response of the form Exx + result := FSendCmdWaitForReply('g', reply) and ((length(reply) > 4) and (reply[1] <> 'E')) + and (length(reply) = 2*sz); + if Result then + begin + //WriteLn('Read registers reply: ', reply); + for i := 0 to sz-1 do + b[i] := StrToInt('$'+reply[2*i+1]+reply[2*i+2]); + result := true; + end + else + begin + DebugLn(DBG_WARNINGS, ['Warning: "g" command returned unexpected result: ', reply]); + FillByte(b[0], sz, 0); + end; + Move(b[0], regs, sz); +end; + +function TRspConnection.WriteRegisters(constref regs; const sz: integer + ): boolean; +var + cmd, reply, s: string; + i, offset: integer; + pb: PByte; +begin + pb := @regs; + result := false; + reply := ''; + cmd := format('G', []); + offset := length(cmd); + setlength(cmd, offset+sz*2); + for i := 0 to sz-1 do + begin + s := IntToHex(pb^, 2); + cmd[offset + 2*i + 1] := s[1]; + cmd[offset + 2*i + 2] := s[2]; + end; + + // Normal receive error, or an error number of the form Exx + result := FSendCmdWaitForReply(cmd, reply) and (reply = 'OK'); + if not result then + DebugLn(DBG_WARNINGS, ['Warning: "G" command returned unexpected result: ', reply]); +end; + +function TRspConnection.ReadData(const AAddress: TDbgPtr; + const ASize: cardinal; out AData): boolean; +var + buf: pbyte; + cmd, reply: string; + i: integer; +begin + result := false; + getmem(buf, ASize); + cmd := 'm'+IntToHex(AAddress, 2)+',' + IntToHex(ASize, 2); + result := FSendCmdWaitForReply(cmd, reply) and (length(reply) = ASize*2); + if result then + begin + for i := 0 to ASize-1 do + buf[i] := StrToInt('$'+reply[2*i + 1]+reply[2*i + 2]) + end + else + begin + DebugLn(DBG_WARNINGS, ['Warning: "m" command returned unexpected result: ', reply]); + FillByte(buf[0], ASize, 0); + end; + + System.Move(buf^, AData, ASize); + Freemem(buf); +end; + +function TRspConnection.WriteData(const AAdress: TDbgPtr; + const ASize: Cardinal; const AData): Boolean; +var + cmd, reply, s: string; + i, offset: integer; + pb: PByte; +begin + result := false; + cmd := format('M%X,%X:', [AAdress, ASize]); + offset := length(cmd); + setlength(cmd, offset + 2*ASize); + pb := @AData; + for i := 0 to ASize-1 do + begin + s := IntToHex(pb^, 2); + cmd[offset + 2*i+1] := s[1]; + cmd[offset + 2*i+2] := s[2]; + inc(pb); + end; + + result := FSendCmdWaitForReply(cmd, reply) and (reply = 'OK'); + if not result then + DebugLn(DBG_WARNINGS, ['Warning: "M" command returned unexpected result: ', reply]); +end; + +function TRspConnection.Init: integer; +var + reply: string; + intRegs: TInitializedRegisters; +begin + result := 0; + reply := ''; + if not FSendCmdWaitForReply('vMustReplyEmpty', reply) or (reply <> '') then + begin + DebugLn(DBG_WARNINGS, ['Warning: vMustReplyEmpty command returned unexpected result: ', reply]); + exit; + end; + + if FSendCommandOK('?') then + begin + result := WaitForSignal(reply, intRegs); + end; + // TODO: Do something with fresh register information +end; + +initialization + DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} ); + DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} ); +end. + diff --git a/components/fpdebug/fpdebug.lpk b/components/fpdebug/fpdebug.lpk index 71a616f350..6fe17e4859 100644 --- a/components/fpdebug/fpdebug.lpk +++ b/components/fpdebug/fpdebug.lpk @@ -40,147 +40,163 @@ File(s) with other licenses (see also header in file(s): (Any modifications/translations of this file are from duby) "/> - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - + + + + + + + + + + + + + + + + + - - + + - - + + - - + + - + diff --git a/components/fpdebug/fpdebug.pas b/components/fpdebug/fpdebug.pas index 34320a969e..7b11fa77c2 100644 --- a/components/fpdebug/fpdebug.pas +++ b/components/fpdebug/fpdebug.pas @@ -14,7 +14,8 @@ uses FpImgReaderMachoFile, FpImgReaderMacho, FpPascalBuilder, FpDbgInfo, FpdMemoryTools, FpErrorMessages, FPDbgController, FpDbgDwarfVerbosePrinter, FpDbgDwarfDataClasses, FpDbgDwarfFreePascal, fpDbgSymTableContext, - fpDbgSymTable, LazarusPackageIntf; + fpDbgSymTable, FpDbgAvrClasses, FpDbgDisasAvr, FpDbgRsp, FpDbgCommon, + LazarusPackageIntf; implementation