The remaining Business of the AGM along with the Melbourne Monthly ADUG meeting are on this coming Monday 20th November, from 6:00 (AEDT) via Zoom and at the Melbourne Men’s Shed.
Sorry not sure of timing. I am guessing the AGM may run from 7:30 for (hopefully) just a short time.
This month we have Grahame Grieve coming to talk about diagnosing and finding double free’s.
(And probably plenty of other interesting stuff)
Zoom links will be here Monday Evening.
For those who are interested, this is the code we’ll be working through tomorrow night.
Note that I’ll be working with Lazarus on OSX, but the behaviour of Delphi on windows almost identical (we’ll discuss where they differ, as that’s important)
// unit1
unit Unit1;
{$mode delphi}{$H+}
{
FMM notes: AlwaysClearFreedMemory
}
interface
uses
Classes, SysUtils, Contnrs, Forms, Controls, Graphics, Dialogs, StdCtrls,
baseunit;
type
{ TTestObject }
TTestObject = class (TObject)
private
FName: String;
FSerial : integer;
public
constructor create(name : String);
destructor destroy; override;
property name : String read FName;
function summary(p : TObject) : String;
end;
{ TTestObject2 }
TTestObject2 = class (TObject)
private
FName: String;
FSerial : integer;
public
constructor create(name : String);
destructor destroy; override;
property name : String read FName;
function summary(p : TObject) : String;
end;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Button6: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
var
GSerial : integer;
GCount : integer;
{ TTestObject }
constructor TTestObject.create(name: String);
begin
inherited Create;
FName := name;
interlockedIncrement(GCount);
interlockedIncrement(GSerial);
FSerial := GSerial;
end;
destructor TTestObject.destroy;
begin
interlockedDecrement(GCount);
inherited destroy;
end;
function TTestObject.summary(p: TObject): String;
begin
result := inttostr(int64(p))+'/'+inttostr(int64(self))+': '+name+' ('+ClassName+'='+inttostr(FSerial)+')';
end;
{ TTestObject2 }
constructor TTestObject2.create(name: String);
begin
inherited Create;
FName := name;
interlockedIncrement(GCount);
interlockedIncrement(GSerial);
FSerial := GSerial;
end;
destructor TTestObject2.destroy;
begin
interlockedDecrement(GCount);
inherited destroy;
end;
function TTestObject2.summary(p: TObject): String;
begin
result := inttostr(int64(p))+'/'+inttostr(int64(self))+': '+name+' ('+ClassName+'='+inttostr(FSerial)+')';
end;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
a : TTestObject;
list : TObjectList;
begin
a := TTestObject.create('Test #1');
try
showMessage(a.summary(a));
finally
a.free;
end;
list := TObjectList.create(true);
try
list.add(TTestObject.create('Test #2'));
a := list[0] as TTestObject;
showMessage(a.summary(a));
finally
list.free;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
a : TTestObject;
list : TObjectList;
begin
list := TObjectList.create(true);
try
a := TTestObject.create('Test #3');
try
list.add(a);
showMessage(a.summary(a));
finally
//a.free;
end;
a := list[0] as TTestObject;
showMessage(a.summary(a));
finally
list.free;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
a, b : TTestObject;
list : TObjectList;
begin
list := TObjectList.create(false);
try
a := TTestObject.create('Test #4');
try
list.add(a);
showMessage(a.summary(a));
finally
a.free;
end;
b := TTestObject.Create('Test #5');
try
showMessage(b.summary(b));
a := list[0] as TTestObject;
showMessage(a.summary(a));
finally
b.free;
end;
finally
list.free;
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
var
a, b, c, d : TTestObject;
begin
a := TTestObject.create('Test A');
b := TTestObject.Create('Test B');
showMessage(a.className);
a.free;
b.free;
a := TTestObject.create('Test A');
a.free;
b := TTestObject.Create('Test B');
a.free;
c := TTestObject.Create('Test C');
b.free;
d := TTestObject.Create('Test D');
showMessage(a.summary(a));
c.free;
d.free; // bang
end;
procedure TForm1.Button5Click(Sender: TObject);
var
a, b, c : TTestObject;
d : TTestObject2;
begin
a := TTestObject.create('Test A');
b := TTestObject.Create('Test B');
Assert(a is TTestObject);
a.free;
b.free;
a := TTestObject.create('Test A');
Assert(a is TTestObject);
a.free;
b := TTestObject.Create('Test B');
a.free;
c := TTestObject.Create('Test C');
Assert(a is TTestObject);
b.free;
d := TTestObject2.Create('Test D');
Assert(a is TTestObject); // bang
c.free;
d.free;
end;
procedure TForm1.Button6Click(Sender: TObject);
var
b : TBaseObject;
begin
b := TBaseObject.create;
b.free;
b.free;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if (GCount > 0) then
showMessage(inttostr(GCount)+' objects live');
end;
end.
// baseunit
unit baseunit;
{$mode delphi}{$H+}
{$IFOPT D+}
{$DEFINE OBJECT_TRACKING}
{$ENDIF}
interface
uses
Classes, SysUtils, Generics.Collections;
type
TNameString = String[16];
TDoubleFreeCallBack = procedure(info : String) of object;
{
TBaseObject is a counted object type that reports when there are object leaks
}
{ TBaseObject }
TBaseObject = class (TObject)
private
FDisposed : boolean;
{$IFDEF OBJECT_TRACKING}
FSerial : integer;
FNext, FPrev : TBaseObject;
FTracked : boolean;
{$ENDIF}
procedure init;
procedure close;
protected
{$IFOPT D+}
// This is a workaround for the delphi debugger not showing the actual class of an object that is polymorphic
// It's sole purpose is to be visible in the debugger. No other functionality should depend on it
FNamedClass : TNameString;
FDebugInfo : String;
function updatedDebugInfo : String;
{$ENDIF}
function dumpSummary : String;
public
constructor Create; Overload; Virtual;
destructor Destroy; Override;
Procedure Free; Overload;
Procedure AfterConstruction; Override;
{$IFDEF OBJECT_TRACKING}
property SerialNumber : integer read FSerial;
{$ENDIF}
{$IFOPT D+}
function debugInfo : String; virtual; // what's visible to the debugger
procedure updateDebugInfo;
{$ENDIF}
end;
var
GMemoryTrackingDialog : boolean;
GMemoryTrackingFile : String;
GDoubleFreeCallBack : TDoubleFreeCallBack;
implementation
//-- 1. Class Count tracking -----------------------------
type
{ TClassTrackingType }
TClassTrackingType = class (TObject)
private
firstObject, lastObject : TBaseObject;
count : integer;
deltaCount : integer;
serial : integer;
function objectSummary : String;
end;
{ TClassTrackingType }
function TClassTrackingType.objectSummary: String;
var
t : TBaseObject;
begin
result := '';
{$IFDEF OBJECT_TRACKING}
if (count > 0) and (count <= 80) then
begin
result := '; '+firstObject.dumpSummary;
t := firstObject.FNext;
while (t <> nil) do
begin
result := result + ',' + t.dumpSummary;
t := t.FNext;
end;
end
{$ENDIF}
end;
var
GInited : boolean;
GLock : TRTLCriticalSection;
GClassTracker : TDictionary<String, TClassTrackingType>;
procedure memoryLeakReport;
var
t : TClassTrackingType;
n, s : String;
i : integer;
f : System.text;
ts : TStringList;
begin
s := 'Memory Leak Report at '+formatDateTime('c', now)+#13#10;
i := 0;
EnterCriticalSection(GLock);
try
ts := TStringList.Create;
try
for n in GClassTracker.Keys do
ts.add(n);
ts.Sort;
for n in ts do
begin
t := GClassTracker[n];
i := i + t.count;
if t.count > 0 then
s := s + n+': '+inttostr(t.count)+' of '+inttostr(t.serial)+t.objectSummary+#13#10;
t.free;
end;
finally
ts.free;
end;
finally
LeaveCriticalSection(GLock);
end;
if (GMemoryTrackingFile <> '') then
begin
assignFile(f, GMemoryTrackingFile);
Rewrite(f);
writeln(f, s);
closeFile(f);
end;
if (i > 0) and GMemoryTrackingDialog then
begin
{$IFDEF WINDOWS}
messagebox(0, pchar(s), 'Object Leaks', MB_OK);
{$ELSE}
// DefaultMessageBox(pchar(s), 'Object Leaks', MB_OK);
{$ENDIF}
end;
end;
procedure initUnit;
begin
if not GInited then
begin
GInited := true;
{$IFDEF OBJECT_TRACKING}
InitCriticalSection(GLock);
GClassTracker := TDictionary<String, TClassTrackingType>.Create;
GMemoryTrackingDialog := true;
{$ENDIF}
end;
end;
procedure endUnit;
begin
{$IFDEF OBJECT_TRACKING}
if GMemoryTrackingDialog or (GMemoryTrackingFile <> '') then
MemoryLeakReport;
GClassTracker.free;
DoneCriticalSection(GLock);
{$ENDIF}
GInited := false;
end;
{ TBaseObject }
constructor TBaseObject.Create;
Begin
Inherited;
FNamedClass := copy(ClassName, 1, 16);
init;
end;
destructor TBaseObject.Destroy;
begin
close;
inherited Destroy;
end;
procedure TBaseObject.Free;
var
nmCls : String;
begin
If Assigned(Self) Then
begin
if FDisposed then
begin
try
nmCls := FNamedClass;
except
nmCls := '??';
end;
if assigned(GDoubleFreeCallBack) then
try
{$IFDEF OBJECT_TRACKING}
GDoubleFreeCallBack(nmCls+':'+inttostr(FSerial));
{$ELSE}
GDoubleFreeCallBack(nmCls);
{$ENDIF}
except
end;
raise Exception.Create('Attempt to free a class again (of type '+nmCls+' (?))');
end
else
begin
self.Destroy;
self.FDisposed := true;
end;
end;
end;
procedure TBaseObject.AfterConstruction;
begin
inherited AfterConstruction;
updateDebugInfo;
end;
function TBaseObject.debugInfo: String;
begin
result := '';
end;
procedure TBaseObject.updateDebugInfo;
begin
FDebugInfo := debugInfo;
end;
function TBaseObject.updatedDebugInfo: String;
begin
try
updateDebugInfo;
except
end;
result := FDebugInfo;
end;
procedure TBaseObject.init;
var
t : TClassTrackingType;
begin
{$IFDEF OBJECT_TRACKING}
if not GInited then
initUnit;
EnterCriticalSection(GLock);
try
if not GClassTracker.TryGetValue(ClassName, t) then
begin
t := TClassTrackingType.Create;
GClassTracker.Add(ClassName, t);
end;
inc(t.count);
inc(t.deltaCount);
inc(t.serial);
FSerial := t.serial;
if t.firstObject = nil then
begin
assert(t.count = 1);
t.firstObject := self;
t.lastObject := self;
FPrev := nil;
FNext := nil;
end
else
begin
t.lastObject.FNext := self;
FPrev := t.lastObject;
FNext := nil;
t.lastObject := self;
end;
finally
LeaveCriticalSection(GLock);
end;
// if you have a leak in the leak report, and the FSerial is consistent (they generally are)
// you can set these two values and put break points on here and the destroy
if (ClassName = 'X') and (FSerial = 234) then
FTracked := true;
{$ENDIF}
end;
procedure TBaseObject.close;
var
t : TClassTrackingType;
Begin
{$IFDEF OBJECT_TRACKING}
// see note in init;
if FTracked then
FTracked := false;
if GInited then
begin
EnterCriticalSection(GLock);
try
if GClassTracker.TryGetValue(ClassName, t) then // this will succeed
begin
dec(t.Count);
dec(t.deltaCount);
if FPrev = nil then
begin
t.firstObject := self.FNext;
if self.FNext <> nil then
self.FNext.FPrev := nil;
end
else
begin
if self.FNext <> nil then
self.FNext.FPrev := self.FPrev;
self.FPrev.FNext := self.FNext;
end;
if FNext = nil then
begin
t.lastObject := self.FPrev;
if self.FPrev <> nil then
self.FPrev.FNext := nil;
end
else
begin
if self.FPrev <> nil then
self.FPrev.FNext := self.FNext;
self.FNext.FPrev := self.FPrev;
end;
end;
finally
LeaveCriticalSection(GLock);
end;
end;
{$ENDIF}
end;
function TBaseObject.dumpSummary: String;
begin
{$IFDEF TRACK_CLASSES}
result := inttostr(FSerial)+':'+FUpdatedDebugInfo;
{$ELSE}
result := updatedDebugInfo;
{$ENDIF}
end;
Initialization
initUnit;
finalization
endUnit;
end.
For the AGM documents including the missing Financial documents and minutes for the partially completed AGM for tonight, follow the following link
Australian Delphi User Group Inc Annual General Meeting 2023 – ADUG
Hello,
Just wondering if instructions have been sent out for tonight’s meeting?
Dial by your location
• +61 8 6119 3900 Australia
• +61 8 7150 1149 Australia
• +61 2 8015 6011 Australia
• +61 3 7018 2005 Australia
• +61 7 3185 3730 Australia
• +1 253 215 8782 US (Tacoma)
• +1 301 715 8592 US (Washington DC)
• +1 305 224 1968 US
• +1 309 205 3325 US
• +1 312 626 6799 US (Chicago)
• +1 346 248 7799 US (Houston)
• +1 360 209 5623 US
• +1 386 347 5053 US
• +1 507 473 4847 US
• +1 564 217 2000 US
• +1 646 558 8656 US (New York)
• +1 646 931 3860 US
• +1 669 444 9171 US
• +1 669 900 9128 US (San Jose)
• +1 689 278 1000 US
• +1 719 359 4580 US
• +1 253 205 0468 US
Meeting ID: 860 7479 1577
Passcode: 634295
Find your local number: Zoom International Dial-in Numbers - Zoom
Hi Graham
First, I’d like to thank you for your very interesting talk on double frees.
It was very informative.
I am one of those Delphi people who use TMyClass(Inst) instead of (Inst
as TMyClass).
I may have misheard the advice given to me but I was informed that
TMyClass(Inst) was the prefered way to go.
I always test Inst prior to calling TMyClass(Inst) to ensure that Inst
is of that class.
Is there any reason why (Inst as TMyClass) is preferable, especially as
I ensure that Inst is of TMyClass just prior to the call?
Regards
Graeme
Hi Graham
First, I’d like to thank you for your very interesting talk on double frees.
It was very informative.
I am one of those Delphi people who use TMyClass(Inst) instead of (Inst
as TMyClass).
I may have misheard the advice given to me but I was informed that
TMyClass(Inst) was the prefered way to go.
I always test Inst prior to calling TMyClass(Inst) to ensure that Inst
is of that class.
Is there any reason why (Inst as TMyClass) is preferable, especially as
I ensure that Inst is of TMyClass just prior to the call?
Regards
Graeme
oh hey, if you check is first, then you don’t need to feel bad, but what if you miss? I’d always use as anyway
Here’s the last of my code, the memory scrubber
unit memscrub;
{$mode delphi}{$H+}
{
Copyright (c) 2011+, Health Intersections Pty Ltd (http://www.healthintersections.com.au)
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* Neither the name of HL7 nor the names of its contributors may be used to
endorse or promote products derived from this software without specific
prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
}
interface
const
MEM_MAGIC_VALUE = #$EB;
type
// this class installs a memory tracker that wipes disposed memory with the value $eb
//
{ TScrubbingMemoryManagerTracker }
TScrubbingMemoryManagerTracker = class
public
class procedure install; // must call this during start up
end;
implementation
{ TScrubbingMemoryManagerTracker }
var
GRealMM : TMemoryManager;
Function MemSize(p : pointer) : ptruint;
begin
if p = nil then
result := 0
else
result := GRealMM.MemSize(p);
end;
Function RGetMem(Size:ptruint):Pointer;
begin
result := GRealMM.GetMem(size);
end;
Function RFreemem(p:pointer):ptruint;
begin
if (p <> nil) then
fillChar(p^, MemSize(p), MEM_MAGIC_VALUE);
result := GRealMM.FreeMem(p);
end;
Function RFreememSize(p:pointer;Size:ptruint):ptruint;
begin
if (p <> nil) then
fillChar(p^, size, MEM_MAGIC_VALUE);
result := GRealMM.FreememSize(p, size);
end;
Function RAllocMem(Size:ptruint):Pointer;
begin
// can't clear memory that is reallocated
result := GRealMM.AllocMem(Size);
end;
Function RReAllocMem(var p:pointer;Size:ptruint):Pointer;
begin
result := GRealMM.ReAllocMem(p, size);
end;
class procedure TScrubbingMemoryManagerTracker.install;
var
mm : TMemoryManager;
begin
GetMemoryManager(GRealMM);
mm := GRealMM;
mm.Getmem := RGetMem;
mm.Freemem := RFreemem;
mm.FreememSize := RFreememSize;
mm.AllocMem := RAllocMem;
mm.ReAllocMem := RReAllocMem;
SetMemoryManager(mm);
end;
end.
The little snippet of Rust that I mentioned …
fn main() {
let s = String::from("Hello World!");
println!("s = {}", s);
drop(s);
drop(s);
}
I mentioned that, without using references, passing a variable to a function entirely consumes the variable … and transfers its existence into the scope of the function.
I forgot to mention the punchline … as a result of that compiler design, the implementation of drop is :
fn drop<T> (x: T) { }
ie … it is a generic function (procedure in OP) that accepts a value of any type … and does nothing with it.
Adug Meeting 20/11/2023 an Outline
AGM
Some discussion about some of the items in the financials.
Why was Venue expenses so big?
-Partly Back Invoices from Perth
Tiger Tech and Amazon bigger this year?
-Delayed reimbursements for CC payments
Financials look quite good, (around +9K from last year)
Financials were agreed too, and the AGM was closed.
Thank You Frank.
Grahame Grieve presentation
Double Free’s
Grahame doesn’t like double free’s, and the issues they can cause
(potentially much later on, and in some totally unrelated piece of code)
His Demo’s showed how objects were Freed, and then new objects took
their place.
Then when you accidently Freed object A a second time, it actually Freed
object D, that was then broken, even though you hadn’t done anything
wrong with object D.
Partly because of Last In First Out allocation strategy from the memory
manager used. Which probably makes these things a bit quicker to fail.
So issues found out earlier.
(Using Lazarus)
He has a memory manager utility that runs on top of your existing memory
manager, that will overwrite freed memory with EB’s. So that if you try
to reuse an object after freeing it, or free it again, it will break
immediately and is hopefully obvious what has happened.
Grahame uses a TBaseObject as a base for all his business objects,
TBaseObject has tracking information eg. Name of class as text, a serial
number, and links to a table (amongst other things) that helps when
attempting to track down this type of problem.
It takes over the free method.
It doesn’t work with FreeAndNil() because of this.
Ensuring there are no memory leaks is a first step.
Thank You Grahame
Other things:
TMenu
TSynEdit
TTreeView
Vincent
Delphi.Dev Package Manager.
How Rust does things.
@GrahameDGrieve that was a great presentation.
I think it would be really appreciated by the UK guys, and @jasonukDev … if it worked out with timezones.
(Last meeting was 8pm - 1am in Perth time, so even later in AEST terms)
3am? I’m known to be crazy, but I have a hard rule: nothing between midnight and 5am. Other than that I’d be happy to repeat it
I’ve mentioned Maybe or Optional types in the thread on functional patterns.
Couldn’t we use the type system to eliminate at least double free?
If a pointer-ish type, like a class, was an Optional< TMyClass, nothing >
then instead of FreeAndNil we could have FreeAndNothing,
and the value of the type would change to something that doesn’t even implement free.
The meeting presentation recording is now available on youtube at
