diff --git a/components/fpdebug/fpdbgdwarf.pas b/components/fpdebug/fpdbgdwarf.pas index 899da0cc8c..a8dde63d15 100644 --- a/components/fpdebug/fpdbgdwarf.pas +++ b/components/fpdebug/fpdbgdwarf.pas @@ -204,6 +204,7 @@ type ASource: TFpDbgValue): Boolean; // Used for Typecast // StructureValue: Any Value returned via GetMember points to its structure property StructureValue: TFpDwarfValue read FStructureValue write SetStructureValue; + property ValueSymbol: TFpDwarfSymbolValue read FValueSymbol; // DataAddressCache[0]: ValueAddress // DataAddressCache[1..n]: DataAddress property DataAddressCache[AIndex: Integer]: TFpDbgMemLocation read GetDataAddressCache write SetDataAddressCache; end; @@ -430,6 +431,14 @@ type public destructor Destroy; override; end; + + { TFpDwarfValueSubroutine } + + TFpDwarfValueSubroutine = class(TFpDwarfValue) + protected + function GetDataAddress: TFpDbgMemLocation; override; + function IsValidTypeCast: Boolean; override; + end; {%endregion Value objects } {%region Symbol objects } @@ -726,6 +735,29 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line property IsInternalPointer: Boolean read GetIsInternalPointer write FIsInternalPointer; // Class (also DynArray, but DynArray is handled without this) end; + { TFpDwarfSymbolTypeSubroutine } + + TFpDwarfSymbolTypeSubroutine = class(TFpDwarfSymbolType) + private + FProcMembers: TRefCntObjList; + FLastMember: TFpDbgSymbol; + procedure CreateMembers; + protected + //copied from TFpDwarfSymbolValueProc + function GetMember(AIndex: Int64): TFpDbgSymbol; override; + function GetMemberByName(AIndex: String): TFpDbgSymbol; override; + function GetMemberCount: Integer; override; + + function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override; + // TODO: deal with DW_TAG_pointer_type + function GetDataAddressNext(AValueObj: TFpDwarfValue; + var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType; + ATargetCacheIndex: Integer): Boolean; override; + procedure KindNeeded; override; + public + destructor Destroy; override; + end; + { TFpDwarfSymbolValueEnumMember } TFpDwarfSymbolValueEnumMember = class(TFpDwarfSymbolValue) @@ -893,6 +925,8 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line // function GetFlags: TDbgSymbolFlags; override; function GetLine: Cardinal; override; function GetValueObject: TFpDbgValue; override; + function GetValueAddress(AValueObj: TFpDwarfValue; out + AnAddress: TFpDbgMemLocation): Boolean; override; public constructor Create(ACompilationUnit: TDwarfCompilationUnit; AInfo: PDwarfAddressInfo; AAddress: TDbgPtr); overload; destructor Destroy; override; @@ -946,6 +980,62 @@ begin WriteStr(Result, ASubRangeBoundReadState); end; +{ TFpDwarfValueSubroutine } + +function TFpDwarfValueSubroutine.GetDataAddress: TFpDbgMemLocation; +var + fields: TFpDbgValueFieldFlags; + t: TFpDbgMemLocation; +begin + if (FValueSymbol <> nil) then begin + if not FValueSymbol.GetValueDataAddress(Self, Result) then + Result := InvalidLoc; + end + else + if (FTypeCastSourceValue <> nil) then begin + fields := FTypeCastSourceValue.FieldFlags; + if svfOrdinal in fields then + Result := TargetLoc(TDbgPtr(FTypeCastSourceValue.AsCardinal)) + else + if svfAddress in fields then begin + Result := InvalidLoc; + t := FTypeCastSourceValue.Address; + assert(SizeOf(Result) >= AddressSize, 'TDbgDwarfStructSymbolValue.GetDataAddress'); + if (MemManager <> nil) then begin + Result := MemManager.ReadAddress(t, AddressSize); + if not IsValidLoc(Result) then + FLastError := MemManager.LastError; + end; + end; + end + else + Result := InvalidLoc; +end; + +function TFpDwarfValueSubroutine.IsValidTypeCast: Boolean; +var + f: TFpDbgValueFieldFlags; +begin + Result := HasTypeCastInfo; + If not Result then + exit; + + f := FTypeCastSourceValue.FieldFlags; + if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then + exit; + + if (svfOrdinal in f)then + exit; + if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and + (FTypeCastSourceValue.Size = FOwner.CompilationUnit.AddressSize) + then + exit; + if (f * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) then + exit; + + Result := False; +end; + { TFpDwarfDefaultSymbolClassMap } class function TFpDwarfDefaultSymbolClassMap.GetExistingClassMap: PFpDwarfSymbolClassMap; @@ -967,7 +1057,7 @@ begin DW_TAG_string_type, DW_TAG_union_type, DW_TAG_ptr_to_member_type, DW_TAG_file_type, - DW_TAG_thrown_type, DW_TAG_subroutine_type: + DW_TAG_thrown_type: Result := TFpDwarfSymbolType; // Type types @@ -986,11 +1076,13 @@ begin DW_TAG_structure_type, DW_TAG_class_type: Result := TFpDwarfSymbolTypeStructure; DW_TAG_array_type: Result := TFpDwarfSymbolTypeArray; + DW_TAG_subroutine_type: Result := TFpDwarfSymbolTypeSubroutine; // Value types DW_TAG_variable: Result := TFpDwarfSymbolValueVariable; DW_TAG_formal_parameter: Result := TFpDwarfSymbolValueParameter; DW_TAG_member: Result := TFpDwarfSymbolValueMember; DW_TAG_subprogram: Result := TFpDwarfSymbolValueProc; + //DW_TAG_inlined_subroutine, DW_TAG_entry_poin // DW_TAG_compile_unit: Result := TFpDwarfSymbolUnit; @@ -3935,6 +4027,116 @@ begin Result := inherited DataSize; end; +{ TFpDwarfSymbolTypeSubroutine } + +procedure TFpDwarfSymbolTypeSubroutine.CreateMembers; +var + Info: TDwarfInformationEntry; + Info2: TDwarfInformationEntry; +begin + if FProcMembers <> nil then + exit; + FProcMembers := TRefCntObjList.Create; + Info := InformationEntry.Clone; + Info.GoChild; + + while Info.HasValidScope do begin + if ((Info.AbbrevTag = DW_TAG_formal_parameter) or (Info.AbbrevTag = DW_TAG_variable)) //and + //not(Info.IsArtificial) + then begin + Info2 := Info.Clone; + FProcMembers.Add(Info2); + Info2.ReleaseReference; + end; + Info.GoNext; + end; + + Info.ReleaseReference; +end; + +function TFpDwarfSymbolTypeSubroutine.GetMember(AIndex: Int64): TFpDbgSymbol; +begin + CreateMembers; + FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF}; + FLastMember := TFpDwarfSymbol.CreateSubClass('', TDwarfInformationEntry(FProcMembers[AIndex])); + {$IFDEF WITH_REFCOUNT_DEBUG}FLastMember.DbgRenameReference(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember');{$ENDIF} + Result := FLastMember; +end; + +function TFpDwarfSymbolTypeSubroutine.GetMemberByName(AIndex: String + ): TFpDbgSymbol; +var + Info: TDwarfInformationEntry; + s, s2: String; + i: Integer; +begin + CreateMembers; + s2 := LowerCase(AIndex); + FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF}; + FLastMember := nil;; + for i := 0 to FProcMembers.Count - 1 do begin + Info := TDwarfInformationEntry(FProcMembers[i]); + if Info.ReadName(s) and (LowerCase(s) = s2) then begin + FLastMember := TFpDwarfSymbol.CreateSubClass('', Info); + {$IFDEF WITH_REFCOUNT_DEBUG}FLastMember.DbgRenameReference(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember');{$ENDIF} + break; + end; + end; + Result := FLastMember; +end; + +function TFpDwarfSymbolTypeSubroutine.GetMemberCount: Integer; +begin + CreateMembers; + Result := FProcMembers.Count; +end; + +function TFpDwarfSymbolTypeSubroutine.GetTypedValueObject(ATypeCast: Boolean + ): TFpDwarfValue; +begin + Result := TFpDwarfValueSubroutine.Create(Self); +end; + +function TFpDwarfSymbolTypeSubroutine.GetDataAddressNext( + AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation; + ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; +var + t: TFpDbgMemLocation; +begin + t := AValueObj.DataAddressCache[ATargetCacheIndex]; + if IsInitializedLoc(t) then begin + AnAddress := t; + end + else begin + Result := AValueObj.MemManager <> nil; + if not Result then + exit; + AnAddress := AValueObj.MemManager.ReadAddress(AnAddress, CompilationUnit.AddressSize); + AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress; + end; + Result := IsValidLoc(AnAddress); + + if not Result then + if IsError(AValueObj.MemManager.LastError) then + SetLastError(AValueObj.MemManager.LastError); + // Todo: other error +end; + +procedure TFpDwarfSymbolTypeSubroutine.KindNeeded; +begin + if TypeInfo <> nil then + SetKind(skFunctionRef) + else + SetKind(skProcedureRef); +end; + +destructor TFpDwarfSymbolTypeSubroutine.Destroy; +begin + FreeAndNil(FProcMembers); + FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF}; + inherited Destroy; +end; + { TDbgDwarfIdentifierEnumElement } procedure TFpDwarfSymbolValueEnumMember.ReadOrdinalValue; @@ -4648,7 +4850,7 @@ begin Result := FValueObject; if Result <> nil then exit; - FValueObject := TFpDwarfValue.Create(nil); + FValueObject := TFpDwarfValueSubroutine.Create(nil); {$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF} FValueObject.MakePlainRefToCirclular; FValueObject.SetValueSymbol(self); @@ -4656,6 +4858,25 @@ begin Result := FValueObject; end; +function TFpDwarfSymbolValueProc.GetValueAddress(AValueObj: TFpDwarfValue; out + AnAddress: TFpDbgMemLocation): Boolean; +var + AttrData: TDwarfAttribData; + Addr: TDBGPtr; +begin + AnAddress := AValueObj.DataAddressCache[0]; + Result := IsValidLoc(AnAddress); + if IsInitializedLoc(AnAddress) then + exit; + AnAddress := InvalidLoc; + if InformationEntry.GetAttribData(DW_AT_low_pc, AttrData) then + if InformationEntry.ReadAddressValue(AttrData, Addr) then + AnAddress := TargetLoc(Addr); + //DW_AT_ranges + Result := IsValidLoc(AnAddress); + AValueObj.DataAddressCache[0] := AnAddress; +end; + function TFpDwarfSymbolValueProc.StateMachineValid: Boolean; var SM1, SM2: TDwarfLineInfoStateMachine; diff --git a/components/fpdebug/fpdbgdwarfdataclasses.pas b/components/fpdebug/fpdbgdwarfdataclasses.pas index 4893e812a3..2bd36b6d2d 100644 --- a/components/fpdebug/fpdbgdwarfdataclasses.pas +++ b/components/fpdebug/fpdbgdwarfdataclasses.pas @@ -331,6 +331,7 @@ type function ReadValue(const AnAttribData: TDwarfAttribData; out AValue: PChar): Boolean; inline; function ReadValue(const AnAttribData: TDwarfAttribData; out AValue: String): Boolean; inline; function ReadValue(const AnAttribData: TDwarfAttribData; out AValue: TByteDynArray; AnFormString: Boolean = False): Boolean; inline; + function ReadAddressValue(const AnAttribData: TDwarfAttribData; out AValue: TDBGPtr): Boolean; inline; function ReadReference(const AnAttribData: TDwarfAttribData; out AValue: Pointer; out ACompUnit: TDwarfCompilationUnit): Boolean; inline; function ReadValue(AnAttrib: Cardinal; out AValue: Integer): Boolean; inline; @@ -2793,6 +2794,16 @@ begin ); end; +function TDwarfInformationEntry.ReadAddressValue( + const AnAttribData: TDwarfAttribData; out AValue: TDBGPtr): Boolean; +begin + Result := AnAttribData.InformationEntry.FCompUnit.ReadAddressValue( + AnAttribData.InfoPointer, + AnAttribData.InformationEntry.FAbbrevData[AnAttribData.Idx].Form, + AValue + ); +end; + function TDwarfInformationEntry.ReadReference( const AnAttribData: TDwarfAttribData; out AValue: Pointer; out ACompUnit: TDwarfCompilationUnit): Boolean; diff --git a/components/fpdebug/fppascalbuilder.pas b/components/fpdebug/fppascalbuilder.pas index b779dce3d6..01f611d751 100644 --- a/components/fpdebug/fppascalbuilder.pas +++ b/components/fpdebug/fppascalbuilder.pas @@ -5,8 +5,9 @@ unit FpPascalBuilder; interface uses - Classes, SysUtils, DbgIntfBaseTypes, DbgIntfDebuggerBase, FpDbgInfo, FpdMemoryTools, - FpErrorMessages, LazLoggerBase, LazUTF8; + Classes, SysUtils, DbgIntfBaseTypes, DbgIntfDebuggerBase, FpDbgInfo, + FpdMemoryTools, FpErrorMessages, FpDbgDwarfDataClasses, FpDbgDwarf, + LazLoggerBase, LazUTF8, LazClasses; type TTypeNameFlag = ( @@ -258,21 +259,53 @@ var Result := GetTypeName(ADeclaration, ADbgSymbol, []); end; + function GetParameterList(out ADeclaration: String): Boolean; + var + i: Integer; + m: TFpDbgSymbol; + name, lname: String; + begin + ADeclaration := ''; + lname := ''; + for i := 0 to ADbgSymbol.MemberCount - 1 do begin + m := ADbgSymbol.Member[i]; + if (m <> nil) and (sfParameter in m.Flags) then begin + GetTypeName(name, m, [tnfOnlyDeclared]); + if (lname <> '') then begin + if (lname = name) then + ADeclaration := ADeclaration + ', ' + else + ADeclaration := ADeclaration + ': ' + lname + '; '; + end + else + if ADeclaration <> '' then + ADeclaration := ADeclaration + '; '; + ADeclaration := ADeclaration + m.Name; + lname := name; + end; + end; + if (lname <> '') then + ADeclaration := ADeclaration + ': ' + lname; + Result := True; + end; + function GetFunctionType(out ADeclaration: String): Boolean; var - s: String; + s, p: String; begin - // Todo param GetTypeAsDeclaration(s, ADbgSymbol.TypeInfo, AFlags); - ADeclaration := 'function ' + ADbgSymbol.Name + ' () : ' + s + ''; + GetParameterList(p); + ADeclaration := 'function ' + '(' + p + '): ' + s + ''; if sfVirtual in ADbgSymbol.Flags then ADeclaration := ADeclaration + '; virtual'; Result := true; end; function GetProcedureType(out ADeclaration: String): Boolean; + var + p: String; begin - // Todo param - ADeclaration := 'procedure ' + ADbgSymbol.Name + ' ()'; + GetParameterList(p); + ADeclaration := 'procedure ' + '(' + p + ')'; if sfVirtual in ADbgSymbol.Flags then ADeclaration := ADeclaration + '; virtual'; Result := true; end; @@ -436,8 +469,8 @@ begin skPointer: Result := GetPointerType(ATypeDeclaration); skInteger, skCardinal, skBoolean, skChar, skFloat: Result := GetBaseType(ATypeDeclaration); - skFunction: Result := GetFunctionType(ATypeDeclaration); - skProcedure: Result := GetProcedureType(ATypeDeclaration); + skFunction, skFunctionRef: Result := GetFunctionType(ATypeDeclaration); + skProcedure, skProcedureRef: Result := GetProcedureType(ATypeDeclaration); skClass: Result := GetClassType(ATypeDeclaration); skRecord: Result := GetRecordType(ATypeDeclaration); skEnum: Result := GetEnumType(ATypeDeclaration); @@ -634,6 +667,56 @@ function TFpPascalPrettyPrinter.InternalPrintValue(out APrintedValue: String; Result := True; end; + procedure DoFunction; + var + s: String; + proc: TFpDwarfSymbol; + v: TDBGPtr; + t: TFpDbgSymbol; + par: TFpDwarfValue; + begin + proc := nil; + v := AValue.DataAddress.Address; + if (ppvCreateDbgType in AFlags) then begin + ADBGTypeInfo^ := TDBGType.Create(AValue.Kind, ''); + if AValue.Kind in [skFunctionRef, skProcedureRef] then + ADBGTypeInfo^.Value.AsPointer := Pointer(v); // TODO: no cut off + end; + + // TODO: depending on verbosity: TypeName($0123456) + if AValue.Kind in [skFunctionRef, skProcedureRef] then begin + if v = 0 then + APrintedValue := 'nil' + else + APrintedValue := '$'+IntToHex(v, AnAddressSize*2); + + t := AValue.TypeInfo; + proc := TFpDwarfSymbol(TDbgDwarfSymbolBase(t).CompilationUnit.Owner.FindSymbol(v)); + if proc <> nil then begin + //t := proc; + s := proc.Name; + par := nil; + if (proc is TFpDwarfSymbolValueProc) then + par := TFpDwarfSymbolValueProc(proc).GetSelfParameter; + if (par <> nil) and (par.TypeInfo <> nil) then + s := par.TypeInfo.Name + '.' + s; + APrintedValue := APrintedValue + ' = ' + s; // TODO: offset to startaddress + end; + APrintedValue := APrintedValue + ': '; + end + else + t := TFpDwarfValue(AValue).ValueSymbol; + + if AFlags * PV_FORWARD_FLAGS <> [] then + GetTypeName(s, t) + else + GetTypeAsDeclaration(s, t); + APrintedValue := APrintedValue + s; + + ReleaseRefAndNil(proc); + Result := True; + end; + procedure DoInt; var n: Integer; @@ -1023,8 +1106,10 @@ begin Result := False; case AValue.Kind of skUnit: ; - skProcedure: ; - skFunction: ; + skProcedure, + skFunction, + skProcedureRef, + skFunctionRef: DoFunction; skPointer: DoPointer(False); skInteger: DoInt; skCardinal: DoCardinal;