From 9066b473203cb20090a2b3b904572e1a74e81247 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Mon, 6 Jun 2022 07:05:47 +1000 Subject: [PATCH] chore(windows): extract TJCLMapScanner down to separate unit TJCLMapScanner was the only class used in the entire JCL, in a build-time project (sentrytool). For now, I have copied this class plus its handful of dependent functions into Keyman.System.JclMapScanner so that we can remove 3381 files from the repository. We do not plan to use JCL in the future. --- .../Keyman.System.JclMapScanner.pas | 1166 +++++++++++++++++ .../sentrytool/Keyman.System.MapToSym.pas | 4 +- .../src/buildtools/sentrytool/sentrytool.dpr | 3 +- .../buildtools/sentrytool/sentrytool.dproj | 3 +- 4 files changed, 1172 insertions(+), 4 deletions(-) create mode 100644 windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas diff --git a/windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas b/windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas new file mode 100644 index 0000000000..34d0746e70 --- /dev/null +++ b/windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas @@ -0,0 +1,1166 @@ +// +// This is a lightly modified version of TJclMapScanner, removing all reference +// to loaded modules, as we don't use those for our map file conversion. All +// unrelated code is excluded so we do not need to depend on the full JCL. +// +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } +{ you may not use this file except in compliance with the License. You may obtain a copy of the } +{ License at http://www.mozilla.org/MPL/ } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } +{ ANY KIND, either express or implied. See the License for the specific language governing rights } +{ and limitations under the License. } +{ } +{ The Original Code is JclDebug.pas. } +{ } +{ The Initial Developers of the Original Code are Petr Vones and Marcel van Brakel. } +{ Portions created by these individuals are Copyright (C) of these individuals. } +{ All Rights Reserved. } +{ } +{ Contributor(s): } +{ Marcel van Brakel } +{ Flier Lu (flier) } +{ Florent Ouchet (outchy) } +{ Robert Marquardt (marquardt) } +{ Robert Rossmair (rrossmair) } +{ Andreas Hausladen (ahuser) } +{ Petr Vones (pvones) } +{ Soeren Muehlbauer } +{ Uwe Schuster (uschuster) } +{ } +{**************************************************************************************************} +{ } +{ Various debugging support routines and classes. This includes: Diagnostics routines, Trace } +{ routines, Stack tracing and Source Locations a la the C/C++ __FILE__ and __LINE__ macros. } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +unit Keyman.System.JclMapScanner; + +interface + +uses + System.Classes, + System.SysUtils, + Winapi.Windows; + +type + TJclAddr32 = Cardinal; + TJclAddr64 = UInt64; + + {$IFDEF _WIN64} + TJclAddr = TJclAddr64; + {$ELSE} + TJclAddr = TJclAddr32; + {$ENDIF} + + PJclMapAddress = ^TJclMapAddress; + TJclMapAddress = packed record + Segment: Word; + Offset: TJclAddr; + end; + + PJclMapString = PAnsiChar; + + TJclFileMappingStream = class(TCustomMemoryStream) + private + FFileHandle: THandle; + FMapping: THandle; + protected + procedure Close; + public + constructor Create(const FileName: string; FileMode: Word = fmOpenRead or fmShareDenyWrite); + destructor Destroy; override; + function Write(const Buffer; Count: Longint): Longint; override; + end; + + TJclAbstractMapParser = class(TObject) + private + FLinkerBug: Boolean; + FLinkerBugUnitName: PJclMapString; + FStream: TJclFileMappingStream; + function GetLinkerBugUnitName: string; + protected +(* FModule: HMODULE;*) + FLastUnitName: PJclMapString; + FLastUnitFileName: PJclMapString; + procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); virtual; abstract; + procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); virtual; abstract; + procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract; + procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract; + procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); virtual; abstract; + procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); virtual; abstract; + public + constructor Create(const MapFileName: TFileName; Module: HMODULE); overload; virtual; + constructor Create(const MapFileName: TFileName); overload; + destructor Destroy; override; + procedure Parse; + class function MapStringToFileName(MapString: PJclMapString): string; + class function MapStringToModuleName(MapString: PJclMapString): string; + class function MapStringToStr(MapString: PJclMapString; IgnoreSpaces: Boolean = False): string; + property LinkerBug: Boolean read FLinkerBug; + property LinkerBugUnitName: string read GetLinkerBugUnitName; + property Stream: TJclFileMappingStream read FStream; + end; + + TJclMapStringCache = record + CachedValue: string; + RawValue: PJclMapString; + end; + + // MAP file scanner + PJclMapSegmentClass = ^TJclMapSegmentClass; + TJclMapSegmentClass = record + Segment: Word; // segment ID + Start: DWORD; // start as in the map file + Addr: DWORD; // start as in process memory + VA: DWORD; // position relative to module base adress + Len: DWORD; // segment length + SectionName: TJclMapStringCache; + GroupName: TJclMapStringCache; + end; + + PJclMapSegment = ^TJclMapSegment; + TJclMapSegment = record + Segment: Word; + StartVA: DWORD; // VA relative to (module base address + $10000) + EndVA: DWORD; + UnitName: TJclMapStringCache; + end; + + PJclMapProcName = ^TJclMapProcName; + TJclMapProcName = record + Segment: Word; + VA: DWORD; // VA relative to (module base address + $10000) + ProcName: TJclMapStringCache; + end; + + PJclMapLineNumber = ^TJclMapLineNumber; + TJclMapLineNumber = record + Segment: Word; + VA: DWORD; // VA relative to (module base address + $10000) + LineNumber: Integer; + end; + + TJclMapScanner = class(TJclAbstractMapParser) + private + FSegmentClasses: array of TJclMapSegmentClass; + FLineNumbers: array of TJclMapLineNumber; + FProcNames: array of TJclMapProcName; + FSegments: array of TJclMapSegment; + FSourceNames: array of TJclMapProcName; + FLineNumbersCnt: Integer; + FLineNumberErrors: Integer; + FNewUnitFileName: PJclMapString; + FProcNamesCnt: Integer; + FSegmentCnt: Integer; + FLastAccessedSegementIndex: Integer; + function IndexOfSegment(Addr: DWORD): Integer; + protected + function MAPAddrToVA(const Addr: DWORD): DWORD; + procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override; + procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override; + procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override; + procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override; + procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override; + procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override; + procedure Scan; + public + constructor Create(const MapFileName: TFileName; Module: HMODULE); override; + + class function MapStringCacheToFileName(var MapString: TJclMapStringCache): string; + class function MapStringCacheToModuleName(var MapString: TJclMapStringCache): string; + class function MapStringCacheToStr(var MapString: TJclMapStringCache; IgnoreSpaces: Boolean = False): string; + + // Addr are virtual addresses relative to (module base address + $10000) + function LineNumberFromAddr(Addr: DWORD): Integer; overload; + function LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer; overload; + function ModuleNameFromAddr(Addr: DWORD): string; + function ModuleStartFromAddr(Addr: DWORD): DWORD; + function ProcNameFromAddr(Addr: DWORD): string; overload; + function ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string; overload; + function SourceNameFromAddr(Addr: DWORD): string; + property LineNumberErrors: Integer read FLineNumberErrors; + end; + +implementation + +uses + System.AnsiStrings, + System.Character; + +//=== { TJclFileMappingStream } ============================================== + +constructor TJclFileMappingStream.Create(const FileName: string; FileMode: Word); +var + Protect, Access, Size: DWORD; + BaseAddress: Pointer; +begin + inherited Create; + FFileHandle := THandle(FileOpen(FileName, FileMode)); + if FFileHandle = INVALID_HANDLE_VALUE then + RaiseLastOSError; + if (FileMode and $0F) = fmOpenReadWrite then + begin + Protect := PAGE_WRITECOPY; + Access := FILE_MAP_COPY; + end + else + begin + Protect := PAGE_READONLY; + Access := FILE_MAP_READ; + end; + FMapping := CreateFileMapping(FFileHandle, nil, Protect, 0, 0, nil); + if FMapping = 0 then + begin + Close; + RaiseLastOSError; + end; + BaseAddress := MapViewOfFile(FMapping, Access, 0, 0, 0); + if BaseAddress = nil then + begin + Close; + RaiseLastOSError; + end; + Size := GetFileSize(FFileHandle, nil); + if Size = DWORD(-1) then + begin + UnMapViewOfFile(BaseAddress); + Close; + RaiseLastOSError; + end; + SetPointer(BaseAddress, Size); +end; + +destructor TJclFileMappingStream.Destroy; +begin + Close; + inherited Destroy; +end; + +procedure TJclFileMappingStream.Close; +begin + if Memory <> nil then + begin + UnMapViewOfFile(Memory); + SetPointer(nil, 0); + end; + if FMapping <> 0 then + begin + CloseHandle(FMapping); + FMapping := 0; + end; + if FFileHandle <> INVALID_HANDLE_VALUE then + begin + FileClose(FFileHandle); + FFileHandle := INVALID_HANDLE_VALUE; + end; +end; + +function TJclFileMappingStream.Write(const Buffer; Count: Integer): Longint; +begin + Result := 0; + if (Size - Position) >= Count then + begin + System.Move(Buffer, Pointer(TJclAddr(Memory) + TJclAddr(Position))^, Count); + Position := Position + Count; + Result := Count; + end; +end; + +//=== { TJclAbstractMapParser } ============================================== + +constructor TJclAbstractMapParser.Create(const MapFileName: TFileName; Module: HMODULE); +begin + inherited Create; +(* FModule := Module;*) + if FileExists(MapFileName) then + FStream := TJclFileMappingStream.Create(MapFileName, fmOpenRead or fmShareDenyWrite); +end; + +constructor TJclAbstractMapParser.Create(const MapFileName: TFileName); +begin + Create(MapFileName, 0); +end; + +destructor TJclAbstractMapParser.Destroy; +begin + FreeAndNil(FStream); + inherited Destroy; +end; + +function TJclAbstractMapParser.GetLinkerBugUnitName: string; +begin + Result := MapStringToStr(FLinkerBugUnitName); +end; + +class function TJclAbstractMapParser.MapStringToFileName(MapString: PJclMapString): string; +var + PEnd: PJclMapString; +begin + if MapString = nil then + begin + Result := ''; + Exit; + end; + PEnd := MapString; + while (PEnd^ <> #0) and not (PEnd^ in ['=', #10, #13]) do + Inc(PEnd); + if (PEnd^ = '=') then + begin + while (PEnd >= MapString) and (PEnd^ <> ' ') do + Dec(PEnd); + while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do + Dec(PEnd); + end; + SetString(Result, MapString, PEnd - MapString); +end; + +class function TJclAbstractMapParser.MapStringToModuleName(MapString: PJclMapString): string; +var + PStart, PEnd, PExtension: PJclMapString; +begin + if MapString = nil then + begin + Result := ''; + Exit; + end; + PEnd := MapString; + while (PEnd^ <> #0) and not (PEnd^ in ['=', #10, #13]) do + Inc(PEnd); + if (PEnd^ = '=') then + begin + while (PEnd >= MapString) and (PEnd^ <> ' ') do + Dec(PEnd); + while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do + Dec(PEnd); + end; + PExtension := PEnd; + while (PExtension >= MapString) and (PExtension^ <> '.') and (PExtension^ <> '|') do + Dec(PExtension); + if (System.AnsiStrings.StrIComp(PExtension, '.pas ') = 0) or + (System.AnsiStrings.StrIComp(PExtension, '.obj ') = 0) then + PEnd := PExtension; + PExtension := PEnd; + while (PExtension >= MapString) and (PExtension^ <> '|') and (PExtension^ <> '\') do + Dec(PExtension); + if PExtension >= MapString then + PStart := PExtension + 1 + else + PStart := MapString; + SetString(Result, PStart, PEnd - PStart); +end; + +class function TJclAbstractMapParser.MapStringToStr(MapString: PJclMapString; + IgnoreSpaces: Boolean): string; +var + P: PJclMapString; +begin + if MapString = nil then + begin + Result := ''; + Exit; + end; + if MapString^ = '(' then + begin + Inc(MapString); + P := MapString; + while (P^ <> #0) and not (P^ in [')', #10, #13]) do + Inc(P); + end + else + begin + P := MapString; + if IgnoreSpaces then + while (P^ <> #0) and not (P^ in ['(', #10, #13]) do + Inc(P) + else + while (P^ <> #0) and (P^ <> '(') and (P^ > ' ') do + Inc(P); + end; + SetString(Result, MapString, P - MapString); +end; + +const + NativeLineFeed = Char(#10); + NativeCarriageReturn = Char(#13); + +function CharIsReturn(const C: Char): Boolean; +begin + Result := (C = NativeLineFeed) or (C = NativeCarriageReturn); +end; + +function CharIsDigit(const C: Char): Boolean; +begin + Result := C.IsDigit; +end; + +procedure TJclAbstractMapParser.Parse; +const + TableHeader : array [0..3] of string = ('Start', 'Length', 'Name', 'Class'); + SegmentsHeader : array [0..3] of string = ('Detailed', 'map', 'of', 'segments'); + PublicsByNameHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Name'); + PublicsByValueHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Value'); + LineNumbersPrefix : string = 'Line numbers for'; +var + CurrPos, EndPos: PJclMapString; +{$IFNDEF COMPILER9_UP} + PreviousA, +{$ENDIF COMPILER9_UP} + A: TJclMapAddress; + L: Integer; + P1, P2: PJclMapString; + + function Eof: Boolean; + begin + Result := CurrPos >= EndPos; + end; + + procedure SkipWhiteSpace; + var + LCurrPos, LEndPos: PJclMapString; + begin + LCurrPos := CurrPos; + LEndPos := EndPos; + while (LCurrPos < LEndPos) and (LCurrPos^ <= ' ') do + Inc(LCurrPos); + CurrPos := LCurrPos; + end; + + procedure SkipEndLine; + begin + while not Eof and not CharIsReturn(Char(CurrPos^)) do + Inc(CurrPos); + SkipWhiteSpace; + end; + + function IsDecDigit: Boolean; + begin + Result := CharIsDigit(Char(CurrPos^)); + end; + + function ReadTextLine: string; + var + P: PJclMapString; + begin + P := CurrPos; + while (P^ <> #0) and not (P^ in [#10, #13]) do + Inc(P); + SetString(Result, CurrPos, P - CurrPos); + CurrPos := P; + end; + + + function ReadDecValue: Integer; + var + P: PJclMapString; + begin + P := CurrPos; + Result := 0; + while P^ in ['0'..'9'] do + begin + Result := Result * 10 + (Ord(P^) - Ord('0')); + Inc(P); + end; + CurrPos := P; + end; + + function ReadHexValue: DWORD; + var + C: AnsiChar; + begin + Result := 0; + repeat + C := CurrPos^; + case C of + '0'..'9': + Result := (Result shl 4) or DWORD(Ord(C) - Ord('0')); + 'A'..'F': + Result := (Result shl 4) or DWORD(Ord(C) - Ord('A') + 10); + 'a'..'f': + Result := (Result shl 4) or DWORD(Ord(C) - Ord('a') + 10); + 'H', 'h': + begin + Inc(CurrPos); + Break; + end; + else + Break; + end; + Inc(CurrPos); + until False; + end; + + function ReadAddress: TJclMapAddress; + begin + Result.Segment := ReadHexValue; + if CurrPos^ = ':' then + begin + Inc(CurrPos); + Result.Offset := ReadHexValue; + end + else + Result.Offset := 0; + end; + + function ReadString: PJclMapString; + begin + SkipWhiteSpace; + Result := CurrPos; + while {(CurrPos^ <> #0) and} (CurrPos^ > ' ') do + Inc(CurrPos); + end; + + procedure FindParam(Param: AnsiChar); + begin + while not ((CurrPos^ = Param) and ((CurrPos + 1)^ = '=')) do + Inc(CurrPos); + Inc(CurrPos, 2); + end; + + function SyncToHeader(const Header: array of string): Boolean; + var + S: string; + TokenIndex, OldPosition, CurrentPosition: Integer; + begin + Result := False; + while not Eof do + begin + S := Trim(ReadTextLine); + TokenIndex := Low(Header); + CurrentPosition := 0; + OldPosition := 0; + while (TokenIndex <= High(Header)) do + begin + CurrentPosition := Pos(Header[TokenIndex],S); + if (CurrentPosition <= OldPosition) then + begin + CurrentPosition := 0; + Break; + end; + OldPosition := CurrentPosition; + Inc(TokenIndex); + end; + Result := CurrentPosition <> 0; + if Result then + Break; + SkipEndLine; + end; + if not Eof then + SkipWhiteSpace; + end; + + function SyncToPrefix(const Prefix: string): Boolean; + var + I: Integer; + P: PJclMapString; + S: string; + begin + if Eof then + begin + Result := False; + Exit; + end; + SkipWhiteSpace; + I := Length(Prefix); + P := CurrPos; + while not Eof and (P^ <> #13) and (P^ <> #0) and (I > 0) do + begin + Inc(P); + Dec(I); + end; + SetString(S, CurrPos, Length(Prefix)); + Result := (S = Prefix); + if Result then + CurrPos := P; + SkipWhiteSpace; + end; + +begin + if FStream <> nil then + begin + FLinkerBug := False; +{$IFNDEF COMPILER9_UP} + PreviousA.Segment := 0; + PreviousA.Offset := 0; +{$ENDIF COMPILER9_UP} + CurrPos := FStream.Memory; + EndPos := CurrPos + FStream.Size; + if SyncToHeader(TableHeader) then + while IsDecDigit do + begin + A := ReadAddress; + SkipWhiteSpace; + L := ReadHexValue; + P1 := ReadString; + P2 := ReadString; + SkipEndLine; + ClassTableItem(A, L, P1, P2); + end; + if SyncToHeader(SegmentsHeader) then + while IsDecDigit do + begin + A := ReadAddress; + SkipWhiteSpace; + L := ReadHexValue; + FindParam('C'); + P1 := ReadString; + FindParam('M'); + P2 := ReadString; + SkipEndLine; + SegmentItem(A, L, P1, P2); + end; + if SyncToHeader(PublicsByNameHeader) then + while IsDecDigit do + begin + A := ReadAddress; + P1 := ReadString; + SkipEndLine; // compatibility with C++Builder MAP files + PublicsByNameItem(A, P1); + end; + if SyncToHeader(PublicsByValueHeader) then + while not Eof and IsDecDigit do + begin + A := ReadAddress; + P1 := ReadString; + SkipEndLine; // compatibility with C++Builder MAP files + PublicsByValueItem(A, P1); + end; + while SyncToPrefix(LineNumbersPrefix) do + begin + FLastUnitName := CurrPos; + FLastUnitFileName := CurrPos; + while FLastUnitFileName^ <> '(' do + Inc(FLastUnitFileName); + SkipEndLine; + LineNumberUnitItem(FLastUnitName, FLastUnitFileName); + repeat + SkipWhiteSpace; + L := ReadDecValue; + SkipWhiteSpace; + A := ReadAddress; + SkipWhiteSpace; + LineNumbersItem(L, A); +{$IFNDEF COMPILER9_UP} + if (not FLinkerBug) and (A.Offset < PreviousA.Offset) then + begin + FLinkerBugUnitName := FLastUnitName; + FLinkerBug := True; + end; + PreviousA := A; +{$ENDIF COMPILER9_UP} + until not IsDecDigit; + end; + end; +end; + +//=== { TJclMapScanner } ===================================================== + +constructor TJclMapScanner.Create(const MapFileName: TFileName; Module: HMODULE); +begin + inherited Create(MapFileName, Module); + Scan; +end; + +function TJclMapScanner.MAPAddrToVA(const Addr: DWORD): DWORD; +begin + // MAP file format was changed in Delphi 2005 + // before Delphi 2005: segments started at offset 0 + // only one segment of code + // after Delphi 2005: segments started at code base address (module base address + $10000) + // 2 segments of code + if (Length(FSegmentClasses) > 0) and (FSegmentClasses[0].Start > 0) and (Addr >= FSegmentClasses[0].Start) then + // Delphi 2005 and later + // The first segment should be code starting at module base address + $10000 + Result := Addr - FSegmentClasses[0].Start + else + // before Delphi 2005 + Result := Addr; +end; + +class function TJclMapScanner.MapStringCacheToFileName( + var MapString: TJclMapStringCache): string; +begin + Result := MapString.CachedValue; + if Result = '' then + begin + Result := MapStringToFileName(MapString.RawValue); + MapString.CachedValue := Result; + end; +end; + +class function TJclMapScanner.MapStringCacheToModuleName( + var MapString: TJclMapStringCache): string; +begin + Result := MapString.CachedValue; + if Result = '' then + begin + Result := MapStringToModuleName(MapString.RawValue); + MapString.CachedValue := Result; + end; +end; + +class function TJclMapScanner.MapStringCacheToStr(var MapString: TJclMapStringCache; + IgnoreSpaces: Boolean): string; +begin + Result := MapString.CachedValue; + if Result = '' then + begin + Result := MapStringToStr(MapString.RawValue, IgnoreSpaces); + MapString.CachedValue := Result; + end; +end; + +procedure TJclMapScanner.ClassTableItem(const Address: TJclMapAddress; Len: Integer; + SectionName, GroupName: PJclMapString); +var + C: Integer; +(* SectionHeader: PImageSectionHeader; *) +begin + C := Length(FSegmentClasses); + SetLength(FSegmentClasses, C + 1); + FSegmentClasses[C].Segment := Address.Segment; + FSegmentClasses[C].Start := Address.Offset; + FSegmentClasses[C].Addr := Address.Offset; // will be fixed below while considering module mapped address + // test GroupName because SectionName = '.tls' in Delphi and '_tls' in BCB + if System.AnsiStrings.StrIComp(GroupName, 'TLS') = 0 then + FSegmentClasses[C].VA := FSegmentClasses[C].Start + else + FSegmentClasses[C].VA := MAPAddrToVA(FSegmentClasses[C].Start); + FSegmentClasses[C].Len := Len; + FSegmentClasses[C].SectionName.RawValue := SectionName; + FSegmentClasses[C].GroupName.RawValue := GroupName; +(* + if FModule <> 0 then + begin + { Fix the section addresses } + SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(SectionName)); + if SectionHeader = nil then + { before Delphi 2005 the class names where used for the section names } + SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(GroupName)); + + if SectionHeader <> nil then + begin + FSegmentClasses[C].Addr := TJclAddr(FModule) + SectionHeader.VirtualAddress; + FSegmentClasses[C].VA := SectionHeader.VirtualAddress; + end; + end; +*) +end; + +function TJclMapScanner.LineNumberFromAddr(Addr: DWORD): Integer; +var + Dummy: Integer; +begin + Result := LineNumberFromAddr(Addr, Dummy); +end; + +function Search_MapLineNumber(Item1, Item2: Pointer): Integer; +begin + Result := Integer(PJclMapLineNumber(Item1)^.VA) - PInteger(Item2)^; +end; + +// Dynamic array sort and search routines +type + TDynArraySortCompare = function (Item1, Item2: Pointer): Integer; + SizeInt = Integer; + PSizeInt = ^SizeInt; + +function SearchDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare; + ValuePtr: Pointer; Nearest: Boolean): SizeInt; +var + L, H, I, C: SizeInt; + B: Boolean; +begin + Result := -1; + if ArrayPtr <> nil then + begin + L := 0; + H := PSizeInt(TJclAddr(ArrayPtr) - SizeOf(SizeInt))^ - 1; + B := False; + while L <= H do + begin + I := (L + H) shr 1; + C := SortFunc(Pointer(TJclAddr(ArrayPtr) + TJclAddr(I * SizeInt(ElementSize))), ValuePtr); + if C < 0 then + L := I + 1 + else + begin + H := I - 1; + if C = 0 then + begin + B := True; + L := I; + end; + end; + end; + if B then + Result := L + else + if Nearest and (H >= 0) then + Result := H; + end; +end; + +function TJclMapScanner.LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer; +var + I: Integer; + ModuleStartAddr: DWORD; +begin + ModuleStartAddr := ModuleStartFromAddr(Addr); + Result := 0; + Offset := 0; + I := SearchDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Search_MapLineNumber, @Addr, True); + if (I <> -1) and (FLineNumbers[I].VA >= ModuleStartAddr) then + begin + Result := FLineNumbers[I].LineNumber; + Offset := Addr - FLineNumbers[I].VA; + end; +end; + +procedure TJclMapScanner.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); +var + SegIndex, C: Integer; + VA: DWORD; + Added: Boolean; +begin + Added := False; + for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do + if (FSegmentClasses[SegIndex].Segment = Address.Segment) + and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then + begin + if System.AnsiStrings.StrIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS') = 0 then + Va := Address.Offset + else + VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start); + { Starting with Delphi 2005, "empty" units are listes with the last line and + the VA 0001:00000000. When we would accept 0 VAs here, System.pas functions + could be mapped to other units and line numbers. Discaring such items should + have no impact on the correct information, because there can't be a function + that starts at VA 0. } + if VA = 0 then + Continue; + if FLineNumbersCnt = Length(FLineNumbers) then + begin + if FLineNumbersCnt < 512 then + SetLength(FLineNumbers, FLineNumbersCnt + 512) + else + SetLength(FLineNumbers, FLineNumbersCnt * 2); + end; + FLineNumbers[FLineNumbersCnt].Segment := FSegmentClasses[SegIndex].Segment; + FLineNumbers[FLineNumbersCnt].VA := VA; + FLineNumbers[FLineNumbersCnt].LineNumber := LineNumber; + Inc(FLineNumbersCnt); + Added := True; + if FNewUnitFileName <> nil then + begin + C := Length(FSourceNames); + SetLength(FSourceNames, C + 1); + FSourceNames[C].Segment := FSegmentClasses[SegIndex].Segment; + FSourceNames[C].VA := VA; + FSourceNames[C].ProcName.RawValue := FNewUnitFileName; + FNewUnitFileName := nil; + end; + Break; + end; + if not Added then + Inc(FLineNumberErrors); +end; + +procedure TJclMapScanner.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); +begin + FNewUnitFileName := UnitFileName; +end; + +function TJclMapScanner.IndexOfSegment(Addr: DWORD): Integer; +var + L, R: Integer; + S: PJclMapSegment; +begin + R := Length(FSegments) - 1; + Result := FLastAccessedSegementIndex; + if Result <= R then + begin + S := @FSegments[Result]; + if (S.StartVA <= Addr) and (Addr < S.EndVA) then + Exit; + end; + + // binary search + L := 0; + while L <= R do + begin + Result := L + (R - L) div 2; + S := @FSegments[Result]; + if Addr >= S.EndVA then + L := Result + 1 + else + begin + R := Result - 1; + if (S.StartVA <= Addr) and (Addr < S.EndVA) then + begin + FLastAccessedSegementIndex := Result; + Exit; + end; + end; + end; + Result := -1; +end; + +function TJclMapScanner.ModuleNameFromAddr(Addr: DWORD): string; +var + I: Integer; +begin + I := IndexOfSegment(Addr); + if I <> -1 then + Result := MapStringCacheToModuleName(FSegments[I].UnitName) + else + Result := ''; +end; + +function TJclMapScanner.ModuleStartFromAddr(Addr: DWORD): DWORD; +var + I: Integer; +begin + I := IndexOfSegment(Addr); + Result := DWORD(-1); + if I <> -1 then + Result := FSegments[I].StartVA; +end; + +function TJclMapScanner.ProcNameFromAddr(Addr: DWORD): string; +var + Dummy: Integer; +begin + Result := ProcNameFromAddr(Addr, Dummy); +end; + +function Search_MapProcName(Item1, Item2: Pointer): Integer; +begin + Result := Integer(PJclMapProcName(Item1)^.VA) - PInteger(Item2)^; +end; + +function TJclMapScanner.ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string; +var + I: Integer; + ModuleStartAddr: DWORD; +begin + ModuleStartAddr := ModuleStartFromAddr(Addr); + Result := ''; + Offset := 0; + I := SearchDynArray(FProcNames, SizeOf(FProcNames[0]), Search_MapProcName, @Addr, True); + if (I <> -1) and (FProcNames[I].VA >= ModuleStartAddr) then + begin + Result := MapStringCacheToStr(FProcNames[I].ProcName, True); + Offset := Addr - FProcNames[I].VA; + end; +end; + +procedure TJclMapScanner.PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); +begin + { TODO : What to do? } +end; + +procedure TJclMapScanner.PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); +var + SegIndex: Integer; +begin + for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do + if (FSegmentClasses[SegIndex].Segment = Address.Segment) + and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then + begin + if FProcNamesCnt = Length(FProcNames) then + begin + if FProcNamesCnt < 512 then + SetLength(FProcNames, FProcNamesCnt + 512) + else + SetLength(FProcNames, FProcNamesCnt * 2); + end; + FProcNames[FProcNamesCnt].Segment := FSegmentClasses[SegIndex].Segment; + if System.AnsiStrings.StrIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS') = 0 then + FProcNames[FProcNamesCnt].VA := Address.Offset + else + FProcNames[FProcNamesCnt].VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start); + FProcNames[FProcNamesCnt].ProcName.RawValue := Name; + Inc(FProcNamesCnt); + Break; + end; +end; + +function Sort_MapLineNumber(Item1, Item2: Pointer): Integer; +begin + Result := Integer(PJclMapLineNumber(Item1)^.VA) - Integer(PJclMapLineNumber(Item2)^.VA); +end; + +function Sort_MapProcName(Item1, Item2: Pointer): Integer; +begin + Result := Integer(PJclMapProcName(Item1)^.VA) - Integer(PJclMapProcName(Item2)^.VA); +end; + +function Sort_MapSegment(Item1, Item2: Pointer): Integer; +begin + Result := Integer(PJclMapSegment(Item1)^.StartVA) - Integer(PJclMapSegment(Item2)^.StartVA); +end; + +type + TDynByteArray = array of Byte; + +procedure SortDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare); +var + TempBuf: TDynByteArray; + + function ArrayItemPointer(Item: SizeInt): Pointer; + begin + Assert(Item >= 0); + Result := Pointer(TJclAddr(ArrayPtr) + TJclAddr(Item * SizeInt(ElementSize))); + end; + + procedure QuickSort(L, R: SizeInt); + var + I, J, T: SizeInt; + P, IPtr, JPtr: Pointer; + ElSize: Integer; + begin + ElSize := ElementSize; + repeat + I := L; + J := R; + P := ArrayItemPointer((L + R) shr 1); + repeat + IPtr := ArrayItemPointer(I); + JPtr := ArrayItemPointer(J); + while SortFunc(IPtr, P) < 0 do + begin + Inc(I); + Inc(PByte(IPtr), ElSize); + end; + while SortFunc(JPtr, P) > 0 do + begin + Dec(J); + Dec(PByte(JPtr), ElSize); + end; + if I <= J then + begin + if I <> J then + begin + case ElementSize of + SizeOf(Byte): + begin + T := PByte(IPtr)^; + PByte(IPtr)^ := PByte(JPtr)^; + PByte(JPtr)^ := T; + end; + SizeOf(Word): + begin + T := PWord(IPtr)^; + PWord(IPtr)^ := PWord(JPtr)^; + PWord(JPtr)^ := T; + end; + SizeOf(Integer): + begin + T := PInteger(IPtr)^; + PInteger(IPtr)^ := PInteger(JPtr)^; + PInteger(JPtr)^ := T; + end; + else + Move(IPtr^, TempBuf[0], ElementSize); + Move(JPtr^, IPtr^, ElementSize); + Move(TempBuf[0], JPtr^, ElementSize); + end; + end; + if P = IPtr then + P := JPtr + else + if P = JPtr then + P := IPtr; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(L, J); + L := I; + until I >= R; + end; + +begin + if ArrayPtr <> nil then + begin + SetLength(TempBuf, ElementSize); + QuickSort(0, PSizeInt(TJclAddr(ArrayPtr) - SizeOf(SizeInt))^ - 1); + end; +end; + +procedure TJclMapScanner.Scan; +begin + FLineNumberErrors := 0; + FSegmentCnt := 0; + FProcNamesCnt := 0; + FLastAccessedSegementIndex := 0; + Parse; + SetLength(FLineNumbers, FLineNumbersCnt); + SetLength(FProcNames, FProcNamesCnt); + SetLength(FSegments, FSegmentCnt); + SortDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Sort_MapLineNumber); + SortDynArray(FProcNames, SizeOf(FProcNames[0]), Sort_MapProcName); + SortDynArray(FSegments, SizeOf(FSegments[0]), Sort_MapSegment); + SortDynArray(FSourceNames, SizeOf(FSourceNames[0]), Sort_MapProcName); +end; + +procedure TJclMapScanner.SegmentItem(const Address: TJclMapAddress; Len: Integer; + GroupName, UnitName: PJclMapString); +var + SegIndex: Integer; + VA: DWORD; +begin + for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do + if (FSegmentClasses[SegIndex].Segment = Address.Segment) + and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then + begin + if System.AnsiStrings.StrIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS') = 0 then + VA := Address.Offset + else + VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start); + if FSegmentCnt mod 16 = 0 then + SetLength(FSegments, FSegmentCnt + 16); + FSegments[FSegmentCnt].Segment := FSegmentClasses[SegIndex].Segment; + FSegments[FSegmentCnt].StartVA := VA; + FSegments[FSegmentCnt].EndVA := VA + DWORD(Len); + FSegments[FSegmentCnt].UnitName.RawValue := UnitName; + Inc(FSegmentCnt); + Break; + end; +end; + +function TJclMapScanner.SourceNameFromAddr(Addr: DWORD): string; +var + I: Integer; + ModuleStartVA: DWORD; +begin + // try with line numbers first (Delphi compliance) + ModuleStartVA := ModuleStartFromAddr(Addr); + Result := ''; + I := SearchDynArray(FSourceNames, SizeOf(FSourceNames[0]), Search_MapProcName, @Addr, True); + if (I <> -1) and (FSourceNames[I].VA >= ModuleStartVA) then + Result := MapStringCacheToStr(FSourceNames[I].ProcName); + if Result = '' then + begin + // try with module names (C++Builder compliance) + I := IndexOfSegment(Addr); + if I <> -1 then + Result := MapStringCacheToFileName(FSegments[I].UnitName); + end; +end; + +end. + diff --git a/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas b/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas index f5c90cba2c..1ffa354f0e 100644 --- a/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas +++ b/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas @@ -8,7 +8,7 @@ uses System.SysUtils, Winapi.Windows, - JclDebug; + Keyman.System.JclMapScanner; type TMapToSymFindFileProc = function(const UnitName: string): string; @@ -69,7 +69,7 @@ var s: TJclMapScannerCracker; r: TStringList; i: Integer; - fileName, groupName, unitName: string; + fileName, unitName: string; procCount, lineCount: Integer; procLen, lineIndex, lineLen: Integer; procName: string; diff --git a/windows/src/buildtools/sentrytool/sentrytool.dpr b/windows/src/buildtools/sentrytool/sentrytool.dpr index f1ed8450b6..0f275594aa 100644 --- a/windows/src/buildtools/sentrytool/sentrytool.dpr +++ b/windows/src/buildtools/sentrytool/sentrytool.dpr @@ -9,7 +9,8 @@ uses Keyman.System.SentryTool.SentryToolMain in 'Keyman.System.SentryTool.SentryToolMain.pas', Keyman.System.MapToSym in 'Keyman.System.MapToSym.pas', Keyman.System.AddPdbToPe in 'Keyman.System.AddPdbToPe.pas', - Keyman.System.SentryTool.DelphiSearchFile in 'Keyman.System.SentryTool.DelphiSearchFile.pas'; + Keyman.System.SentryTool.DelphiSearchFile in 'Keyman.System.SentryTool.DelphiSearchFile.pas', + Keyman.System.JclMapScanner in 'Keyman.System.JclMapScanner.pas'; begin try diff --git a/windows/src/buildtools/sentrytool/sentrytool.dproj b/windows/src/buildtools/sentrytool/sentrytool.dproj index 2e2743555d..a711b8689f 100644 --- a/windows/src/buildtools/sentrytool/sentrytool.dproj +++ b/windows/src/buildtools/sentrytool/sentrytool.dproj @@ -97,6 +97,7 @@ + Cfg_2 Base @@ -138,7 +139,7 @@ true - + sentrytool.exe true