View Issue Details

IDProjectCategoryView StatusLast Update
0032353FPCRTLpublic2017-09-02 17:13
ReporterBenito van der ZanderAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionfixed 
Product Version3.1.1Product Build 
Target Version3.2.0Fixed in Version3.1.1 
Summary0032353: destroy counter break object pooling
DescriptionI use TInterfacedObject with an object pool. When the object is destroyed, it puts it memory back to the pool, so the next time it is created, it is created without a memory allocation and just takes its memory from the pool.

After r36757 0032168 that does not work anymore, because destroy is now only called at most once, so an object taken from the pool can never be freed again.

It should modify the reference counter for 0032168, not add a second counter
TagsNo tags attached.
Fixed in Revision37112
FPCOldBugId
FPCTarget
Attached Files
  • forum.pas (1,816 bytes)
    program forum;
    
    {$mode objfpc}{$H+}
    
    uses
      {$IFDEF UNIX}{$IFDEF UseCThreads}
      cthreads,
      {$ENDIF}{$ENDIF}
      Classes
      { you can add units after this };
    
    var
        commonValues: array[0..0] of record
          size: integer;
          cache: array[0..10000] of tobject;
        end;
    
    type TFasterObject = class(TInterfacedObject)
        field: string;
        class function newinstance : tobject;override;
        procedure FreeInstance;override;
        destructor Destroy; override;
        class function classKind: integer; virtual;
    end;
    
    class function TFasterObject.newinstance: tobject;
    var k: integer;
      size: Integer;
      //hackMethod: TMethod;
    begin
      k := classKind;
      size := commonValues[k].size;
      if size > 0 then begin
        result := commonValues[k].cache[size-1];
        dec(commonValues[k].size);
        //this can be skipped by cleaning it up in the destructor
        //hackMethod := tmethod(@CleanupInstance);
        //hackMethod.Data := result;
        //TProcedureOfObject(hackMethod)();
        //InitInstance(result);
      end else begin
        result := inherited newinstance;
      end;
    end;
    
    procedure TFasterObject.FreeInstance;
    var
      k: integer;
      size: Integer;
    begin
      k := classKind;
      size := commonValues[k].size;
      if (size < high(commonValues[k].cache)) then begin
        commonValues[k].cache[size] := self;
        inc(commonValues[k].size);
      end else begin
        //CleanupInstance;
        FreeMem(Pointer(Self));
      end;
    end;
    
    destructor TFasterObject.Destroy;
    begin
      field := '';
      inherited Destroy;
    end;
    
    class function TFasterObject.classKind: integer;
    begin
      result := 0; //unique id, overriden for every derived class
    end;
    
    var temp: IUnknown;
    begin
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
    end.
    
    
    forum.pas (1,816 bytes)
  • forum_TAKE_THIS_ONE.pas (2,605 bytes)
    program forum;
    
    {$mode objfpc}{$H+}
    
    uses heaptrc,
      {$IFDEF UNIX}{$IFDEF UseCThreads}
      cthreads,
      {$ENDIF}{$ENDIF}
      Classes
      { you can add units after this };
    
    var
        commonValues: array[0..0] of record
          size: integer;
          cache: array[0..10000] of tobject;
        end;
    
    type TFasterObject = class(TInterfacedObject, IUnknown)
        field: string;
        class function newinstance : tobject;override;
        procedure FreeInstance;override;
        procedure AfterConstruction; override;
        destructor Destroy; override;
        class function classKind: integer; virtual;
    end;
    
    type TNewinstanceFunc = function: tobject of object;
    class function TFasterObject.newinstance: tobject;
    var k: integer;
      size: Integer;
      hackMethod: TMethod;
    begin
      k := classKind;
      size := commonValues[k].size;
      writeln('new', size);
      if size > 0 then begin
        result := commonValues[k].cache[size-1];
        dec(commonValues[k].size);
        //this can be skipped by cleaning it up in the destructor
        //hackMethod := tmethod(@CleanupInstance);
        //hackMethod.Data := result;
        //TProcedureOfObject(hackMethod)();
        //InitInstance(result);
      end else begin
        hackMethod.Data := self;
        hackMethod.Code := @TObject.newinstance;
        result := TNewinstanceFunc(hackMethod)();
      end;
    end;
    
    procedure TFasterObject.FreeInstance;
    var
      k: integer;
      size: Integer;
    begin
      k := classKind;
      size := commonValues[k].size;
      writeln('free', size);
      if (size < high(commonValues[k].cache)) then begin
        commonValues[k].cache[size] := self;
        inc(commonValues[k].size);
      end else begin
        //CleanupInstance;
        FreeMem(Pointer(Self));
      end;
    end;
    
    procedure TFasterObject.AfterConstruction;
    begin
      //TInterfacedObject has a hack to allow the constructor to pass self as interface to non-const parameters.
      //We do not do this, so this override disables it.
    end;
    
    destructor TFasterObject.Destroy;
    begin
      field := '';
      inherited Destroy;
    end;
    
    class function TFasterObject.classKind: integer;
    begin
      result := 0; //unique id, overriden for every derived class
    end;
    
    procedure x;
    var temp: IUnknown;
    begin
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
      temp := TFasterObject.Create;
      temp := nil;
    end;
    var
    i: Integer;
    begin
      x;
      for i := 0 to high(commonValues[0].cache) do
        if commonValues[0].cache[i] <> nil then
          Freemem(pointer(commonValues[0].cache[i]));
    end.
    
    
    forum_TAKE_THIS_ONE.pas (2,605 bytes)

Activities

Michael Van Canneyt

2017-08-28 22:50

administrator   ~0102477

Does the pool zero out the memory when it takes an object from the pool ?

If it does, it should also zero out the second counter, and all should be well.
If it does not, it's an error in the pool, since after creation, all memory should be empty.

Benito van der Zander

2017-08-28 23:58

reporter   ~0102478

Last edited: 2017-08-29 01:22

View 2 revisions

My destructors zero the memory.

They have to, because when there a managed fields like strings, not setting them to nil would waste memory on unused strings. Then the pool knows all fields are zero when they are in the pool, so it does not need to zero anything else

And it only zeros the known fields. If it zeros everything, it also zeros the VMTs which are costly to reinitialize (especially since objects with interfaces have multiple VMTs).

Michael Van Canneyt

2017-08-29 07:27

administrator   ~0102482

If the memory is zeroed in the destructor as you claim, both counters should be 0, and all should function normally. So somehow I doubt this is happening.

Assuming for a moment there is a bug. Could you test with adding

TInterfacedObject(NewInstance).fdestroycount:=0; at line 1074 of objpas.inc ?

If that does not help, please give a fully compilable demo program.

Benito van der Zander

2017-08-29 10:05

reporter   ~0102487

> If the memory is zeroed in the destructor as you claim, both counters should be 0, and all should function normally. So somehow I doubt this is happening.

It zeros its fields. as in

destructor TXQValueString.Destroy;
begin
  str := '';
  inherited Destroy;
end;

> If that does not help, please give a fully compilable demo program.

Just try my internet tools

https://github.com/benibela/internettools/issues/15

Michael Van Canneyt

2017-08-29 10:58

administrator   ~0102489

Did you try the proposed fix ?

I'm not going to try your internet demo just to reproduce a bug.
So please provide a simple demo without dependencies.

Thaddy de Koning

2017-08-29 11:06

reporter   ~0102491

Last edited: 2017-08-29 11:07

View 2 revisions

Benito, you can also override Newinstance. That should work if your pool is predictable. (and is Delphi compatible)

Benito van der Zander

2017-08-29 23:46

reporter   ~0102503

> Did you try the proposed fix ?

I had not even time to try that fpc trunk.

I am still on r35800

> Benito, you can also override Newinstance. That should work if your pool is predictable. (and is Delphi compatible)

That is what I do: https://github.com/benibela/internettools/blob/master/data/xquery_types.inc#L159

Michael Van Canneyt

2017-08-30 10:30

administrator   ~0102508

@Benito: I didn't update trunk. It has little point, since I have no sample program to work with.

So I propose you to insert the fix in your local copy, and test that.

Benito van der Zander

2017-08-30 13:26

reporter   ~0102518

You updated trunk when you put the destructor counter there.

When I put the line in my local copy, it would say unknown field destructor counter.

murnur19 could test it

Michael Van Canneyt

2017-08-30 14:27

administrator   ~0102520

I repeat:
Please attach a compileable, self-contained demo that shows the problem.

As long as that does not happen, fixes will also not happen...

jamie philbrook

2017-08-31 19:47

reporter   ~0102543

Why he does not use a TObjectList or Tlist is beyond me.

I don't think coders should be hacking into the under layer
when there are ready made classes/Objects suited for the intent.

Benito van der Zander

2017-09-02 12:13

reporter  

forum.pas (1,816 bytes)
program forum;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes
  { you can add units after this };

var
    commonValues: array[0..0] of record
      size: integer;
      cache: array[0..10000] of tobject;
    end;

type TFasterObject = class(TInterfacedObject)
    field: string;
    class function newinstance : tobject;override;
    procedure FreeInstance;override;
    destructor Destroy; override;
    class function classKind: integer; virtual;
end;

class function TFasterObject.newinstance: tobject;
var k: integer;
  size: Integer;
  //hackMethod: TMethod;
begin
  k := classKind;
  size := commonValues[k].size;
  if size > 0 then begin
    result := commonValues[k].cache[size-1];
    dec(commonValues[k].size);
    //this can be skipped by cleaning it up in the destructor
    //hackMethod := tmethod(@CleanupInstance);
    //hackMethod.Data := result;
    //TProcedureOfObject(hackMethod)();
    //InitInstance(result);
  end else begin
    result := inherited newinstance;
  end;
end;

procedure TFasterObject.FreeInstance;
var
  k: integer;
  size: Integer;
begin
  k := classKind;
  size := commonValues[k].size;
  if (size < high(commonValues[k].cache)) then begin
    commonValues[k].cache[size] := self;
    inc(commonValues[k].size);
  end else begin
    //CleanupInstance;
    FreeMem(Pointer(Self));
  end;
end;

destructor TFasterObject.Destroy;
begin
  field := '';
  inherited Destroy;
end;

class function TFasterObject.classKind: integer;
begin
  result := 0; //unique id, overriden for every derived class
end;

var temp: IUnknown;
begin
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
end.

forum.pas (1,816 bytes)

Benito van der Zander

2017-09-02 13:34

reporter  

forum_TAKE_THIS_ONE.pas (2,605 bytes)
program forum;

{$mode objfpc}{$H+}

uses heaptrc,
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes
  { you can add units after this };

var
    commonValues: array[0..0] of record
      size: integer;
      cache: array[0..10000] of tobject;
    end;

type TFasterObject = class(TInterfacedObject, IUnknown)
    field: string;
    class function newinstance : tobject;override;
    procedure FreeInstance;override;
    procedure AfterConstruction; override;
    destructor Destroy; override;
    class function classKind: integer; virtual;
end;

type TNewinstanceFunc = function: tobject of object;
class function TFasterObject.newinstance: tobject;
var k: integer;
  size: Integer;
  hackMethod: TMethod;
begin
  k := classKind;
  size := commonValues[k].size;
  writeln('new', size);
  if size > 0 then begin
    result := commonValues[k].cache[size-1];
    dec(commonValues[k].size);
    //this can be skipped by cleaning it up in the destructor
    //hackMethod := tmethod(@CleanupInstance);
    //hackMethod.Data := result;
    //TProcedureOfObject(hackMethod)();
    //InitInstance(result);
  end else begin
    hackMethod.Data := self;
    hackMethod.Code := @TObject.newinstance;
    result := TNewinstanceFunc(hackMethod)();
  end;
end;

procedure TFasterObject.FreeInstance;
var
  k: integer;
  size: Integer;
begin
  k := classKind;
  size := commonValues[k].size;
  writeln('free', size);
  if (size < high(commonValues[k].cache)) then begin
    commonValues[k].cache[size] := self;
    inc(commonValues[k].size);
  end else begin
    //CleanupInstance;
    FreeMem(Pointer(Self));
  end;
end;

procedure TFasterObject.AfterConstruction;
begin
  //TInterfacedObject has a hack to allow the constructor to pass self as interface to non-const parameters.
  //We do not do this, so this override disables it.
end;

destructor TFasterObject.Destroy;
begin
  field := '';
  inherited Destroy;
end;

class function TFasterObject.classKind: integer;
begin
  result := 0; //unique id, overriden for every derived class
end;

procedure x;
var temp: IUnknown;
begin
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
  temp := TFasterObject.Create;
  temp := nil;
end;
var
i: Integer;
begin
  x;
  for i := 0 to high(commonValues[0].cache) do
    if commonValues[0].cache[i] <> nil then
      Freemem(pointer(commonValues[0].cache[i]));
end.

forum_TAKE_THIS_ONE.pas (2,605 bytes)

Benito van der Zander

2017-09-02 13:39

reporter   ~0102594

>Please attach a compileable, self-contained demo that shows the problem.

Guess we can just change my forum post http://forum.lazarus.freepascal.org/index.php?topic=34457.0 to use TInterfacedObject

> I don't think coders should be hacking into the under layer
>when there are ready made classes/Objects suited for the intent.

That is what I thought, but clearly it was a mistake to use TInterfacedObject. The solution is to never use a fpc class, otherwise that class get changed suddenly and breaks everything

Thaddy de Koning

2017-09-02 15:11

reporter   ~0102595

Well. Attach it? I do not see a difference debugging a recent Delphi and recent FPC on a low-level. Proof is my code also works on Berlin....

Michael Van Canneyt

2017-09-02 17:13

administrator   ~0102596

I fixed the bug.

As for your remark:
"That is what I thought, but clearly it was a mistake to use TInterfacedObject. The solution is to never use a fpc class, otherwise that class get changed suddenly and breaks everything "

We fix things, and yes, this can cause breakage sometimes in other places.
Then we fix that too. Normal in software development.

As a last thing I'll point out that what you're doing is actually a serious hack.

NewInstance *must guarantee* that the instance is properly initialized.

Your code in no way guarantees that; instead it relies on the assumption that the destructor has properly reset all fields.

As soon as one destructor has forgotten a field, it will wreak havoc on your code. Which is of course exactly what happened here.

So this "bug" is actually of your own making.
What is worse, you know it, see the remark in the test program:
  //this can be skipped by cleaning it up in the destructor
    //hackMethod := tmethod(@CleanupInstance);
    //hackMethod.Data := result;
    //TProcedureOfObject(hackMethod)();
    //InitInstance(result);

Anyway, fixed.

Issue History

Date Modified Username Field Change
2017-08-28 22:30 Benito van der Zander New Issue
2017-08-28 22:50 Michael Van Canneyt Note Added: 0102477
2017-08-28 22:50 Michael Van Canneyt Assigned To => Michael Van Canneyt
2017-08-28 22:50 Michael Van Canneyt Status new => feedback
2017-08-28 23:58 Benito van der Zander Note Added: 0102478
2017-08-28 23:58 Benito van der Zander Status feedback => assigned
2017-08-29 01:22 Benito van der Zander Note Edited: 0102478 View Revisions
2017-08-29 07:27 Michael Van Canneyt Note Added: 0102482
2017-08-29 10:05 Benito van der Zander Note Added: 0102487
2017-08-29 10:58 Michael Van Canneyt Note Added: 0102489
2017-08-29 11:06 Thaddy de Koning Note Added: 0102491
2017-08-29 11:07 Thaddy de Koning Note Edited: 0102491 View Revisions
2017-08-29 23:46 Benito van der Zander Note Added: 0102503
2017-08-30 10:30 Michael Van Canneyt Note Added: 0102508
2017-08-30 13:26 Benito van der Zander Note Added: 0102518
2017-08-30 14:27 Michael Van Canneyt Note Added: 0102520
2017-08-31 19:47 jamie philbrook Note Added: 0102543
2017-09-02 12:13 Benito van der Zander File Added: forum.pas
2017-09-02 13:34 Benito van der Zander File Added: forum_TAKE_THIS_ONE.pas
2017-09-02 13:39 Benito van der Zander Note Added: 0102594
2017-09-02 15:11 Thaddy de Koning Note Added: 0102595
2017-09-02 17:13 Michael Van Canneyt Fixed in Revision => 37112
2017-09-02 17:13 Michael Van Canneyt Note Added: 0102596
2017-09-02 17:13 Michael Van Canneyt Status assigned => resolved
2017-09-02 17:13 Michael Van Canneyt Fixed in Version => 3.1.1
2017-09-02 17:13 Michael Van Canneyt Resolution open => fixed
2017-09-02 17:13 Michael Van Canneyt Target Version => 3.2.0