From 1c87d531990935e384248ebaa9d962094a6cc619 Mon Sep 17 00:00:00 2001 From: Martin Date: Fri, 5 Aug 2022 00:56:23 +0200 Subject: [PATCH] Debugger: implement reading class.unitname from RTTI --- components/fpdebug/fpdbgcommon.pas | 6 + components/fpdebug/fpdbgdwarffreepascal.pas | 159 +++++++++++++----- components/fpdebug/fpdbginfo.pas | 32 ++-- .../lazdebuggerfp/fpdebugdebugger.pas | 2 +- .../lazdebuggerfp/fpdebugvalueconvertors.pas | 2 +- .../lazdebuggerfp/test/testwatches.pas | 111 +++++++++++- 6 files changed, 247 insertions(+), 65 deletions(-) diff --git a/components/fpdebug/fpdbgcommon.pas b/components/fpdebug/fpdbgcommon.pas index ea962f9921..970622aea8 100644 --- a/components/fpdebug/fpdbgcommon.pas +++ b/components/fpdebug/fpdbgcommon.pas @@ -31,6 +31,7 @@ function hostDescriptor: TTargetDescriptor; procedure AssertFpDebugThreadId(const AName: String); procedure AssertFpDebugThreadIdNotMain(const AName: String); procedure SetCurrentFpDebugThreadIdForAssert(AnId: TThreadID); +procedure ClearCurrentFpDebugThreadIdForAssert; property CurrentFpDebugThreadIdForAssert: TThreadID write SetCurrentFpDebugThreadIdForAssert; {$ENDIF} @@ -87,6 +88,11 @@ begin FCurrentFpDebugThreadIdValidForAssert := True; end; +procedure ClearCurrentFpDebugThreadIdForAssert; +begin + FCurrentFpDebugThreadIdValidForAssert := False; +end; + {$ENDIF} end. diff --git a/components/fpdebug/fpdbgdwarffreepascal.pas b/components/fpdebug/fpdbgdwarffreepascal.pas index 954fe03bc5..0f67b8e92b 100644 --- a/components/fpdebug/fpdbgdwarffreepascal.pas +++ b/components/fpdebug/fpdbgdwarffreepascal.pas @@ -43,7 +43,7 @@ type function GetInstanceClassNameFromPVmt(APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; - out AClassName: String; out AnError: TFpError): boolean; + AClassName, AUnitName: PString; out AnError: TFpError): boolean; end; { TFpDwarfFreePascalSymbolClassMapDwarf2 } @@ -157,12 +157,12 @@ type //function GetInstanceClass(AValueObj: TFpValueDwarf): TFpSymbolDwarf; override; class function GetInstanceClassNameFromPVmt(APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; - out AClassName: String; out AnError: TFpError; + AClassName, AUnitName: PString; out AnError: TFpError; AParentClassIndex: integer = 0; ACompilerVersion: Cardinal = 0): boolean; public - function GetInstanceClassName(AValueObj: TFpValue; out - AClassName: String; + function GetInstanceClassName(AValueObj: TFpValue; + AClassName, AUnitName: PString; AParentClassIndex: integer = 0): boolean; override; end; @@ -412,11 +412,11 @@ begin end; function TFpDwarfFreePascalSymbolClassMap.GetInstanceClassNameFromPVmt( - APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; out - AClassName: String; out AnError: TFpError): boolean; + APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; + AClassName, AUnitName: PString; out AnError: TFpError): boolean; begin Result := TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassNameFromPVmt(APVmt, - AContext, ASizeOfAddr, AClassName, AnError); + AContext, ASizeOfAddr, AClassName, AUnitName, AnError); end; { TFpDwarfFreePascalSymbolClassMapDwarf2 } @@ -968,8 +968,8 @@ begin end; function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassName( - AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer - ): boolean; + AValueObj: TFpValue; AClassName, AUnitName: PString; + AParentClassIndex: integer): boolean; var AnErr: TFpError; begin @@ -978,7 +978,7 @@ begin exit; Result := GetInstanceClassNameFromPVmt(LocToAddrOrNil(AValueObj.DataAddress), TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress, - AClassName, AnErr, AParentClassIndex, + AClassName, AUnitName, AnErr, AParentClassIndex, TFpDwarfFreePascalSymbolClassMap(CompilationUnit.DwarfSymbolClassMap).FCompilerVersion ); @@ -987,25 +987,33 @@ begin end; class function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassNameFromPVmt - (APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; out - AClassName: String; out AnError: TFpError; AParentClassIndex: integer; - ACompilerVersion: Cardinal): boolean; + (APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; + AClassName, AUnitName: PString; out AnError: TFpError; + AParentClassIndex: integer; ACompilerVersion: Cardinal): boolean; + + function CheckIsReadableMem(AMem: TFpDbgMemLocation): Boolean; + begin + Result := IsReadableMem(AMem); + if not Result then + AnError := CreateError(fpErrCanNotReadMemAtAddr, [AMem.Address]); + end; + var VmtAddr, ClassNameAddr, A: TFpDbgMemLocation; NameLen: QWord; begin Result := False; AnError := NoError; - AClassName := ''; + if AClassName <> nil then AClassName^ := ''; + if AUnitName <> nil then AUnitName^ := ''; if not AContext.ReadAddress(TargetLoc(APVmt), SizeVal(ASizeOfAddr), VmtAddr) then begin AnError := AContext.LastMemError; + AContext.ClearLastMemError; exit; end; - if not IsReadableMem(VmtAddr) then begin - AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]); + if not CheckIsReadableMem(VmtAddr) then exit; - end; while AParentClassIndex > 0 do begin {$PUSH}{$Q-} @@ -1014,24 +1022,24 @@ begin A := VmtAddr; if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin AnError := AContext.LastMemError; + AContext.ClearLastMemError; exit; end; - if not IsReadableMem(VmtAddr) then begin - AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]); + if IsTargetNil(VmtAddr) then + exit; // no error / top parent reached + if not CheckIsReadableMem(VmtAddr) then exit; - end; if (ACompilerVersion >= $030200) then begin A := VmtAddr; if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin AnError := AContext.LastMemError; + AContext.ClearLastMemError; exit; end; - if not IsReadableMem(VmtAddr) then begin - AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]); + if not CheckIsReadableMem(VmtAddr) then exit; - end; end; dec(AParentClassIndex); @@ -1041,31 +1049,90 @@ begin VmtAddr.Address := VmtAddr.Address + TDBGPtr(3 * ASizeOfAddr); {$POP} - if not AContext.ReadAddress(VmtAddr, SizeVal(ASizeOfAddr), ClassNameAddr) then begin - AnError := AContext.LastMemError; - exit; - end; - if not IsReadableMem(ClassNameAddr) then begin - AnError := CreateError(fpErrCanNotReadMemAtAddr, [ClassNameAddr.Address]); - exit; - end; - if not AContext.ReadUnsignedInt(ClassNameAddr, SizeVal(1), NameLen) then begin - AnError := AContext.LastMemError; - exit; - end; - if NameLen = 0 then begin - AnError := CreateError(fpErrAnyError, ['No name found']); - exit; - end; - if not AContext.MemManager.SetLength(AClassName, NameLen) then begin - AnError := AContext.LastMemError; - exit; + if AClassName <> nil then begin + if not AContext.ReadAddress(VmtAddr, SizeVal(ASizeOfAddr), ClassNameAddr) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + if not CheckIsReadableMem(ClassNameAddr) then + exit; + + if not AContext.ReadUnsignedInt(ClassNameAddr, SizeVal(1), NameLen) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + if NameLen = 0 then begin + AnError := CreateError(fpErrAnyError, ['No name found']); + exit; + end; + if not AContext.MemManager.SetLength(AClassName^, NameLen) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + + ClassNameAddr.Address := ClassNameAddr.Address + 1; + Result := AContext.ReadMemory(ClassNameAddr, SizeVal(NameLen), @AClassName^[1]); + if not Result then + AnError := AContext.LastMemError; + AContext.ClearLastMemError; end; - ClassNameAddr.Address := ClassNameAddr.Address + 1; - Result := AContext.ReadMemory(ClassNameAddr, SizeVal(NameLen), @AClassName[1]); - if not Result then - AnError := AContext.LastMemError; + if AUnitName <> nil then begin + // get vTypeInfo + {$PUSH}{$Q-} + VmtAddr.Address := VmtAddr.Address + TDBGPtr(4 * ASizeOfAddr); + {$POP} + + if not AContext.ReadAddress(VmtAddr, SizeVal(ASizeOfAddr), ClassNameAddr) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + if not CheckIsReadableMem(ClassNameAddr) then + exit; + + //inc(Pointer(classtypeinfo), PByte(Pointer(classtypeinfo)+1)^ + 2); + A := ClassNameAddr; + {$PUSH}{$Q-} + A.Address := A.Address + 1; + {$POP} + if not AContext.ReadUnsignedInt(A, SizeVal(1), NameLen) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + {$PUSH}{$Q-} + ClassNameAddr.Address := ClassNameAddr.Address + TDBGPtr(NameLen + 2) + TDBGPtr(2 * ASizeOfAddr + 2); + if (ACompilerVersion >= $030300) then + ClassNameAddr.Address := ClassNameAddr.Address + TDBGPtr(ASizeOfAddr); + {$POP} + // Maybe align to next qword + + + if not AContext.ReadUnsignedInt(ClassNameAddr, SizeVal(1), NameLen) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + if NameLen = 0 then begin + AnError := CreateError(fpErrAnyError, ['No name found']); + exit; + end; + if not AContext.MemManager.SetLength(AUnitName^, NameLen) then begin + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + exit; + end; + + ClassNameAddr.Address := ClassNameAddr.Address + 1; + Result := AContext.ReadMemory(ClassNameAddr, SizeVal(NameLen), @AUnitName^[1]); + if not Result then + AnError := AContext.LastMemError; + AContext.ClearLastMemError; + end; end; { TFpValueDwarfV2FreePascalShortString } diff --git a/components/fpdebug/fpdbginfo.pas b/components/fpdebug/fpdbginfo.pas index cf54527159..1e028873b3 100644 --- a/components/fpdebug/fpdbginfo.pas +++ b/components/fpdebug/fpdbginfo.pas @@ -187,7 +187,8 @@ type public function GetTypeCastedValue(ADataVal: TFpValue): TFpValue; virtual; // only if Symbol is a type - function GetInstanceClassName(out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual; + function GetInstanceClassName(out AClassName; AParentClassIndex: integer = 0): boolean; virtual; + function GetInstanceClassName(AClassName: PString; AUnitName: PString = nil; AParentClassIndex: integer = 0): boolean; virtual; // base class? Or Member includes member from base (* Member: @@ -463,7 +464,7 @@ type // property Flags: TDbgSymbolFlags read GetFlags; property Parent: TFpSymbol read GetParent; deprecated; - function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual; + function GetInstanceClassName(AValueObj: TFpValue; AClassName, AUnitName: PString; AParentClassIndex: integer = 0): boolean; virtual; // for Subranges // Type-Symbols only? // TODO: flag bounds as cardinal if needed @@ -508,7 +509,7 @@ type function GetNestedSymbolByName(const AIndex: String): TFpSymbol; override; function GetNestedSymbolCount: Integer; override; public - function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; override; + function GetInstanceClassName(AValueObj: TFpValue; AClassName, AUnitName: PString; AParentClassIndex: integer = 0): boolean; override; function GetValueBounds(AValueObj: TFpValue; out ALowBound, AHighBound: Int64): Boolean; override; function GetValueLowBound(AValueObj: TFpValue; out ALowBound: Int64): Boolean; override; function GetValueHighBound(AValueObj: TFpValue; out AHighBound: Int64): Boolean; override; @@ -929,7 +930,13 @@ begin Result := nil; end; -function TFpValue.GetInstanceClassName(out AClassName: String; +function TFpValue.GetInstanceClassName(out AClassName; + AParentClassIndex: integer): boolean; +begin + Result := GetInstanceClassName(@AClassName, nil); +end; + +function TFpValue.GetInstanceClassName(AClassName, AUnitName: PString; AParentClassIndex: integer): boolean; var ti: TFpSymbol; @@ -937,7 +944,7 @@ begin ti := TypeInfo; Result := ti <> nil; if Result then - Result := ti.GetInstanceClassName(Self, AClassName, AParentClassIndex); + Result := ti.GetInstanceClassName(Self, AClassName, AUnitName, AParentClassIndex); end; procedure TFpValue.ResetError; @@ -1396,10 +1403,11 @@ begin Result := DoReadSize(AValueObj, ASize); end; -function TFpSymbol.GetInstanceClassName(AValueObj: TFpValue; out - AClassName: String; AParentClassIndex: integer): boolean; +function TFpSymbol.GetInstanceClassName(AValueObj: TFpValue; AClassName, + AUnitName: PString; AParentClassIndex: integer): boolean; begin - AClassName := ''; + if AClassName <> nil then AClassName^ := ''; + if AUnitName <> nil then AUnitName^ := ''; Result := False; end; @@ -1777,16 +1785,16 @@ begin Result := 0; // Result := inherited GetOrdinalValue; end; -function TFpSymbolForwarder.GetInstanceClassName(AValueObj: TFpValue; out - AClassName: String; AParentClassIndex: integer): boolean; +function TFpSymbolForwarder.GetInstanceClassName(AValueObj: TFpValue; + AClassName, AUnitName: PString; AParentClassIndex: integer): boolean; var p: TFpSymbol; begin p := GetForwardToSymbol; if p <> nil then - Result := p.GetInstanceClassName(AValueObj, AClassName, AParentClassIndex) + Result := p.GetInstanceClassName(AValueObj, AClassName, AUnitName, AParentClassIndex) else - Result := inherited GetInstanceClassName(AValueObj, AClassName, AParentClassIndex); + Result := inherited GetInstanceClassName(AValueObj, AClassName, AUnitName, AParentClassIndex); end; function TFpSymbolForwarder.GetValueBounds(AValueObj: TFpValue; out diff --git a/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas b/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas index 82a1fdf7c2..d65af9559f 100644 --- a/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas +++ b/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas @@ -3292,7 +3292,7 @@ begin if (FDbgController.CurrentProcess <> nil) then TFpDwarfFreePascalSymbolClassMap.GetInstanceForDbgInfo(FDbgController.CurrentProcess.DbgInfo) .GetInstanceClassNameFromPVmt - (AnAddr, FDbgController.DefaultContext, DBGPTRSIZE[FDbgController.CurrentProcess.Mode], Result, AnErr); + (AnAddr, FDbgController.DefaultContext, DBGPTRSIZE[FDbgController.CurrentProcess.Mode], @Result, nil, AnErr); end; procedure TFpDebugDebugger.DoThreadDebugOutput(Sender: TObject; ProcessId, diff --git a/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas b/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas index f8393c4346..d36cebdd30 100644 --- a/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas +++ b/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas @@ -312,7 +312,7 @@ begin end; CnIdx := 0; - while AValue.GetInstanceClassName(ValClassName, CnIdx) and + while AValue.GetInstanceClassName(@ValClassName, nil, CnIdx) and (ValClassName <> '') do begin ValClassName := LowerCase(ValClassName); diff --git a/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas b/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas index d452d31197..920d27cf8e 100644 --- a/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas +++ b/components/lazdebuggers/lazdebuggerfp/test/testwatches.pas @@ -6,10 +6,10 @@ interface uses Classes, SysUtils, fpcunit, testregistry, TestBase, FpDebugValueConvertors, - TestDbgControl, TestDbgTestSuites, TestOutputLogger, TTestWatchUtilities, - TestCommonSources, TestDbgConfig, LazDebuggerIntf, LazDebuggerIntfBaseTypes, - DbgIntfDebuggerBase, DbgIntfBaseTypes, Forms, IdeDebuggerBase, - IdeDebuggerWatchResult; + FpDebugDebugger, TestDbgControl, TestDbgTestSuites, TestOutputLogger, + TTestWatchUtilities, TestCommonSources, TestDbgConfig, LazDebuggerIntf, + LazDebuggerIntfBaseTypes, DbgIntfDebuggerBase, DbgIntfBaseTypes, FpDbgInfo, + FpPascalParser, FpDbgCommon, Forms, IdeDebuggerBase, IdeDebuggerWatchResult; type @@ -33,6 +33,7 @@ type procedure TestWatchesExpression; procedure TestWatchesModify; procedure TestWatchesErrors; + procedure TestClassRtti; end; implementation @@ -41,7 +42,7 @@ var ControlTestWatch, ControlTestWatchScope, ControlTestWatchValue, ControlTestWatchFunct, ControlTestWatchFunctStr, ControlTestWatchFunctRec, ControlTestWatchFunctVariant, ControlTestWatchAddressOf, ControlTestWatchTypeCast, ControlTestModify, - ControlTestExpression, ControlTestErrors: Pointer; + ControlTestExpression, ControlTestErrors, ControlTestRTTI: Pointer; procedure TTestWatches.RunToPause(var ABrk: TDBGBreakPoint; ADisableBreak: Boolean); @@ -3693,6 +3694,105 @@ begin end; end; +procedure TTestWatches.TestClassRtti; +var + ExeName: String; + Src: TCommonSource; + BrkPrg: TDBGBreakPoint; + fp: TFpDebugDebugger; + AnExpressionScope: TFpDbgSymbolScope; + APasExpr: TFpPascalExpression; + ResValue: TFpValue; + InstClass, AnUnitName: String; + r: Boolean; +begin + if SkipTest then exit; + if not TestControlCanTest(ControlTestRTTI) then exit; + + Src := GetCommonSourceFor('WatchesValuePrg.pas'); + TestCompile(Src, ExeName); + + AssertTrue('Start debugger', Debugger.StartDebugger(AppDir, ExeName)); + + try + BrkPrg := Debugger.SetBreakPoint(Src, 'Prg'); + AssertDebuggerNotInErrorState; + RunToPause(BrkPrg); + +{$IFDEF FPDEBUG_THREAD_CHECK} + ClearCurrentFpDebugThreadIdForAssert; +{$ENDIF} + + fp := TFpDebugDebugger(Debugger.LazDebugger); + AnExpressionScope := fp.DbgController.CurrentProcess.FindSymbolScope(fp.DbgController.CurrentThread.ID, 0); + TestTrue('got scope', AnExpressionScope <> nil); + + if AnExpressionScope <> nil then begin + + APasExpr := TFpPascalExpression.Create('MyClass1', AnExpressionScope); + ResValue := APasExpr.ResultValue; + + r := ResValue.GetInstanceClassName(InstClass); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TMyClass', InstClass); + + r := ResValue.GetInstanceClassName(@InstClass, @AnUnitName); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TMyClass', InstClass); + TestEquals('unit name', 'WatchesValuePrg', AnUnitName); + + r := ResValue.GetInstanceClassName(@InstClass, @AnUnitName, 1); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TMyBaseClass', InstClass); + TestEquals('unit name', 'WatchesValuePrg', AnUnitName); + + r := ResValue.GetInstanceClassName(@InstClass, @AnUnitName, 2); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TObject', InstClass); + TestEquals('unit name', 'system', lowercase(AnUnitName)); + + APasExpr.Free; + + + + APasExpr := TFpPascalExpression.Create('MyClass2', AnExpressionScope); + ResValue := APasExpr.ResultValue; + + r := ResValue.GetInstanceClassName(InstClass); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TMyClass', InstClass); + + r := ResValue.GetInstanceClassName(@InstClass, @AnUnitName); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TMyClass', InstClass); + TestEquals('unit name', 'WatchesValuePrg', AnUnitName); + + r := ResValue.GetInstanceClassName(@InstClass, @AnUnitName, 1); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TMyBaseClass', InstClass); + TestEquals('unit name', 'WatchesValuePrg', AnUnitName); + + r := ResValue.GetInstanceClassName(@InstClass, @AnUnitName, 2); + TestTrue('got inst class ', r); + TestEquals('inst class ', 'TObject', InstClass); + TestEquals('unit name', 'system', lowercase(AnUnitName)); + + APasExpr.Free; + + + + end; + + + finally + Debugger.RunToNextPause(dcStop); + Debugger.ClearDebuggerMonitors; + Debugger.FreeDebugger; + + AssertTestErrors; + end; +end; + initialization RegisterDbgTest(TTestWatches); @@ -3708,6 +3808,7 @@ initialization ControlTestModify := TestControlRegisterTest('Modify', ControlTestWatch); ControlTestExpression := TestControlRegisterTest('Expression', ControlTestWatch); ControlTestErrors := TestControlRegisterTest('Errors', ControlTestWatch); + ControlTestRTTI := TestControlRegisterTest('Rtti', ControlTestWatch); end.