diff --git a/DbgCodeProfiler.pas b/DbgCodeProfiler.pas new file mode 100644 index 0000000..19d7c08 --- /dev/null +++ b/DbgCodeProfiler.pas @@ -0,0 +1,475 @@ +unit DbgCodeProfiler; + +interface + +uses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes, + System.SysUtils, System.SyncObjs, DebugerTypes; + +type + TDbgCodeProfiler = class + private + DbgTrackBreakpoints: TTrackBreakpointList; + DbgTrackRETBreakpoints: TTrackRETBreakpointList; + + public + DbgCurTrackAddress: Pointer; + + constructor Create; + destructor Destroy; override; + + procedure Clear; + + procedure SetTrackBreakpoint(const Address: Pointer; FuncInfo: TObject; const BPType: TTrackBreakpointType = tbTrackFunc); + function SetTrackRETBreakpoint(const Address: Pointer): PTrackRETBreakpoint; + + procedure RemoveTrackBreakpoint(const Address: Pointer; const BPType: TTrackBreakpointType = tbTrackFunc); + function ProcessTrackBreakPoint(DebugEvent: PDebugEvent): LongBool; + function ProcessTrackRETBreakPoint(DebugEvent: PDebugEvent): LongBool; + + procedure InitDbgTracking(const Capacity: Integer); + procedure ClearDbgTracking; + end; + +implementation + +uses + DebugInfo, WinAPIUtils, Debuger, System.Contnrs; + +{ TDbgCodeProfiler } + +procedure TDbgCodeProfiler.Clear; +begin + ClearDbgTracking; +end; + +procedure TDbgCodeProfiler.ClearDbgTracking; +begin + if Assigned(DbgTrackBreakpoints) then + begin + DbgTrackBreakpoints.Clear; + FreeAndNil(DbgTrackBreakpoints); + end; + + if Assigned(DbgTrackRETBreakpoints) then + begin + DbgTrackRETBreakpoints.Clear; + FreeAndNil(DbgTrackRETBreakpoints); + end; +end; + +constructor TDbgCodeProfiler.Create; +begin + inherited; +end; + +destructor TDbgCodeProfiler.Destroy; +begin + Clear; + + inherited; +end; + +procedure TDbgCodeProfiler.InitDbgTracking(const Capacity: Integer); +begin + DbgTrackBreakpoints := TTrackBreakpointList.Create(Capacity * 2); + DbgTrackBreakpoints.OwnsValues := True; + + DbgTrackRETBreakpoints := TTrackRETBreakpointList.Create(Capacity * 2); + DbgTrackRETBreakpoints.OwnsValues := True; +end; + +function TDbgCodeProfiler.ProcessTrackBreakPoint(DebugEvent: PDebugEvent): LongBool; +var + ThData: PThreadData; + Address: Pointer; + TrackBp: PTrackBreakpoint; + ParentFuncAddr: Pointer; + TrackRETBreakpoint: PTrackRETBreakpoint; + + procedure _RegisterTrackPoint; + var + TrackFuncInfo: TCodeTrackFuncInfo; + ParentCallFuncInfo: TCallFuncInfo; + ParentFuncInfo: TFuncInfo; + ParentTrackFuncInfo: TCodeTrackFuncInfo; + + TrackStackPoint: PTrackStackPoint; + CurTime: UInt64; + begin + // Текущее время CPU потока + CurTime := _QueryThreadCycleTime(ThData^.ThreadHandle); + + // --- Регистрируем вызываемую функцию в текущем потоке --- // + Inc(ThData^.DbgTrackEventCount); + + TrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(TrackBp^.FuncInfo)); + ThData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); + + TrackFuncInfo.IncCallCount; + TrackFuncInfo.TrackUnitInfo.IncCallCount; + + // Добавляем линк с текущей функции на родительскую + ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); + + // Добавляем линк с родительской функции на текущую + ParentTrackFuncInfo := nil; + + if Assigned(ParentCallFuncInfo) then + begin + ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); + if Assigned(ParentFuncInfo) then + begin + ParentTrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); + ThData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); + + ParentTrackFuncInfo.AddChildCall(Address); + end; + end; + + // Создание новой записи для Track Stack + TrackStackPoint := AllocMem(SizeOf(TTrackStackPoint)); + + // Добавляем в Track Stack + ThData^.DbgTrackStack.Push(TrackStackPoint); + + TrackStackPoint^.TrackFuncInfo := TrackFuncInfo; + TrackStackPoint^.ParentTrackFuncInfo := ParentTrackFuncInfo; + TrackStackPoint^.TrackRETBreakpoint := TrackRETBreakpoint; + TrackStackPoint^.Enter := CurTime; + TrackStackPoint^.Elapsed := 0; + + // --- Регистрируем вызываемую функцию в процессе --- // + TInterlocked.Increment(gvDebuger.ProcessData.DbgTrackEventCount); + + TrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData^.DbgTrackFuncList.GetTrackFuncInfo(TrackBp^.FuncInfo)); + gvDebuger.ProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); + + TrackFuncInfo.IncCallCount; + TrackFuncInfo.TrackUnitInfo.IncCallCount; + + // Добавляем линк с текущей функции на родительскую + ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); + + // Добавляем линк с родительской функции на текущую + ParentTrackFuncInfo := nil; + + if Assigned(ParentCallFuncInfo) then + begin + ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); + if Assigned(ParentFuncInfo) then + begin + ParentTrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); + gvDebuger.ProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); + + ParentTrackFuncInfo.AddChildCall(Address); + end; + end; + + // Записываем инфу для процесса + TrackStackPoint^.ProcTrackFuncInfo := TrackFuncInfo; + TrackStackPoint^.ProcParentTrackFuncInfo := ParentTrackFuncInfo; + end; + + procedure _RegisterFreeMemInfoPoint; + var + FuncInfo: TFuncInfo; + MemInfo: TGetMemInfo; + Param: TVarInfo; + Addr: Pointer; + begin + FuncInfo := TFuncInfo(TrackBp^.FuncInfo); + if (gvDebugInfo.MemoryManagerInfo.FreeMem = FuncInfo) or + (gvDebugInfo.MemoryManagerInfo.ReallocMem = FuncInfo) + then + begin + Param := TVarInfo(FuncInfo.Params[0]); + Addr := Pointer(Integer(Param.Value)); + + if gvDebuger.DbgMemoryProfiler.FindMemoryPointer(Addr, ThData, MemInfo) then + begin + Dec(ThData^.DbgGetMemInfoSize, MemInfo.Size); + + Dec(gvDebuger.ProcessData.ProcessGetMemCount); + Dec(gvDebuger.ProcessData.ProcessGetMemSize, MemInfo.Size); + + ThData^.DbgGetMemInfo.Remove(Addr); + end; + end; + end; + +begin + if gvDebuger.UpdateCurThreadContext then + begin + ThData := gvDebuger.CurThreadData; + + Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress; + if DbgTrackBreakpoints.TryGetValue(Address, TrackBp) then + begin + // Получаем адресс выхода в родительской функции + ParentFuncAddr := nil; + Check(gvDebuger.ReadData(Pointer(ThData^.Context^.Esp), @ParentFuncAddr, SizeOf(Pointer))); + + // Устанавливаем точку останова на выход + TrackRETBreakpoint := SetTrackRETBreakpoint(ParentFuncAddr); + TrackRETBreakpoint^.FuncInfo := TrackBp^.FuncInfo; + TrackRETBreakpoint^.BPType := TrackBp^.BPType; + + // Восстанавливаем Code byte для продолжения выполнения + DbgCurTrackAddress := Address; + gvDebuger.RemoveBreakpoint(Address, TrackBp^.SaveByte); + gvDebuger.SetSingleStepMode(ThData, True); + + // --- Регистрация --- // + // TODO: Можно вынести обработку в отдельный поток + if tbTrackFunc in TrackBp^.BPType then + _RegisterTrackPoint; + + if tbMemInfo in TrackBp^.BPType then + _RegisterFreeMemInfoPoint; + + // Выходим с признаком успешной регистрации + Exit(True); + end; + end; + + // Это не Track Breakpoint + Exit(False); +end; + +function TDbgCodeProfiler.ProcessTrackRETBreakPoint(DebugEvent: PDebugEvent): LongBool; +var + ThData: PThreadData; + Address: Pointer; + TrackRETBp: PTrackRETBreakpoint; + + procedure _RegisterRETTrackPoint; + var + TrackStackPoint: PTrackStackPoint; + CurTime: UInt64; + FuncAddress: Pointer; + CallFuncInfo: TCallFuncInfo; + begin + CurTime := _QueryThreadCycleTime(ThData^.ThreadHandle); + + // Обработка Track-стека текущего потока + while ThData^.DbgTrackStack.Count > 0 do + begin + TrackStackPoint := ThData^.DbgTrackStack.Pop; + + // Увеличиваем счетчик самой функции + TrackStackPoint^.Leave := CurTime; + // Thread + TrackStackPoint^.TrackFuncInfo.GrowElapsed(TrackStackPoint^.Elapsed); + // Proc + TrackStackPoint^.ProcTrackFuncInfo.GrowElapsed(TrackStackPoint^.Elapsed); + + // Увеличиваем счетчик родителя + // Thread + if TrackStackPoint^.TrackFuncInfo.ParentFuncs.TryGetValue(Address, CallFuncInfo) then + Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); + + // Proc + if TrackStackPoint^.ProcTrackFuncInfo.ParentFuncs.TryGetValue(Address, CallFuncInfo) then + Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); + + // Увеличиваем свой счетчик у родителя + // Thread + if Assigned(TrackStackPoint^.ParentTrackFuncInfo) then + begin + FuncAddress := TFuncInfo(TrackStackPoint^.TrackFuncInfo.FuncInfo).Address; + if TrackStackPoint^.ParentTrackFuncInfo.ChildFuncs.TryGetValue(FuncAddress, CallFuncInfo) then + Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); + end; + + // Proc + if Assigned(TrackStackPoint^.ProcParentTrackFuncInfo) then + begin + FuncAddress := TFuncInfo(TrackStackPoint^.ProcTrackFuncInfo.FuncInfo).Address; + if TrackStackPoint^.ProcParentTrackFuncInfo.ChildFuncs.TryGetValue(FuncAddress, CallFuncInfo) then + Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); + end; + + // Если это вершина стека - выходим + if TrackStackPoint^.TrackRETBreakpoint = TrackRETBp then + begin + // Dec(TrackRETBp.Count); + + FreeMemory(TrackStackPoint); + Break; + end; + + FreeMemory(TrackStackPoint); + end; + end; + + procedure _RegisterGetMemInfoPoint; + var + FuncInfo: TFuncInfo; + ParamSize: TVarInfo; + ParamAddr: TVarInfo; + Addr: Pointer; + Size: Cardinal; + NewMemInfo: TGetMemInfo; + begin + FuncInfo := TFuncInfo(TrackRETBp^.FuncInfo); + + // Dec(TrackRETBp^.Count); + + ParamAddr := nil; + ParamSize := nil; + + if (gvDebugInfo.MemoryManagerInfo.GetMem = FuncInfo) or + (gvDebugInfo.MemoryManagerInfo.AllocMem = FuncInfo) + then + begin + // GetMem: function(Size: NativeInt): Pointer; + // AllocMem: function(Size: NativeInt): Pointer; + + ParamSize := TVarInfo(FuncInfo.Params[0]); + + ParamAddr := TVarInfo.Create; + ParamAddr.DataType := FuncInfo.ResultType; + ParamAddr.VarKind := vkRegister; + end + else + if (gvDebugInfo.MemoryManagerInfo.ReallocMem = FuncInfo) + then + begin + // ReallocMem: function(P: Pointer; Size: NativeInt): Pointer; + + ParamSize := TVarInfo(FuncInfo.Params[1]); + + ParamAddr := TVarInfo.Create; + ParamAddr.DataType := FuncInfo.ResultType; + ParamAddr.VarKind := vkRegister; + end; + + if Assigned(ParamSize) and Assigned(ParamAddr) then + begin + Size := 1; //ParamSize.Value; + Addr := Pointer(Integer(ParamAddr.Value)); + + FreeAndNil(ParamAddr); + + // Добавляем инфу про новый объект + //NewMemInfo := AllocMem(SizeOf(RGetMemInfo)); + NewMemInfo := TGetMemInfo.Create; + + NewMemInfo.PerfIdx := gvDebuger.ProcessData.CurDbgPointIdx; + NewMemInfo.ObjAddr := Addr; + NewMemInfo.Size := Size; + + //NewMemInfo^.Stack := DbgMemInfo^.Stack; + NewMemInfo.Stack[0] := nil; + + NewMemInfo.ObjectType := ''; // На этот момент тип ещё может быть неопределен + + ThData^.DbgGetMemInfo.AddOrSetValue(Addr, NewMemInfo); + Inc(ThData^.DbgGetMemInfoSize, NewMemInfo.Size); + + Inc(gvDebuger.ProcessData.ProcessGetMemCount); + Inc(gvDebuger.ProcessData.ProcessGetMemSize, NewMemInfo.Size); + end; + end; + +begin + if gvDebuger.UpdateCurThreadContext then + begin + ThData := gvDebuger.CurThreadData; + + Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress; + if DbgTrackRETBreakpoints.TryGetValue(Address, TrackRETBp) and (TrackRETBp.Count > 0){???} then + begin + if tbTrackFunc in TrackRETBp^.BPType then + _RegisterRETTrackPoint; + + if tbMemInfo in TrackRETBp^.BPType then + _RegisterGetMemInfoPoint; + + // Уменьшаем счетчик + if TrackRETBp.Count > 0 then + Dec(TrackRETBp.Count); + + // Восстанавливаем breakpoint в случае рекурсивного вызова функции + if TrackRETBp.Count > 0 then + DbgCurTrackAddress := Address; + + // Восстанавливаем byte-code для продолжения выполнения + gvDebuger.RemoveBreakpoint(Address, TrackRETBp^.SaveByte); + + //if TrackRETBp^.Count = 0 then + // DbgTrackRETBreakpoints.Remove(Address); + + gvDebuger.SetSingleStepMode(ThData, True); + + Exit(True); + end; + end; + + Exit(False); +end; + +procedure TDbgCodeProfiler.RemoveTrackBreakpoint(const Address: Pointer; const BPType: TTrackBreakpointType); +var + TrackBp: PTrackBreakpoint; +begin + if DbgTrackBreakpoints.TryGetValue(Address, TrackBp) then + begin + Exclude(TrackBp^.BPType, BPType); + + if TrackBp^.BPType = [] then + begin + gvDebuger.RemoveBreakpoint(Address, TrackBp^.SaveByte); + //DbgTrackBreakpoints.Remove(Address); + end; + end + else + RaiseDebugCoreException(); +end; + +procedure TDbgCodeProfiler.SetTrackBreakpoint(const Address: Pointer; FuncInfo: TObject; const BPType: TTrackBreakpointType); +var + TrackBk: PTrackBreakpoint; +begin + if not DbgTrackBreakpoints.TryGetValue(Address, TrackBk) then + begin + TrackBk := AllocMem(SizeOf(TTrackBreakpoint)); + + TrackBk^.FuncInfo := FuncInfo; + TrackBk^.SaveByte := 0; + + TrackBk^.BPType := []; + Include(TrackBk^.BPType, BPType); + + gvDebuger.SetBreakpoint(Address, TrackBk^.SaveByte); + + DbgTrackBreakpoints.Add(Address, TrackBk); + end + else + Include(TrackBk^.BPType, BPType); +end; + +function TDbgCodeProfiler.SetTrackRETBreakpoint(const Address: Pointer): PTrackRETBreakpoint; +begin + if DbgTrackRETBreakpoints.TryGetValue(Address, Result) then + begin + Inc(Result^.Count); + + gvDebuger.RestoreBreakpoint(Address); + end + else + begin + GetMem(Result, SizeOf(TTrackRETBreakpoint)); + + Result^.Count := 1; + + Result^.SaveByte := 0; + gvDebuger.SetBreakpoint(Address, Result^.SaveByte); + + Result^.BPType := []; + + DbgTrackRETBreakpoints.Add(Address, Result); + end; +end; + +end. diff --git a/DbgMemoryProfiler.pas b/DbgMemoryProfiler.pas new file mode 100644 index 0000000..f09684a --- /dev/null +++ b/DbgMemoryProfiler.pas @@ -0,0 +1,293 @@ +unit DbgMemoryProfiler; + +interface + +uses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes, + System.SysUtils, System.SyncObjs, DebugerTypes; + +type + TProcessMemoryQueue = TQueue; + + TDbgMemoryProfiler = class + private + FProcessMemoryQueue: TProcessMemoryQueue; + + FMemoryCheckMode: LongBool; + FMemoryCallStack: LongBool; + FMemoryCheckDoubleFree: LongBool; + + procedure SetMemoryCallStack(const Value: LongBool); + procedure SetMemoryCheckDoubleFree(const Value: LongBool); + procedure SetMemoryCheckMode(const Value: LongBool); + public + constructor Create; + destructor Destroy; override; + + procedure Clear; + + function ProcessMemoryInfoQueue: LongBool; + procedure ProcessMemoryInfoBuf(const Buf: PDbgMemInfoListBuf); + + function FindMemoryPointer(const Ptr: Pointer; var ThData: PThreadData; var MemInfo: TGetMemInfo): LongBool; + + procedure LoadMemoryInfoPackEx(const MemInfoPack: Pointer; const Count: Cardinal); + + procedure UpdateMemoryInfoObjectTypes; + procedure UpdateMemoryInfoObjectTypesOfThread(ThData: PThreadData); + + property MemoryCheckMode: LongBool read FMemoryCheckMode write SetMemoryCheckMode; + property MemoryCallStack: LongBool read FMemoryCallStack write SetMemoryCallStack; + property MemoryCheckDoubleFree: LongBool read FMemoryCheckDoubleFree write SetMemoryCheckDoubleFree; + end; + +implementation + +uses Debuger; + +const + _MAX_MEM_INFO_BUF_COUNT = 512; + + +{ TDbgMemoryProfiler } + +procedure TDbgMemoryProfiler.Clear; +begin + FProcessMemoryQueue.Clear; +end; + +constructor TDbgMemoryProfiler.Create; +begin + inherited; + + FProcessMemoryQueue := TProcessMemoryQueue.Create(True); + FProcessMemoryQueue.Capacity := _MAX_MEM_INFO_BUF_COUNT + 1; +end; + +destructor TDbgMemoryProfiler.Destroy; +begin + Clear; + + FreeAndNil(FProcessMemoryQueue); + + inherited; +end; + +function TDbgMemoryProfiler.FindMemoryPointer(const Ptr: Pointer; var ThData: PThreadData; var MemInfo: TGetMemInfo): LongBool; +var + Idx: Integer; +begin + Result := False; + + // Ищем в текущем потоке + if ThData <> Nil then + Result := ThData^.DbgGetMemInfo.TryGetValue(Ptr, MemInfo); + + if not Result then + begin + // Ищем в других потоках + Idx := 0; + repeat + ThData := gvDebuger.GetThreadDataByIdx(Idx); + if ThData <> Nil then + begin + Result := ThData^.DbgGetMemInfo.TryGetValue(Ptr, MemInfo); + + Inc(Idx); + end; + until Result or (ThData = Nil); + end; +end; + +procedure TDbgMemoryProfiler.LoadMemoryInfoPackEx(const MemInfoPack: Pointer; const Count: Cardinal); +var + Buf: PDbgMemInfoListBuf; +begin + if not MemoryCheckMode then + Exit; + + while FProcessMemoryQueue.Count >= _MAX_MEM_INFO_BUF_COUNT do + SwitchToThread; + + Buf := AllocMem(SizeOf(TDbgMemInfoListBuf)); + Buf^.Count := Count; + Buf^.DbgMemInfoList := AllocMem(Count * SizeOf(TDbgMemInfo)); + Buf^.DbgPointIdx := gvDebuger.ProcessData.CurDbgPointIdx; + + if gvDebuger.ReadData(MemInfoPack, Buf^.DbgMemInfoList, Count * SizeOf(TDbgMemInfo)) then + FProcessMemoryQueue.Enqueue(Buf) + else + RaiseDebugCoreException(); +end; + +procedure TDbgMemoryProfiler.ProcessMemoryInfoBuf(const Buf: PDbgMemInfoListBuf); +var + Idx: Integer; + DbgMemInfo: PDbgMemInfo; + ThData: PThreadData; + FoundThData: PThreadData; + MemInfo: TGetMemInfo; + NewMemInfo: TGetMemInfo; +begin + ThData := Nil; + + for Idx := 0 to Buf^.Count - 1 do + begin + DbgMemInfo := @Buf^.DbgMemInfoList^[Idx]; + if (ThData = Nil) or (ThData^.ThreadID <> DbgMemInfo^.ThreadId) then + ThData := gvDebuger.GetThreadData(DbgMemInfo^.ThreadId, True); + + if ThData = Nil then + RaiseDebugCoreException(); + + case DbgMemInfo^.MemInfoType of + miGetMem: + begin + //DoDbgLog(DbgMemInfo^.ThreadId, Format('%s: %p (%d)', ['GetMem', DbgMemInfo^.Ptr, DbgMemInfo^.Size])); + + // Если найден ещё неосвобожденный объект, то он уже был кем-то освобожден + // TODO: Если есть такие объекты, то это мы где-то пропустили FreeMem + (* + FoundThData := ThData; + if FindMemoryPointer(DbgMemInfo^.Ptr, FoundThData, MemInfo) then + begin + //DoDbgLog(FoundThData^.ThreadId, Format('<<< ERROR!!! FOUND BEFORE GETMEM (%d)', [MemInfo^.Size])); + + Dec(FoundThData^.DbgGetMemInfoSize, MemInfo^.Size); + + Dec(FProcessData.ProcessGetMemCount); + Dec(FProcessData.ProcessGetMemSize, MemInfo^.Size); + + FoundThData^.DbgGetMemInfo.Remove(DbgMemInfo^.Ptr); + end; + *) + + // Добавляем инфу про новый объект + NewMemInfo := TGetMemInfo.Create; + + NewMemInfo.PerfIdx := Buf^.DbgPointIdx; + NewMemInfo.ObjAddr := DbgMemInfo^.Ptr; + NewMemInfo.Size := DbgMemInfo^.Size; + NewMemInfo.ObjectType := ''; // На этот момент тип ещё может быть неопределен + + NewMemInfo.LoadStack(@DbgMemInfo^.Stack); + + ThData^.DbgGetMemInfo.AddOrSetValue(DbgMemInfo^.Ptr, NewMemInfo); + TInterlocked.Add(ThData^.DbgGetMemInfoSize, NewMemInfo.Size); + + TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemCount, 1); + TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemSize, NewMemInfo.Size); + end; + miFreeMem: + begin + //DoDbgLog(DbgMemInfo^.ThreadId, Format('%s: %p (%d)', ['FreeMem', DbgMemInfo^.Ptr, DbgMemInfo^.Size])); + + FoundThData := ThData; + if FindMemoryPointer(DbgMemInfo^.Ptr, FoundThData, MemInfo) then + begin + TInterlocked.Add(FoundThData^.DbgGetMemInfoSize, -MemInfo.Size); + + TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemCount, -1); + TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemSize, -MemInfo.Size); + + FoundThData^.DbgGetMemInfo.Remove(DbgMemInfo^.Ptr); + end + else + begin + // Сюда может зайти, если объект создался раньше установки хука на менеджер памяти + //RaiseDebugCoreException(); + //DoDbgLog(DbgMemInfo^.ThreadId, '<<< ERROR!!! NOT FOUND FOR FREEMEM'); + + // TODO: Double free ??? + end; + end; + end; + end; +end; + +function TDbgMemoryProfiler.ProcessMemoryInfoQueue: LongBool; +var + Buf: PDbgMemInfoListBuf; +begin + Result := False; + + if not MemoryCheckMode then + Exit; + + try + if FProcessMemoryQueue.Count > 0 then + begin + Buf := FProcessMemoryQueue.Dequeue; + try + ProcessMemoryInfoBuf(Buf); + finally + FreeMemory(Buf^.DbgMemInfoList); + FreeMemory(Buf); + end; + + Result := True; + end; + except + on E: Exception do ; // TODO: + end; +end; + +procedure TDbgMemoryProfiler.SetMemoryCallStack(const Value: LongBool); +begin + FMemoryCallStack := Value; +end; + +procedure TDbgMemoryProfiler.SetMemoryCheckDoubleFree(const Value: LongBool); +begin + FMemoryCheckDoubleFree := Value; +end; + +procedure TDbgMemoryProfiler.SetMemoryCheckMode(const Value: LongBool); +begin + FMemoryCheckMode := Value; +end; + +procedure TDbgMemoryProfiler.UpdateMemoryInfoObjectTypes; +var + Idx: Integer; + ThData: PThreadData; +begin + Idx := 0; + repeat + ThData := gvDebuger.GetThreadDataByIdx(Idx); + if ThData <> Nil then + begin + UpdateMemoryInfoObjectTypesOfThread(ThData); + Inc(Idx); + end; + until ThData = Nil; + + // Потеряшки + (* + GetMemInfo := ProcessData.DbgGetMemInfo; + if GetMemInfo.Count > 0 then + begin + for GetMemInfoItem in GetMemInfo do + GetMemInfoItem.Value^.ObjectType := GetMemInfoItem.Value^.GetObjectType(GetMemInfoItem.Key); + end; + *) +end; + +procedure TDbgMemoryProfiler.UpdateMemoryInfoObjectTypesOfThread(ThData: PThreadData); +var + GetMemInfo: TGetMemInfoList; + GetMemInfoItem: TGetMemInfoItem; +begin + GetMemInfo := ThData^.DbgGetMemInfo; + if GetMemInfo.Count > 0 then + begin + GetMemInfo.LockForRead; + try + for GetMemInfoItem in GetMemInfo do + GetMemInfoItem.Value.CheckObjectType; + finally + GetMemInfo.UnLockForRead; + end; + end; +end; + +end. diff --git a/DbgSamplingProfiler.pas b/DbgSamplingProfiler.pas new file mode 100644 index 0000000..5aa90e8 --- /dev/null +++ b/DbgSamplingProfiler.pas @@ -0,0 +1,317 @@ +unit DbgSamplingProfiler; + +interface + +uses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes, + System.SysUtils, System.SyncObjs, DebugerTypes; + +type + TDbgSamplingProfiler = class + private + // Timers + FTimerQueue: THandle; + FSamplingTimer: THandle; + FSamplingLock: TCriticalSection; + public + constructor Create; + destructor Destroy; override; + + procedure Clear; + + procedure InitSamplingTimer; + procedure ResetSamplingTimer; + procedure DoSamplingEvent; + + procedure ProcessDbgSamplingInfo; + function ProcessSamplingInfo: LongBool; + + procedure AddThreadSamplingInfo(ThreadData: PThreadData); + function ProcessThreadSamplingInfo(ThreadData: PThreadData): LongBool; + procedure ProcessThreadSamplingStack(ThreadData: PThreadData; var Stack: TDbgInfoStack); + procedure ProcessThreadSamplingAddress(ThData: PThreadData; FuncAddr, ParentFuncAddr: Pointer); + end; + +implementation + +uses + Debuger, WinAPIUtils, DebugInfo; + +procedure _DbgSamplingEvent(Context: Pointer; Success: LongBool); stdcall; +begin + if Assigned(gvDebuger) then + gvDebuger.DbgSamplingProfiler.DoSamplingEvent; +end; + + +{ TDbgSamplingProfiler } + +procedure TDbgSamplingProfiler.AddThreadSamplingInfo(ThreadData: PThreadData); +var + ThCPU: UInt64; + FreqCPU: Int64; + Stack: TDbgInfoStack; + StackInfo: PDbgInfoStackRec; + Res: DWORD; +begin + if Assigned(ThreadData^.ThreadAdvInfo) and (ThreadData^.ThreadAdvInfo.ThreadAdvType = tatNormal) then + begin + ThCPU := _QueryThreadCycleTime(ThreadData^.ThreadHandle); + FreqCPU := _QueryPerformanceFrequency; + + // FreqCPU - количество циклов CPU за 1 сек + // Обрабатываем только те потоки, которые получили более 10% циклов за 1 мсек + if (ThCPU - ThreadData^.SamplingCPUTime) > (FreqCPU div 10000) then + begin + ThreadData^.SamplingCPUTime := ThCPU; + Inc(ThreadData^.SamplingCount); + + SetLength(Stack, 0); + + Res := SuspendThread(ThreadData^.ThreadHandle); + if Res = 0 then + begin + if gvDebuger.UpdateThreadContext(ThreadData, CONTEXT_CONTROL) then + gvDebuger.GetCallStackEx(ThreadData, Stack); + end; + + ResumeThread(ThreadData^.ThreadHandle); + + if Length(Stack) > 0 then + begin + New(StackInfo); + StackInfo^.Stack := Stack; + + ThreadData^.SamplingQueue.Add(StackInfo); + end; + end + else + ThreadData^.SamplingCPUTime := ThCPU; + end; +end; + +procedure TDbgSamplingProfiler.Clear; +begin + +end; + +constructor TDbgSamplingProfiler.Create; +begin + inherited; + + FTimerQueue := 0; + FSamplingTimer := 0; + FSamplingLock := TCriticalSection.Create; +end; + +destructor TDbgSamplingProfiler.Destroy; +begin + Clear; + + inherited; +end; + +procedure TDbgSamplingProfiler.DoSamplingEvent; +begin + if gvDebuger.DbgState <> dsWait then Exit; + + // Игнорим обработку, если не успели за отведенное время + if FSamplingLock.TryEnter then + begin + ProcessDbgSamplingInfo; + + FSamplingLock.Leave; + end; +end; + +procedure TDbgSamplingProfiler.InitSamplingTimer; +begin + FTimerQueue := CreateTimerQueue; + if FTimerQueue <> 0 then + begin + if CreateTimerQueueTimer(FSamplingTimer, FTimerQueue, @_DbgSamplingEvent, nil, 100, 1, WT_EXECUTEINPERSISTENTTHREAD) then + begin + gvDebuger.Log('Init sampling timer - ok'); + Exit; + end; + end; + + gvDebuger.Log('Init sampling timer - fail'); +end; + +procedure TDbgSamplingProfiler.ProcessDbgSamplingInfo; +var + CPUTime: UInt64; + ThData: PThreadData; + I: Integer; + Threads: TDbgActiveThreads; +begin + CPUTime := _QueryProcessCycleTime(gvDebuger.ProcessData^.AttachedProcessHandle); + // TODO: Контроль загрузки CPU + if CPUTime > gvDebuger.ProcessData^.SamplingCPUTime then + begin + gvDebuger.ProcessData^.SamplingCPUTime := CPUTime; + TInterlocked.Increment(gvDebuger.ProcessData^.SamplingCount); + + gvDebuger.GetActiveThreads(Threads); + + for I := 0 to High(Threads) do + begin + ThData := Threads[I]; + if ThData^.State = tsActive then + AddThreadSamplingInfo(ThData); + end; + end; +end; + +function TDbgSamplingProfiler.ProcessSamplingInfo: LongBool; +var + I: Integer; + ThData: PThreadData; +begin + Result := False; + + if not(gvDebuger.CodeTracking and gvDebuger.SamplingMethod) then + Exit; + + try + for I := gvDebuger.GetThreadCount - 1 downto 0 do + begin + ThData := gvDebuger.GetThreadDataByIdx(I); + Result := ProcessThreadSamplingInfo(ThData) or Result; + end; + except + on E: Exception do ; // TODO: + end; +end; + +procedure TDbgSamplingProfiler.ProcessThreadSamplingAddress(ThData: PThreadData; FuncAddr, ParentFuncAddr: Pointer); +var + UnitInfo: TUnitInfo; + FuncInfo: TFuncInfo; + LineInfo: TLineInfo; + + TrackFuncInfo: TCodeTrackFuncInfo; + ParentCallFuncInfo: TCallFuncInfo; + ParentFuncInfo: TFuncInfo; + ParentTrackFuncInfo: TCodeTrackFuncInfo; +begin + // --- Регистрируем вызываемую функцию в текущем потоке --- // + if gvDebugInfo.GetLineInfo(FuncAddr, UnitInfo, FuncInfo, LineInfo, False) = slNotFound then + Exit; + + TrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo)); + ThData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); + + TrackFuncInfo.IncCallCount; + + // Добавление в список активных юнитов + ThData.DbgTrackUsedUnitList.AddOrSetValue(UnitInfo, TrackFuncInfo.TrackUnitInfo); + + // Добавляем линк с текущей функции на родительскую + ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); + + // Добавляем линк с родительской функции на текущую + if Assigned(ParentCallFuncInfo) then + begin + ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); + if Assigned(ParentFuncInfo) then + begin + ParentTrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); + ThData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); + + ParentTrackFuncInfo.AddChildCall(FuncAddr); + end; + end; + + // --- Регистрируем вызываемую функцию в процессе --- // + TrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData^.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo)); + gvDebuger.ProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); + + TrackFuncInfo.IncCallCount; + + // Добавление в список активных юнитов + gvDebuger.ProcessData^.DbgTrackUsedUnitList.AddOrSetValue(UnitInfo, TrackFuncInfo.TrackUnitInfo); + + // Добавляем линк с текущей функции на родительскую + ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); + + // Добавляем линк с родительской функции на текущую + if Assigned(ParentCallFuncInfo) then + begin + ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); + if Assigned(ParentFuncInfo) then + begin + ParentTrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); + gvDebuger.ProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); + + ParentTrackFuncInfo.AddChildCall(FuncAddr); + end; + end; +end; + +function TDbgSamplingProfiler.ProcessThreadSamplingInfo(ThreadData: PThreadData): LongBool; +var + StackInfo: PDbgInfoStackRec; +begin + if ThreadData.SamplingQueue.Count > 0 then + begin + try + while ThreadData.SamplingQueue.Count > 0 do + begin + StackInfo := ThreadData.SamplingQueue.Dequeue; + try + if Length(StackInfo^.Stack) > 0 then + ProcessThreadSamplingStack(ThreadData, StackInfo^.Stack); + finally + Dispose(StackInfo); + end; + end; + except + on E: Exception do ; + end; + + Result := True; + end + else + Result := False; +end; + +procedure TDbgSamplingProfiler.ProcessThreadSamplingStack(ThreadData: PThreadData; var Stack: TDbgInfoStack); +var + Idx: Integer; + TrackUnitInfoPair: TTrackUnitInfoPair; +begin + TInterlocked.Add(gvDebuger.ProcessData.DbgTrackEventCount, 1); + TInterlocked.Add(ThreadData^.DbgTrackEventCount, 1); + + try + for Idx := 0 to High(Stack) - 1 do + ProcessThreadSamplingAddress(ThreadData, Stack[Idx], Stack[Idx + 1]); + + for TrackUnitInfoPair in ThreadData.DbgTrackUsedUnitList do + TrackUnitInfoPair.Value.IncCallCount; + + for TrackUnitInfoPair in gvDebuger.ProcessData.DbgTrackUsedUnitList do + TrackUnitInfoPair.Value.IncCallCount; + finally + SetLength(Stack, 0); + ThreadData.DbgTrackUsedUnitList.Clear; + gvDebuger.ProcessData.DbgTrackUsedUnitList.Clear; + end; +end; + +procedure TDbgSamplingProfiler.ResetSamplingTimer; +begin + if FTimerQueue <> 0 then + begin + if DeleteTimerQueue(FTimerQueue) then + gvDebuger.Log('Reset timer queue - ok') + else + gvDebuger.Log('Reset timer queue - fail'); + + FSamplingTimer := 0; + FTimerQueue := 0; + end; +end; + +end. diff --git a/DbgSyncObjsProfiler.pas b/DbgSyncObjsProfiler.pas new file mode 100644 index 0000000..24ff644 --- /dev/null +++ b/DbgSyncObjsProfiler.pas @@ -0,0 +1,254 @@ +unit DbgSyncObjsProfiler; + +interface + +uses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes, + System.SysUtils, System.SyncObjs, DebugerTypes; + +type + TSyncObjsInfoQueue = TQueue; + + TDbgSyncObjsProfiler = class + private + FSyncObjsInfoQueue: TSyncObjsInfoQueue; + + FSyncObjsTracking: LongBool; + procedure SetSyncObjsTracking(const Value: LongBool); + public + constructor Create; + destructor Destroy; override; + + procedure Clear; + + function ProcessSyncObjsInfoQueue: LongBool; + procedure LoadSyncObjsInfoPackEx(const SyncObjsInfoPack: Pointer; const Count: Cardinal); + procedure ProcessSyncObjsInfoBuf(const Buf: PDbgSyncObjsInfoListBuf); + + property SyncObjsInfoQueue: TSyncObjsInfoQueue read FSyncObjsInfoQueue; + property SyncObjsTracking: LongBool read FSyncObjsTracking write SetSyncObjsTracking; + end; + +implementation + +uses Debuger, CollectList; + +const + _MAX_SYNC_OBJS_INFO_BUF_COUNT = 512; + +{ TDbgSyncObjsProfiler } + +procedure TDbgSyncObjsProfiler.Clear; +begin + FSyncObjsInfoQueue.Clear; +end; + +constructor TDbgSyncObjsProfiler.Create; +begin + inherited; + + FSyncObjsInfoQueue := TSyncObjsInfoQueue.Create(True); + FSyncObjsInfoQueue.Capacity := _MAX_SYNC_OBJS_INFO_BUF_COUNT + 1; +end; + +destructor TDbgSyncObjsProfiler.Destroy; +begin + + inherited; +end; + +procedure TDbgSyncObjsProfiler.LoadSyncObjsInfoPackEx(const SyncObjsInfoPack: Pointer; const Count: Cardinal); +var + Buf: PDbgSyncObjsInfoListBuf; +begin + if not SyncObjsTracking then + Exit; + + while FSyncObjsInfoQueue.Count >= _MAX_SYNC_OBJS_INFO_BUF_COUNT do + SwitchToThread; + + Buf := AllocMem(SizeOf(TDbgSyncObjsInfoListBuf)); + Buf^.Count := Count; + Buf^.DbgSyncObjsInfoList := AllocMem(Count * SizeOf(TDbgSyncObjsInfo)); + Buf^.DbgPointIdx := gvDebuger.ProcessData.CurDbgPointIdx; + + if gvDebuger.ReadData(SyncObjsInfoPack, Buf^.DbgSyncObjsInfoList, Count * SizeOf(TDbgSyncObjsInfo)) then + FSyncObjsInfoQueue.Enqueue(Buf) + else + RaiseDebugCoreException(); +end; + +procedure TDbgSyncObjsProfiler.ProcessSyncObjsInfoBuf(const Buf: PDbgSyncObjsInfoListBuf); +var + ThData: PThreadData; + + function FindCSLink(const CSData: PRTLCriticalSection): PSyncObjsInfo; + var + Idx: Integer; + begin + for Idx := ThData^.DbgSyncObjsInfo.Count - 1 downto 0 do + begin + Result := ThData^.DbgSyncObjsInfo[Idx]; + if (Result^.SyncObjsInfo.SyncObjsType = soInCriticalSection) and + (Result^.Link = nil) and + (Result^.SyncObjsInfo.CS = CSData) and + (Result^.SyncObjsInfo.SyncObjsStateType = sosEnter) + then + Exit; + end; + + Result := nil; + end; + +var + Idx: Integer; + SyncObjsInfo: PDbgSyncObjsInfo; + ThSyncObjsInfo: PSyncObjsInfo; + SyncObjsLink: PSyncObjsInfo; + SyncObjsLinkExt: PSyncObjsInfo; +begin + ThData := Nil; + + for Idx := 0 to Buf^.Count - 1 do + begin + SyncObjsInfo := @Buf^.DbgSyncObjsInfoList^[Idx]; + if (ThData = Nil) or (ThData^.ThreadID <> SyncObjsInfo^.ThreadId) then + ThData := gvDebuger.GetThreadData(SyncObjsInfo^.ThreadId, True); + + if ThData = Nil then + Continue; // TODO: В каких-то случаях сюда заходит + //RaiseDebugCoreException(); + + case SyncObjsInfo^.SyncObjsType of + soSleep, soWaitForSingleObject, soWaitForMultipleObjects, soEnterCriticalSection, soInCriticalSection, soSendMessage: + begin + ThData^.DbgSyncObjsInfo.BeginRead; + try + SyncObjsLink := nil; + SyncObjsLinkExt := nil; + + if SyncObjsInfo^.SyncObjsStateType = sosLeave then + begin + // Поиск sosEnter вызова + if SyncObjsInfo^.SyncObjsType = soInCriticalSection then + begin + // Так как Id события выхода не совпадает с Id входа, то ищем по указателю CS + // Необходимо найти последнее событие по CS с SyncObjsStateType = sosEnter + + SyncObjsLink := FindCSLink(SyncObjsInfo^.CS); + end + else + begin + // У остальных типов Id события входа и выхода будут совпадать + + if ThData^.DbgSyncObjsInfoByID.TryGetValue(SyncObjsInfo^.Id, SyncObjsLink) then + begin + // Удаляем отработанный Id из словаря, кроме EnterCriticalSection, + // который ещё нужен для soInCriticalSection + + if SyncObjsInfo^.SyncObjsType <> soEnterCriticalSection then + ThData^.DbgSyncObjsInfoByID.Remove(SyncObjsInfo^.Id); + end; + end; + end + else // sosEnter + begin + if SyncObjsInfo^.SyncObjsType = soInCriticalSection then + begin + // Ищем линк на soEnterCriticalSection + if ThData^.DbgSyncObjsInfoByID.TryGetValue(SyncObjsInfo^.Id, SyncObjsLinkExt) then + ThData^.DbgSyncObjsInfoByID.Remove(SyncObjsInfo^.Id); + end; + end; + + // Добавляем инфу про новый элемент + ThSyncObjsInfo := ThData^.DbgSyncObjsInfo.Add; + + if ThData^.State = tsFinished then + ThSyncObjsInfo^.PerfIdx := PThreadPoint(ThData^.DbgPoints[ThData^.DbgPoints.Count - 1])^.PerfIdx + else + ThSyncObjsInfo^.PerfIdx := Buf^.DbgPointIdx; + + // Линк на пару + ThSyncObjsInfo^.Link := SyncObjsLink; + if SyncObjsLink <> nil then + SyncObjsLink^.Link := ThSyncObjsInfo; + + // Внешний линк + ThSyncObjsInfo^.LinkExt := SyncObjsLinkExt; + if SyncObjsLinkExt <> nil then + SyncObjsLinkExt^.LinkExt := ThSyncObjsInfo; + + // Копируем инфу из буфера, так как он потом будет уничтожен + ThSyncObjsInfo^.SyncObjsInfo.Init(SyncObjsInfo); + + ThData^.DbgSyncObjsInfo.Commit; + + // Добавляем инфу про sosEnter вызовы + if SyncObjsInfo^.SyncObjsStateType = sosEnter then + begin + if SyncObjsInfo^.SyncObjsType <> soInCriticalSection then + ThData^.DbgSyncObjsInfoByID.AddOrSetValue(SyncObjsInfo^.Id, ThSyncObjsInfo); + end; + + // Формируем стек вызова + case SyncObjsInfo^.SyncObjsType of + soEnterCriticalSection, soInCriticalSection, + soSendMessage, + soWaitForSingleObject, soWaitForMultipleObjects: + begin + ThData^.DbgSyncObjsUnitList.LoadStack(ThSyncObjsInfo); + end; + end; + finally + ThData^.DbgSyncObjsInfo.EndRead; + end; + end; + soLeaveCriticalSection: + begin + // TODO: + end; + end; + end; +end; + +function TDbgSyncObjsProfiler.ProcessSyncObjsInfoQueue: LongBool; +var + Buf: PDbgSyncObjsInfoListBuf; +begin + Result := False; + + if not SyncObjsTracking then + Exit; + + if FSyncObjsInfoQueue.Count > 0 then + begin + try + // Пропускаем недавние события для корректной обработки коротких критических секций + if FSyncObjsInfoQueue.Count < _MAX_SYNC_OBJS_INFO_BUF_COUNT then + begin + Buf := FSyncObjsInfoQueue.First; + if (gvDebuger.ProcessData^.CurDbgPointIdx - Buf^.DbgPointIdx) <= 2 then + Exit; + end; + + Buf := FSyncObjsInfoQueue.Dequeue; + try + ProcessSyncObjsInfoBuf(Buf); + finally + FreeMemory(Buf^.DbgSyncObjsInfoList); + FreeMemory(Buf); + end; + + Result := True; + except + on E: Exception do ; // TODO: + end; + end; +end; + +procedure TDbgSyncObjsProfiler.SetSyncObjsTracking(const Value: LongBool); +begin + FSyncObjsTracking := Value; +end; + +end. diff --git a/DbgWorkerThread.pas b/DbgWorkerThread.pas new file mode 100644 index 0000000..2770425 --- /dev/null +++ b/DbgWorkerThread.pas @@ -0,0 +1,93 @@ +unit DbgWorkerThread; + +interface + +uses System.Classes, System.SysUtils; + +type + TDbgWorkerThread = class(TThread) + protected + procedure Execute; override; + public + constructor Create; + destructor Destroy; override; + + procedure Stop; + + class procedure Init; static; + class procedure Reset; static; + end; + +var + gvDbgWorkerThread: TDbgWorkerThread = Nil; + +implementation + +uses Debuger; + +{ TDbgWorkerThread } + +constructor TDbgWorkerThread.Create; +begin + inherited Create(True); + FreeOnTerminate := False; + + Suspended := False; +end; + +destructor TDbgWorkerThread.Destroy; +begin + inherited; +end; + +procedure TDbgWorkerThread.Execute; +var + HasNext: LongBool; +begin + NameThreadForDebugging(ClassName); + + repeat + HasNext := False; + + if Assigned(gvDebuger) then + begin + HasNext := gvDebuger.DbgSamplingProfiler.ProcessSamplingInfo; + + HasNext := gvDebuger.DbgMemoryProfiler.ProcessMemoryInfoQueue or HasNext; + HasNext := gvDebuger.DbgSysncObjsProfiler.ProcessSyncObjsInfoQueue or HasNext; + + if not HasNext then + Sleep(10); + end; + until Terminated and not(HasNext); +end; + +class procedure TDbgWorkerThread.Init; +begin + if gvDebuger.CodeTracking or + gvDebuger.DbgMemoryProfiler.MemoryCheckMode or + gvDebuger.DbgSysncObjsProfiler.SyncObjsTracking + then + begin + if gvDbgWorkerThread = Nil then + gvDbgWorkerThread := TDbgWorkerThread.Create; + end; +end; + +class procedure TDbgWorkerThread.Reset; +begin + if Assigned(gvDbgWorkerThread) then + begin + gvDbgWorkerThread.Stop; + FreeAndNil(gvDbgWorkerThread); + end; +end; + +procedure TDbgWorkerThread.Stop; +begin + Terminate; + WaitFor; +end; + + +end. diff --git a/Debuger.pas b/Debuger.pas index 2555df1..70a0f9b 100644 --- a/Debuger.pas +++ b/Debuger.pas @@ -5,7 +5,8 @@ interface uses WinApi.Windows, System.Classes, System.SysUtils, System.SyncObjs, ClassUtils, JclPeImage, JclDebug, DebugerTypes, DbgHookTypes, - Collections.Queues, Collections.Dictionaries; + Collections.Queues, Collections.Dictionaries, DbgMemoryProfiler, + DbgSyncObjsProfiler, DbgSamplingProfiler, DbgCodeProfiler; type TDebuger = class @@ -36,39 +37,20 @@ TDebuger = class FTraceEvent: TEvent; FTraceCounter: Cardinal; - // Timers - FTimerQueue: THandle; - FSamplingTimer: THandle; - FSamplingLock: TCriticalSection; - // Debug options FPerfomanceMode: LongBool; FExceptionCheckMode: LongBool; FExceptionCallStack: LongBool; - FMemoryCheckMode: LongBool; - FMemoryCallStack: LongBool; - FMemoryCheckDoubleFree: LongBool; - FCodeTracking: LongBool; FTrackSystemUnits: LongBool; FSamplingMethod: LongBool; - - FSyncObjsTracking: LongBool; // --- FMemoryBPCheckMode: LongBool; FPerfomanceCheckPtr: Pointer; - //FPerfomanceThreadId: TThreadId; - - //FDbgShareMem: THandle; - - DbgTrackBreakpoints: TTrackBreakpointList; - DbgTrackRETBreakpoints: TTrackRETBreakpointList; - - DbgCurTrackAddress: Pointer; // внешние события FMainLoopFailed: TNotifyEvent; @@ -90,8 +72,10 @@ TDebuger = class FBreakPoint: TBreakPointEvent; FHardwareBreakpoint: THardwareBreakpointEvent; - FProcessMemoryQueue: TQueue; - FProcessSyncObjsInfoQueue: TQueue; + FDbgMemoryProfiler: TDbgMemoryProfiler; + FDbgSyncObjsProfiler: TDbgSyncObjsProfiler; + FDbgSamplingProfiler: TDbgSamplingProfiler; + FDbgCodeProfiler: TDbgCodeProfiler; function GetExceptionEvent(const Index: TExceptionCode): TDefaultExceptionEvent; procedure SetExceptionEvent(const Index: TExceptionCode; const Value: TDefaultExceptionEvent); @@ -102,21 +86,6 @@ TDebuger = class procedure SetTrackSystemUnits(const Value: LongBool); procedure SetExceptionCallStack(const Value: LongBool); procedure SetExceptionCheckMode(const Value: LongBool); - procedure SetMemoryCallStack(const Value: LongBool); - procedure SetMemoryCheckDoubleFree(const Value: LongBool); - procedure SetMemoryCheckMode(const Value: LongBool); - - procedure LoadMemoryInfoPackEx(const MemInfoPack: Pointer; const Count: Cardinal); - function ProcessMemoryInfoQueue: LongBool; - procedure ProcessMemoryInfoBuf(const Buf: PDbgMemInfoListBuf); - - procedure UpdateMemoryInfoObjectTypes; - procedure UpdateMemoryInfoObjectTypesOfThread(ThData: PThreadData); - function FindMemoryPointer(const Ptr: Pointer; var ThData: PThreadData; var MemInfo: TGetMemInfo): LongBool; - - procedure LoadSyncObjsInfoPackEx(const SyncObjsInfoPack: Pointer; const Count: Cardinal); - function ProcessSyncObjsInfoQueue: LongBool; - procedure ProcessSyncObjsInfoBuf(const Buf: PDbgSyncObjsInfoListBuf); procedure DoSetBreakpoint(const Address: Pointer; var SaveByte: Byte); procedure DoSetBreakpointF(const Address: Pointer; var SaveByte: Byte); @@ -127,7 +96,6 @@ TDebuger = class procedure SetDbgTraceState(const Value: TDbgTraceState); procedure SetDbgState(const Value: TDbgState); - procedure SetSyncObjsTracking(const Value: LongBool); procedure SetSamplingMethod(const Value: LongBool); function GetActive: LongBool; inline; @@ -137,7 +105,6 @@ TDebuger = class procedure RemoveThread(const ThreadID: TThreadId); function GetThreadIndex(const ThreadID: TThreadId; const UseFinished: LongBool = False): Integer; - procedure GetActiveThreads(var Res: TDbgActiveThreads); function GetThreadInfoIndex(const ThreadId: TThreadId): Integer; function AddThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo; @@ -168,9 +135,6 @@ TDebuger = class procedure ProcessExceptionBreakPoint(DebugEvent: PDebugEvent); - function ProcessTrackBreakPoint(DebugEvent: PDebugEvent): LongBool; - function ProcessTrackRETBreakPoint(DebugEvent: PDebugEvent): LongBool; - function ProcessUserBreakPoint(DebugEvent: PDebugEvent): LongBool; function ProcessTraceBreakPoint(DebugEvent: PDebugEvent): LongBool; @@ -202,19 +166,11 @@ TDebuger = class procedure ToggleMemoryBreakpoint(Index: Integer; Active: LongBool); procedure UpdateHardwareBreakpoints(const ThreadID: TThreadId); - procedure SetSingleStepMode(const ThreadID: TThreadId; const RestoreEIPAfterBP: LongBool); overload; - procedure SetSingleStepMode(ThData: PThreadData; const RestoreEIPAfterBP: LongBool); overload; - function PerfomancePauseDebug: LongBool; function AddThreadPointInfo(ThreadData: PThreadData; const PointType: TDbgPointType; DebugEvent: PDebugEvent = nil): LongBool; function AddProcessPointInfo(const PointType: TDbgPointType): LongBool; - procedure AddThreadSamplingInfo(ThreadData: PThreadData); - function ProcessThreadSamplingInfo(ThreadData: PThreadData): LongBool; - procedure ProcessThreadSamplingStack(ThreadData: PThreadData; var Stack: TDbgInfoStack); - procedure ProcessThreadSamplingAddress(ThData: PThreadData; FuncAddr, ParentFuncAddr: Pointer); - function ProcessSamplingInfo: LongBool; public constructor Create; destructor Destroy; override; @@ -235,10 +191,6 @@ TDebuger = class // Основной цикл обработки дебажных событий procedure ProcessDebugEvents; - procedure InitSamplingTimer; - procedure ResetSamplingTimer; - procedure DoSamplingEvent; - // чтение запись данных Function ProcAllocMem(const Size: Cardinal): Pointer; Procedure ProcFreeMem(Data : Pointer; const Size: Cardinal = 0); @@ -269,6 +221,9 @@ TDebuger = class function GetRegisters(const ThreadID: TThreadId): TContext; procedure SetRegisters(const ThreadID: TThreadId; var Context: TContext); + procedure SetSingleStepMode(const ThreadID: TThreadId; const RestoreEIPAfterBP: LongBool); overload; + procedure SetSingleStepMode(ThData: PThreadData; const RestoreEIPAfterBP: LongBool); overload; + Function IsValidAddr(Const Addr: Pointer): LongBool; Function IsValidCodeAddr(Const Addr: Pointer): LongBool; Function IsValidProcessCodeAddr(Const Addr: Pointer): LongBool; @@ -281,6 +236,7 @@ TDebuger = class function CurThreadData: PThreadData; function GetThreadCount: Integer; function GetThreadDataByIdx(const Idx: Integer): PThreadData; + procedure GetActiveThreads(var Res: TDbgActiveThreads); // выполнение кода Procedure ExecuteCode(AddrPtr: Pointer; const TimeOut: Cardinal); @@ -291,16 +247,11 @@ TDebuger = class function SetUserBreakpoint(Address: Pointer; const ThreadId: TThreadId = 0; const Description: string = ''): LongBool; function SetMemoryBreakpoint(Address: Pointer; Size: Cardinal; BreakOnWrite: LongBool; const Description: string): LongBool; - procedure SetTrackBreakpoint(const Address: Pointer; FuncInfo: TObject; const BPType: TTrackBreakpointType = tbTrackFunc); - function SetTrackRETBreakpoint(const Address: Pointer): PTrackRETBreakpoint; - - procedure RemoveTrackBreakpoint(const Address: Pointer; const BPType: TTrackBreakpointType = tbTrackFunc); - - procedure InitDbgTracking(const Capacity: Integer); - procedure ClearDbgTracking; - - procedure RemoveBreakpoint(Index: Integer); + procedure RemoveBreakpoint(const Address: Pointer; const SaveByte: Byte); overload; inline; + procedure SetBreakpoint(const Address: Pointer; var SaveByte: Byte); inline; + procedure RestoreBreakpoint(const Address: Pointer); inline; + procedure RemoveBreakpoint(Index: Integer); overload; procedure ToggleBreakpoint(Index: Integer; Active: LongBool); function BreakpointCount: Integer; @@ -358,17 +309,16 @@ TDebuger = class property ExceptionCheckMode: LongBool read FExceptionCheckMode write SetExceptionCheckMode; property ExceptionCallStack: LongBool read FExceptionCallStack write SetExceptionCallStack; - property MemoryCheckMode: LongBool read FMemoryCheckMode write SetMemoryCheckMode; - property MemoryCallStack: LongBool read FMemoryCallStack write SetMemoryCallStack; - property MemoryCheckDoubleFree: LongBool read FMemoryCheckDoubleFree write SetMemoryCheckDoubleFree; - property CodeTracking: LongBool read FCodeTracking write SetCodeTracking; property TrackSystemUnits: LongBool read FTrackSystemUnits write SetTrackSystemUnits; property SamplingMethod: LongBool read FSamplingMethod write SetSamplingMethod; - property SyncObjsTracking: LongBool read FSyncObjsTracking write SetSyncObjsTracking; - property MemoryBPCheckMode: LongBool read FMemoryBPCheckMode write FMemoryBPCheckMode; + + property DbgMemoryProfiler: TDbgMemoryProfiler read FDbgMemoryProfiler; + property DbgSysncObjsProfiler: TDbgSyncObjsProfiler read FDbgSyncObjsProfiler; + property DbgSamplingProfiler: TDbgSamplingProfiler read FDbgSamplingProfiler; + property DbgCodeProfiler: TDbgCodeProfiler read FDbgCodeProfiler; end; var @@ -378,40 +328,14 @@ implementation uses RTLConsts, Math, DebugHook, DebugInfo, WinAPIUtils, Winapi.TlHelp32, Winapi.ImageHlp, - System.Contnrs, System.AnsiStrings, CollectList, Collections.Base; - -const - _MAX_SYNC_OBJS_INFO_BUF_COUNT = 512; - _MAX_MEM_INFO_BUF_COUNT = 512; - -type - TDbgWorkerThread = class(TThread) - protected - procedure Execute; override; - public - constructor Create; - destructor Destroy; override; - - procedure Stop; - - class procedure Init; static; - class procedure Reset; static; - end; - -var - gvDbgWorkerThread: TDbgWorkerThread = Nil; + System.Contnrs, System.AnsiStrings, CollectList, Collections.Base, + DbgWorkerThread; function _DbgPerfomanceHook(pvParam: Pointer): DWORD; stdcall; begin Result := DWORD(@_DbgPerfomanceHook); end; -procedure Check(const Value: LongBool); inline; -begin - if not Value then - RaiseLastOSError; -end; - function CodeDataToExceptionCode(const Value: DWORD): TExceptionCode; const EXCEPTION_UNKNOWN = 0; @@ -559,56 +483,10 @@ function TDebuger.AddThreadPointInfo(ThreadData: PThreadData; const PointType: T end; end; -procedure TDebuger.AddThreadSamplingInfo(ThreadData: PThreadData); -var - ThCPU: UInt64; - FreqCPU: Int64; - Stack: TDbgInfoStack; - StackInfo: PDbgInfoStackRec; - Res: DWORD; -begin - if Assigned(ThreadData^.ThreadAdvInfo) and (ThreadData^.ThreadAdvInfo.ThreadAdvType = tatNormal) then - begin - ThCPU := _QueryThreadCycleTime(ThreadData^.ThreadHandle); - FreqCPU := _QueryPerformanceFrequency; - - // FreqCPU - количество циклов CPU за 1 сек - // Обрабатываем только те потоки, которые получили более 10% циклов за 1 мсек - if (ThCPU - ThreadData^.SamplingCPUTime) > (FreqCPU div 10000) then - begin - ThreadData^.SamplingCPUTime := ThCPU; - Inc(ThreadData^.SamplingCount); - - SetLength(Stack, 0); - - Res := SuspendThread(ThreadData^.ThreadHandle); - if Res = 0 then - begin - if UpdateThreadContext(ThreadData, CONTEXT_CONTROL) then - GetCallStackEx(ThreadData, Stack); - end; - - ResumeThread(ThreadData^.ThreadHandle); - - if Length(Stack) > 0 then - begin - New(StackInfo); - StackInfo^.Stack := Stack; - - ThreadData^.SamplingQueue.Add(StackInfo); - end; - end - else - ThreadData^.SamplingCPUTime := ThCPU; - end; -end; - function TDebuger.AddProcessPointInfo(const PointType: TDbgPointType): LongBool; var ProcPoint: PProcessPoint; - //Prev: UInt64; Cur: UInt64; - //PPrev: Int64; PCur: Int64; PrevTime: UInt64; CurTime: UInt64; @@ -621,9 +499,6 @@ function TDebuger.AddProcessPointInfo(const PointType: TDbgPointType): LongBool; CurTime := GetProcessCPUTime(FProcessData.AttachedProcessHandle); Delta := 0; - //PPrev := 0; - //Prev := 0; - //Cur := 0; case PointType of ptStart, ptException, ptThreadInfo, ptTraceInfo {, ptMemoryInfo}: @@ -641,12 +516,10 @@ function TDebuger.AddProcessPointInfo(const PointType: TDbgPointType): LongBool; ptPerfomance: begin // дельта абсолютного времени - //PPrev := FProcessData.Elapsed; FProcessData.Elapsed := PCur; // дельта счетчика таймера CPU Cur := _QueryProcessCycleTime(FProcessData.AttachedProcessHandle); - //Prev := FProcessData.CPUElapsed; FProcessData.CPUElapsed := Cur; // Время CPU процесса @@ -670,8 +543,6 @@ function TDebuger.AddProcessPointInfo(const PointType: TDbgPointType): LongBool; case PointType of ptPerfomance: begin - //ProcPoint^.DeltaTick := PCur - PPrev; - //ProcPoint^.DeltaTickCPU := Cur - Prev; ProcPoint^.DeltaTime := Delta; end; end; @@ -730,7 +601,6 @@ function TDebuger.AttachToProcess(const ProcessID: TProcessId; SentEntryPointBre FSetEntryPointBreakPoint := SentEntryPointBreakPoint; - //FProcessInfo.State := psActive; FProcessData.ProcessID := ProcessID; Result := DebugActiveProcess(Cardinal(ProcessID)); @@ -806,8 +676,10 @@ procedure TDebuger.ClearDbgInfo; begin DbgState := dsNone; - FProcessMemoryQueue.Clear; - FProcessSyncObjsInfoQueue.Clear; + FDbgMemoryProfiler.Clear; + FDbgSyncObjsProfiler.Clear; + FDbgSamplingProfiler.Clear; + FDbgCodeProfiler.Clear; FProcessData.Clear; @@ -828,27 +700,10 @@ procedure TDebuger.ClearDbgInfo; finally FThreadAdvInfoList.Clear; - ClearDbgTracking; - FTraceCounter := 0; end; end; -procedure TDebuger.ClearDbgTracking; -begin - if Assigned(DbgTrackBreakpoints) then - begin - DbgTrackBreakpoints.Clear; - FreeAndNil(DbgTrackBreakpoints); - end; - - if Assigned(DbgTrackRETBreakpoints) then - begin - DbgTrackRETBreakpoints.Clear; - FreeAndNil(DbgTrackRETBreakpoints); - end; -end; - function TDebuger.ContinueDebug: LongBool; begin Result := False; @@ -913,18 +768,10 @@ constructor TDebuger.Create(); FPerfomanceMode := False; FPerfomanceCheckPtr := Nil; //Pointer($76FED315); - FTimerQueue := 0; - FSamplingTimer := 0; - FSamplingLock := TCriticalSection.Create; - - FProcessMemoryQueue := TQueue.Create(True); - FProcessMemoryQueue.Capacity := _MAX_MEM_INFO_BUF_COUNT + 1; - - FProcessSyncObjsInfoQueue := TQueue.Create(True); - FProcessSyncObjsInfoQueue.Capacity := _MAX_SYNC_OBJS_INFO_BUF_COUNT + 1; - - //FDbgShareMem := - // CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, 4 * 1024, 'DBG_SHARE_MEM'); + FDbgSamplingProfiler := TDbgSamplingProfiler.Create; + FDbgMemoryProfiler := TDbgMemoryProfiler.Create; + FDbgSyncObjsProfiler := TDbgSyncObjsProfiler.Create; + FDbgCodeProfiler := TDbgCodeProfiler.Create; end; function TDebuger.CurThreadData: PThreadData; @@ -1007,19 +854,16 @@ destructor TDebuger.Destroy; FreeAndNil(FThreadList); FreeAndNil(FThreadAdvInfoList); - //CloseHandle(FDbgShareMem); - //FDbgShareMem := 0; - FreeAndNil(FProcessData.DbgExceptions); FreeMemory(FProcessData); FProcessData := nil; FreeAndNil(FTraceEvent); - FreeAndNil(FSamplingLock); - - FreeAndNil(FProcessMemoryQueue); - FreeAndNil(FProcessSyncObjsInfoQueue); + FreeAndNil(FDbgMemoryProfiler); + FreeAndNil(FDbgSyncObjsProfiler); + FreeAndNil(FDbgSamplingProfiler); + FreeAndNil(FDbgCodeProfiler); inherited; end; @@ -1060,8 +904,8 @@ procedure TDebuger.DoCreateProcess(DebugEvent: PDebugEvent); FProcessData.DbgTrackUsedUnitList.OwnsKeys := False; FProcessData.DbgTrackUsedUnitList.OwnsValues := False; - DbgTrackBreakpoints := nil; - DbgTrackRETBreakpoints := nil; + //DbgTrackBreakpoints := nil; + //DbgTrackRETBreakpoints := nil; // Метка старта процесса AddProcessPointInfo(ptStart); @@ -1099,7 +943,8 @@ procedure TDebuger.DoCreateProcess(DebugEvent: PDebugEvent); end; // Запуск потока по обработке стеков - InitSamplingTimer; + if CodeTracking and SamplingMethod then + DbgSamplingProfiler.InitSamplingTimer; TDbgWorkerThread.Init; @@ -1122,7 +967,7 @@ procedure TDebuger.DoDebugString(DebugEvent: PDebugEvent); procedure TDebuger.DoExitProcess(DebugEvent: PDebugEvent); begin - ResetSamplingTimer; + DbgSamplingProfiler.ResetSamplingTimer; TDbgWorkerThread.Reset; @@ -1693,66 +1538,6 @@ function TDebuger.PauseDebug: LongBool; Result := True; end; -procedure TDebuger.InitDbgTracking(const Capacity: Integer); -begin - DbgTrackBreakpoints := TTrackBreakpointList.Create(Capacity * 2); - DbgTrackBreakpoints.OwnsValues := True; - - DbgTrackRETBreakpoints := TTrackRETBreakpointList.Create(Capacity * 2); - DbgTrackRETBreakpoints.OwnsValues := True; -end; - -procedure _DbgSamplingEvent(Context: Pointer; Success: LongBool); stdcall; -begin - if Assigned(gvDebuger) then - gvDebuger.DoSamplingEvent; -end; - -procedure TDebuger.DoSamplingEvent; -begin - if DbgState <> dsWait then Exit; - - // Игнорим обработку, если не успели за отведенное время - if FSamplingLock.TryEnter then - begin - ProcessDbgSamplingInfo(Nil); - - FSamplingLock.Leave; - end; -end; - -procedure TDebuger.InitSamplingTimer; -begin - if CodeTracking and SamplingMethod then - begin - FTimerQueue := CreateTimerQueue; - if FTimerQueue <> 0 then - begin - if CreateTimerQueueTimer(FSamplingTimer, FTimerQueue, @_DbgSamplingEvent, nil, 100, 1, WT_EXECUTEINPERSISTENTTHREAD) then - begin - Log('Init sampling timer - ok'); - Exit; - end; - end; - - Log('Init sampling timer - fail'); - end; -end; - -procedure TDebuger.ResetSamplingTimer; -begin - if FTimerQueue <> 0 then - begin - if DeleteTimerQueue(FTimerQueue) then - Log('Reset timer queue - ok') - else - Log('Reset timer queue - fail'); - - FSamplingTimer := 0; - FTimerQueue := 0; - end; -end; - function TDebuger.InjectFunc(Func: Pointer; const CodeSize: Cardinal): Pointer; begin Result := VirtualAllocEx(FProcessData.AttachedProcessHandle, nil, CodeSize, MEM_COMMIT, PAGE_READWRITE); @@ -1846,14 +1631,11 @@ procedure TDebuger.ProcessExceptionBreakPoint(DebugEvent: PDebugEvent); begin if FCodeTracking or FMemoryBPCheckMode then begin - if ProcessTrackRETBreakPoint(DebugEvent) then + if DbgCodeProfiler.ProcessTrackRETBreakPoint(DebugEvent) then Exit; - if ProcessTrackBreakPoint(DebugEvent) then + if DbgCodeProfiler.ProcessTrackBreakPoint(DebugEvent) then Exit; - - //if FMemoryBPCheckMode and not FCodeTracking then - // FMemoryBPCheckMode := (DbgTrackRETBreakpoints.Count > 0) or (DbgTrackBreakpoints.Count > 0); end; if ProcessUserBreakPoint(DebugEvent) then @@ -1926,10 +1708,10 @@ procedure TDebuger.ProcessExceptionSingleStep(DebugEvent: PDebugEvent); //if Assigned(ThData) then //begin - if Assigned(DbgCurTrackAddress) then + if Assigned(DbgCodeProfiler.DbgCurTrackAddress) then begin - DoRestoreBreakpointF(DbgCurTrackAddress); - DbgCurTrackAddress := nil; + DoRestoreBreakpointF(DbgCodeProfiler.DbgCurTrackAddress); + DbgCodeProfiler.DbgCurTrackAddress := nil; end; Exit; @@ -2042,918 +1824,140 @@ function TDebuger.ProcessHardwareBreakpoint(DebugEvent: PDebugEvent): LongBool; end; end; -procedure TDebuger.ProcessMemoryInfoBuf(const Buf: PDbgMemInfoListBuf); -var - Idx: Integer; - DbgMemInfo: PDbgMemInfo; - ThData: PThreadData; - FoundThData: PThreadData; - MemInfo: TGetMemInfo; - NewMemInfo: TGetMemInfo; +function TDebuger.ProcessTraceBreakPoint(DebugEvent: PDebugEvent): LongBool; begin - ThData := Nil; + Result := False; - for Idx := 0 to Buf^.Count - 1 do + if DbgTraceState in [dtsPause..dtsStepOut] then begin - DbgMemInfo := @Buf^.DbgMemInfoList^[Idx]; - if (ThData = Nil) or (ThData^.ThreadID <> DbgMemInfo^.ThreadId) then - ThData := GetThreadData(DbgMemInfo^.ThreadId, True); - - if ThData = Nil then - RaiseDebugCoreException(); - - case DbgMemInfo^.MemInfoType of - miGetMem: - begin - //DoDbgLog(DbgMemInfo^.ThreadId, Format('%s: %p (%d)', ['GetMem', DbgMemInfo^.Ptr, DbgMemInfo^.Size])); - - // Если найден ещё неосвобожденный объект, то он уже был кем-то освобожден - // TODO: Если есть такие объекты, то это мы где-то пропустили FreeMem - (* - FoundThData := ThData; - if FindMemoryPointer(DbgMemInfo^.Ptr, FoundThData, MemInfo) then - begin - //DoDbgLog(FoundThData^.ThreadId, Format('<<< ERROR!!! FOUND BEFORE GETMEM (%d)', [MemInfo^.Size])); - - Dec(FoundThData^.DbgGetMemInfoSize, MemInfo^.Size); - - Dec(FProcessData.ProcessGetMemCount); - Dec(FProcessData.ProcessGetMemSize, MemInfo^.Size); - - FoundThData^.DbgGetMemInfo.Remove(DbgMemInfo^.Ptr); - end; - *) - - // Добавляем инфу про новый объект - NewMemInfo := TGetMemInfo.Create; - - NewMemInfo.PerfIdx := Buf^.DbgPointIdx; - NewMemInfo.ObjAddr := DbgMemInfo^.Ptr; - NewMemInfo.Size := DbgMemInfo^.Size; - NewMemInfo.ObjectType := ''; // На этот момент тип ещё может быть неопределен - - NewMemInfo.LoadStack(@DbgMemInfo^.Stack); - - ThData^.DbgGetMemInfo.AddOrSetValue(DbgMemInfo^.Ptr, NewMemInfo); - TInterlocked.Add(ThData^.DbgGetMemInfoSize, NewMemInfo.Size); - - TInterlocked.Add(FProcessData.ProcessGetMemCount, 1); - TInterlocked.Add(FProcessData.ProcessGetMemSize, NewMemInfo.Size); - end; - miFreeMem: - begin - //DoDbgLog(DbgMemInfo^.ThreadId, Format('%s: %p (%d)', ['FreeMem', DbgMemInfo^.Ptr, DbgMemInfo^.Size])); + DbgState := dsPause; - FoundThData := ThData; - if FindMemoryPointer(DbgMemInfo^.Ptr, FoundThData, MemInfo) then - begin - TInterlocked.Add(FoundThData^.DbgGetMemInfoSize, -MemInfo.Size); + Inc(FTraceCounter); + ProcessDbgTraceInfo(DebugEvent); - TInterlocked.Add(FProcessData.ProcessGetMemCount, -1); - TInterlocked.Add(FProcessData.ProcessGetMemSize, -MemInfo.Size); + // Ждем событие на продолжение дебага + FTraceEvent.ResetEvent; + FTraceEvent.WaitFor; - FoundThData^.DbgGetMemInfo.Remove(DbgMemInfo^.Ptr); - end - else - begin - // Сюда может зайти, если объект создался раньше установки хука на менеджер памяти - //RaiseDebugCoreException(); - //DoDbgLog(DbgMemInfo^.ThreadId, '<<< ERROR!!! NOT FOUND FOR FREEMEM'); + ProcessDbgTraceInfo(DebugEvent); - // TODO: Double free ??? - end; - end; - end; + Result := True; end; end; -function TDebuger.ProcessMemoryInfoQueue: LongBool; +function TDebuger.ProcessUserBreakPoint(DebugEvent: PDebugEvent): LongBool; var - Buf: PDbgMemInfoListBuf; + Address: Pointer; + ReleaseBP: LongBool; + BreakPointIndex: Integer; begin Result := False; - if not MemoryCheckMode then - Exit; + ReleaseBP := False; + FRemoveCurrentBreakpoint := False; - try - if FProcessMemoryQueue.Count > 0 then - begin - Buf := FProcessMemoryQueue.Dequeue; - try - ProcessMemoryInfoBuf(Buf); - finally - FreeMemory(Buf^.DbgMemInfoList); - FreeMemory(Buf); - end; + Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress; + BreakPointIndex := GetBPIndex(Address, DebugEvent^.dwThreadId); + if BreakPointIndex >= 0 then + begin + if Assigned(FBreakPoint) then + FBreakPoint(Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord, BreakPointIndex, ReleaseBP) + else + CallUnhandledBreakPointEvents(ecBreakpoint, DebugEvent); - Result := True; - end; - except - on E: Exception do ; // TODO: + ToggleInt3Breakpoint(BreakPointIndex, False); + SetSingleStepMode(DebugEvent^.dwThreadId, True); + if ReleaseBP or FRemoveCurrentBreakpoint then + RemoveBreakpoint(BreakPointIndex) + else + FRestoreBPIndex := BreakPointIndex; + + Result := True; end; end; -function TDebuger.ProcessSamplingInfo: LongBool; +procedure TDebuger.ProcessDbgPerfomance(DebugEvent: PDebugEvent); var - I: Integer; ThData: PThreadData; + I: Integer; begin - Result := False; - - if not(CodeTracking and SamplingMethod) then - Exit; + DbgState := dsPerfomance; - try - for I := FThreadList.Count - 1 downto 0 do + // Добавляем инфу про состояние процесса + if AddProcessPointInfo(ptPerfomance) then + begin + // Если процесс активен, то добавляем инфу про активные потоки + for I := 0 to FThreadList.Count - 1 do begin ThData := FThreadList[I]; - Result := ProcessThreadSamplingInfo(ThData) or Result; + if ThData^.State = tsActive then + AddThreadPointInfo(ThData, ptPerfomance); end; - except - on E: Exception do ; // TODO: end; end; -procedure TDebuger.ProcessSyncObjsInfoBuf(const Buf: PDbgSyncObjsInfoListBuf); +procedure TDebuger.ProcessDbgSamplingInfo(DebugEvent: PDebugEvent); +begin + DbgSamplingProfiler.ProcessDbgSamplingInfo; +end; + +procedure TDebuger.ProcessDbgSyncObjsInfo(DebugEvent: PDebugEvent); var - ThData: PThreadData; + ER: PExceptionRecord; + DbgInfoType: TDbgInfoType; + Ptr: Pointer; + Size: Cardinal; +begin + ER := @DebugEvent^.Exception.ExceptionRecord; + DbgInfoType := TDbgInfoType(ER^.ExceptionInformation[0]); - function FindCSLink(const CSData: PRTLCriticalSection): PSyncObjsInfo; - var - Idx: Integer; - begin - for Idx := ThData^.DbgSyncObjsInfo.Count - 1 downto 0 do - begin - Result := ThData^.DbgSyncObjsInfo[Idx]; - if (Result^.SyncObjsInfo.SyncObjsType = soInCriticalSection) and - (Result^.Link = nil) and - (Result^.SyncObjsInfo.CS = CSData) and - (Result^.SyncObjsInfo.SyncObjsStateType = sosEnter) - then - Exit; - end; + case DbgInfoType of + dstSyncObjsInfo: + begin + Ptr := Pointer(ER^.ExceptionInformation[1]); + Size := ER^.ExceptionInformation[2]; - Result := nil; + DbgSysncObjsProfiler.LoadSyncObjsInfoPackEx(Ptr, Size); + end; + dstPerfomanceAndInfo: + begin + Ptr := Pointer(ER^.ExceptionInformation[3]); + Size := ER^.ExceptionInformation[4]; + + DbgSysncObjsProfiler.LoadSyncObjsInfoPackEx(Ptr, Size); + end; end; +end; +function TDebuger.ReadData(const AddrPrt, ResultPtr: Pointer; const DataSize: Integer): LongBool; var - Idx: Integer; - SyncObjsInfo: PDbgSyncObjsInfo; - ThSyncObjsInfo: PSyncObjsInfo; - SyncObjsLink: PSyncObjsInfo; - SyncObjsLinkExt: PSyncObjsInfo; + Dummy: TSysUInt; begin - ThData := Nil; - - for Idx := 0 to Buf^.Count - 1 do - begin - SyncObjsInfo := @Buf^.DbgSyncObjsInfoList^[Idx]; - if (ThData = Nil) or (ThData^.ThreadID <> SyncObjsInfo^.ThreadId) then - ThData := GetThreadData(SyncObjsInfo^.ThreadId, True); - - if ThData = Nil then - Continue; // TODO: В каких-то случаях сюда заходит - //RaiseDebugCoreException(); - - case SyncObjsInfo^.SyncObjsType of - soSleep, soWaitForSingleObject, soWaitForMultipleObjects, soEnterCriticalSection, soInCriticalSection, soSendMessage: - begin - ThData^.DbgSyncObjsInfo.BeginRead; - try - SyncObjsLink := nil; - SyncObjsLinkExt := nil; + Result := ReadProcessMemory(FProcessData.AttachedProcessHandle, AddrPrt, ResultPtr, DataSize, Dummy) and + (Integer(Dummy) = DataSize); +end; - if SyncObjsInfo^.SyncObjsStateType = sosLeave then - begin - // Поиск sosEnter вызова - if SyncObjsInfo^.SyncObjsType = soInCriticalSection then - begin - // Так как Id события выхода не совпадает с Id входа, то ищем по указателю CS - // Необходимо найти последнее событие по CS с SyncObjsStateType = sosEnter - - SyncObjsLink := FindCSLink(SyncObjsInfo^.CS); - end - else - begin - // У остальных типов Id события входа и выхода будут совпадать - - if ThData^.DbgSyncObjsInfoByID.TryGetValue(SyncObjsInfo^.Id, SyncObjsLink) then - begin - // Удаляем отработанный Id из словаря, кроме EnterCriticalSection, - // который ещё нужен для soInCriticalSection - - if SyncObjsInfo^.SyncObjsType <> soEnterCriticalSection then - ThData^.DbgSyncObjsInfoByID.Remove(SyncObjsInfo^.Id); - end; - end; - end - else // sosEnter - begin - if SyncObjsInfo^.SyncObjsType = soInCriticalSection then - begin - // Ищем линк на soEnterCriticalSection - if ThData^.DbgSyncObjsInfoByID.TryGetValue(SyncObjsInfo^.Id, SyncObjsLinkExt) then - ThData^.DbgSyncObjsInfoByID.Remove(SyncObjsInfo^.Id); - end; - end; +function TDebuger.ReadStringA(AddrPrt: Pointer; Len: Integer = 0): AnsiString; +var + C: AnsiChar; +begin + Result := ''; - // Добавляем инфу про новый элемент - ThSyncObjsInfo := ThData^.DbgSyncObjsInfo.Add; + if Len = -1 then + begin + // передан указатель на PAnsiChar. Читаем до первого #0 + // TODO: Переписать это на чтение буфером + repeat + C := #0; - if ThData^.State = tsFinished then - ThSyncObjsInfo^.PerfIdx := PThreadPoint(ThData^.DbgPoints[ThData^.DbgPoints.Count - 1])^.PerfIdx - else - ThSyncObjsInfo^.PerfIdx := Buf^.DbgPointIdx; + if not ReadData(AddrPrt, @C, SizeOf(AnsiChar)) then Exit; - // Линк на пару - ThSyncObjsInfo^.Link := SyncObjsLink; - if SyncObjsLink <> nil then - SyncObjsLink^.Link := ThSyncObjsInfo; + if C <> #0 then + begin + Result := Result + C; - // Внешний линк - ThSyncObjsInfo^.LinkExt := SyncObjsLinkExt; - if SyncObjsLinkExt <> nil then - SyncObjsLinkExt^.LinkExt := ThSyncObjsInfo; - - // Копируем инфу из буфера, так как он потом будет уничтожен - ThSyncObjsInfo^.SyncObjsInfo.Init(SyncObjsInfo); - - ThData^.DbgSyncObjsInfo.Commit; - - // Добавляем инфу про sosEnter вызовы - if SyncObjsInfo^.SyncObjsStateType = sosEnter then - begin - if SyncObjsInfo^.SyncObjsType <> soInCriticalSection then - ThData^.DbgSyncObjsInfoByID.AddOrSetValue(SyncObjsInfo^.Id, ThSyncObjsInfo); - end; - - // Формируем стек вызова - case SyncObjsInfo^.SyncObjsType of - soEnterCriticalSection, soInCriticalSection, - soSendMessage, - soWaitForSingleObject, soWaitForMultipleObjects: - begin - ThData^.DbgSyncObjsUnitList.LoadStack(ThSyncObjsInfo); - end; - end; - finally - ThData^.DbgSyncObjsInfo.EndRead; - end; - end; - soLeaveCriticalSection: - begin - // TODO: - end; - end; - end; -end; - -function TDebuger.ProcessSyncObjsInfoQueue: LongBool; -var - Buf: PDbgSyncObjsInfoListBuf; -begin - Result := False; - - if not SyncObjsTracking then - Exit; - - if FProcessSyncObjsInfoQueue.Count > 0 then - begin - try - // Пропускаем недавние события для корректной обработки коротких критических секций - if FProcessSyncObjsInfoQueue.Count < _MAX_SYNC_OBJS_INFO_BUF_COUNT then - begin - Buf := FProcessSyncObjsInfoQueue.First; - if (ProcessData^.CurDbgPointIdx - Buf^.DbgPointIdx) <= 2 then - Exit; - end; - - Buf := FProcessSyncObjsInfoQueue.Dequeue; - try - ProcessSyncObjsInfoBuf(Buf); - finally - FreeMemory(Buf^.DbgSyncObjsInfoList); - FreeMemory(Buf); - end; - - Result := True; - except - on E: Exception do ; // TODO: - end; - end; -end; - -function TDebuger.ProcessThreadSamplingInfo(ThreadData: PThreadData): LongBool; -var - StackInfo: PDbgInfoStackRec; -begin - if ThreadData.SamplingQueue.Count > 0 then - begin - try - while ThreadData.SamplingQueue.Count > 0 do - begin - StackInfo := ThreadData.SamplingQueue.Dequeue; - try - if Length(StackInfo^.Stack) > 0 then - ProcessThreadSamplingStack(ThreadData, StackInfo^.Stack); - finally - Dispose(StackInfo); - end; - end; - except - on E: Exception do ; - end; - - Result := True; - end - else - Result := False; -end; - -procedure TDebuger.ProcessThreadSamplingAddress(ThData: PThreadData; FuncAddr, ParentFuncAddr: Pointer); -var - UnitInfo: TUnitInfo; - FuncInfo: TFuncInfo; - LineInfo: TLineInfo; - - TrackFuncInfo: TCodeTrackFuncInfo; - ParentCallFuncInfo: TCallFuncInfo; - ParentFuncInfo: TFuncInfo; - ParentTrackFuncInfo: TCodeTrackFuncInfo; -begin - // --- Регистрируем вызываемую функцию в текущем потоке --- // - if gvDebugInfo.GetLineInfo(FuncAddr, UnitInfo, FuncInfo, LineInfo, False) = slNotFound then - Exit; - - TrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo)); - ThData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); - - TrackFuncInfo.IncCallCount; - - // Добавление в список активных юнитов - ThData.DbgTrackUsedUnitList.AddOrSetValue(UnitInfo, TrackFuncInfo.TrackUnitInfo); - - // Добавляем линк с текущей функции на родительскую - ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); - - // Добавляем линк с родительской функции на текущую - if Assigned(ParentCallFuncInfo) then - begin - ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); - if Assigned(ParentFuncInfo) then - begin - ParentTrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); - ThData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); - - ParentTrackFuncInfo.AddChildCall(FuncAddr); - end; - end; - - // --- Регистрируем вызываемую функцию в процессе --- // - TrackFuncInfo := TCodeTrackFuncInfo(FProcessData^.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo)); - FProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); - - TrackFuncInfo.IncCallCount; - - // Добавление в список активных юнитов - FProcessData^.DbgTrackUsedUnitList.AddOrSetValue(UnitInfo, TrackFuncInfo.TrackUnitInfo); - - // Добавляем линк с текущей функции на родительскую - ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); - - // Добавляем линк с родительской функции на текущую - if Assigned(ParentCallFuncInfo) then - begin - ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); - if Assigned(ParentFuncInfo) then - begin - ParentTrackFuncInfo := TCodeTrackFuncInfo(FProcessData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); - FProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); - - ParentTrackFuncInfo.AddChildCall(FuncAddr); - end; - end; -end; - -procedure TDebuger.ProcessThreadSamplingStack(ThreadData: PThreadData; var Stack: TDbgInfoStack); -var - Idx: Integer; - TrackUnitInfoPair: TTrackUnitInfoPair; -begin - TInterlocked.Add(FProcessData.DbgTrackEventCount, 1); - TInterlocked.Add(ThreadData^.DbgTrackEventCount, 1); - - try - for Idx := 0 to High(Stack) - 1 do - ProcessThreadSamplingAddress(ThreadData, Stack[Idx], Stack[Idx + 1]); - - for TrackUnitInfoPair in ThreadData.DbgTrackUsedUnitList do - TrackUnitInfoPair.Value.IncCallCount; - - for TrackUnitInfoPair in FProcessData.DbgTrackUsedUnitList do - TrackUnitInfoPair.Value.IncCallCount; - finally - SetLength(Stack, 0); - ThreadData.DbgTrackUsedUnitList.Clear; - FProcessData.DbgTrackUsedUnitList.Clear; - end; -end; - -function TDebuger.ProcessTraceBreakPoint(DebugEvent: PDebugEvent): LongBool; -begin - Result := False; - - if DbgTraceState in [dtsPause..dtsStepOut] then - begin - DbgState := dsPause; - - Inc(FTraceCounter); - ProcessDbgTraceInfo(DebugEvent); - - // Ждем событие на продолжение дебага - FTraceEvent.ResetEvent; - FTraceEvent.WaitFor; - - ProcessDbgTraceInfo(DebugEvent); - - Result := True; - end; -end; - -function TDebuger.ProcessTrackBreakPoint(DebugEvent: PDebugEvent): LongBool; -var - ThData: PThreadData; - Address: Pointer; - TrackBp: PTrackBreakpoint; - ParentFuncAddr: Pointer; - TrackRETBreakpoint: PTrackRETBreakpoint; - - procedure _RegisterTrackPoint; - var - TrackFuncInfo: TCodeTrackFuncInfo; - ParentCallFuncInfo: TCallFuncInfo; - ParentFuncInfo: TFuncInfo; - ParentTrackFuncInfo: TCodeTrackFuncInfo; - - TrackStackPoint: PTrackStackPoint; - CurTime: UInt64; - begin - // Текущее время CPU потока - CurTime := _QueryThreadCycleTime(ThData^.ThreadHandle); - - // --- Регистрируем вызываемую функцию в текущем потоке --- // - Inc(ThData^.DbgTrackEventCount); - - TrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(TrackBp^.FuncInfo)); - ThData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); - - TrackFuncInfo.IncCallCount; - TrackFuncInfo.TrackUnitInfo.IncCallCount; - - // Добавляем линк с текущей функции на родительскую - ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); - - // Добавляем линк с родительской функции на текущую - ParentTrackFuncInfo := nil; - - if Assigned(ParentCallFuncInfo) then - begin - ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); - if Assigned(ParentFuncInfo) then - begin - ParentTrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); - ThData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); - - ParentTrackFuncInfo.AddChildCall(Address); - end; - end; - - // Создание новой записи для Track Stack - TrackStackPoint := AllocMem(SizeOf(TTrackStackPoint)); - - // Добавляем в Track Stack - ThData^.DbgTrackStack.Push(TrackStackPoint); - - TrackStackPoint^.TrackFuncInfo := TrackFuncInfo; - TrackStackPoint^.ParentTrackFuncInfo := ParentTrackFuncInfo; - TrackStackPoint^.TrackRETBreakpoint := TrackRETBreakpoint; - TrackStackPoint^.Enter := CurTime; - TrackStackPoint^.Elapsed := 0; - - // --- Регистрируем вызываемую функцию в процессе --- // - Inc(FProcessData.DbgTrackEventCount); - - TrackFuncInfo := TCodeTrackFuncInfo(FProcessData^.DbgTrackFuncList.GetTrackFuncInfo(TrackBp^.FuncInfo)); - FProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo); - - TrackFuncInfo.IncCallCount; - TrackFuncInfo.TrackUnitInfo.IncCallCount; - - // Добавляем линк с текущей функции на родительскую - ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr); - - // Добавляем линк с родительской функции на текущую - ParentTrackFuncInfo := nil; - - if Assigned(ParentCallFuncInfo) then - begin - ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo); - if Assigned(ParentFuncInfo) then - begin - ParentTrackFuncInfo := TCodeTrackFuncInfo(FProcessData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo)); - FProcessData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo); - - ParentTrackFuncInfo.AddChildCall(Address); - end; - end; - - // Записываем инфу для процесса - TrackStackPoint^.ProcTrackFuncInfo := TrackFuncInfo; - TrackStackPoint^.ProcParentTrackFuncInfo := ParentTrackFuncInfo; - end; - - procedure _RegisterFreeMemInfoPoint; - var - FuncInfo: TFuncInfo; - MemInfo: TGetMemInfo; - Param: TVarInfo; - Addr: Pointer; - begin - FuncInfo := TFuncInfo(TrackBp^.FuncInfo); - if (gvDebugInfo.MemoryManagerInfo.FreeMem = FuncInfo) or - (gvDebugInfo.MemoryManagerInfo.ReallocMem = FuncInfo) - then - begin - Param := TVarInfo(FuncInfo.Params[0]); - Addr := Pointer(Integer(Param.Value)); - - if FindMemoryPointer(Addr, ThData, MemInfo) then - begin - Dec(ThData^.DbgGetMemInfoSize, MemInfo.Size); - - Dec(FProcessData.ProcessGetMemCount); - Dec(FProcessData.ProcessGetMemSize, MemInfo.Size); - - ThData^.DbgGetMemInfo.Remove(Addr); - end; - end; - end; - -begin - if UpdateCurThreadContext then - begin - ThData := FCurThreadData; - - Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress; - if DbgTrackBreakpoints.TryGetValue(Address, TrackBp) then - begin - // Получаем адресс выхода в родительской функции - ParentFuncAddr := nil; - Check(ReadData(Pointer(ThData^.Context^.Esp), @ParentFuncAddr, SizeOf(Pointer))); - - // Устанавливаем точку останова на выход - TrackRETBreakpoint := SetTrackRETBreakpoint(ParentFuncAddr); - TrackRETBreakpoint^.FuncInfo := TrackBp^.FuncInfo; - TrackRETBreakpoint^.BPType := TrackBp^.BPType; - - // Восстанавливаем Code byte для продолжения выполнения - DbgCurTrackAddress := Address; - DoRemoveBreakpointF(Address, TrackBp^.SaveByte); - SetSingleStepMode(ThData, True); - - // --- Регистрация --- // - // TODO: Можно вынести обработку в отдельный поток - if tbTrackFunc in TrackBp^.BPType then - _RegisterTrackPoint; - - if tbMemInfo in TrackBp^.BPType then - _RegisterFreeMemInfoPoint; - - // Выходим с признаком успешной регистрации - Exit(True); - end; - end; - - // Это не Track Breakpoint - Exit(False); -end; - -function TDebuger.ProcessTrackRETBreakPoint(DebugEvent: PDebugEvent): LongBool; -var - ThData: PThreadData; - Address: Pointer; - TrackRETBp: PTrackRETBreakpoint; - - procedure _RegisterRETTrackPoint; - var - TrackStackPoint: PTrackStackPoint; - CurTime: UInt64; - FuncAddress: Pointer; - CallFuncInfo: TCallFuncInfo; - begin - CurTime := _QueryThreadCycleTime(ThData^.ThreadHandle); - - // Обработка Track-стека текущего потока - while ThData^.DbgTrackStack.Count > 0 do - begin - TrackStackPoint := ThData^.DbgTrackStack.Pop; - - // Увеличиваем счетчик самой функции - TrackStackPoint^.Leave := CurTime; - // Thread - TrackStackPoint^.TrackFuncInfo.GrowElapsed(TrackStackPoint^.Elapsed); - // Proc - TrackStackPoint^.ProcTrackFuncInfo.GrowElapsed(TrackStackPoint^.Elapsed); - - // Увеличиваем счетчик родителя - // Thread - if TrackStackPoint^.TrackFuncInfo.ParentFuncs.TryGetValue(Address, CallFuncInfo) then - Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); - - // Proc - if TrackStackPoint^.ProcTrackFuncInfo.ParentFuncs.TryGetValue(Address, CallFuncInfo) then - Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); - - // Увеличиваем свой счетчик у родителя - // Thread - if Assigned(TrackStackPoint^.ParentTrackFuncInfo) then - begin - FuncAddress := TFuncInfo(TrackStackPoint^.TrackFuncInfo.FuncInfo).Address; - if TrackStackPoint^.ParentTrackFuncInfo.ChildFuncs.TryGetValue(FuncAddress, CallFuncInfo) then - Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); - end; - - // Proc - if Assigned(TrackStackPoint^.ProcParentTrackFuncInfo) then - begin - FuncAddress := TFuncInfo(TrackStackPoint^.ProcTrackFuncInfo.FuncInfo).Address; - if TrackStackPoint^.ProcParentTrackFuncInfo.ChildFuncs.TryGetValue(FuncAddress, CallFuncInfo) then - Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed); - end; - - // Если это вершина стека - выходим - if TrackStackPoint^.TrackRETBreakpoint = TrackRETBp then - begin - // Dec(TrackRETBp.Count); - - FreeMemory(TrackStackPoint); - Break; - end; - - FreeMemory(TrackStackPoint); - end; - end; - - procedure _RegisterGetMemInfoPoint; - var - FuncInfo: TFuncInfo; - ParamSize: TVarInfo; - ParamAddr: TVarInfo; - Addr: Pointer; - Size: Cardinal; - NewMemInfo: TGetMemInfo; - begin - FuncInfo := TFuncInfo(TrackRETBp^.FuncInfo); - - // Dec(TrackRETBp^.Count); - - ParamAddr := nil; - ParamSize := nil; - - if (gvDebugInfo.MemoryManagerInfo.GetMem = FuncInfo) or - (gvDebugInfo.MemoryManagerInfo.AllocMem = FuncInfo) - then - begin - // GetMem: function(Size: NativeInt): Pointer; - // AllocMem: function(Size: NativeInt): Pointer; - - ParamSize := TVarInfo(FuncInfo.Params[0]); - - ParamAddr := TVarInfo.Create; - ParamAddr.DataType := FuncInfo.ResultType; - ParamAddr.VarKind := vkRegister; - end - else - if (gvDebugInfo.MemoryManagerInfo.ReallocMem = FuncInfo) - then - begin - // ReallocMem: function(P: Pointer; Size: NativeInt): Pointer; - - ParamSize := TVarInfo(FuncInfo.Params[1]); - - ParamAddr := TVarInfo.Create; - ParamAddr.DataType := FuncInfo.ResultType; - ParamAddr.VarKind := vkRegister; - end; - - if Assigned(ParamSize) and Assigned(ParamAddr) then - begin - Size := 1; //ParamSize.Value; - Addr := Pointer(Integer(ParamAddr.Value)); - - FreeAndNil(ParamAddr); - - // Добавляем инфу про новый объект - //NewMemInfo := AllocMem(SizeOf(RGetMemInfo)); - NewMemInfo := TGetMemInfo.Create; - - NewMemInfo.PerfIdx := ProcessData.CurDbgPointIdx; - NewMemInfo.ObjAddr := Addr; - NewMemInfo.Size := Size; - - //NewMemInfo^.Stack := DbgMemInfo^.Stack; - NewMemInfo.Stack[0] := nil; - - NewMemInfo.ObjectType := ''; // На этот момент тип ещё может быть неопределен - - ThData^.DbgGetMemInfo.AddOrSetValue(Addr, NewMemInfo); - Inc(ThData^.DbgGetMemInfoSize, NewMemInfo.Size); - - Inc(FProcessData.ProcessGetMemCount); - Inc(FProcessData.ProcessGetMemSize, NewMemInfo.Size); - end; - end; - -begin - if UpdateCurThreadContext then - begin - ThData := FCurThreadData; - - Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress; - if DbgTrackRETBreakpoints.TryGetValue(Address, TrackRETBp) and (TrackRETBp.Count > 0){???} then - begin - if tbTrackFunc in TrackRETBp^.BPType then - _RegisterRETTrackPoint; - - if tbMemInfo in TrackRETBp^.BPType then - _RegisterGetMemInfoPoint; - - // Уменьшаем счетчик - if TrackRETBp.Count > 0 then - Dec(TrackRETBp.Count); - - // Восстанавливаем breakpoint в случае рекурсивного вызова функции - if TrackRETBp.Count > 0 then - DbgCurTrackAddress := Address; - - // Восстанавливаем byte-code для продолжения выполнения - DoRemoveBreakpointF(Address, TrackRETBp^.SaveByte); - - //if TrackRETBp^.Count = 0 then - // DbgTrackRETBreakpoints.Remove(Address); - - SetSingleStepMode(ThData, True); - - Exit(True); - end; - end; - - Exit(False); -end; - -function TDebuger.ProcessUserBreakPoint(DebugEvent: PDebugEvent): LongBool; -var - Address: Pointer; - ReleaseBP: LongBool; - BreakPointIndex: Integer; -begin - Result := False; - - ReleaseBP := False; - FRemoveCurrentBreakpoint := False; - - Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress; - BreakPointIndex := GetBPIndex(Address, DebugEvent^.dwThreadId); - if BreakPointIndex >= 0 then - begin - if Assigned(FBreakPoint) then - FBreakPoint(Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord, BreakPointIndex, ReleaseBP) - else - CallUnhandledBreakPointEvents(ecBreakpoint, DebugEvent); - - ToggleInt3Breakpoint(BreakPointIndex, False); - SetSingleStepMode(DebugEvent^.dwThreadId, True); - if ReleaseBP or FRemoveCurrentBreakpoint then - RemoveBreakpoint(BreakPointIndex) - else - FRestoreBPIndex := BreakPointIndex; - - Result := True; - end; -end; - -procedure TDebuger.ProcessDbgPerfomance(DebugEvent: PDebugEvent); -var - ThData: PThreadData; - I: Integer; -begin - DbgState := dsPerfomance; - - // Добавляем инфу про состояние процесса - if AddProcessPointInfo(ptPerfomance) then - begin - // Если процесс активен, то добавляем инфу про активные потоки - for I := 0 to FThreadList.Count - 1 do - begin - ThData := FThreadList[I]; - if ThData^.State = tsActive then - AddThreadPointInfo(ThData, ptPerfomance); - end; - end; -end; - -procedure TDebuger.ProcessDbgSamplingInfo(DebugEvent: PDebugEvent); -var - CPUTime: UInt64; - ThData: PThreadData; - I: Integer; - Threads: TDbgActiveThreads; -begin - CPUTime := _QueryProcessCycleTime(ProcessData^.AttachedProcessHandle); - // TODO: Контроль загрузки CPU - if CPUTime > ProcessData^.SamplingCPUTime then - begin - ProcessData^.SamplingCPUTime := CPUTime; - Inc(ProcessData^.SamplingCount); - - GetActiveThreads(Threads); - - for I := 0 to High(Threads) do - begin - ThData := Threads[I]; - if ThData^.State = tsActive then - AddThreadSamplingInfo(ThData); - end; - - (* - for I := 0 to FThreadList.Count - 1 do - begin - ThData := FThreadList[I]; - if ThData^.State = tsActive then - AddThreadSamplingInfo(ThData); - end; - *) - end; -end; - -procedure TDebuger.ProcessDbgSyncObjsInfo(DebugEvent: PDebugEvent); -var - ER: PExceptionRecord; - DbgInfoType: TDbgInfoType; - Ptr: Pointer; - Size: Cardinal; -begin - ER := @DebugEvent^.Exception.ExceptionRecord; - DbgInfoType := TDbgInfoType(ER^.ExceptionInformation[0]); - - case DbgInfoType of - dstSyncObjsInfo: - begin - Ptr := Pointer(ER^.ExceptionInformation[1]); - Size := ER^.ExceptionInformation[2]; - - LoadSyncObjsInfoPackEx(Ptr, Size); - end; - dstPerfomanceAndInfo: - begin - Ptr := Pointer(ER^.ExceptionInformation[3]); - Size := ER^.ExceptionInformation[4]; - - LoadSyncObjsInfoPackEx(Ptr, Size); - end; - end; -end; - -function TDebuger.ReadData(const AddrPrt, ResultPtr: Pointer; const DataSize: Integer): LongBool; -var - Dummy: TSysUInt; -begin - Result := ReadProcessMemory(FProcessData.AttachedProcessHandle, AddrPrt, ResultPtr, DataSize, Dummy) and - (Integer(Dummy) = DataSize); -end; - -function TDebuger.ReadStringA(AddrPrt: Pointer; Len: Integer = 0): AnsiString; -var - C: AnsiChar; -begin - Result := ''; - - if Len = -1 then - begin - // передан указатель на PAnsiChar. Читаем до первого #0 - // TODO: Переписать это на чтение буфером - repeat - C := #0; - - if not ReadData(AddrPrt, @C, SizeOf(AnsiChar)) then Exit; - - if C <> #0 then - begin - Result := Result + C; - - AddrPrt := IncPointer(AddrPrt, SizeOf(AnsiChar)); - end; + AddrPrt := IncPointer(AddrPrt, SizeOf(AnsiChar)); + end; until C = #0; end @@ -3016,6 +2020,11 @@ procedure TDebuger.RemoveBreakpoint(Index: Integer); end; end; +procedure TDebuger.RemoveBreakpoint(const Address: Pointer; const SaveByte: Byte); +begin + DoRemoveBreakpointF(Address, SaveByte); +end; + procedure TDebuger.RemoveCurrentBreakpoint; begin FRemoveCurrentBreakpoint := True; @@ -3041,26 +2050,13 @@ procedure TDebuger.RemoveThread(const ThreadID: TThreadId); if AddProcessPointInfo(ptThreadInfo) then AddThreadPointInfo(ThData, ptStop); - UpdateMemoryInfoObjectTypesOfThread(ThData); + DbgMemoryProfiler.UpdateMemoryInfoObjectTypesOfThread(ThData); end; end; -procedure TDebuger.RemoveTrackBreakpoint(const Address: Pointer; const BPType: TTrackBreakpointType); -var - TrackBp: PTrackBreakpoint; +procedure TDebuger.RestoreBreakpoint(const Address: Pointer); begin - if DbgTrackBreakpoints.TryGetValue(Address, TrackBp) then - begin - Exclude(TrackBp^.BPType, BPType); - - if TrackBp^.BPType = [] then - begin - DoRemoveBreakpointF(Address, TrackBp^.SaveByte); - //DbgTrackBreakpoints.Remove(Address); - end; - end - else - RaiseDebugCoreException(); + DoRestoreBreakpointF(Address); end; procedure TDebuger.ProcessDbgException(DebugEvent: PDebugEvent); @@ -3090,74 +2086,6 @@ procedure TDebuger.ProcessDbgException(DebugEvent: PDebugEvent); end; end; -function TDebuger.FindMemoryPointer(const Ptr: Pointer; var ThData: PThreadData; var MemInfo: TGetMemInfo): LongBool; -var - Idx: Integer; -begin - Result := False; - - // Ищем в текущем потоке - if ThData <> Nil then - Result := ThData^.DbgGetMemInfo.TryGetValue(Ptr, MemInfo); - - if not Result then - begin - // Ищем в других потоках - Idx := 0; - repeat - ThData := GetThreadDataByIdx(Idx); - if ThData <> Nil then - begin - Result := ThData^.DbgGetMemInfo.TryGetValue(Ptr, MemInfo); - - Inc(Idx); - end; - until Result or (ThData = Nil); - end; -end; - -procedure TDebuger.LoadMemoryInfoPackEx(const MemInfoPack: Pointer; const Count: Cardinal); -var - Buf: PDbgMemInfoListBuf; -begin - if not MemoryCheckMode then - Exit; - - while FProcessMemoryQueue.Count >= _MAX_MEM_INFO_BUF_COUNT do - SwitchToThread; - - Buf := AllocMem(SizeOf(TDbgMemInfoListBuf)); - Buf^.Count := Count; - Buf^.DbgMemInfoList := AllocMem(Count * SizeOf(TDbgMemInfo)); - Buf^.DbgPointIdx := ProcessData.CurDbgPointIdx; - - if ReadData(MemInfoPack, Buf^.DbgMemInfoList, Count * SizeOf(TDbgMemInfo)) then - FProcessMemoryQueue.Enqueue(Buf) - else - RaiseDebugCoreException(); -end; - -procedure TDebuger.LoadSyncObjsInfoPackEx(const SyncObjsInfoPack: Pointer; const Count: Cardinal); -var - Buf: PDbgSyncObjsInfoListBuf; -begin - if not SyncObjsTracking then - Exit; - - while FProcessSyncObjsInfoQueue.Count >= _MAX_SYNC_OBJS_INFO_BUF_COUNT do - SwitchToThread; - - Buf := AllocMem(SizeOf(TDbgSyncObjsInfoListBuf)); - Buf^.Count := Count; - Buf^.DbgSyncObjsInfoList := AllocMem(Count * SizeOf(TDbgSyncObjsInfo)); - Buf^.DbgPointIdx := ProcessData.CurDbgPointIdx; - - if ReadData(SyncObjsInfoPack, Buf^.DbgSyncObjsInfoList, Count * SizeOf(TDbgSyncObjsInfo)) then - FProcessSyncObjsInfoQueue.Enqueue(Buf) - else - RaiseDebugCoreException(); -end; - procedure TDebuger.Log(const Msg: String); begin DoDbgLog(CurThreadId, Msg); @@ -3180,7 +2108,7 @@ procedure TDebuger.ProcessDbgMemoryInfo(DebugEvent: PDebugEvent); Size := ER^.ExceptionInformation[2]; //LoadMemoryInfoPack(Ptr, Size); - LoadMemoryInfoPackEx(Ptr, Size); + DbgMemoryProfiler.LoadMemoryInfoPackEx(Ptr, Size); end; dstMemHookStatus: begin @@ -3374,6 +2302,11 @@ function TDebuger.SetUserBreakpoint(Address: Pointer; const ThreadId: TThreadId Result := AddNewBreakPoint(Breakpoint); end; +procedure TDebuger.SetBreakpoint(const Address: Pointer; var SaveByte: Byte); +begin + DoSetBreakpointF(Address, SaveByte); +end; + procedure TDebuger.SetCloseDebugProcess(const Value: LongBool); begin FCloseDebugProcess := Value; @@ -3496,21 +2429,6 @@ function TDebuger.SetMemoryBreakpoint(Address: Pointer; Size: Cardinal; BreakOnW Result := AddNewBreakPoint(Breakpoint); end; -procedure TDebuger.SetMemoryCallStack(const Value: LongBool); -begin - FMemoryCallStack := Value; -end; - -procedure TDebuger.SetMemoryCheckDoubleFree(const Value: LongBool); -begin - FMemoryCheckDoubleFree := Value; -end; - -procedure TDebuger.SetMemoryCheckMode(const Value: LongBool); -begin - FMemoryCheckMode := Value; -end; - procedure TDebuger.SetPerfomanceMode(const Value: LongBool); begin if FPerfomanceMode <> Value then @@ -3553,11 +2471,6 @@ procedure TDebuger.SetSingleStepMode(ThData: PThreadData; const RestoreEIPAfterB Check(SetThreadContext(ThData^.ThreadHandle, ThData^.Context^)); end; -procedure TDebuger.SetSyncObjsTracking(const Value: LongBool); -begin - FSyncObjsTracking := Value; -end; - procedure TDebuger.SetSingleStepMode(const ThreadID: TThreadId; const RestoreEIPAfterBP: LongBool); var ThData: PThreadData; @@ -3608,51 +2521,6 @@ procedure TDebuger.SetThreadName(DebugEvent: PDebugEvent); end; end; -procedure TDebuger.SetTrackBreakpoint(const Address: Pointer; FuncInfo: TObject; const BPType: TTrackBreakpointType = tbTrackFunc); -var - TrackBk: PTrackBreakpoint; -begin - if not DbgTrackBreakpoints.TryGetValue(Address, TrackBk) then - begin - TrackBk := AllocMem(SizeOf(TTrackBreakpoint)); - - TrackBk^.FuncInfo := FuncInfo; - TrackBk^.SaveByte := 0; - - TrackBk^.BPType := []; - Include(TrackBk^.BPType, BPType); - - DoSetBreakpointF(Address, TrackBk^.SaveByte); - - DbgTrackBreakpoints.Add(Address, TrackBk); - end - else - Include(TrackBk^.BPType, BPType); -end; - -function TDebuger.SetTrackRETBreakpoint(const Address: Pointer): PTrackRETBreakpoint; -begin - if DbgTrackRETBreakpoints.TryGetValue(Address, Result) then - begin - Inc(Result^.Count); - - DoRestoreBreakpointF(Address); - end - else - begin - GetMem(Result, SizeOf(TTrackRETBreakpoint)); - - Result^.Count := 1; - - Result^.SaveByte := 0; - DoSetBreakpointF(Address, Result^.SaveByte); - - Result^.BPType := []; - - DbgTrackRETBreakpoints.Add(Address, Result); - end; -end; - procedure TDebuger.SetTrackSystemUnits(const Value: LongBool); begin FTrackSystemUnits := Value; @@ -3944,50 +2812,6 @@ procedure TDebuger.UpdateHardwareBreakpoints(const ThreadID: TThreadId); end; end; -procedure TDebuger.UpdateMemoryInfoObjectTypes; -var - Idx: Integer; - ThData: PThreadData; -begin - Idx := 0; - repeat - ThData := GetThreadDataByIdx(Idx); - if ThData <> Nil then - begin - UpdateMemoryInfoObjectTypesOfThread(ThData); - Inc(Idx); - end; - until ThData = Nil; - - // Потеряшки - (* - GetMemInfo := ProcessData.DbgGetMemInfo; - if GetMemInfo.Count > 0 then - begin - for GetMemInfoItem in GetMemInfo do - GetMemInfoItem.Value^.ObjectType := GetMemInfoItem.Value^.GetObjectType(GetMemInfoItem.Key); - end; - *) -end; - -procedure TDebuger.UpdateMemoryInfoObjectTypesOfThread(ThData: PThreadData); -var - GetMemInfo: TGetMemInfoList; - GetMemInfoItem: TGetMemInfoItem; -begin - GetMemInfo := ThData^.DbgGetMemInfo; - if GetMemInfo.Count > 0 then - begin - GetMemInfo.LockForRead; - try - for GetMemInfoItem in GetMemInfo do - GetMemInfoItem.Value.CheckObjectType; - finally - GetMemInfo.UnLockForRead; - end; - end; -end; - function TDebuger.UpdateThreadContext(ThreadData: PThreadData; const ContextFlags: Cardinal = CONTEXT_FULL): LongBool; begin Result := False; @@ -4020,67 +2844,6 @@ function TDebuger.WriteData(AddrPrt, DataPtr: Pointer; const DataSize: Cardinal) Result := FlushInstructionCache(FProcessData.AttachedProcessHandle, AddrPrt, DataSize); end; -{ TDbgSamplingThread } - -constructor TDbgWorkerThread.Create; -begin - inherited Create(True); - FreeOnTerminate := False; - - Suspended := False; -end; - -destructor TDbgWorkerThread.Destroy; -begin - inherited; -end; - -procedure TDbgWorkerThread.Execute; -var - HasNext: LongBool; -begin - NameThreadForDebugging(ClassName); - - repeat - HasNext := False; - - if Assigned(gvDebuger) then - begin - HasNext := gvDebuger.ProcessSamplingInfo; - - HasNext := gvDebuger.ProcessMemoryInfoQueue or HasNext; - HasNext := gvDebuger.ProcessSyncObjsInfoQueue or HasNext; - - if not HasNext then - Sleep(10); - end; - until Terminated and not(HasNext); -end; - -class procedure TDbgWorkerThread.Init; -begin - if gvDebuger.CodeTracking or gvDebuger.MemoryCheckMode or gvDebuger.SyncObjsTracking then - begin - if gvDbgWorkerThread = Nil then - gvDbgWorkerThread := TDbgWorkerThread.Create; - end; -end; - -class procedure TDbgWorkerThread.Reset; -begin - if Assigned(gvDbgWorkerThread) then - begin - gvDbgWorkerThread.Stop; - FreeAndNil(gvDbgWorkerThread); - end; -end; - -procedure TDbgWorkerThread.Stop; -begin - Terminate; - WaitFor; -end; - initialization finalization diff --git a/DebugerTypes.pas b/DebugerTypes.pas index a7da357..c31136b 100644 --- a/DebugerTypes.pas +++ b/DebugerTypes.pas @@ -662,7 +662,7 @@ TProcessData = record CPUElapsed: UInt64; // время использования CPU SamplingCPUTime: UInt64; - SamplingCount: Cardinal; + SamplingCount: Int64; DbgPoints: TProcessPointList; diff --git a/DelphiDebugInfo.pas b/DelphiDebugInfo.pas index b4444e6..9fd792c 100644 --- a/DelphiDebugInfo.pas +++ b/DelphiDebugInfo.pas @@ -1215,13 +1215,13 @@ procedure TDelphiDebugInfo.ResetMemoryManagerBreakpoints; if MemoryManagerInfo.VarInfo = nil then Exit; if MemoryManagerInfo.GetMem <> nil then - gvDebuger.RemoveTrackBreakpoint(MemoryManagerInfo.GetMem.Address, tbMemInfo); + gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.GetMem.Address, tbMemInfo); if MemoryManagerInfo.FreeMem <> nil then - gvDebuger.RemoveTrackBreakpoint(MemoryManagerInfo.FreeMem.Address, tbMemInfo); + gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.FreeMem.Address, tbMemInfo); if MemoryManagerInfo.ReallocMem <> nil then - gvDebuger.RemoveTrackBreakpoint(MemoryManagerInfo.ReallocMem.Address, tbMemInfo); + gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.ReallocMem.Address, tbMemInfo); if MemoryManagerInfo.AllocMem <> nil then - gvDebuger.RemoveTrackBreakpoint(MemoryManagerInfo.AllocMem.Address, tbMemInfo); + gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.AllocMem.Address, tbMemInfo); gvDebuger.Log('Reset slow memory manager hook - ok'); end; @@ -1334,7 +1334,7 @@ procedure TDelphiDebugInfo.SetMemoryManagerBreakpoints; Result := Nil; if GetLineInfo(Addr, UnitInfo, Result, LineInfo, False) <> slNotFound then - gvDebuger.SetTrackBreakpoint(Addr, Result, tbMemInfo) + gvDebuger.DbgCodeProfiler.SetTrackBreakpoint(Addr, Result, tbMemInfo) else RaiseDebugCoreException(); end; @@ -1942,8 +1942,8 @@ procedure TDelphiDebugInfo.InitCodeTracking(const SetBP: LongBool); for I := 0 to Units.Count - 1 do Inc(FuncCount, TUnitInfo(Units.Objects[I]).Funcs.Count); - gvDebuger.ClearDbgTracking; - gvDebuger.InitDbgTracking(FuncCount); + gvDebuger.DbgCodeProfiler.ClearDbgTracking; + gvDebuger.DbgCodeProfiler.InitDbgTracking(FuncCount); if SetBP then begin @@ -1968,7 +1968,7 @@ procedure TDelphiDebugInfo.InitCodeTracking(const SetBP: LongBool); for J := 0 to UnitInfo.Funcs.Count - 1 do begin FuncInfo := TFuncInfo(UnitInfo.Funcs[J]); - gvDebuger.SetTrackBreakpoint(FuncInfo.Address, FuncInfo); + gvDebuger.DbgCodeProfiler.SetTrackBreakpoint(FuncInfo.Address, FuncInfo); end; end; end; @@ -1998,8 +1998,8 @@ procedure TDelphiDebugInfo.InitCodeTracking(const SetBP: LongBool); Pointer(FImage.OptionalHeader32.ImageBase), MemoryManagerInfo.VarInfo, RTLInfo.vmtClassName, - gvDebuger.MemoryCallStack, - gvDebuger.SyncObjsTracking + gvDebuger.DbgMemoryProfiler.MemoryCallStack, + gvDebuger.DbgSysncObjsProfiler.SyncObjsTracking ); end; End; diff --git a/Spider.dpr b/Spider.dpr index 27e3829..bdca34c 100644 --- a/Spider.dpr +++ b/Spider.dpr @@ -45,7 +45,12 @@ uses MapDebugInfo in 'MapDebugInfo.pas', JclPeImage in 'JclPeImage.pas', uSharedObject in 'uSharedObject.pas', - uSQLiteDB in 'uSQLiteDB.pas'; + uSQLiteDB in 'uSQLiteDB.pas', + DbgMemoryProfiler in 'DbgMemoryProfiler.pas', + DbgWorkerThread in 'DbgWorkerThread.pas', + DbgSyncObjsProfiler in 'DbgSyncObjsProfiler.pas', + DbgSamplingProfiler in 'DbgSamplingProfiler.pas', + DbgCodeProfiler in 'DbgCodeProfiler.pas'; {$R *.res} diff --git a/Spider.dproj b/Spider.dproj index 15704c3..e83471b 100644 --- a/Spider.dproj +++ b/Spider.dproj @@ -3,7 +3,7 @@ {99256B98-0F1D-4707-BC25-85850B6A52B7} 14.6 Spider.dpr - Release + Debug DCC32 VCL True @@ -19,12 +19,6 @@ Base true - - true - Cfg_1 - true - true - true Base @@ -40,14 +34,14 @@ 3 SUPPORTS_INLINE;$(DCC_Define) true - 2 + 5 false false Spider_Icon.ico "Silver|VCLSTYLE|$(PUBLIC)\Documents\RAD Studio\11.0\Styles\Silver.vsf" $(BDS)\bin\default_app.manifest vclx;vcl;vclimg;dbrtl;Rave77VCL;bdertl;rtl;vclactnband;vcldb;vcldbx;vcltouch;xmlrtl;dsnap;dsnapcon;TeeUI;Tee;TeeDB;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_100_140;Intraweb_100_140;VclSmp;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DataSnapServer;DbxClientDriver;DBXInterBaseDriver;DBXMySQLDriver;dbxcds;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;GanttPackage;VirtualTreesR;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;acnt2010_R;$(DCC_UsePackage) - CompanyName=;FileDescription=;FileVersion=1.3.2.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=Spider;ProductVersion=1.3;Comments= + CompanyName=;FileDescription=;FileVersion=1.3.5.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=Spider;ProductVersion=1.3;Comments= Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Bindings;$(DCC_Namespace) 1033 C:\Projects\Spider\JCL\source\common;C:\Projects\Spider\JCL\source\include;C:\Projects\Spider\JCL\source\include\jedi;C:\Projects\Spider\JCL\source\windows;C:\Projects\Spider\JCL\source;$(BRCC_IncludePath) @@ -67,10 +61,6 @@ true RELEASE;$(DCC_Define) - - 3 - CompanyName=;FileDescription=;FileVersion=1.3.3.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=Spider;ProductVersion=1.3;Comments= - 3 true @@ -145,6 +135,12 @@ + + + + + + Cfg_2 Base @@ -177,7 +173,7 @@ 0 1 1 - 331 + 336 False False False @@ -189,7 +185,7 @@ - 0.1.1.331 + 0.1.1.336 diff --git a/Spider.res b/Spider.res index 6cceaf8..507e3fe 100644 Binary files a/Spider.res and b/Spider.res differ diff --git a/WinAPIUtils.pas b/WinAPIUtils.pas index f4aa400..d00c407 100644 --- a/WinAPIUtils.pas +++ b/WinAPIUtils.pas @@ -31,6 +31,8 @@ function GetFileVersion(const AFileName: string): string; function GetGUID: String; +procedure Check(const Value: LongBool); inline; + implementation type @@ -56,6 +58,12 @@ function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' n NtSuspendProcess: TProcFunction = Nil; NtResumeProcess: TProcFunction = Nil; +procedure Check(const Value: LongBool); +begin + if not Value then + RaiseLastOSError; +end; + procedure _LoadKernelProcs; begin _KernelLibHandle := SafeLoadLibrary('ntdll.dll'); diff --git a/uDebugerThread.pas b/uDebugerThread.pas index 9c18bb1..83c6b41 100644 --- a/uDebugerThread.pas +++ b/uDebugerThread.pas @@ -129,9 +129,9 @@ procedure TDebugerThread.Execute; begin gvDebuger.PerfomanceMode := (doProfiler in FDbgOptions); - gvDebuger.MemoryCheckMode := (doMemProfiler in FDbgOptions); - gvDebuger.MemoryCallStack := gvDebuger.MemoryCheckMode and (doMemCallStack in FDbgOptions); - gvDebuger.MemoryCheckDoubleFree := gvDebuger.MemoryCheckMode and (doMemCheckDoubleFree in FDbgOptions); + gvDebuger.DbgMemoryProfiler.MemoryCheckMode := (doMemProfiler in FDbgOptions); + gvDebuger.DbgMemoryProfiler.MemoryCallStack := gvDebuger.DbgMemoryProfiler.MemoryCheckMode and (doMemCallStack in FDbgOptions); + gvDebuger.DbgMemoryProfiler.MemoryCheckDoubleFree := gvDebuger.DbgMemoryProfiler.MemoryCheckMode and (doMemCheckDoubleFree in FDbgOptions); gvDebuger.ExceptionCheckMode := (doExceptions in FDbgOptions); gvDebuger.ExceptionCallStack := gvDebuger.ExceptionCheckMode and (doExceptionCallStack in FDbgOptions); @@ -140,7 +140,7 @@ procedure TDebugerThread.Execute; gvDebuger.TrackSystemUnits := gvDebuger.CodeTracking and (doTrackSystemUnits in FDbgOptions); gvDebuger.SamplingMethod := gvDebuger.CodeTracking and (doSamplingMethod in FDbgOptions); - gvDebuger.SyncObjsTracking := (doSyncObjsTracking in FDbgOptions); + gvDebuger.DbgSysncObjsProfiler.SyncObjsTracking := (doSyncObjsTracking in FDbgOptions); _AC.Log(dltInfo, 'Start debug process'); try