QualityCentral

Public Report

Report From: Delphi-BCB/Compiler/Delphi/Finalization [ Add a report in this area ]

Report #: 44634

Status: Open

Compiler finalizes record incorrectly

Project: Delphi

Build #: 10.0.2288.42451

Version: 10.0

Submitted By: Joe White

Report Type: Basic functionality failure

Date Reported: 4/18/2007 10:57:04 AM

Severity: Extreme corner case

Last Updated: 4/21/2007 2:17:29 PM

Platform: 95, 98, 2000, NT, XP

Internal Tracking #: 249447

Resolution: None (Resolution Comments)

Resolved in Build: : None

Duplicate of: None

Voting and Rating

Overall Rating: (2 Total Ratings)

4.50 out of 5

Total Votes: 34

Description

When you have

(a) a record that contains an interface reference and one or more methods,
(b) a function that returns that record, and
(c) code that chains a call to that function with a call to a method on the record (e.g. MyFunction.DoSomething),

the compiler incorrectly finalizes the interface refcount too many times, causing the interfaced object to be freed even though there's still a live reference to it. This results in heap problems and sporadic (though sometimes reproducible) AVs.

However, the problem can be verified easily using the FastMM4 memory manager in full debug mode. See Steps.

The problem line is marked "<--- compiler incorrectly releases refcount too many times"; if this line is omitted, or the statement is broken into two statements by using a temporary variable, the problem does not occur.

Steps to Reproduce:

Save the attachments (or see below for detailed steps). Open and run the project.

Expected: should run without errors and show "Press ENTER".
Actual: pops up a FastMM error dialog showing that an interface was used after it was freed (see attached screenshot).

--------

To repro the problem from scratch:
1. Create a new Win32 console app. Save it somewhere.
2. Download the FastMM4 distribution from http://fastmm.sourceforge.net/. Copy the following files from the FastMM zip into the same directory as your project file:
    - FastMM4.pas
    - FastMM4Messages.pas
    - FastMM4Options.inc
    - FullDebugMode DLL\Precompiled\FastMM_FullDebugMode.dll
3. Make the following changes to FastMM4Options.inc:
    - Define FullDebugMode. (remove the "." before the "$define")
    - Define CatchUseOfFreedInterfaces. (remove the "." before the "$define")
4. Add the below code to your project file.
5. Save all, compile, and run.

--------

program Project2;

{$APPTYPE CONSOLE}

uses
  FastMM4,
  SysUtils;

type
  TRecord = record
  public
    Value: IInterface;
    procedure Foo;
  end;

  TTester = class
  strict private
    FFoo: TRecord;
    function Value: TRecord;
  public
    procedure Test;
  end;

{ TRecord }

procedure TRecord.Foo;
begin
end;

{ TTester }

procedure TTester.Test;
begin
  FFoo.Value := TInterfacedObject.Create;
  Value.Foo; // <--- compiler incorrectly releases refcount too many times
  FFoo.Value := nil; // <--- error: use of already-freed interface
end;

function TTester.Value: TRecord;
begin
  Result := FFoo;
end;

var
  Tester: TTester;
begin
  Tester := TTester.Create;
  try
    try
      Tester.Test;
    except
      on E: Exception do
        WriteLn(E.ClassName + ': ' + E.Message);
    end;
  finally
    FreeAndNil(Tester);
  end;
  WriteLn('Press ENTER:');
  ReadLn;
end.

Workarounds

None

Attachment

Clean.zip

Comments

Fernando Madruga at 4/18/2007 7:54:27 PM -

Still reproducible in Delphi 2007

Primoz Gabrijelcic at 4/18/2007 11:54:51 PM -

I believe this works 'as designed'.

When you call TTester.Value, Result := FFoo line doesn't return an address of the FFoo record but a bytewise copy of this record. IOW, this implementation of TTester.Value would be functionally equivalent to the one in the report:

function TTester.Value: TRecord;
begin
  Move(FFoo, Result, SizeOf(FFoo));
end;

That creates a copy of the FFoo.Value interface but doesn't increment its refcount.

Just after the Value.Foo; is executed, compiler notices that this temp copy of TRecord went out of scope and it finalizes it, decrementing refcount of <temp copy>.Value in the process. Unfortunately, <temp copy>.Value is the same instance as FFoo.Value so FFoo.Value has now been freed.

Fix:

function TTester.Value: TRecord;
begin
  Result := FFoo;
  Result.Value._AddRef;
end;

Joe White at 4/19/2007 5:30:12 AM -

You've never looked in the CPU view, have you? :-)

If a record contains finalizable types, then the compiler does not use Move(), or any other sort of bytewise copy, when it copies that record's contents. It uses @CopyRecord (_CopyRecord in System.pas), which looks at the RTTI to determine how to correctly manage references. It does this so you don't have to manually call _LStrAsg or _WStrAsg or _WStrClr to correctly assign any long-string references in the record, _VarCopy to assign Variants, _IntfCopy to assign interface references, _DynArrayAsg to assign dynamic-array references, or _CopyArray to copy static arrays of other finalizable types.

Interface references are automatically refcounted by the compiler. This doesn't somehow go away just because they're in a record.

The compiler actually does generate a call to @CopyRecord in this code. It just generates some other code that I don't fully grok, and the end result is, in this sample code, it breaks.

Try this: add a second interface-type variable to TRecord, then run the program again. Now it manages the refcount correctly, and does not double-free. (This is part of why I classified this as an "extreme corner case" -- everything has to be just so for it to break.)

Primoz Gabrijelcic at 4/19/2007 12:47:59 PM -

I did look into CPU view, but missed that :(

You're totally correct here.

Primoz Gabrijelcic at 4/20/2007 2:03:22 PM -

It seems that D2007 compiler generates slightly different but still broken code.

procedure TTester.Test;
begin
  FFoo.Value := TInterfacedObject.Create;
  //refcount = 1
  Value.Foo;
  //refcount = 2
  FFoo.Value := nil;
  //refcount = 1, temp copy of Value holds another reference
  //<--- FinalizeArray gets passed array of two pointers, both pointing to the FFoo.Value
end;

function TTester.Value: TRecord;
begin
  //refcount = 1
  Result := FFoo;
  //refcount = 2
end;

Everything is right up to the end of TTester.Test. Here a FinalizeArray is called and is passed an array of two pointers - both pointing to the FFoo.Value interface. Refcount for that interface is then decremented to 0, interface is destroyed and IntfClear is then called again for the same (destroyed) interface.

Frank Semmling at 4/11/2010 1:10:00 PM -

It would be nice if this problem would be solved gradually times.

Currently it looks like that I can throw away because of this error 2 projects, since there is no thoroughly tolerable substitute.

Here is my code with an incorrect reference counting by a dyn. array:

program Project3;

{$APPTYPE CONSOLE}

uses SysUtils;

type
  TRecord = record
    Data: array of Integer;
    function Value: Integer;
  end;

function TRecord.Value: Integer;
begin
  Result := Data[12345000];
end;

var
  Rec: TRecord;

function datafunc: TRecord;
begin
  Result := Rec;
end;

procedure Test;
begin
  Writeln(datafunc.Value);
end;

begin
  // monitored expressions / überwachte Ausdrücke:
  //    internal pointer:  PByte(Rec.Data)
  //    reference counter: PLongInt(PByte(Rec.Data) - 8)^
  SetLength(Rec.Data, 12345678);
  Rec.Data[12345000] := 678;
  Test;
  Test;
Test;
end.

http://www.delphipraxis.net/post1145795.html#1145795

Frank Semmling at 4/12/2010 6:43:35 AM -

The cause is a forgotten CopeyRcord, so there are problems with AnsiString, WideString, UnicodeString, Variant, Interface and dynamic Array.

##### complete functions ##################################
Following again the only differences.

procedure Test;
begin
  Writeln(datafunc.Value);
end;

Project1.dpr.27: begin
00408EB0 55               push ebp
00408EB1 8BEC             mov ebp,esp
00408EB3 83C4F8           add esp,-$08
00408EB6 33C0             xor eax,eax
00408EB8 8945F8           mov [ebp-$08],eax
00408EBB 8D45FC           lea eax,[ebp-$04]
00408EBE 8B15588E4000     mov edx,[$00408e58]
00408EC4 E87FBFFFFF       call @InitializeRecord
00408EC9 33C0             xor eax,eax
00408ECB 55               push ebp
00408ECC 68248F4000       push $00408f24
00408ED1 64FF30           push dword ptr fs:[eax]
00408ED4 648920           mov fs:[eax],esp

Project1.dpr.28: Writeln(datafunc.Value);
00408ED7 8D45F8           lea eax,[ebp-$08]
00408EDA E8B9FFFFFF       call datafunc
**************************************************
00408EDF 8B45F8           mov eax,[ebp-$08]
00408EE2 8945FC           mov [ebp-$04],eax
**************************************************
00408EE5 8D45FC           lea eax,[ebp-$04]
00408EE8 E89FFFFFFF       call TRecord.Value
00408EED 8BD0             mov edx,eax
00408EEF A150CC4000       mov eax,[$0040cc50]
00408EF4 E833AAFFFF       call @Write0Long
00408EF9 E85AAAFFFF       call @WriteLn
00408EFE E819A2FFFF       call @_IOTest

Project1.dpr.29: end;
00408F03 33C0             xor eax,eax
00408F05 5A               pop edx
00408F06 59               pop ecx
00408F07 59               pop ecx
00408F08 648910           mov fs:[eax],edx
00408F0B 682B8F4000       push $00408f2b
00408F10 8D45F8           lea eax,[ebp-$08]
00408F13 8B15588E4000     mov edx,[$00408e58]
00408F19 B902000000       mov ecx,$00000002
00408F1E E841C0FFFF       call @FinalizeArray
00408F23 C3               ret
00408F24 E9B3ACFFFF       jmp @HandleFinally
00408F29 EBE5             jmp $00408f10
00408F2B 59               pop ecx
00408F2C 59               pop ecx
00408F2D 5D               pop ebp
00408F2E C3               ret

procedure Test;
begin
  with datafunc do Writeln(Value);
end;

Project1.dpr.27: begin
00408EB0 55               push ebp
00408EB1 8BEC             mov ebp,esp
00408EB3 83C4F8           add esp,-$08
00408EB6 33C0             xor eax,eax
00408EB8 8945F8           mov [ebp-$08],eax
00408EBB 8D45FC           lea eax,[ebp-$04]
00408EBE 8B15588E4000     mov edx,[$00408e58]
00408EC4 E87FBFFFFF       call @InitializeRecord
00408EC9 33C0             xor eax,eax
00408ECB 55               push ebp
00408ECC 682F8F4000       push $00408f2f
00408ED1 64FF30           push dword ptr fs:[eax]
00408ED4 648920           mov fs:[eax],esp

Project1.dpr.28: with datafunc do Writeln(Value);
00408ED7 8D45F8           lea eax,[ebp-$08]
00408EDA E8B9FFFFFF       call datafunc
**************************************************
00408EDF 8D55F8           lea edx,[ebp-$08]
00408EE2 8D45FC           lea eax,[ebp-$04]
00408EE5 8B0D588E4000     mov ecx,[$00408e58]
00408EEB E8A8C1FFFF       call @CopyRecord
**************************************************
00408EF0 8D45FC           lea eax,[ebp-$04]
00408EF3 E894FFFFFF       call TRecord.Value
00408EF8 8BD0             mov edx,eax
00408EFA A150CC4000       mov eax,[$0040cc50]
00408EFF E828AAFFFF       call @Write0Long
00408F04 E84FAAFFFF       call @WriteLn
00408F09 E80EA2FFFF       call @_IOTest

*Project1.dpr.29: end;
00408F0E 33C0             xor eax,eax
00408F10 5A               pop edx
00408F11 59               pop ecx
00408F12 59               pop ecx
00408F13 648910           mov fs:[eax],edx
00408F16 68368F4000       push $00408f36
00408F1B 8D45F8           lea eax,[ebp-$08]
00408F1E 8B15588E4000     mov edx,[$00408e58]
00408F24 B902000000       mov ecx,$00000002
00408F29 E836C0FFFF       call @FinalizeArray
00408F2E C3               ret
00408F2F E9A8ACFFFF       jmp @HandleFinally
00408F34 EBE5             jmp $00408f1b
00408F36 59               pop ecx
00408F37 59               pop ecx
00408F38 5D               pop ebp
00408F39 C3               ret

##### differences ##################################

Writeln(datafunc.Value);

...
call datafunc
mov eax,[ebp-$08]
mov [ebp-$04],eax
lea eax,[ebp-$04]
call TRecord.Value
...

with datafunc do Writeln(Value);

...
call datafunc
lea edx,[ebp-$08]
lea eax,[ebp-$04]
mov ecx,[$00408e58]
call @CopyRecord
lea eax,[ebp-$04]
call TRecord.Value
...

##### an example from the Delphi RTL ###########################

program Project1;

uses SysUtils, Dialogs, Rtti;

type PInterface = ^IInterface;

var Rec: TRttiContext;

function datafunc: TRttiContext;
begin
  Result := Rec;
end;

procedure Test;
begin
  if datafunc.FindType('Rtti.TRttiContext').TypeSize <> 4 then
    Beep;
end;

begin   assert(false);
  Rec := TRttiContext.Create;
  Test;
  if PInterface(@Rec)^ = nil then
    ShowMessage('The interface was deleted, but really should be in place'
      + sLineBreak + 'was never released because Rec.FContextToken.');
  // Below no error occurs because DoCreate created a new interface.
  Test;
  Test;
  Rec.Free;
end.

// from unit Rtti.pas

procedure EnsurePoolToken(TokenRef: PInterface);
begin
  sample := PPointer(TokenRef)^;
  if sample <> nil then
    Exit;
  DoCreate;
end;

function TRttiContext.FindType(const AQualifiedName: string): TRttiType;
begin
  EnsurePoolToken(@FContextToken);
  Result := Pool.FindType(AQualifiedName);
end;

Frank Semmling at 4/11/2010 1:53:08 PM -

Some tests later:

All complex types have problems.
- interfaces
- dynamic arrays
- strings (AnsiString, UnicodeSting etc.)
- and even the WideString

Thus, record functions are not usable as soon as they are to return a more complex record.

Frank Semmling at 4/11/2010 1:14:16 PM -

[add]
This also allows you not use the really beautiful record features practical because it involves a potential risk.

Quality Central

Developer Tools

Database Tools