1

アプリケーションのメモリリークを見つけるのに役立つツールを開発しています。この機能は、オブジェクト(TOBJECT)を操作している間は正常に実行されますが、バッファーを操作しているときに問題が発生します。場合によっては、アプリケーションでエラーが発生したことを特定できなかったため、このエラーはメモリへのアクセスが悪いようです。ロジックまたはコードで発生する可能性のあるエラーは見つかりませんでした。Delphiの経験が豊富な人が私を助けてくれるなら。おそらく、メモリマネージャの特定の動作が問題を引き起こしている可能性があります。

もう少し説明:

メモリ割り当て制御

目的:決定されたサイズのメモリバッファがすべてシステムによって割り当てられている量をカウントします。例:

バッファサイズ| 割り当て量| 使用された合計メモリ

325     |       35265      |    11461125    
23      |       32         |     736
...     |       ...        |    ...

メモリの割り当てと割り当て解除を制御する方法:

I created an array of integer that goes from 0 to 65365. This array will be used to keep the amount of allocs of the corresponding size.
For example, If I call GetMem for a buffer of 523, the Array[523] will increase + 1. 

The GetMem, ReallocMem, AllocMem, the problem is easy to resolve 'cause one of it's parameters is the size of the buffer. So I can use this to increase the position of the array.

The problem cames with the FreeMem, 'cause the only parameter is the pointer of the buffer. I don't know it's size.
    - I can't create a list to keep the Pointer and it's size. 'Cause there is SO much allocations, it will be so much expensive to the application keep searching/adding/removing items from this list. And this list must to be protected with critical section etc etc. So no way.

How I'm trying to solve this problem: 
    Just to remeber I created the array to keep the number off allocations. 

    Items:     0                              65365
               |................................|
    Addess:   $X                            $(65365x SizeOf(Integer))   

    When allocators methos are called, for example: GetMem(52);
    I changed the behavior of it, I will alloc the requested size (52), but I'll add here a size of an integer;
    So I will have:  

    0     4                          56 
    |.....|...........................|
       $x           

    In the plus space (0..3) I'll set the address of the corresponding space of the array. In this case the address position $array(52). And I add + (SizeOf(Integer)) to the address result of the GetMem, so it will have access just the 52 bytes that were asked for.

    When the FreeMem are called. What I do is:
        - Get the pointer asked for deallocation.
        - Decrease the pointer by the size of the integer
        - Check if the address of the current pointer is relative to the Array of control address.
        - If it is, I use the the address and decrease 1 from the Array position
        - And ask for the FreeMem

時間とシステムの大部分で、それは非常にうまく機能しています。しかし、どうすればよいかわからない瞬間があり、システムで奇妙なエラーが発生しました。この実装を非アクティブにすると、決して得られないエラー。

理解しやすくするためにコードにコメントしていますが、ハードコードではないので、次のようにします。

他のスレッド:https ://forums.embarcadero.com/thread.jspa?threadID = 77787

unit uInstancesAnalyser;

    {
    Functionality: The feature developed in this unit try to watch how the memory are being allocated by your system. The main focus of it is help to find memory leak in the most non intrusive way.
    How to Install: Put this unit as the first unit of yout project. If use use a third memory manager put this unit just after the unit of your memory manager.
    How to get it's report: It's not the final version of this unit, so the viewer was not developed. By the momento you can call the
        method SaveInstancesToFile. It'll create a text file called MemReport in the executable path.

    WARNING: If you use the pointer of the VMT destinated to vmtAutoTable, you should not use the directive TRACEINSTANCES.

    How it works:
    The feature work in two different approaches:
    1) Map the memory usage by objects
    2) Map the memory usage by buffers (Records, strings and so on)

    How are Objects tracked:
      The TObject.NewInstance was replaced by a new method (TObjectHack.NNewInstanceTrace).
      So when the creation of an object is called it's redirect to the new method. In this new method is increased the counter of the relative class and change the method in the VMT that is responsible to free the object to a new destructor method (vmtFreeInstance). This new destructor call the decrease of the counter and the old destructor.
      This way I can know how much of objects of each class are alive in the system.

      (More details about how it deep work can be found in the comments on the code)

    How are Memory Buffer Traced:
      The GetMem, FreeMem, ReallocMem, AllocMem were replaced by new method that have an special behavior to help track the buffers.

       As the memory allocation use the same method to every kind of memory request, I'm not able to create a single counter to each count of buffer. So, I calculate them base on it size. First I create a array of integer that start on 0 and goes to 65365.
      When the system ask me to give it a buffer of 65 bytes, I increase the position 65 of the array and the buffer is deallocated I call the decrease of the position of the array corresponding to buffer size. If the size requested to the buffer is bigger or equal to 65365, I'll use the position 65365 of the array.

      (More details about how it deep work can be found in the comments on the code)

    --------------------------------------------------------------------------------------
    Develop by  Rodrigo Farias Rezino
        E-mail: rodrigofrezino@gmail.com
        Stackoverflow: http://stackoverflow.com/users/225010/saci
         Please, any bug let me know
    }

    interface
    {$DEFINE TRACEBUFFER}    {Directive used to track buffer} //Comment to inactive
    {$DEFINE TRACEINSTANCES} {Directive used to track objects} //Comment to inactive

    //{$DEFINE WATCHTHREADS} // It's not finished

    uses
      Classes, SyncObjs, uIntegerList;

      {You can register possibles names for some Buffers Sizes, it can be useful when you are working with record. Example
        TRecordTest = record
          Field1: Integer
          Field2: string[50]

        So, you can call RegisterNamedBuffer(TRecordTest, SizeOf(TRecordTest));
        This way, in on the report of buffer/objects will be explicit what possibles named buffer can be that memory in use.}
      procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);

      {This function return the possible named buffers registered with that size}
      function GetBufferName(ASize: integer): string;

      {It's a simple output to save the report of memory usage on the disk. It'll create a file called test.txt in the executable directory}
      procedure SaveInstancesToFile;

    var
      {Flag to say if the memory watcher is on or off}
      SIsMemoryWatcherActive: Boolean;

    implementation

    uses
       Windows, SysUtils, TypInfo;

    const
      SIZE_OF_INT = SizeOf(Integer);

      SIZE_OF_MAP = 65365;
      {$IFDEF WATCHTHREADS}
      GAP_SIZE = SIZE_OF_INT * 2;
      {$ELSE}
      GAP_SIZE = SIZE_OF_INT;
      {$ENDIF}

    type
      TArrayOfMap = array [0..SIZE_OF_MAP] of Integer;
      TThreadMemory = array [0..SIZE_OF_MAP] of Integer;

      {This class is used to Register}
      TNamedBufferList = class(TIntegerList)
      public
        constructor Create;

        function GetBufferName(ASize: integer): string;
        procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
      end;

      PClassVars = ^TClassVars;
      TClassVars = class(TObject)
      private
        class var ListClassVars: TList;
      public
        BaseInstanceCount: Integer;
        BaseClassName: string;
        BaseParentClassName: string;
        BaseInstanceSize: Integer;
        OldVMTFreeInstance: Pointer;
        constructor Create;
        class procedure SaveToDisk;
      end;

      TNamedBuffer = class(TObject)
        Names: string;
      end;

      PJump = ^TJump;
      TJump = packed record
        OpCode: Byte;
        Distance: Pointer;
      end;

      TObjectHack = class(TObject)
      private
        FCriticalSection: TCriticalSection;
        class procedure SetClassVars(AClassVars: TClassVars); //inline;
        class function GetClassVars: TClassVars; inline;

        procedure IncCounter; inline;
        procedure DecCounter; inline;
        procedure CallOldFunction;
      public
        constructor Create;
        destructor Destroy; override;

        class function NNewInstance: TObject;
        class function NNewInstanceTrace: TObject;
        procedure NFreeInstance;
      end;

    var
      SDefaultGetMem: function(Size: Integer): Pointer;
      SDefaultFreeMem: function(P: Pointer): Integer;
      SDefaultReallocMem: function(P: Pointer; Size: Integer): Pointer;
      SDefaultAllocMem: function(Size: Cardinal): Pointer;

      SThreadMemory: TThreadMemory;
      SMap: TArrayOfMap;
      SNamedBufferList: TNamedBufferList;

      {$IFDEF WATCHTHREADS}
      SMissedMemoryFlow: Integer;
      {$ENDIF}

    {$REGION 'Util'}
    type
      TWinVersion = (wvUnknown, wv95, wv98, wv98SE, wvNT, wvME, wv2000, wvXP, wvVista, wv2003, wv7);

    function GetWinVersion: TWinVersion;
    var
      osVerInfo: TOSVersionInfo;
      majorVersion, minorVersion: Integer;
    begin
      Result := wvUnknown;
      osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
      if GetVersionEx(osVerInfo) then
      begin
        minorVersion := osVerInfo.dwMinorVersion;
        majorVersion := osVerInfo.dwMajorVersion;
        case osVerInfo.dwPlatformId of
          VER_PLATFORM_WIN32_NT:
          begin
            if majorVersion <= 4 then
              Result := wvNT
            else if (majorVersion = 5) and (minorVersion = 0) then
              Result := wv2000
            else if (majorVersion = 5) and (minorVersion = 1) then
              Result := wvXP
            else if (majorVersion = 5) and (minorVersion = 2) then
              Result := wv2003
            else if (majorVersion = 6) then
              Result := wvVista
            else if (majorVersion = 7) then
              Result := wv7;
          end;
          VER_PLATFORM_WIN32_WINDOWS:
          begin
            if (majorVersion = 4) and (minorVersion = 0) then
              Result := wv95
            else if (majorVersion = 4) and (minorVersion = 10) then
            begin
              if osVerInfo.szCSDVersion[1] = 'A' then
                Result := wv98SE
              else
                Result := wv98;
            end
            else if (majorVersion = 4) and (minorVersion = 90) then
              Result := wvME
            else
              Result := wvUnknown;
          end;
        end;
      end;
    end;

    function GetMethodAddress(AStub: Pointer): Pointer;
    const
      CALL_OPCODE = $E8;
    begin
      if PBYTE(AStub)^ = CALL_OPCODE then
      begin
        Inc(Integer(AStub));
        Result := Pointer(Integer(AStub) + SizeOf(Pointer) + PInteger(AStub)^);
      end
      else
        Result := nil;
    end;

    procedure AddressPatch(const ASource, ADestination: Pointer);
    const
      JMP_OPCODE = $E9;
      SIZE = SizeOf(TJump);
    var
      NewJump: PJump;
      OldProtect: Cardinal;
    begin
      if VirtualProtect(ASource, SIZE, PAGE_EXECUTE_READWRITE, OldProtect) then
      begin
        NewJump := PJump(ASource);
        NewJump.OpCode := JMP_OPCODE;
        NewJump.Distance := Pointer(Integer(ADestination) - Integer(ASource) - 5);

        FlushInstructionCache(GetCurrentProcess, ASource, SizeOf(TJump));
        VirtualProtect(ASource, SIZE, OldProtect, @OldProtect);
      end;
    end;

    function PatchCodeDWORD(ACode: PDWORD; AValue: DWORD): Boolean;
    var
      LRestoreProtection, LIgnore: DWORD;
    begin
      Result := False;
      if VirtualProtect(ACode, SizeOf(ACode^), PAGE_EXECUTE_READWRITE, LRestoreProtection) then
      begin
        Result := True;
        ACode^ := AValue;
        Result := VirtualProtect(ACode, SizeOf(ACode^), LRestoreProtection, LIgnore);

        if not Result then
          Exit;

        Result := FlushInstructionCache(GetCurrentProcess, ACode, SizeOf(ACode^));
      end;
    end;

    {$ENDREGION}

    function GetInstanceList: TList;
    begin
      Result := TClassVars.ListClassVars;
    end;

    procedure SaveInstancesToFile;
    begin
      TClassVars.SaveToDisk;
    end;

    procedure OldNewInstance;
    asm
      call TObject.NewInstance;
    end;

    procedure OldAfterConstruction;
    asm
      call TObject.InitInstance;
    end;

    { TObjectHack }
    type
      TExecute = procedure of object;

    procedure TObjectHack.CallOldFunction;
    var
      Routine: TMethod;
      Execute: TExecute;
    begin
      Routine.Data := Pointer(Self);
      Routine.Code := GetClassVars.OldVMTFreeInstance;
      Execute := TExecute(Routine);
      Execute;
    end;

    constructor TObjectHack.Create;
    begin

    end;

    procedure TObjectHack.DecCounter;
    var
      ThreadId: Cardinal;
    begin
      {$IFDEF WATCHTHREADS}
      ThreadId := GetCurrentThreadId;
      SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - Self.InstanceSize;
      ThreadId := 0;
      if (Self.ClassType.InheritsFrom(TThread)) then
        ThreadId := TThread(Self).ThreadID;
      {$ENDIF}

      GetClassVars.BaseInstanceCount := GetClassVars.BaseInstanceCount -1;
      CallOldFunction;

      {$IFDEF WATCHTHREADS}
      if ThreadId <> 0 then
      begin
        if SThreadMemory[ThreadId] < 0 then
          SMissedMemoryFlow := SMissedMemoryFlow + SThreadMemory[ThreadId];

        SThreadMemory[ThreadId] := 0;
      end;
      {$ENDIF}
    end;

    destructor TObjectHack.Destroy;
    begin

      inherited;
    end;

    class function TObjectHack.GetClassVars: TClassVars;
    begin
      Result := PClassVars(Integer(Self) + vmtAutoTable)^;
    end;

    function _InitializeHook(AClass: TClass; AOffset: Integer; HookAddress: Pointer): Boolean;
    var
      lAddress: Pointer;
      lProtect: DWord;
    begin
      lAddress := Pointer(Integer(AClass) + AOffset);
      Result := VirtualProtect(lAddress, 4, PAGE_READWRITE, @lProtect);
      if not Result then
        Exit;

      CopyMemory(lAddress, @HookAddress, 4);
      Result := VirtualProtect(lAddress, 4, lProtect, @lProtect);
    end;

    class procedure TObjectHack.SetClassVars(AClassVars: TClassVars);
    begin
      AClassVars.BaseClassName := Self.ClassName;
      AClassVars.BaseInstanceSize := Self.InstanceSize;
      AClassVars.OldVMTFreeInstance := PPointer(Integer(TClass(Self)) + vmtFreeInstance)^;

      if Self.ClassParent <> nil then
        AClassVars.BaseParentClassName := Self.ClassParent.ClassName;

      PatchCodeDWORD(PDWORD(Integer(Self) + vmtAutoTable), DWORD(AClassVars));
      _InitializeHook(Self, vmtFreeInstance, @TObjectHack.DecCounter);
    end;

    procedure RegisterClassVarsSupport(const Classes: array of TObjectHack);
    var
      LClass: TObjectHack;
    begin
      for LClass in Classes do
        if LClass.GetClassVars = nil then
          LClass.SetClassVars(TClassVars.Create)
        else
          raise Exception.CreateFmt('Class %s has automated section or duplicated registration.', [LClass.ClassName]);
    end;

    procedure TObjectHack.IncCounter;
    begin
      if GetClassVars = nil then
        RegisterClassVarsSupport(Self);

      GetClassVars.BaseInstanceCount := GetClassVars.BaseInstanceCount + 1;
    end;

    { TClassVars }

    constructor TClassVars.Create;
    begin
      ListClassVars.Add(Self);
    end;

    class procedure TClassVars.SaveToDisk;
    var
      LStringList: TStringList;
      i: Integer;
    begin
      LStringList := TStringList.Create;
      try
        LStringList.Add('CLASS | NUMBER OF INSTANCES');
        {$IFDEF TRACEINSTANCES}
        for i := 0 to ListClassVars.Count -1 do
          if TClassVars(ListClassVars.Items[I]).BaseInstanceCount > 0 then
            LStringList.Add(TClassVars(ListClassVars.Items[I]).BaseClassName + '|' + IntToStr(TClassVars(ListClassVars.Items[I]).BaseInstanceCount));
        {$ENDIF}

        {$IFDEF TRACEBUFFER}
        for I := 0 to SIZE_OF_MAP do
          if SMap[I] > 0 then
            LStringList.Add(Format('Mem. Size: %d | Amount: %d', [I, SMap[I]]));
        {$ENDIF}

        LStringList.SaveToFile(ExtractFilePath(ParamStr(0)) + 'MemReport.txt');
      finally
        FreeAndNil(LStringList);
      end;
    end;

    //////////////////////////////////////////////////////////////////////////////////////
    ///  Memory manager controller

    function IsInMap(AValue: Integer): Boolean; inline;
    begin
      try
        Result := (AValue > Integer(@SMap)) and (AValue <= Integer(@SMap[SIZE_OF_MAP]));
      except
        Result := False;
      end;
    end;

    function MemorySizeOfPos(APos: Integer): Integer; inline;
    begin
      Result := (APos - Integer(@SMap)) div SIZE_OF_INT;
    end;

    function NAllocMem(Size: Cardinal): Pointer;
    var
      pIntValue: ^Integer;
      MapSize: Integer;
      ThreadId: Cardinal;
    begin
      if Size > SIZE_OF_MAP then
        MapSize := SIZE_OF_MAP
      else
        MapSize := Size;

      Result := SDefaultAllocMem(Size + GAP_SIZE);
      pIntValue := Result;
      SMap[MapSize] := SMap[MapSize] + 1;
      pIntValue^ := Integer(@SMap[MapSize]);

      {$IFDEF WATCHTHREADS}
      ThreadId := GetCurrentThreadId;
      SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Size;

      pIntValue := Pointer(Integer(Result) + SIZE_OF_INT);
      pIntValue^ := ThreadId;
      {$ENDIF}

      Result := Pointer(Integer(Result) + GAP_SIZE);
    end;

    function NGetMem(Size: Integer): Pointer;
    var
      LPointer: Pointer;
      pIntValue: ^Integer;
      MapSize: Integer;
      ThreadId: Cardinal;
    begin
      if Size > SIZE_OF_MAP then
        MapSize := SIZE_OF_MAP
      else
        MapSize := Size;

      LPointer := SDefaultGetMem(Size + GAP_SIZE);
      pIntValue := LPointer;
      SMap[MapSize] := SMap[MapSize] + 1;
      pIntValue^ := Integer(@SMap[MapSize]);

      {$IFDEF WATCHTHREADS}
      ThreadId := GetCurrentThreadId;
      SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Size;

      pIntValue := Pointer(Integer(LPointer) + SIZE_OF_INT);
      pIntValue^ := ThreadId;
      {$ENDIF}

      Result := Pointer(Integer(LPointer) + GAP_SIZE);
    end;

    function NFreeMem(P: Pointer): Integer;
    var
      pIntValue: ^Integer;
      LPointer: Pointer;
      ThreadId: Cardinal;
      LFreed: Boolean;
    begin
      LPointer := Pointer(Integer(P) - GAP_SIZE);
      pIntValue := LPointer;
      if IsInMap(pIntValue^) then
      begin
        {$IFDEF WATCHTHREADS}
        ThreadId := Integer(Pointer(Integer(pIntValue) + SIZE_OF_INT)^);
        SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - MemorySizeOfPos(pIntValue^);
        {$ENDIF}
        Integer(Pointer(pIntValue^)^) := Integer(Pointer(pIntValue^)^) - 1;
        Result := SDefaultFreeMem(LPointer);
      end
      else
        Result := SDefaultFreeMem(P);
    end;

    function NReallocMem(P: Pointer; Size: Integer): Pointer;
    var
      pIntValue: ^Integer;
      LPointer: Pointer;
      LSizeMap: Integer;
      ThreadId: Cardinal;
    begin
      LPointer := Pointer(Integer(P) - GAP_SIZE);
      pIntValue := LPointer;
      if not IsInMap(pIntValue^) then
      begin
        Result := SDefaultReallocMem(P, Size);
        Exit;
      end;

      if Size > SIZE_OF_MAP then
        LSizeMap := SIZE_OF_MAP
      else
        LSizeMap := Size;

      //Uma vez com o valor setado, não pode remover o setor
      Integer(Pointer(pIntValue^)^) := Integer(Pointer(pIntValue^)^) - 1;

      {$IFDEF WATCHTHREADS}
      ThreadId := Integer(Pointer(Integer(pIntValue) + SIZE_OF_INT)^);
      SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - MemorySizeOfPos(pIntValue^) + Size;
      {$ENDIF}

      Result := SDefaultReallocMem(LPointer, Size + GAP_SIZE);
      SMap[LSizeMap] := SMap[LSizeMap] + 1;
      pIntValue := Result;
      pIntValue^ := Integer(@SMap[LSizeMap]);
      Result := Pointer(Integer(Result) + GAP_SIZE);
    end;

    procedure TObjectHack.NFreeInstance;
    var
      ThreadId: Cardinal;
    begin
      {$IFDEF WATCHTHREADS}
      ThreadId := GetCurrentThreadId;
      SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - Self.InstanceSize;
      {$ENDIF}
      CleanupInstance;
      SDefaultFreeMem(Self);
    end;

    class function TObjectHack.NNewInstance: TObject;
    var
      ThreadId: Cardinal;
    begin
      Result := InitInstance(SDefaultGetMem(Self.InstanceSize));
      {$IFDEF WATCHTHREADS}
      ThreadId := GetCurrentThreadId;
      SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Self.InstanceSize;
      {$ENDIF}
    end;

    class function TObjectHack.NNewInstanceTrace: TObject;
    var
      ThreadId: Cardinal;
    begin
      try
        Result := InitInstance(SDefaultGetMem(Self.InstanceSize));
        if (Result.ClassType = TClassVars) or (Result is EExternal) then
          Exit;

        TObjectHack(Result).IncCounter;
        {$IFDEF WATCHTHREADS}
        ThreadId := GetCurrentThreadId;
        SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Self.InstanceSize;
        {$ENDIF}
      except
        raise Exception.Create(Result.ClassName);
      end;
    end;

    procedure InitializeArray;
    var
      I: Integer;
    begin
      for I := 0 to SIZE_OF_MAP do
        SMap[I] := 0;
    end;

    type
      PLocalTest = ^LocalTest;
      LocalTest = record
        Size: integer;
        Size2: string;
      end;

    procedure ApplyMemoryManager;
    var
      LMemoryManager: TMemoryManagerEx;
    begin
      GetMemoryManager(LMemoryManager);
      SDefaultGetMem := LMemoryManager.GetMem;
      {$IFNDEF TRACEBUFFER}
      Exit;
      {$ENDIF}
      LMemoryManager.GetMem := NGetMem;

      SDefaultFreeMem := LMemoryManager.FreeMem;
      LMemoryManager.FreeMem := NFreeMem;

      SDefaultReallocMem := LMemoryManager.ReallocMem;
      LMemoryManager.ReallocMem := NReallocMem;

      SDefaultAllocMem := LMemoryManager.AllocMem;
      LMemoryManager.AllocMem := NAllocMem;

      SetMemoryManager(LMemoryManager);
    end;

    procedure TestRecord;
    var
      LTest: PLocalTest;
    begin
      LTest := AllocMem(1);
      Dispose(LTest);

      LTest := AllocMem(SIZE_OF_MAP + 1);
      Dispose(LTest);

      New(LTest);
      ReallocMem(LTest, SIZE_OF_MAP +1);
      Dispose(LTest);
    end;

    procedure TesteObject;
    var
      LTestObject: TObject;
    begin
      LTestObject := TObject.Create;
      LTestObject.Free;
    end;

    { TNamedBuffer }

    constructor TNamedBufferList.Create;
    begin
      inherited Create;
      Sorted := True;
    end;

    function GetBufferName(ASize: integer): string;
    begin
      Result := SNamedBufferList.GetBufferName(ASize);
    end;

    procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
    begin
      SNamedBufferList.RegisterNamedBuffer(ABufferName, ASize);
    end;

    function TNamedBufferList.GetBufferName(ASize: integer): string;
    var
      LIndex: Integer;
    begin
      Result := 'Unknow';
      LIndex := IndexOf(ASize);
      if LIndex = -1 then
        Exit;
      Result := TNamedBuffer(Objects[LIndex]).Names;
    end;

    procedure TNamedBufferList.RegisterNamedBuffer(ABufferName: string; ASize: integer);
    var
      LIndex: Integer;
      LNamedBuffer: TNamedBuffer;
    begin
      LIndex := IndexOf(ASize);
      if LIndex = -1 then
      begin
        LNamedBuffer := TNamedBuffer.Create;
        LNamedBuffer.Names := 'Possible types: ' + ABufferName;
        Self.AddObject(ASize, LNamedBuffer);
      end
      else
        TNamedBuffer(Objects[LIndex]).Names := TNamedBuffer(Objects[LIndex]).Names + ' | ' + ABufferName;
    end;

    procedure InitializeAnalyser;
    var
      LCan: Boolean;
    begin
      SIsMemoryWatcherActive := False;
      SNamedBufferList := TNamedBufferList.Create;

      case GetWinVersion of
        wv98, wvXP, wvVista, wv7: LCan := True;
        else LCan := False;
      end;

      if not LCan then
        Exit;

      {$IFDEF TRACEINSTANCES}
      TClassVars.ListClassVars := TList.Create;
      {$ENDIF}

      {$IFDEF TRACEBUFFER}
      InitializeArray;
      {$ENDIF}

      ApplyMemoryManager;
      ///  Buffer wrapper
      {$IFDEF TRACEBUFFER}
      TestRecord;
        {$IFNDEF TRACEINSTANCES}
        AddressPatch(GetMethodAddress(@OldNewInstance), @TObjectHack.NNewInstance);
        {$ENDIF}
      {$ENDIF}

      ///Class wrapper
      {$IFDEF TRACEINSTANCES}
      AddressPatch(GetMethodAddress(@OldNewInstance), @TObjectHack.NNewInstanceTrace);
      TesteObject;
      {$ENDIF}
      SIsMemoryWatcherActive := True;
    end;


    { TThreadDestroy }
    initialization
      InitializeAnalyser

    end.
4

1 に答える 1

0

FreeMem のパリティ バイトを消去していませんでした。誰かが見たり助けたりしたい場合は、これに取り組み続けます:http://rfrezinos.wordpress.com/delphi-memory-profiler/

に注意してください。

于 2013-03-21T03:32:31.663 に答える