* Added a new tiOPF demo testing the performance of reference counted vs non-reference counted objects.

5 files changed, 682 insertions, 0 deletions

diff --git a/extras/tiopf/demos/Demo_TtiBaseObject/PerformanceTesting.lpi b/extras/tiopf/demos/Demo_TtiBaseObject/PerformanceTesting.lpi
new file mode 100644
index 00000000..4d24712d
--- /dev/null
+++ b/extras/tiopf/demos/Demo_TtiBaseObject/PerformanceTesting.lpi
@@ -0,0 +1,62 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="6"/>
+    <General>
+      <Flags>
+        <SaveOnlyProjectUnits Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=""/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="fpgui_package"/>
+        <MinVersion Minor="5" Release="1" Valid="True"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="tiOPF"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="PerformanceTesting.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="frm_main.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="frm_main"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Other>
+      <CustomOptions Value="-FUunits
+-dUseCThreads
+"/>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>
diff --git a/extras/tiopf/demos/Demo_TtiBaseObject/PerformanceTesting.lpr b/extras/tiopf/demos/Demo_TtiBaseObject/PerformanceTesting.lpr
new file mode 100644
index 00000000..85ac297a
--- /dev/null
+++ b/extras/tiopf/demos/Demo_TtiBaseObject/PerformanceTesting.lpr
@@ -0,0 +1,31 @@
+{
+  This demo does performance testing of the TtiBaseObject to see the difference
+  when Reference Counting is enabled, linked in or not.
+}
+program PerformanceTesting;
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Classes, fpgfx, frm_main;
+
+
+procedure MainProc;
+var
+  frm: TMainForm;
+begin
+  fpgApplication.Initialize;
+  frm := TMainForm.Create(nil);
+  try
+    frm.Show;
+    fpgApplication.Run;
+  finally
+    frm.Free;
+  end;
+end;
+
+begin
+  MainProc;
+end.
+
diff --git a/extras/tiopf/demos/Demo_TtiBaseObject/frm_main.pas b/extras/tiopf/demos/Demo_TtiBaseObject/frm_main.pas
new file mode 100644
index 00000000..e4aec833
--- /dev/null
+++ b/extras/tiopf/demos/Demo_TtiBaseObject/frm_main.pas
@@ -0,0 +1,218 @@
+unit frm_main;
+
+{$mode objfpc}{$H+}
+
+// You need to enable these in tiOPF's tiDefines.inc as well.
+{.$Define object_tracking}
+{$Define reference_counting}
+
+
+interface
+
+uses
+  SysUtils, Classes, gfxbase, fpgfx, gui_edit, 
+  gfx_widget, gui_form, gui_label, gui_button,
+  gui_listbox, gui_memo, gui_combobox, gui_grid, 
+  gui_dialogs, gui_checkbox, gui_tree, gui_trackbar, 
+  gui_progressbar, gui_radiobutton, gui_tab, gui_menu,
+  gui_bevel, gui_popupcalendar, gui_gauge;
+
+type
+
+  TMainForm = class(TfpgForm)
+  private
+    procedure   PerformanceTestNoReferenceCounting(Sender: TObject);
+    procedure   PerformanceTestReferenceCounting(Sender: TObject);
+    procedure   btnTestValidClick(Sender: TObject);
+    procedure   Log(const AMessage: string);
+  public
+    {@VFD_HEAD_BEGIN: MainForm}
+    btnNoRefCount: TfpgButton;
+    btnRefCount: TfpgButton;
+    btnTestValid: TfpgButton;
+    memName1: TfpgMemo;
+    lblName1: TfpgLabel;
+    lblName2: TfpgLabel;
+    memLog: TfpgMemo;
+    {@VFD_HEAD_END: MainForm}
+    constructor Create(AOwner: TComponent); override;
+    procedure   AfterCreate; override;
+  end;
+
+{@VFD_NEWFORM_DECL}
+
+implementation
+
+uses
+  tiUtils,
+  tiBaseObject;
+  
+const
+  CTestRunTime = 5; // Seconds
+  CTestCount = 1000000; // 1 million
+
+{@VFD_NEWFORM_IMPL}
+
+procedure TMainForm.PerformanceTestNoReferenceCounting(Sender: TObject);
+var
+  LO: TtiBaseObject;
+  LStart: Cardinal;
+  LCount: Cardinal;
+begin
+  LCount := 0;
+  LStart := tiGetTickCount;
+  while LCount < CTestCount do
+  begin
+    LO := TtiBaseObject.Create;
+    LO.Free;
+    Inc(LCount);
+  end;
+  Log(Format('%s iterations in %d ms (no reference counting)',
+      [tiIntToCommaStr(LCount), tiGetTickCount - LStart]));
+end;
+
+procedure TMainForm.PerformanceTestReferenceCounting(Sender: TObject);
+{$ifdef reference_counting}
+var
+//  LO: IInterface;
+  LO: TtiBaseObject;  // We are testing object creation only. Hence a class and not interface reference.
+  LStart: Cardinal;
+  LCount: Cardinal;
+begin
+  LCount := 0;
+  LStart := tiGetTickCount;
+  while LCount < CTestCount do
+  begin
+    LO := TtiBaseObject.CreateWithRefCounting;
+    LO.Free;    // we are testing object creation. This remove the garbage collector.
+    Inc(LCount);
+  end;
+  Log(Format('%s iterations in %d ms (reference counting)',
+      [tiIntToCommaStr(LCount), tiGetTickCount - LStart]));
+{$else}
+begin
+  Assert(False, 'reference_counting not enabled');
+{$endif}
+end;
+
+procedure TMainForm.btnTestValidClick(Sender: TObject);
+var
+  LO: TtiBaseObject;
+begin
+  LO := TtiBaseObject.Create;
+  Assert(LO.TestValid);
+  LO.Free;
+  Assert(not LO.TestValid);
+end;
+
+procedure TMainForm.Log(const AMessage: string);
+begin
+  memLog.Lines.Add(AMessage);
+  memLog.Invalidate;
+end;
+
+constructor TMainForm.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  memLog.Lines.Clear;
+  {$ifdef object_tracking}
+    Log('object_tracking is ON');
+  {$else}
+    btnTestValid.Enabled := False;
+    Log('object_tracking is OFF');
+  {$endif}
+  {$ifdef reference_counting}
+    Log('reference_counting is ON');
+  {$else}
+    Log('reference_counting is OFF');
+    btnRefCount.Enabled := False;
+  {$endif}
+  Log('---');
+end;
+
+procedure TMainForm.AfterCreate;
+begin
+  {@VFD_BODY_BEGIN: MainForm}
+  Name := 'MainForm';
+  SetPosition(307, 319, 357, 290);
+  WindowTitle := 'TtiBaseObject Performance Demo';
+  WindowPosition := wpScreenCenter;
+
+  btnNoRefCount := TfpgButton.Create(self);
+  with btnNoRefCount do
+  begin
+    Name := 'btnNoRefCount';
+    SetPosition(16, 28, 155, 23);
+    Text := 'No reference counting';
+    FontDesc := '#Label1';
+    ImageName := '';
+    OnClick := @PerformanceTestNoReferenceCounting;
+  end;
+
+  btnRefCount := TfpgButton.Create(self);
+  with btnRefCount do
+  begin
+    Name := 'btnRefCount';
+    SetPosition(16, 56, 155, 23);
+    Text := 'Reference counting';
+    FontDesc := '#Label1';
+    ImageName := '';
+    OnClick := @PerformanceTestReferenceCounting;
+  end;
+
+  btnTestValid := TfpgButton.Create(self);
+  with btnTestValid do
+  begin
+    Name := 'btnTestValid';
+    SetPosition(16, 112, 155, 23);
+    Text := 'TtiBaseObject.TestValid';
+    FontDesc := '#Label1';
+    ImageName := '';
+    OnClick := @btnTestValidClick;
+  end;
+
+  memName1 := TfpgMemo.Create(self);
+  with memName1 do
+  begin
+    Name := 'memName1';
+    SetPosition(176, 28, 176, 125);
+    Lines.Add('Toggle the conditional defines');
+    Lines.Add('REFERENCE_COUNTING ');
+    Lines.Add('and OBJECT_TRACKING on ');
+    Lines.Add('and off to examine behaviour.');
+    FontDesc := '#Edit1';
+    Enabled := False;
+  end;
+
+  lblName1 := TfpgLabel.Create(self);
+  with lblName1 do
+  begin
+    Name := 'lblName1';
+    SetPosition(8, 8, 160, 15);
+    Text := 'Performance';
+    FontDesc := '#Label2';
+  end;
+
+  lblName2 := TfpgLabel.Create(self);
+  with lblName2 do
+  begin
+    Name := 'lblName2';
+    SetPosition(8, 92, 160, 15);
+    Text := 'TtiBaseObject.TestValid';
+    FontDesc := '#Label2';
+  end;
+
+  memLog := TfpgMemo.Create(self);
+  with memLog do
+  begin
+    Name := 'memLog';
+    SetPosition(8, 164, 344, 121);
+    Lines.Add('');
+    FontDesc := '#Edit1';
+  end;
+
+  {@VFD_BODY_END: MainForm}
+end;
+
+
+end.
diff --git a/extras/tiopf/demos/Demo_TtiBaseObject/performancetest.lpi b/extras/tiopf/demos/Demo_TtiBaseObject/performancetest.lpi
new file mode 100644
index 00000000..bb61968c
--- /dev/null
+++ b/extras/tiopf/demos/Demo_TtiBaseObject/performancetest.lpi
@@ -0,0 +1,123 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="6"/>
+    <General>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=""/>
+      <ActiveEditorIndexAtStart Value="0"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+      <Language Value=""/>
+      <CharSet Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <Units Count="9">
+      <Unit0>
+        <Filename Value="performancetest.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="performancetest"/>
+        <CursorPos X="1" Y="13"/>
+        <TopLine Value="1"/>
+        <EditorIndex Value="0"/>
+        <UsageCount Value="20"/>
+        <Loaded Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="frm_main.pas"/>
+        <UnitName Value="frm_main"/>
+        <CursorPos X="37" Y="85"/>
+        <TopLine Value="65"/>
+        <EditorIndex Value="4"/>
+        <UsageCount Value="10"/>
+        <Loaded Value="True"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="/opt/fpc_2.2.0/src/packages/fcl-base/src/inc/custapp.pp"/>
+        <UnitName Value="CustApp"/>
+        <CursorPos X="3" Y="26"/>
+        <TopLine Value="11"/>
+        <UsageCount Value="10"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="../../../../../3rdParty/tiOPF2/Source/Core/tiUtils.pas"/>
+        <UnitName Value="tiUtils"/>
+        <CursorPos X="9" Y="507"/>
+        <TopLine Value="486"/>
+        <UsageCount Value="10"/>
+      </Unit3>
+      <Unit4>
+        <Filename Value="../../../../../3rdParty/tiOPF2/Source/Core/tiLinux.pas"/>
+        <UnitName Value="tiLinux"/>
+        <CursorPos X="1" Y="48"/>
+        <TopLine Value="28"/>
+        <UsageCount Value="10"/>
+      </Unit4>
+      <Unit5>
+        <Filename Value="../../../../../3rdParty/tiOPF2/Source/Core/tiBaseObject.pas"/>
+        <UnitName Value="tiBaseObject"/>
+        <CursorPos X="1" Y="658"/>
+        <TopLine Value="631"/>
+        <EditorIndex Value="3"/>
+        <UsageCount Value="10"/>
+        <Loaded Value="True"/>
+      </Unit5>
+      <Unit6>
+        <Filename Value="/opt/fpc_2.2.0/src/rtl/inc/objpash.inc"/>
+        <CursorPos X="29" Y="220"/>
+        <TopLine Value="212"/>
+        <EditorIndex Value="1"/>
+        <UsageCount Value="10"/>
+        <Loaded Value="True"/>
+      </Unit6>
+      <Unit7>
+        <Filename Value="/opt/fpc_2.2.0/src/rtl/inc/objpas.inc"/>
+        <CursorPos X="9" Y="709"/>
+        <TopLine Value="705"/>
+        <EditorIndex Value="2"/>
+        <UsageCount Value="10"/>
+        <Loaded Value="True"/>
+      </Unit7>
+      <Unit8>
+        <Filename Value="FMain.pas"/>
+        <UnitName Value="FMain"/>
+        <CursorPos X="1" Y="1"/>
+        <TopLine Value="38"/>
+        <UsageCount Value="10"/>
+      </Unit8>
+    </Units>
+    <JumpHistory Count="2" HistoryIndex="1">
+      <Position1>
+        <Filename Value="performancetest.lpr"/>
+        <Caret Line="112" Column="1" TopLine="112"/>
+      </Position1>
+      <Position2>
+        <Filename Value="performancetest.lpr"/>
+        <Caret Line="249" Column="1" TopLine="220"/>
+      </Position2>
+    </JumpHistory>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>
diff --git a/extras/tiopf/demos/Demo_TtiBaseObject/performancetest.lpr b/extras/tiopf/demos/Demo_TtiBaseObject/performancetest.lpr
new file mode 100644
index 00000000..d42615cc
--- /dev/null
+++ b/extras/tiopf/demos/Demo_TtiBaseObject/performancetest.lpr
@@ -0,0 +1,248 @@
+{
+  This program tests the speed of Reference Counted and non-Reference Counted
+  objects over a set time period. Default of 5 seconds.
+}
+program performancetest;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils, CustApp;
+
+const
+  CTestCount = 1000000;  // 1 million
+
+type
+  TMyApplication = class(TCustomApplication)
+  protected
+    procedure   DoRun; override;
+    procedure   TestRefCountedObjects;
+    procedure   TestNonRefCountedObjects;
+    procedure   TestRefCountedMyObjects;
+    procedure   TestNonRefCountedMyObjects;
+    procedure   Log(const AMessage: string);
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor  Destroy; override;
+    procedure   WriteHelp; virtual;
+  end;
+  
+
+  TMyBaseObject = class(TObject, IUnknown)
+  private
+    FRefCounting: Boolean;
+    FRefCount: Integer;
+  protected
+    function    QueryInterface(const IID: TGUID; out Obj): longint; stdcall;
+    function    _AddRef: longint; stdcall;
+    function    _Release: longint; stdcall;
+  public
+    constructor Create;
+    destructor  Destroy; override;
+    constructor CreateWithRefCounting;
+    procedure   AfterConstruction; override;
+    procedure   BeforeDestruction; override;
+    class function NewInstance: TObject; override;
+  end;
+
+{ TMyBaseObject }
+
+function TMyBaseObject.QueryInterface(const IID: TGUID; out Obj): longint; stdcall;
+begin
+  if GetInterface(IID, Obj) then
+    Result := 0
+  else
+    Result := E_NOINTERFACE;
+end;
+
+function TMyBaseObject._AddRef: longint; stdcall;
+begin
+  Result := InterlockedIncrement(FRefCount);
+end;
+
+function TMyBaseObject._Release: longint; stdcall;
+begin
+  Result := InterlockedDecrement(FRefCount);
+  if FRefCounting then
+    if Result = 0 then
+      Destroy;
+end;
+
+constructor TMyBaseObject.Create;
+begin
+  FRefCounting := False;
+end;
+
+destructor TMyBaseObject.Destroy;
+begin
+  inherited Destroy;
+end;
+
+constructor TMyBaseObject.CreateWithRefCounting;
+begin
+  Create;
+  FRefCounting := True;
+end;
+
+procedure TMyBaseObject.AfterConstruction;
+begin
+  inherited AfterConstruction;
+  // Release the constructor's implicit refcount
+  if FRefCounting then
+    InterlockedDecrement(FRefCount);
+end;
+
+procedure TMyBaseObject.BeforeDestruction;
+begin
+  if FRefCounting then
+    if FRefCount <> 0 then
+      System.Error(reInvalidPtr);
+  inherited BeforeDestruction;
+end;
+
+class function TMyBaseObject.NewInstance: TObject;
+begin
+  Result := inherited NewInstance;
+  TMyBaseObject(Result).FRefCount := 1;
+end;
+  
+function tiGetTickCount: Cardinal;
+begin
+  Result := Cardinal(Trunc(Now * 24 * 60 * 60 * 1000));
+end;
+
+
+{ TMyApplication }
+
+procedure TMyApplication.DoRun;
+var
+  ErrorMsg: String;
+begin
+  // quick check parameters
+  ErrorMsg := CheckOptions('h','help');
+  if ErrorMsg <> '' then
+  begin
+    ShowException(Exception.Create(ErrorMsg));
+    Halt;
+  end;
+
+  // parse parameters
+  if HasOption('h','help') then
+  begin
+    WriteHelp;
+    Halt;
+  end;
+
+//  TestNonRefCountedMyObjects;
+  TestNonRefCountedObjects;
+  TestRefCountedObjects;
+  TestNonRefCountedMyObjects;
+  TestRefCountedMyObjects;
+
+  // stop program loop
+  Terminate;
+end;
+
+procedure TMyApplication.TestRefCountedObjects;
+var
+  LO: TInterfacedObject;
+  LStart: Cardinal;
+  LCount: Cardinal;
+begin
+  LCount := 0;
+  LStart := tiGetTickCount;
+  while LCount < CTestCount do
+  begin
+    LO := TInterfacedObject.Create;
+    LO.Free;
+    Inc(LCount);
+  end;
+  Log(Format('%s iterations in %d ms (reference counting with TInterfacedObject)',
+      [IntToStr(LCount), tiGetTickCount - LStart]));
+end;
+
+procedure TMyApplication.TestNonRefCountedObjects;
+var
+  LO: TObject;
+  LStart: Cardinal;
+  LCount: Cardinal;
+begin
+  LCount := 0;
+  LStart := tiGetTickCount;
+  while LCount < CTestCount do
+  begin
+    LO := TObject.Create;
+    LO.Free;
+    Inc(LCount);
+  end;
+  Log(Format('%s iterations in %d ms (no reference counting with TObject)',
+      [IntToStr(LCount), tiGetTickCount - LStart]));
+end;
+
+procedure TMyApplication.TestRefCountedMyObjects;
+var
+  LO: TMyBaseObject;
+  LStart: Cardinal;
+  LCount: Cardinal;
+begin
+  LCount := 0;
+  LStart := tiGetTickCount;
+  while LCount < CTestCount do
+  begin
+    LO := TMyBaseObject.CreateWithRefCounting;
+    LO.Free;
+    Inc(LCount);
+  end;
+  Log(Format('%s iterations in %d ms (reference counting with MyBaseObject)',
+      [IntToStr(LCount), tiGetTickCount - LStart]));
+end;
+
+procedure TMyApplication.TestNonRefCountedMyObjects;
+var
+  LO: TMyBaseObject;
+  LStart: Cardinal;
+  LCount: Cardinal;
+begin
+  LCount := 0;
+  LStart := tiGetTickCount;
+  while LCount < CTestCount do
+  begin
+    LO := TMyBaseObject.Create;
+    LO.Free;
+    Inc(LCount);
+  end;
+  Log(Format('%s iterations in %d ms (no reference counting with MyBaseObject)',
+      [IntToStr(LCount), tiGetTickCount - LStart]));
+end;
+
+procedure TMyApplication.Log(const AMessage: string);
+begin
+  writeln(AMessage);
+end;
+
+constructor TMyApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException := True;
+end;
+
+destructor TMyApplication.Destroy;
+begin
+  inherited Destroy;
+end;
+
+procedure TMyApplication.WriteHelp;
+begin
+  { add your help code here }
+  writeln('Usage: ',ExeName,' -h');
+end;
+
+var
+  Application: TMyApplication;
+begin
+  Application := TMyApplication.Create(nil);
+  Application.Title := 'My Application';
+  Application.Run;
+  Application.Free;
+end.
+