paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-18 20:59:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

FPDebug: Value handling / size field

Browse Source 
git-svn-id: trunk@43945 -
This commit is contained in:
martin 2014-02-07 23:40:17 +00:00
parent 2a4cc692f8
commit 2cc1500342
4 changed files with 150 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
components/fpdebug/fpdbgdwarf.pas
View File

@ -635,6 +635,7 @@ type
function IsValidTypeCast: Boolean; override;
function GetAsCardinal: QWord; override;
function GetAsInteger: Int64; override;
function GetSize: Integer; override;
public
constructor Create(AOwner: TDbgDwarfIdentifier; ASize: Integer);
end;
@ -698,6 +699,8 @@ type
function GetFieldFlags: TDbgSymbolValueFieldFlags; override;
function GetAsCardinal: QWord; override;
function GetDataAddress: TDbgPtr; override;
function GetDataSize: Integer; override;
function GetSize: Integer; override;
end;
{ TDbgDwarfStructTypeCastSymbolValue }
@ -711,6 +714,8 @@ type
function GetFieldFlags: TDbgSymbolValueFieldFlags; override;
function GetKind: TDbgSymbolKind; override;
function GetAsCardinal: QWord; override;
function GetSize: Integer; override;
function GetDataSize: Integer; override;
function GetDataAddress: TDbgPtr; override;
function GetDwarfDataAddress(out AnAddress: TDbgPtr; ATargetType: TDbgDwarfTypeIdentifier = nil): Boolean; reintroduce;
function IsValidTypeCast: Boolean; override;
@ -1060,6 +1065,7 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
protected
procedure KindNeeded; override;
procedure TypeInfoNeeded; override; // nil or inherited
procedure SizeNeeded; override;
function GetTypedValueObject(ATypeCast: Boolean): TDbgDwarfSymbolValue; override;
function GetMember(AIndex: Integer): TDbgSymbol; override;
@ -1730,7 +1736,11 @@ end;
function TDbgDwarfStructSymbolValue.GetFieldFlags: TDbgSymbolValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfMembers]; // svfDataSize
Result := Result + [svfMembers];
if kind = skClass then // todo detect hidden pointer
Result := Result + [svfDataSize]
else
Result := Result + [svfSize];
//TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
if Kind in [skClass] then begin
Result := Result + [svfDataAddress, svfSizeOfPointer]; // svfDataSize
@ -1763,12 +1773,32 @@ begin
Result := inherited GetDataAddress;
end;
function TDbgDwarfStructSymbolValue.GetDataSize: Integer;
begin
if (FValueSymbol <> nil) and (FValueSymbol.TypeInfo <> nil) then
Result := FValueSymbol.TypeInfo.Size
else
Result := -1;
end;
function TDbgDwarfStructSymbolValue.GetSize: Integer;
begin
if (Kind <> skClass) and (FValueSymbol <> nil) and (FValueSymbol.TypeInfo <> nil) then
Result := FValueSymbol.TypeInfo.Size
else
Result := -1;
end;
{ TDbgDwarfStructSymbolValue }
function TDbgDwarfStructTypeCastSymbolValue.GetFieldFlags: TDbgSymbolValueFieldFlags;
begin
Result := inherited GetFieldFlags;
Result := Result + [svfMembers]; // svfDataSize
Result := Result + [svfMembers];
if kind = skClass then // todo detect hidden pointer
Result := Result + [svfDataSize]
else
Result := Result + [svfSize];
//TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
if Kind in [skClass] then
@ -1788,6 +1818,22 @@ begin
Result := QWord(DataAddress);
end;
function TDbgDwarfStructTypeCastSymbolValue.GetSize: Integer;
begin
if (Kind <> skClass) and (FTypeCastInfo <> nil) then
Result := FTypeCastInfo.Size
else
Result := -1;
end;
function TDbgDwarfStructTypeCastSymbolValue.GetDataSize: Integer;
begin
if FTypeCastInfo <> nil then
Result := FTypeCastInfo.Size
else
Result := -1;
end;
function TDbgDwarfStructTypeCastSymbolValue.GetDataAddress: TDbgPtr;
var
fields: TDbgSymbolValueFieldFlags;
@ -1848,9 +1894,7 @@ begin
if not Result then
exit;
DebugLnEnter(['>>> TDbgDwarfStructSymbolValue.GetDataAddress ', IntToHex(AnAddress,8)]);
Result := FTypeCastInfo.GetDataAddress(AnAddress, ATargetType);
DebugLnExit(['<<< TDbgDwarfStructSymbolValue.GetDataAddress ']);
end;
function TDbgDwarfStructTypeCastSymbolValue.IsValidTypeCast: Boolean;
@ -2019,7 +2063,7 @@ begin
exit
else
if (FTypeCastSource.FieldFlags * [svfAddress, svfSize] = [svfAddress, svfSize]) and
(FTypeCastSource.Size = FSize)
(FTypeCastSource.Size = FSize) and (FSize > 0)
then
exit;
if (FTypeCastSource.FieldFlags * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) and
@ -2068,6 +2112,11 @@ begin
FIntValue := Result;
end;
function TDbgDwarfNumericSymbolValue.GetSize: Integer;
begin
Result := FSize;
end;
constructor TDbgDwarfNumericSymbolValue.Create(AOwner: TDbgDwarfIdentifier; ASize: Integer);
begin
inherited Create(AOwner);
@ -4632,7 +4681,6 @@ begin
Result := FCU.FOwner.MemReader <> nil;
if not Result then
exit;
DebugLnEnter(['>>> POINTER TDbgDwarfTypeIdentifierPointer.GetDataAddress ']);
//TODO: zero fill / sign extend
case FCU.FAddressSize of
4: begin
@ -4648,7 +4696,6 @@ DebugLnEnter(['>>> POINTER TDbgDwarfTypeIdentifierPointer.GetDataAddress ']);
end;
if Result then
Result := inherited GetDataAddress(AnAddress, ATargetType);
DebugLnExit(['<<< POINTER TDbgDwarfTypeIdentifierPointer.GetDataAddress ']);
end;
function TDbgDwarfTypeIdentifierPointer.GetTypedValueObject(ATypeCast: Boolean): TDbgDwarfSymbolValue;
@ -4742,9 +4789,7 @@ begin
exit;
Assert((TypeInfo is TDbgDwarfIdentifier) and (TypeInfo.SymbolType = stType), 'TDbgDwarfValueIdentifier.GetDataAddress');
AnAddress := Address;
DebugLnEnter(['>>> TDbgDwarfValueIdentifier.GetDataAddress ', IntToHex(AnAddress,8)]);
Result := TDbgDwarfTypeIdentifier(TypeInfo).GetDataAddress(AnAddress, ATargetType);
DebugLnExit(['<<< TDbgDwarfValueIdentifier.GetDataAddress ']);
end;
procedure TDbgDwarfValueIdentifier.KindNeeded;
@ -4967,24 +5012,20 @@ procedure TDbgDwarfIdentifierMember.InitLocationParser(const ALocationParser: TD
var
BaseAddr: TDbgPtr;
begin
DebugLnEnter(['>>> TDbgDwarfIdentifierMember.InitLocationParser ',Self.Name]);
inherited InitLocationParser(ALocationParser, AnObjectDataAddress);
if (StructureValueInfo <> nil) and (ParentTypeInfo <> nil) then begin
DebugLn(['TDbgDwarfIdentifierMember.InitLocationParser AAA']);
Assert((ParentTypeInfo is TDbgDwarfIdentifier) and (ParentTypeInfo.SymbolType = stType), '');
if StructureValueInfo is TDbgDwarfValueIdentifier then begin
if TDbgDwarfValueIdentifier(StructureValueInfo).GetDataAddress(BaseAddr, TDbgDwarfTypeIdentifier(ParentTypeInfo)) then begin
ALocationParser.FStack.Push(BaseAddr, lseValue);
DebugLnExit(['<<< TDbgDwarfIdentifierMember.InitLocationParser GOOD ', BaseAddr,' ',IntToHex(BaseAddr,8)]);
exit
end;
end;
if StructureValueInfo is TDbgDwarfStructTypeCastSymbolValue then begin
if TDbgDwarfStructTypeCastSymbolValue(StructureValueInfo).GetDwarfDataAddress(BaseAddr, TDbgDwarfTypeIdentifier(ParentTypeInfo)) then begin
ALocationParser.FStack.Push(BaseAddr, lseValue);
DebugLnExit(['<<< TDbgDwarfIdentifierMember.InitLocationParser GOOD ', BaseAddr,' ',IntToHex(BaseAddr,8)]);
exit
end;
end;
@ -4992,20 +5033,16 @@ DebugLn(['TDbgDwarfIdentifierMember.InitLocationParser AAA']);
end;
//TODO: error
debugln(['TDbgDwarfIdentifierMember.InitLocationParser FAILED']);
DebugLnExit(['<<< TDbgDwarfIdentifierMember.InitLocationParser ']);
end;
procedure TDbgDwarfIdentifierMember.AddressNeeded;
var
t: TDbgPtr;
begin
DebugLnEnter(['>>> TDbgDwarfIdentifierMember.AddressNeeded ']);
if LocationFromTag(DW_AT_data_member_location, t) then
SetAddress(t)
else
SetAddress(0);
DebugLnExit(['<<< ',t]);
end;
function TDbgDwarfIdentifierMember.HasAddress: Boolean;
@ -5087,19 +5124,15 @@ begin
exit;
end;
DebugLnEnter(['>>> STRUCT TDbgDwarfIdentifierStructure.GetDataAddress ']); try
InitInheritanceInfo;
DebugLn([DbgSName(FInheritanceInfo)]);
//TODO: may be a constant // offset
Result := LocationFromTag(DW_AT_data_member_location, t, AnAddress, FInheritanceInfo);
if not Result then
exit;
debugln(['TDbgDwarfIdentifierStructure.GetDataAddress ', IntToHex(AnAddress,8), ' new ',IntToHex(t,8) ]);
AnAddress := t;
Result := inherited GetDataAddress(AnAddress, ATargetType);
finally DebugLnExit(['>>> STRUCT TDbgDwarfIdentifierStructure.GetDataAddress ']);end;
end;
function TDbgDwarfIdentifierStructure.GetMember(AIndex: Integer): TDbgSymbol;
@ -5199,6 +5232,16 @@ begin
ti.ReleaseReference;
end;
procedure TDbgDwarfIdentifierStructure.SizeNeeded;
var
ByteSize: Integer;
begin
if FInformationEntry.ReadValue(DW_AT_byte_size, ByteSize) then
SetSize(ByteSize)
else
SetSize(0);
end;
function TDbgDwarfIdentifierStructure.GetTypedValueObject(ATypeCast: Boolean): TDbgDwarfSymbolValue;
begin
if ATypeCast then
@ -5513,7 +5556,6 @@ function TDbgDwarfIdentifier.GetDataAddress(var AnAddress: TDbgPtr;
var
ti: TDbgDwarfTypeIdentifier;
begin
debugln(['TDbgDwarfIdentifier.GetDataAddress ',DbgSName(Self), ' targ ',DbgSName(ATargetType)]);
if ATargetType = Self then begin
Result := True;
end

4
components/fpdebug/fpdbginfo.pas
View File

@ -150,7 +150,7 @@ type
function GetAsWideString: WideString; virtual;
function GetAddress: TDbgPtr; virtual;
function GetSize: Integer; virtual;
function GetSize: Integer; virtual; // returns -1, if not available
function GetDataAddress: TDbgPtr; virtual;
function GetDataSize: Integer; virtual;
@ -526,7 +526,7 @@ end;
function TDbgSymbolValue.GetSize: Integer;
begin
Result := 0;
Result := -1;
end;
function TDbgSymbolValue.GetAsBool: Boolean;

4
components/fpdebug/fppascalparser.pas
View File

@ -571,7 +571,7 @@ end;
function TPasParserSymbolValueCastToPointer.GetFieldFlags: TDbgSymbolValueFieldFlags;
begin
if svfCardinal in FValue.FieldFlags then
Result := [svfOrdinal, svfCardinal, svfDataAddress]
Result := [svfOrdinal, svfCardinal, svfSizeOfPointer, svfDataAddress]
else
Result := [];
end;
@ -768,7 +768,7 @@ end;
function TPasParserSymbolValueAddressOf.GetFieldFlags: TDbgSymbolValueFieldFlags;
begin
Result := [svfOrdinal, svfCardinal, svfDataAddress];
Result := [svfOrdinal, svfCardinal, svfSizeOfPointer, svfDataAddress];
end;
function TPasParserSymbolValueAddressOf.GetAsInteger: Int64;

108
components/fpdebug/test/testtypeinfo.pas
View File

@ -18,13 +18,13 @@ type
protected
FDwarfInfo: TDbgDwarf;
published
Procedure New1;
procedure X;
Procedure TestExpressions;
procedure TestCompareUtf8BothCase;
end;
implementation
procedure TTestTypInfo.X;
procedure TTestTypInfo.TestCompareUtf8BothCase;
var
s1, s2,s3: String;
begin
@ -41,7 +41,7 @@ begin
AssertFalse( CompareUtf8BothCase(@s2[1],@s3[1],@s1[1]) );
end;
procedure TTestTypInfo.New1;
procedure TTestTypInfo.TestExpressions;
type
TTestFlag = (ttHasType, ttNotHasType, ttHasSymbol, ttHasValSymbol, ttHasTypeSymbol);
TTestFlags = set of TTestFlag;
@ -50,6 +50,26 @@ var
Ctx: TDbgInfoAddressContext;
Expression: TFpPascalExpression;
procedure ExpFlags(ExpFlags: TDbgSymbolValueFieldFlags; ExpNotFlags: TDbgSymbolValueFieldFlags = []);
var
i: TDbgSymbolValueFieldFlag;
s: string;
f: TDbgSymbolValueFieldFlags;
begin
AssertTrue(CurrentTestName + 'has ResVal', Expression.ResultValue <> nil);
f := Expression.ResultValue.FieldFlags;
For i := low(TDbgSymbolValueFieldFlag) to High(TDbgSymbolValueFieldFlag) do
if i in ExpFlags then begin
WriteStr(s, i);
AssertTrue(CurrentTestName + 'Has flag' + s, i in f);
end;
For i := low(TDbgSymbolValueFieldFlag) to High(TDbgSymbolValueFieldFlag) do
if i in ExpNotFlags then begin
WriteStr(s, i);
AssertTrue(CurrentTestName + 'Has NOT flag' + s, not (i in f));
end;
end;
procedure InitTest(Expr: String; ExtraName: String = '');
begin
if ExtraName <> '' then ExtraName := ' (' + ExtraName + ')';
@ -88,7 +108,40 @@ var
WriteStr(s, CurrentTestName, 'typeinfo.Kind exected ', ExpKind, ' but was ', Expression.ResultValue.TypeInfo.Kind);
AssertTrue(s, Expression.ResultValue.TypeInfo.Kind = ExpKind);
end;
// some general assumptions
s := CurrentTestName;
WriteStr(CurrentTestName, s, ' Expecting for kind:', ExpKind);
case ExpKind of
skInstance: ;
skUnit: ;
skRecord: ExpFlags([svfMembers], [svfOrdinal, svfInteger, svfCardinal, svfDataAddress, svfDataSize]);
skObject: ExpFlags([svfMembers], [svfOrdinal, svfInteger, svfCardinal, svfDataAddress, svfDataSize]);
// skClass does NOT have svfSize (maybe svfSizeOfPointer ?);
skClass: ExpFlags([svfOrdinal, svfMembers, svfDataAddress, svfDataSize], [svfSize, svfInteger, svfCardinal]);
skInterface: ;
skProcedure: ;
skFunction: ;
skArray: ;
// skPointer: svfOrdinal, svfCardinal, svfDataAddress are all the same value
skPointer: ExpFlags([svfOrdinal, svfCardinal, svfDataAddress, svfSizeOfPointer], [svfMembers]);
skInteger: ExpFlags([svfOrdinal, svfInteger], [svfDataAddress, svfDataSize, svfMembers]);
skCardinal: ExpFlags([svfOrdinal, svfCardinal], [svfDataAddress, svfDataSize, svfMembers]);
skBoolean: ;
skChar: ;
skFloat: ;
skString: ;
skAnsiString: ;
skCurrency: ;
skVariant: ;
skWideString: ;
skEnum: ;
skEnumValue: ;
skSet: ;
skRegister: ;
end;
CurrentTestName := s;
end;
procedure StartInvalTest(Expr: String; ExpError: String; ExtraName: String = '');
begin
InitTest(Expr, ExtraName);
@ -98,25 +151,6 @@ var
//ExpError
end;
procedure ExpFlags(ExpFlags: TDbgSymbolValueFieldFlags; ExpNotFlags: TDbgSymbolValueFieldFlags = []);
var
i: TDbgSymbolValueFieldFlag;
s: string;
f: TDbgSymbolValueFieldFlags;
begin
AssertTrue(CurrentTestName + 'has ResVal', Expression.ResultValue <> nil);
f := Expression.ResultValue.FieldFlags;
For i := low(TDbgSymbolValueFieldFlag) to High(TDbgSymbolValueFieldFlag) do
if i in ExpFlags then begin
WriteStr(s, i);
AssertTrue(CurrentTestName + 'Has flag' + s, i in f);
end;
For i := low(TDbgSymbolValueFieldFlag) to High(TDbgSymbolValueFieldFlag) do
if i in ExpNotFlags then begin
WriteStr(s, i);
AssertTrue(CurrentTestName + 'Has NOT flag' + s, not (i in f));
end;
end;
procedure ExpResult(Field: TDbgSymbolValueFieldFlag; ExpValue: QWord);
procedure AssertEqualsQW(const AMessage: string; Expected, Actual: QWord);
begin
@ -238,8 +272,14 @@ begin
StartInvalTest('^longint(@99)', 'xxx');
StartInvalTest('PInt(@99)', 'xxx');
StartInvalTest('@Int1^', 'xxx');
StartInvalTest('^(longint(Int1))', 'xxx'); // no ( allowed between ^ and type
StartTest('LongInt', [ttHasSymbol, ttNotHasType]);
StartTest('^LongInt', [ttHasSymbol, ttNotHasType]);
StartTest('TObject', [ttHasSymbol, ttNotHasType]);
StartTest('^TObject', [ttHasSymbol, ttNotHasType]);
// TODO: maybe treat numbers as integer?
StartTest('244', skCardinal, []);
@ -250,7 +290,7 @@ begin
ImageLoader.TestStackFrame.pint1 := @ImageLoader.TestStackFrame.Int1;
ImageLoader.GlobTestSetup1.VarQWord := PtrInt(@ImageLoader.TestStackFrame.pint1);
ImageLoader.GlobTestSetup1.VarPointer := @ImageLoader.TestStackFrame.pint1;
for i := 0 to 17 do begin
for i := 0 to 22 do begin
case i of
0: s := 'Int1';
1: s := 'longint(Int1)';
@ -270,6 +310,11 @@ begin
15: s := '^^longint(GlobTestSetup1QWord)^^';
16: s := '^^^longint(@GlobTestSetup1QWord)^^^';
17: s := '^^^longint('+IntToStr((PtrUInt(@ImageLoader.GlobTestSetup1.VarPointer)))+')^^^';
18: s := '(^^^longint('+IntToStr((PtrUInt(@ImageLoader.GlobTestSetup1.VarPointer)))+')^^)^';
19: s := '(^^^longint('+IntToStr((PtrUInt(@ImageLoader.GlobTestSetup1.VarPointer)))+')^)^^';
20: s := '((^^^longint('+IntToStr((PtrUInt(@ImageLoader.GlobTestSetup1.VarPointer)))+')^)^)^';
21: s := '^^PInt('+IntToStr((PtrUInt(@ImageLoader.GlobTestSetup1.VarPointer)))+')^^^';
22: s := '(^^PInt('+IntToStr((PtrUInt(@ImageLoader.GlobTestSetup1.VarPointer)))+')^^)^';
end;
StartTest(s, skInteger, [ttHasType]);
@ -277,6 +322,10 @@ begin
ExpResult(svfInteger, -299);
ExpResult(svfOrdinal, QWord(-299));
ExpResult(svfAddress, TDbgPtr(PtrUInt(@ImageLoader.TestStackFrame.Int1)));
case i of
0,1,3..7,10..22: ExpResult(svfSize, 4); // integer
2,8: ExpResult(svfSize, 8); // int64
end;
end;
for i := 0 to 19 do begin
@ -355,9 +404,9 @@ begin
Obj1.FWord := 1019;
Obj1.FWordL := QWord($9aa99aa97bb7b77b); // Make sure there is data, if other fields read to much
for i := 0 to 22 do begin
for i := 0 to 23 do begin
case i of
11..13: ImageLoader.GlobTestSetup1.VarPointer := @ImageLoader.TestStackFrame.Obj1;
11..13, 23: ImageLoader.GlobTestSetup1.VarPointer := @ImageLoader.TestStackFrame.Obj1;
14: ImageLoader.GlobTestSetup1.VarPointer := Pointer(ImageLoader.TestStackFrame.Obj1);
end;
// Different ways to access an object
@ -392,6 +441,7 @@ begin
20: s := '(@PObj1)^^';
21: s := 'VParamTestSetup1Class';
22: s := 'VParamTestSetup1ClassP^';
23: s := '^TTestSetup1Class(GlobTestSetup1Pointer)^';
end;
FieldsExp := [svfMembers, svfOrdinal, svfAddress, svfDataAddress]; // svfSize dataSize;
AddrExp := TDbgPtr(@ImageLoader.TestStackFrame.Obj1);
@ -408,6 +458,10 @@ begin
ExpResult(svfAddress, AddrExp);
ExpResult(svfDataAddress, TDbgPtr(PtrUInt(ImageLoader.TestStackFrame.Obj1)));
ExpResult(svfOrdinal, PtrUInt (ImageLoader.TestStackFrame.Obj1));
case i of
5,6: ExpResult(svfDataSize, TObject.InstanceSize);
else ExpResult(svfDataSize, ImageLoader.TestStackFrame.Obj1.InstanceSize);
end;
// Check result for @object
@ -522,6 +576,7 @@ begin
// svfSize;
ExpFlags([svfMembers, svfAddress], [svfOrdinal, svfCardinal, svfInteger, svfDataAddress]);
ExpResult(svfAddress, TDbgPtr(PtrUInt(@ImageLoader.TestStackFrame.Rec1)));
ExpResult(svfSize, SizeOf(ImageLoader.TestStackFrame.Rec1));
StartTest(s+'.FWord', skCardinal, [ttHasType]);
@ -586,6 +641,7 @@ begin
StartTest(s, skObject, [ttHasType]);
ExpFlags([svfMembers, svfAddress], [svfOrdinal, svfCardinal, svfInteger, svfDataAddress]);
ExpResult(svfAddress, AddrExp);
ExpResult(svfSize, SizeOf(ImageLoader.TestStackFrame.OldObj1));
case i of
2,4: AddrExp := TDbgPtr(PtrUInt(@ImageLoader.TestStackFrame.OldObj1.FWord));