From 2a88900abf6ba2ec2110172fdf6f9fddbef19555 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Wed, 10 Jul 2024 01:01:39 +0200 Subject: [PATCH 1/2] Missing unload --- FastMM4.pas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FastMM4.pas b/FastMM4.pas index bf1d520..1326b23 100644 --- a/FastMM4.pas +++ b/FastMM4.pas @@ -20401,9 +20401,9 @@ procedure FinalizeMemoryManager; ReportLockContention; {$ENDIF} {$IFNDEF NeverUninstall} -// {$IF Defined( FullDebugMode ) AND Defined( LoadDebugDLLDynamically )} -// FullDebugModeUnload; -// {$IFEND} + {$IF Defined( FullDebugMode ) AND Defined( LoadDebugDLLDynamically )} // MS + FastMM_FreeDebugSupportLibrary; + {$IFEND} {Clean up: Free all memory. If this is a .DLL that owns its own MM, then it is necessary to prevent the main application from running out of From 5b52b0cfc719767b9078be268a4f7259f45530e7 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Wed, 10 Jul 2024 01:26:21 +0200 Subject: [PATCH 2/2] v1.65 Synchronized with my latest code again - which is equal to v1.65 from FastMM5 but it builds from Delphi7 upwards --- FullDebugMode DLL/FastMM_FullDebugMode.dpr | 297 +++++++++++---------- 1 file changed, 155 insertions(+), 142 deletions(-) diff --git a/FullDebugMode DLL/FastMM_FullDebugMode.dpr b/FullDebugMode DLL/FastMM_FullDebugMode.dpr index 229692f..226a287 100644 --- a/FullDebugMode DLL/FastMM_FullDebugMode.dpr +++ b/FullDebugMode DLL/FastMM_FullDebugMode.dpr @@ -1,5 +1,5 @@ { -Fast Memory Manager: FullDebugMode Support DLL 1.65 +Fast Memory Manager: FullDebugMode Support DLL 1.64 Description: Support DLL for FastMM. With this DLL available, FastMM will report debug info (unit name, line numbers, etc.) for @@ -48,9 +48,6 @@ Change log: Version 1.64 (27 February 2021) - Implemented a return address information cache that greatly speeds up the conversion of many similar stack traces to text. - Version 1.65 (10 July 2023) - - Made LogStackTrace thread safe. - } {$IFDEF MSWINDOWS} @@ -70,14 +67,11 @@ time.} library FastMM_FullDebugMode; uses - {$ifdef JCLDebug} - JCLDebug, - {$IF NOT Declared( AtomicCmpExchange )}SyncObjs,{$IFEND} - {$endif} + {$ifdef JCLDebug}JCLDebug,{$endif} {$ifdef madExcept}madStackTrace,{$endif} {$ifdef EurekaLog_Legacy}ExceptionLog,{$endif} {$ifdef EurekaLog_V7}EFastMM4Support,{$endif} - SysUtils, {$IFDEF MACOS}Posix.Base, SBMapFiles{$ELSE}Windows{$ENDIF}; + SysUtils, {$IFDEF MACOS}Posix.Base, SBMapFiles {$ELSE}Windows {$ENDIF}; {$R *.res} @@ -129,132 +123,180 @@ type {$IFEND} end; -function TReturnAddressInfoCache.AddEntry(AReturnAddress: NativeUInt; const AReturnAddressInfoText: AnsiString): PReturnAddressInfo; var LReturnAddressInfoCache: TReturnAddressInfoCache; - Result := @Entries[NextNewEntryIndex]; - - {Delete it if it is already in use} - DeleteEntry(Result); - - {Step down the tree until an open slot is found in the required direction.} - LParentItem := @Entries[0]; - LAddressBits := AReturnAddress; - while True do - begin - {Get the current child in the appropriate direction.} - LChildItem := LParentItem.ChildEntries[LAddressBits and 1]; - {No child -> This slot is available.} - if LChildItem = nil then - Break; - {Traverse further down the tree.} - LParentItem := LChildItem; - LAddressBits := LAddressBits shr 1; - end; - LChildIndex := LAddressBits and 1; - - {Insert the node into the tree} - LParentItem.ChildEntries[LChildIndex] := Result; - Result.ParentEntry := LParentItem; - - {Set the info text for the item.} - Result.ReturnAddress := AReturnAddress; - Result.InfoTextLength := Length(AReturnAddressInfoText); - if Result.InfoTextLength > CMaxInfoTextLength then - Result.InfoTextLength := CMaxInfoTextLength; - System.Move(Pointer(AReturnAddressInfoText)^, Result.InfoText, Result.InfoTextLength * SizeOf(AnsiChar)); -end; - +{$IF CompilerVersion >= 23} procedure TReturnAddressInfoCache.DeleteEntry(AEntry: PReturnAddressInfo); +{$ELSE} +procedure TReturnAddressInfoCache_DeleteEntry(AEntry: PReturnAddressInfo); +{$IFEND} var LRemovedItemChildIndex, LMovedItemChildIndex: Integer; LMovedItem, LChildItem: PReturnAddressInfo; begin - {Is this entry currentlty in the tree?} - if AEntry.ParentEntry = nil then - Exit; - - LRemovedItemChildIndex := Ord(AEntry.ParentEntry.ChildEntries[1] = AEntry); + {$IF CompilerVersion < 23} + with LReturnAddressInfoCache do + begin + {$IFEND} + {Is this entry currentlty in the tree?} + if AEntry.ParentEntry = nil then + Exit; - {Does this item have children of its own?} - if (NativeInt(AEntry.ChildEntries[0]) or NativeInt(AEntry.ChildEntries[1])) <> 0 then - begin - {It has children: We need to traverse child items until we find a leaf item and then move it into this item's - position in the search tree.} - LMovedItem := AEntry; + LRemovedItemChildIndex := Ord(AEntry.ParentEntry.ChildEntries[1] = AEntry); - while True do + {Does this item have children of its own?} + if (NativeInt(AEntry.ChildEntries[0]) or NativeInt(AEntry.ChildEntries[1])) <> 0 then begin - LChildItem := LMovedItem.ChildEntries[0]; //try left then right - if LChildItem = nil then + {It has children: We need to traverse child items until we find a leaf item and then move it into this item's + position in the search tree.} + LMovedItem := AEntry; + + while True do begin - LChildItem := LMovedItem.ChildEntries[1]; + LChildItem := LMovedItem.ChildEntries[0]; //try left then right if LChildItem = nil then - Break; + begin + LChildItem := LMovedItem.ChildEntries[1]; + if LChildItem = nil then + Break; + end; + LMovedItem := LChildItem; end; - LMovedItem := LChildItem; - end; - {Disconnect the moved item from its current parent item.} - LMovedItemChildIndex := Ord(LMovedItem.ParentEntry.ChildEntries[1] = LMovedItem); - LMovedItem.ParentEntry.ChildEntries[LMovedItemChildIndex] := nil; + {Disconnect the moved item from its current parent item.} + LMovedItemChildIndex := Ord(LMovedItem.ParentEntry.ChildEntries[1] = LMovedItem); + LMovedItem.ParentEntry.ChildEntries[LMovedItemChildIndex] := nil; - {Set the new parent for the moved item} - AEntry.ParentEntry.ChildEntries[LRemovedItemChildIndex] := LMovedItem; - LMovedItem.ParentEntry := AEntry.ParentEntry; + {Set the new parent for the moved item} + AEntry.ParentEntry.ChildEntries[LRemovedItemChildIndex] := LMovedItem; + LMovedItem.ParentEntry := AEntry.ParentEntry; - {Set the new left child for the moved item} - LChildItem := AEntry.ChildEntries[0]; - if LChildItem <> nil then + {Set the new left child for the moved item} + LChildItem := AEntry.ChildEntries[0]; + if LChildItem <> nil then + begin + LMovedItem.ChildEntries[0] := LChildItem; + LChildItem.ParentEntry := LMovedItem; + AEntry.ChildEntries[0] := nil; + end; + + {Set the new right child for the moved item} + LChildItem := AEntry.ChildEntries[1]; + if LChildItem <> nil then + begin + LMovedItem.ChildEntries[1] := LChildItem; + LChildItem.ParentEntry := LMovedItem; + AEntry.ChildEntries[1] := nil; + end; + + end + else begin - LMovedItem.ChildEntries[0] := LChildItem; - LChildItem.ParentEntry := LMovedItem; - AEntry.ChildEntries[0] := nil; + {The deleted item is a leaf item: Remove it from the tree directly.} + AEntry.ParentEntry.ChildEntries[LRemovedItemChildIndex] := nil; + end; + {Reset the parent for the removed item.} + AEntry.ParentEntry := nil; + {$IF CompilerVersion < 23} end; + {$IFEND} +end; - {Set the new right child for the moved item} - LChildItem := AEntry.ChildEntries[1]; - if LChildItem <> nil then +{$IF CompilerVersion >= 23} +function TReturnAddressInfoCache.AddEntry(AReturnAddress: NativeUInt; const AReturnAddressInfoText: AnsiString): PReturnAddressInfo; +{$ELSE} +function TReturnAddressInfoCache_AddEntry(AReturnAddress: NativeUInt; const AReturnAddressInfoText: AnsiString): PReturnAddressInfo; +{$IFEND} +var + LParentItem, LChildItem: PReturnAddressInfo; + LAddressBits: NativeUInt; + LChildIndex: Integer; +begin + {$IF CompilerVersion < 23} + with LReturnAddressInfoCache do begin - LMovedItem.ChildEntries[1] := LChildItem; - LChildItem.ParentEntry := LMovedItem; - AEntry.ChildEntries[1] := nil; - end; + {$IFEND} + {Get the address of the entry to reuse. (Entry 0 is the tree root.)} + if NextNewEntryIndex = High(Entries) then + NextNewEntryIndex := 0; + Inc(NextNewEntryIndex); - end - else - begin - {The deleted item is a leaf item: Remove it from the tree directly.} - AEntry.ParentEntry.ChildEntries[LRemovedItemChildIndex] := nil; - end; - {Reset the parent for the removed item.} - AEntry.ParentEntry := nil; + Result := @Entries[NextNewEntryIndex]; + + {Delete it if it is already in use} + {$IF CompilerVersion >= 23} + DeleteEntry(Result); + {$ELSE} + TReturnAddressInfoCache_DeleteEntry(Result); + {$IFEND} + + {Step down the tree until an open slot is found in the required direction.} + LParentItem := @Entries[0]; + LAddressBits := AReturnAddress; + while True do + begin + {Get the current child in the appropriate direction.} + LChildItem := LParentItem.ChildEntries[LAddressBits and 1]; + {No child -> This slot is available.} + if LChildItem = nil then + Break; + {Traverse further down the tree.} + LParentItem := LChildItem; + LAddressBits := LAddressBits shr 1; + end; + LChildIndex := LAddressBits and 1; + + {Insert the node into the tree} + LParentItem.ChildEntries[LChildIndex] := Result; + Result.ParentEntry := LParentItem; + + {Set the info text for the item.} + Result.ReturnAddress := AReturnAddress; + Result.InfoTextLength := Length(AReturnAddressInfoText); + if Result.InfoTextLength > CMaxInfoTextLength then + Result.InfoTextLength := CMaxInfoTextLength; + System.Move(Pointer(AReturnAddressInfoText)^, Result.InfoText, Result.InfoTextLength * SizeOf(AnsiChar)); + {$IF CompilerVersion < 23} + end; + {$IFEND} end; +{$IF CompilerVersion >= 23} function TReturnAddressInfoCache.FindEntry(AReturnAddress: NativeUInt): PReturnAddressInfo; +{$ELSE} +function TReturnAddressInfoCache_FindEntry(AReturnAddress: NativeUInt): PReturnAddressInfo; +{$IFEND} var LAddressBits: NativeUInt; LParentItem: PReturnAddressInfo; begin - LAddressBits := AReturnAddress; - LParentItem := @Entries[0]; - {Step down the tree until the item is found or there is no child item in the required direction.} - while True do - begin - {Get the child item in the required direction.} - Result := LParentItem.ChildEntries[LAddressBits and 1]; - {If there is no child, or the child's key value matches the search key value then we're done.} - if (Result = nil) - or (Result.ReturnAddress = AReturnAddress) then + {$IF CompilerVersion < 23} + with LReturnAddressInfoCache do begin - Exit; + {$IFEND} + LAddressBits := AReturnAddress; + LParentItem := @Entries[0]; + {Step down the tree until the item is found or there is no child item in the required direction.} + while True do + begin + {Get the child item in the required direction.} + Result := LParentItem.ChildEntries[LAddressBits and 1]; + {If there is no child, or the child's key value matches the search key value then we're done.} + if (Result = nil) + or (Result.ReturnAddress = AReturnAddress) then + begin + Exit; + end; + {The child key value is not a match -> Move down the tree.} + LParentItem := Result; + LAddressBits := LAddressBits shr 1; end; - {The child key value is not a match -> Move down the tree.} - LParentItem := Result; - LAddressBits := LAddressBits shr 1; - end; + {$IF CompilerVersion < 23} + end; + {$IFEND} end; +{$ENDIF JCLDebug} {--------------------------Stack Tracing Subroutines--------------------------} @@ -480,7 +522,7 @@ var LOldMXCSR: Cardinal; begin {We assume (for now) that all code will execute within the first 4GB of address space.} - if (AReturnAddress > $ffff) {$if SizeOf(Pointer) = 8}and (AReturnAddress <= $ffffffff){$endif} then + if (AReturnAddress > $ffff) {$if SizeOf(Pointer) = 8}and (AReturnAddress <= $ffffffff){$IFEND} then begin {The call address is up to 8 bytes before the return address} LCallAddress := AReturnAddress - 8; @@ -654,7 +696,7 @@ begin {The pointer to the next stack frame appears valid: Get the return address of the current frame} LReturnAddress := PNativeUInt(LCurrentFrame + SizeOf(Pointer))^; {Does this appear to be a valid return address} - if (LReturnAddress > $ffff) {$if SizeOf(Pointer) = 8}and (LReturnAddress <= $ffffffff){$endif} then + if (LReturnAddress > $ffff) {$if SizeOf(Pointer) = 8}and (LReturnAddress <= $ffffffff){$IFEND} then begin {Is the map for this return address incorrect? It may be unknown or marked as non-executable because a library was previously not yet loaded, or perhaps this is not a valid stack frame.} @@ -775,13 +817,6 @@ begin AString := Format('%s[%s]', [AString, AInfo]); end; -var - {$IF Declared( AtomicCmpExchange )} - LLogStackTrace_Locked: Integer; //0 = unlocked, 1 = locked - {$ELSE} - LLogStackTrace_Locked : TCriticalSection; - {$IFEND} - function LogStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; var LInd: Cardinal; @@ -795,15 +830,6 @@ begin LLocationCacheInitialized := False; Result := ABuffer; - - {$IF Declared( AtomicCmpExchange )} - {This routine is protected by a lock - only one thread can be inside it at any given time.} - while AtomicCmpExchange(LLogStackTrace_Locked, 1, 0) <> 0 do - SwitchToThread; - {$ELSE} - LLogStackTrace_Locked.Enter; - {$IFEND} - try for LInd := 0 to AMaxDepth - 1 do begin @@ -817,14 +843,19 @@ begin Result := NativeUIntToHexBuf(LAddress, Result); {If the info for the return address is not yet in the cache, add it.} + {$IF CompilerVersion >= 23} LPInfo := LReturnAddressInfoCache.FindEntry(LAddress); + {$ELSE} + LPInfo := TReturnAddressInfoCache_FindEntry(LAddress); + {$IFEND} + if LPInfo = nil then begin if not LLocationCacheInitialized then begin {$if declared(BeginGetLocationInfoCache)} // available depending on the JCL's version BeginGetLocationInfoCache; - {$endif} + {$IFEND} LLocationCacheInitialized := True; end; {Get location info for the caller (at least one byte before the return address).} @@ -837,7 +868,7 @@ begin {Remove UnitName from ProcedureName, no need to output it twice} P := PChar(LInfo.ProcedureName); if (StrLComp(P, PChar(LInfo.UnitName), Length(LInfo.UnitName)) = 0) and (P[Length(LInfo.UnitName)] = '.') then - AppendInfoToString(LTempStr, Copy(LInfo.ProcedureName, Length(LInfo.UnitName) + 2)) + AppendInfoToString(LTempStr, Copy(LInfo.ProcedureName, Length(LInfo.UnitName) + 2{$IF CompilerVersion < 23},Length( LInfo.ProcedureName )-Length( LInfo.UnitName )-1{$IFEND})) else AppendInfoToString(LTempStr, LInfo.ProcedureName); @@ -861,14 +892,8 @@ begin begin {$if declared(BeginGetLocationInfoCache)} // available depending on the JCL's version EndGetLocationInfoCache; - {$endif} + {$IFEND} end; - - {$IF Declared( AtomicCmpExchange )} - LLogStackTrace_Locked := 0; - {$ELSE} - LLogStackTrace_Locked.Leave; - {$IFEND} end; end; {$endif} @@ -1118,10 +1143,6 @@ exports begin {$ifdef JCLDebug} - {$IF NOT Declared( AtomicCmpExchange )} - LLogStackTrace_Locked := TCriticalSection.Create; - {$IFEND} - {$IF CompilerVersion < 23} {$IF defined( Win32 )} // Win32 or OSX32 TestSSE := GetBriefSSEType; @@ -1133,12 +1154,4 @@ begin JclStackTrackingOptions := JclStackTrackingOptions + [stAllModules]; {$endif} - -//finalization -//{$ifdef JCLDebug} -// {$IF NOT Declared( AtomicCmpExchange )} -// LLogStackTrace_Locked.free; -// {$IFEND} -//{$endif} - end.