Problem with memory leak

[t2000 1]

Hello

I have a command line program and a memory leak after closing
But not always. Only 10-15% of starts are ending with the memory leak.

 

Unexpected Memory Leak
An unexpected memory leak has occurred. The unexpected small block leaks are:

41 - 56 bytes: TOmniCriticalSection x 1
137 - 152 bytes: TFixedCriticalSection x 1

 

This is the code of a unit that works like Application in VCL or FMX.
The important positions are:
constructor create : make Backgroundworker
from outside comes a call to the procedure TServerApp.Call
I put a record into the BlockingCollection and send a message

the message comes to ProcessMessage and I call CreateWorkItem for the BackgroundWorker

In my test, I start the program, I'm in the "Run" procedure, I send a call with WM_QUIT (from outside) and the program ends.

Where and how can I try to find the problem?

Has anybody an idea?

Many thanks, Thomas
 

unit sng.ServerApp;
interface
uses
  System.Classes, System.SysUtils, System.Generics.Collections, Winapi.Windows, Winapi.Messages,
  OtlCommon, OtlParallel, OtlCollections;

type
  TWorkItemCallRec = record
    ProcToCall: TProc<TOmniValue>;
    Data: TOmniValue;
  end;

  TModules = TList<TComponent>;
  TServerApp = class( TComponent)
  private
    FRunning: Boolean;
    FTerminate: Boolean;
    FServerAppName  : String;
    FServerModules  : TModules;

    FMsgDataColl   : TOmniBlockingCollection;
    FWorker        : IOmniBackgroundWorker;

    function ProcessMessage(var Msg: TMsg): Boolean;
    procedure ProcessMessages;

    procedure CreateWorkItem;
    procedure ProcessWorkItem(const workItem: IOmniWorkItem);
    procedure HandleRequestDone(const Sender: IOmniBackgroundWorker; const workItem: IOmniWorkItem);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Run;
    procedure Shutdown;
    procedure SendQuit;
    procedure Call( AMsgCode: Cardinal; AProcToCall: TProc<TOmniValue>; AData: TOmniValue);

    property ServerAppName: String read FServerAppName;
    property Terminated: Boolean read FTerminate;
  end;

var
  ServerApp: TServerApp;

implementation

uses
  OtlTaskControl,
  OtlComm;

{ TServerApp }

function TServerApp.ProcessMessage(var Msg: TMsg): Boolean;
var
  Handled: Boolean;
begin
  Result := False;
  if PeekMessage(Msg, NativeUInt(-1), 0, 0, PM_REMOVE) then begin
    Result := True;
    if Msg.Message <> WM_QUIT then begin
      Handled := False;

      if Msg.Message > sms_OFFSET then
        CreateWorkItem;

      if not Handled then begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end else begin
      FTerminate := True;
    end;
  end;
end;

procedure TServerApp.ProcessMessages;
var
  Msg: TMsg;
begin
  while ProcessMessage(Msg) do {loop};
end;

procedure TServerApp.CreateWorkItem;
var
  LWorkItem  : IOmniWorkItem;
  LOmniValue : TOmniValue;
begin
  if not FMsgDataColl.Take( LOmniValue) then
    raise Exception.Create('Internal Error. ServerApp FMsgDataColl.Take');

  LWorkItem := FWorker.CreateWorkItem( LOmniValue);
  FWorker.Schedule( LWorkItem);
end;

procedure TServerApp.ProcessWorkItem(const workItem: IOmniWorkItem);
var
  CallRec: TWorkItemCallRec;
begin
  CallRec := workItem.Data.CastTo<TWorkItemCallRec>;
  CallRec.ProcToCall( CallRec.Data);
  workItem.Result := 0;
end;

procedure TServerApp.HandleRequestDone(const Sender: IOmniBackgroundWorker; const workItem: IOmniWorkItem);
var
  eClass: string;
  exc   : Exception;
begin
  if workItem.IsExceptional then begin
    eClass := workItem.FatalException.ClassName;
    exc := workItem.DetachException;
    DoLog( loaError, 'Exception: WorkItem: '+workItem.UniqueID.ToString+': '+eClass+':'+exc.Message);
    FreeAndNil(exc);
  end else
    DoLog( 'HandleRequestDone: '+workItem.UniqueID.ToString+': '+workItem.Result.AsString);
end;

constructor TServerApp.Create(AOwner: TComponent);
begin
  inherited;
  FServerModules := TModules.Create;

  FMsgDataColl   := TOmniBlockingCollection.Create;
  FWorker := Parallel.BackgroundWorker
                     .NumTasks( cServerAppBackgroundTasks)
                     .OnRequestDone( HandleRequestDone)
                     .TaskConfig( Parallel.TaskConfig.OnMessage( sms_Processing,
                                  procedure (const task: IOmniTaskControl; const msg: TOmniMessage)
                                  begin
                                    DoLog('OnMessage: '+msg.MsgData.AsString);
                                  end))
                     .Execute( ProcessWorkItem);
end;

destructor TServerApp.Destroy;
var
  i: Integer;
begin
  FMsgDataColl.Free;
  for i := FServerModules.Count-1 downto 0 do
    FServerModules[i].Free;
  FServerModules.Free;
  inherited;
end;

procedure TServerApp.Run;
var
  Msg: TMsg;
  v: TProc;
begin
  FRunning := True;
  try
    // evtl. Exitproc setzen
      repeat
        try
          if not ProcessMessage(Msg) then
            WaitMessage;
        except
          on e: Exception do
            writeln(e.Message);
        end;
      until Terminated;
  finally
    FRunning := False;
  end;
end;

procedure TServerApp.Shutdown;
begin
  // Stoppen aller Dienste
  FWorker.CancelAll;
end;

procedure TServerApp.SendQuit;
begin
  FWorker.CancelAll;
  PostThreadMessage( System.MainThreadID, WM_QUIT, 0, 0);
end;

procedure TServerApp.Call(AMsgCode: Cardinal; AProcToCall: TProc<TOmniValue>; AData: TOmniValue);
var
  CallRec : TWorkItemCallRec;
  oValue  : TOmniValue;
begin
  CallRec.ProcToCall := AProcToCall;
  CallRec.Data       := AData;
  oValue := TOmniValue.FromRecord(CallRec);

  FMsgDataColl.Add( oValue);
  PostThreadMessage( System.MainThreadID, AMsgCode, 0, 0);
end;


initialization
  ServerApp := TServerApp.Create(nil);
finalization
  ServerApp.Free;
end.

 

 

 

 

[Primož Gabrijelčič 223]

Check the stack trace to see where this critical section is allocated from.

 

If this is not possible with the FastMM that comes with Delphi (frankly, I don't use it and I have no idea), use FastMM from git and define FullDebugMode conditional.

[Anders Melander 1815]

2 hours ago, t2000 said:

if Msg.Message <> WM_QUIT then

This is not related to your problem, but you should PostQuitMessage if you remove a WM_QUIT from the message queue.

[Remy Lebeau 1421]

37 minutes ago, Primož Gabrijelčič said:

If this is not possible with the FastMM that comes with Delphi

It is not.

37 minutes ago, Primož Gabrijelčič said:

use FastMM from git and define FullDebugMode conditional.

That is what you will have to do.

[Remy Lebeau 1421]

2 minutes ago, Anders Melander said:

This is not related to your problem, but you should PostQuitMessage if you remove a WM_QUIT from the message queue.

See Raymond Chen's blog for why: Modality, part 3: The WM_QUIT message and Why is there a special PostQuitMessage function?

[t2000 1]

I have used FastMM4. Pretty hard, but now I know the most important things about FastMM4.

I think, I have a side effect from my REST Server thread that works with TMS XData. I use a function with TJSONObject as parameter. (over REST). And there is a hidden Exception in a JSON converter. I haven't seen these exception before. If I change the (REST-) function result to an integer, I can't reproduce the memory leak.

With the build in tools, I couldn't get a stack trace.

Thanks for the first. I keep an eye on it.

The WM_QUIT. Thanks for the note. But I don't have windows here. This is a command line application and later I build a service. The messaging system is only for my own. Perhaps, I can use a WM_USER message number for quit the program internally.

[t2000 1]

My mistake. I have used a TJSONObject with another TJSONObject in it. In the create function I added the second TJSONObject instead of TJSONObject.Clone. The inner TJSONObject was releasd twice.
And then, and then, and then ... I thinkt there were all side effects.