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

FpDebug: limit array stride workaround to fpc < 3.3 / Fix stride calculations

Browse Source 
git-svn-id: trunk@62047 -
This commit is contained in:
martin 2019-10-13 12:25:40 +00:00
parent 765c460114
commit b11f360499
2 changed files with 145 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
components/fpdebug/fpdbgdwarf.pas
View File

@ -628,7 +628,7 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
procedure Init; override;
procedure MemberVisibilityNeeded; override;
function DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; override;
function DoReadStride(AValueObj: TFpValueDwarf; out AStride: TFpDbgValueSize): Boolean;
function DoReadStride(AValueObj: TFpValueDwarf; out AStride: TFpDbgValueSize): Boolean; virtual;
public
(* GetTypedValueObject
AnOuterType: If the type is a "chain" (Declaration > Pointer > ActualType)
@ -687,6 +687,7 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
procedure TypeInfoNeeded; override;
procedure ForwardToSymbolNeeded; override;
function DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; override;
function DoReadStride(AValueObj: TFpValueDwarf; out AStride: TFpDbgValueSize): Boolean; override;
function GetNextTypeInfoForDataAddress(ATargetType: TFpSymbolDwarfType): TFpSymbolDwarfType; override;
public
function GetTypedValueObject(ATypeCast: Boolean; AnOuterType: TFpSymbolDwarfType = nil): TFpValueDwarf; override;
@ -708,9 +709,8 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
{ TFpSymbolDwarfTypeSubRange }
TFpSymbolDwarfTypeSubRange = class(TFpSymbolDwarfTypeModifier)
TFpSymbolDwarfTypeSubRange = class(TFpSymbolDwarfTypeModifierBase)
// TODO not a modifier, maybe have a forwarder base class
// GetNextTypeInfoForDataAddress => wrong behaviour, but basetypes should not change addr anyway.
private
FLowBoundConst: Int64;
FLowBoundSymbol: TFpSymbolDwarfData;
@ -725,7 +725,9 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
FEnumIdxValid: Boolean;
procedure InitEnumIdx;
protected
function DoGetNestedTypeInfo: TFpSymbolDwarfType;override;
function DoGetNestedTypeInfo: TFpSymbolDwarfType; override;
procedure ForwardToSymbolNeeded; override;
procedure TypeInfoNeeded; override;
procedure NameNeeded; override;
procedure KindNeeded; override;
@ -738,6 +740,7 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
procedure ResetValueBounds; override;
destructor Destroy; override;
function GetTypedValueObject(ATypeCast: Boolean; AnOuterType: TFpSymbolDwarfType = nil): TFpValueDwarf; 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;
@ -3732,6 +3735,7 @@ var
AttrData: TDwarfAttribData;
begin
AStride := ZeroSize;
Result := False;
if InformationEntry.GetAttribData(DW_AT_bit_stride, AttrData) then begin
Result := ConstRefOrExprFromAttrData(AttrData, AValueObj as TFpValueDwarf, BitStride);
AStride := SizeFromBits(BitStride);
@ -3944,7 +3948,7 @@ end;
procedure TFpSymbolDwarfTypeModifier.ForwardToSymbolNeeded;
begin
SetForwardToSymbol(NestedTypeInfo)
SetForwardToSymbol(NestedTypeInfo);
end;
function TFpSymbolDwarfTypeModifier.DoReadSize(const AValueObj: TFpValue; out
@ -3953,6 +3957,18 @@ begin
Result := inherited DoForwardReadSize(AValueObj, ASize);
end;
function TFpSymbolDwarfTypeModifier.DoReadStride(AValueObj: TFpValueDwarf; out
AStride: TFpDbgValueSize): Boolean;
var
p: TFpSymbol;
begin
p := GetForwardToSymbol;
if p <> nil then
Result := TFpSymbolDwarfType(p).DoReadStride(AValueObj, AStride)
else
Result := inherited DoReadStride(AValueObj, AStride);
end;
function TFpSymbolDwarfTypeModifier.GetNextTypeInfoForDataAddress(
ATargetType: TFpSymbolDwarfType): TFpSymbolDwarfType;
begin
@ -4047,6 +4063,22 @@ begin
Result := FCountSymbol.TypeInfo as TFpSymbolDwarfType;
end;
procedure TFpSymbolDwarfTypeSubRange.ForwardToSymbolNeeded;
begin
SetForwardToSymbol(NestedTypeInfo);
end;
procedure TFpSymbolDwarfTypeSubRange.TypeInfoNeeded;
var
p: TFpSymbolDwarfType;
begin
p := NestedTypeInfo;
if p <> nil then
SetTypeInfo(p.TypeInfo)
else
SetTypeInfo(nil);
end;
procedure TFpSymbolDwarfTypeSubRange.NameNeeded;
var
AName: String;
@ -4132,6 +4164,20 @@ begin
inherited Destroy;
end;
function TFpSymbolDwarfTypeSubRange.GetTypedValueObject(ATypeCast: Boolean;
AnOuterType: TFpSymbolDwarfType): TFpValueDwarf;
var
ti: TFpSymbolDwarfType;
begin
if AnOuterType = nil then
AnOuterType := Self;
ti := NestedTypeInfo;
if ti <> nil then
Result := ti.GetTypedValueObject(ATypeCast, AnOuterType)
else
Result := inherited;
end;
function TFpSymbolDwarfTypeSubRange.GetValueBounds(AValueObj: TFpValue; out
ALowBound, AHighBound: Int64): Boolean;
begin

165
components/fpdebug/fpdbgdwarffreepascal.pas
View File

@ -19,11 +19,16 @@ type
TFpDwarfFreePascalSymbolClassMap = class(TFpDwarfDefaultSymbolClassMap)
strict private
class var ExistingClassMap: TFpSymbolDwarfClassMap;
private
FCompilerVersion: Cardinal;
protected
function CanHandleCompUnit(ACU: TDwarfCompilationUnit; AHelperData: Pointer): Boolean; override;
class function GetExistingClassMap: PFpDwarfSymbolClassMap; override;
public
class function GetInstanceForCompUnit(ACU: TDwarfCompilationUnit): TFpSymbolDwarfClassMap; override;
class function ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
public
constructor Create(ACU: TDwarfCompilationUnit; AHelperData: Pointer); override;
function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
function CreateContext(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpSymbol;
ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
@ -53,16 +58,11 @@ type
TFpDwarfFreePascalSymbolClassMapDwarf3 = class(TFpDwarfFreePascalSymbolClassMap)
strict private
class var ExistingClassMap: TFpSymbolDwarfClassMap;
private
FCompilerVersion: Cardinal;
protected
function CanHandleCompUnit(ACU: TDwarfCompilationUnit; AHelperData: Pointer): Boolean; override;
class function GetExistingClassMap: PFpDwarfSymbolClassMap; override;
public
class function GetInstanceForCompUnit(ACU: TDwarfCompilationUnit): TFpSymbolDwarfClassMap; override;
class function ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
public
constructor Create(ACU: TDwarfCompilationUnit; AHelperData: Pointer); override;
function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
//class function CreateContext(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpSymbol;
// ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
@ -113,6 +113,7 @@ type
protected
procedure TypeInfoNeeded; override;
procedure KindNeeded; override;
function DoReadStride(AValueObj: TFpValueDwarf; out AStride: TFpDbgValueSize): Boolean; override;
procedure ForwardToSymbolNeeded; override;
function GetNextTypeInfoForDataAddress(ATargetType: TFpSymbolDwarfType): TFpSymbolDwarfType; override;
function GetDataAddressNext(AValueObj: TFpValueDwarf; var AnAddress: TFpDbgMemLocation;
@ -216,11 +217,65 @@ implementation
{ TFpDwarfFreePascalSymbolClassMap }
function TFpDwarfFreePascalSymbolClassMap.CanHandleCompUnit(
ACU: TDwarfCompilationUnit; AHelperData: Pointer): Boolean;
begin
Result := (FCompilerVersion = PtrUInt(AHelperData)) and
inherited CanHandleCompUnit(ACU, AHelperData);
end;
class function TFpDwarfFreePascalSymbolClassMap.GetExistingClassMap: PFpDwarfSymbolClassMap;
begin
Result := @ExistingClassMap;
end;
class function TFpDwarfFreePascalSymbolClassMap.GetInstanceForCompUnit(
ACU: TDwarfCompilationUnit): TFpSymbolDwarfClassMap;
var
s: String;
i, j, AVersion: Integer;
begin
AVersion := 0;
s := LowerCase(ACU.Producer)+' ';
i := pos('free pascal', s) + 11;
if i > 11 then begin
while (i < Length(s)) and (s[i] in [' ', #9]) do
inc(i);
delete(s, 1, i - 1);
i := pos('.', s);
if (i > 1) then begin
j := StrToIntDef(copy(s, 1, i - 1), 0);
if (j >= 0) then
AVersion := j * $10000;
delete(s, 1, i);
end;
if (AVersion > 0) then begin
i := pos('.', s);
if (i > 1) then begin
j := StrToIntDef(copy(s, 1, i - 1), 0);
if (j >= 0) and (j < 99) then
AVersion := AVersion + j * $100
else
AVersion := 0;
delete(s, 1, i);
end;
end;
if (AVersion > 0) then begin
i := pos(' ', s);
if (i > 1) then begin
j := StrToIntDef(copy(s, 1, i - 1), 0);
if (j >= 0) and (j < 99) then
AVersion := AVersion + j
else
AVersion := 0;
end;
end;
end;
Result := DoGetInstanceForCompUnit(ACU, Pointer(PtrUInt(AVersion)));
end;
class function TFpDwarfFreePascalSymbolClassMap.ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean;
var
s: String;
@ -229,6 +284,13 @@ begin
Result := pos('free pascal', s) > 0;
end;
constructor TFpDwarfFreePascalSymbolClassMap.Create(ACU: TDwarfCompilationUnit;
AHelperData: Pointer);
begin
FCompilerVersion := PtrUInt(AHelperData);
inherited Create(ACU, AHelperData);
end;
function TFpDwarfFreePascalSymbolClassMap.GetDwarfSymbolClass(
ATag: Cardinal): TDbgDwarfSymbolBaseClass;
begin
@ -288,64 +350,11 @@ end;
{ TFpDwarfFreePascalSymbolClassMapDwarf3 }
function TFpDwarfFreePascalSymbolClassMapDwarf3.CanHandleCompUnit(
ACU: TDwarfCompilationUnit; AHelperData: Pointer): Boolean;
begin
Result := (FCompilerVersion = PtrUInt(AHelperData)) and
inherited CanHandleCompUnit(ACU, AHelperData);
end;
class function TFpDwarfFreePascalSymbolClassMapDwarf3.GetExistingClassMap: PFpDwarfSymbolClassMap;
begin
Result := @ExistingClassMap;
end;
class function TFpDwarfFreePascalSymbolClassMapDwarf3.GetInstanceForCompUnit(
ACU: TDwarfCompilationUnit): TFpSymbolDwarfClassMap;
var
s: String;
i, j, v: Integer;
begin
s := LowerCase(ACU.Producer)+' ';
v := 0;
i := pos('free pascal', s) + 11;
if i > 11 then begin
while (i < Length(s)) and (s[i] in [' ', #9]) do
inc(i);
delete(s, 1, i - 1);
i := pos('.', s);
if (i > 1) then begin
j := StrToIntDef(copy(s, 1, i - 1), 0);
if (j >= 0) then
v := j * $10000;
delete(s, 1, i);
end;
if (v > 0) then begin
i := pos('.', s);
if (i > 1) then begin
j := StrToIntDef(copy(s, 1, i - 1), 0);
if (j >= 0) and (j < 99) then
v := v + j * $100
else
v := 0;
delete(s, 1, i);
end;
end;
if (v > 0) then begin
i := pos(' ', s);
if (i > 1) then begin
j := StrToIntDef(copy(s, 1, i - 1), 0);
if (j >= 0) and (j < 99) then
v := v + j
else
v := 0;
end;
end;
end;
Result := DoGetInstanceForCompUnit(ACU, Pointer(PtrUInt(v)));
end;
class function TFpDwarfFreePascalSymbolClassMapDwarf3.ClassCanHandleCompUnit(
ACU: TDwarfCompilationUnit): Boolean;
begin
@ -353,13 +362,6 @@ begin
Result := Result and (ACU.Version >= 3);
end;
constructor TFpDwarfFreePascalSymbolClassMapDwarf3.Create(
ACU: TDwarfCompilationUnit; AHelperData: Pointer);
begin
FCompilerVersion := PtrUInt(AHelperData);
inherited;
end;
function TFpDwarfFreePascalSymbolClassMapDwarf3.GetDwarfSymbolClass(
ATag: Cardinal): TDbgDwarfSymbolBaseClass;
begin
@ -641,6 +643,15 @@ begin
inherited;
end;
function TFpSymbolDwarfFreePascalTypePointer.DoReadStride(
AValueObj: TFpValueDwarf; out AStride: TFpDbgValueSize): Boolean;
begin
if IsInternalPointer then
Result := NestedTypeInfo.ReadStride(AValueObj, AStride)
else
Result := inherited DoReadStride(AValueObj, AStride);
end;
procedure TFpSymbolDwarfFreePascalTypePointer.ForwardToSymbolNeeded;
begin
if IsInternalPointer then
@ -924,8 +935,11 @@ end;
function TFpValueDwarfFreePascalArray.DoGetStride(out AStride: TFpDbgValueSize
): Boolean;
begin
//Result := inherited DoGetStride(AStride);
Result := TFpSymbolDwarfType(TypeInfo.NestedSymbol[0]).ReadStride(Self, AStride);
if (TFpDwarfFreePascalSymbolClassMapDwarf3(TypeInfo.CompilationUnit.DwarfSymbolClassMap).FCompilerVersion >= $030300)
then
Result := inherited DoGetStride(AStride)
else
Result := TFpSymbolDwarfType(TypeInfo.NestedSymbol[0]).ReadStride(Self, AStride);
end;
function TFpValueDwarfFreePascalArray.DoGetMainStride(out
@ -933,15 +947,24 @@ function TFpValueDwarfFreePascalArray.DoGetMainStride(out
var
ExtraStride: TFpDbgValueSize;
begin
Result := GetMemberSize(AStride);
if (TFpDwarfFreePascalSymbolClassMapDwarf3(TypeInfo.CompilationUnit.DwarfSymbolClassMap).FCompilerVersion >= $030300)
then
Result := inherited DoGetMainStride(AStride)
else
Result := GetMemberSize(AStride);
end;
function TFpValueDwarfFreePascalArray.DoGetDimStride(AnIndex: integer; out
AStride: TFpDbgValueSize): Boolean;
begin
//Result := inherited DoGetDimStride(AnIndex, AStride);
Result := True;
AStride := ZeroSize;
if (TFpDwarfFreePascalSymbolClassMapDwarf3(TypeInfo.CompilationUnit.DwarfSymbolClassMap).FCompilerVersion >= $030300)
then
Result := inherited DoGetDimStride(AnIndex, AStride)
else
begin
Result := True;
AStride := ZeroSize;
end;
end;
{ TFpSymbolDwarfV3FreePascalSymbolTypeArray }