mORMot Open Source

oz

Member

Registered: 2015-09-02

Posts: 98

Issue with TDynArray.Delete()

Hi Arnaud,

there's an issue with TDynArray.Delete() if the TDynArray contains any kind of T*ObjArray objects.
TDynArray.Delete(aIndex) will not only call the object destructor at [aIndex] position...
Going down the callstack to some deeper level shows that TDynArray.InternalSetLength() calls the next object's destructor too. The array size does not decrease... at the end access violations will happen.

Testcase to reproduce the bug:

type
  TPerson=class(TSynPersistent)
  private
    fFullName: RawUTF8;
  published
    property FullName: RawUTF8 read fFullName write fFullName;
  end;
  TPersonObjArray=array of TPerson;

procedure TTestDynArray.DynArrayDelete;
var
  DA: TDynArray;
  arrPerson: TPersonObjArray;
  i: integer;
  person: TPerson;
const
  cMax=3;
begin
  TJSONSerializer.RegisterObjArrayForJSON([TypeInfo(TPersonObjArray),TPerson]);
  DA.Init(TypeInfo(TPersonObjArray), arrPerson);
  for i:=1 to cMax do
  begin
    person:=TPerson.Create;
    person.FullName:=FormatUTF8('FullName-%',[(i)]);
    DA.Add(person);
  end;
  for i:=Low(arrPerson) to High(arrPerson) do
  begin
    person:=arrPerson[(i)];
    Check(person.FullName=FormatUTF8('FullName-%',[(i+1)]));
  end;
  DA.Delete(0);
  for i:=Low(arrPerson) to High(arrPerson) do
  begin
    person:=arrPerson[(i)];
    Check(person.FullName=FormatUTF8('FullName-%',[(i+2)]));              // BOOM!!! -> access violation 
  end;
  DA.Clear;
end;

TDynArray.Delete implementation:

procedure TDynArray.Delete(aIndex: Integer);
var n, len: integer;
    P: PAnsiChar;
begin
  if fValue=nil then
    exit; // avoid GPF if void
  n := Count;
  if cardinal(aIndex)>=cardinal(n) then
    exit; // out of range
  dec(n);
  P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize);
  if ElemType<>nil then
    _Finalize(P,ElemType) else
    if GetIsObjArray then
      FreeAndNil(PObject(P)^);                  // <- The TPerson object is destroyed here
  if n>aIndex then begin
    len := cardinal(n-aIndex)*ElemSize;
    MoveFast(P[ElemSize],P[0],len);
    if ElemType<>nil then // avoid GPF
      FillcharFast(P[len],ElemSize,0);
  end;
  SetCount(n);                                  // <- this leads to the issue...
end;

procedure TDynArray.SetCount(aCount: integer);
.
.
.
      end else
      if aCount>0 then // aCount=0 should release memory (e.g. TDynArray.Clear)
        // size-down -> only if worth it (for faster Delete)
        if (capa<=MINIMUM_SIZE) or (capa-aCount<capa shr 3) then
          exit;
    end;
  end;
  // no external Count, array size-down or array up-grow -> realloc
  InternalSetLength(aCount);           // <- this leads to the issue...
end;

Going deeper...

procedure TDynArray.InternalSetLength(NewLength: PtrUInt);
var p: PDynArrayRec;
    pa: PAnsiChar absolute p;
    OldLength, NeededSize, minLength: PtrUInt;
    pp: pointer;
    i: integer;
begin // this method is faster than default System.DynArraySetLength() function
  // check that new array length is not just a hidden finalize
  if NewLength=0 then begin
    {$ifndef NOVARIANTS} // faster clear of custom variant uniformous array
    if ArrayType=TypeInfo(TVariantDynArray) then begin
      VariantDynArrayClear(TVariantDynArray(fValue^));
      exit;
    end;
    {$endif}
    if GetIsObjArray then
      for i := 0 to Count-1 do
        PObjectArray(fValue^)^[(i)].Free;
    _DynArrayClear(fValue^,ArrayType);
    exit;
  end;
  // retrieve old length
  p := fValue^;
  if p<>nil then begin
    dec(PtrUInt(p),Sizeof(TDynArrayRec)); // p^ = start of heap object
    OldLength := p^.length;
  end else
    OldLength := 0;
  // calculate the needed size of the resulting memory structure on heap
  NeededSize := NewLength*ElemSize+Sizeof(TDynArrayRec);
  if NeededSize>1024*1024*512 then // max allowed memory block is 512MB
    raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern',
      [PShortString(@PDynArrayTypeInfo(ArrayType).NameLen)^,NewLength]);
  // if not shared (refCnt=1), resize; if shared, create copy (not thread safe)
  if (p=nil) or (p^.refCnt=1) then begin
    if NewLength<OldLength then
      if ElemType<>nil then
        _FinalizeArray(pa+NeededSize,ElemType,OldLength-NewLength) else
        if GetIsObjArray then
          for i := NewLength to OldLength-1 do
            PObjectArray(fValue^)^[(i)].Free;                // <- the TPerson object is destroyed another time. Without this call everything works as expeced.
    ReallocMem(p,neededSize);
  end else begin
    InterlockedDecrement(PInteger(@p^.refCnt)^); // FPC has refCnt: PtrInt
    GetMem(p,neededSize);
    minLength := oldLength;
    if minLength>newLength then
      minLength := newLength;
    if ElemType<>nil then begin
      pp := pa+Sizeof(TDynArrayRec);
      FillcharFast(pp^,minLength*elemSize,0);
      CopyArray(pp,fValue^,ElemType,minLength)
    end else
      MoveFast(fValue^,pa[Sizeof(TDynArrayRec)],minLength*elemSize);
  end;
  // set refCnt=1 and new length to the heap memory structure
  with p^ do begin
    refCnt := 1;
    {$ifdef FPC}
    high := newLength-1;
    {$else}
    length := newLength;
    {$endif}
  end;
  Inc(PtrUInt(p),Sizeof(p^));
  // reset new allocated elements content to zero
  if NewLength>OldLength then begin
    OldLength := OldLength*elemSize;
    FillcharFast(pa[OldLength],neededSize-OldLength-Sizeof(TDynArrayRec),0);
  end;
  fValue^ := p;
end;

As a quick fix I simply disabled the "PObjectArray(fValue^)^[(i)].Free;" call. For now everything works as expected, but I don't know about potential side effects.

bye,
oz.

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,660

Website

Re: Issue with TDynArray.Delete()

I guess http://synopse.info/fossil/info/1b343e1409 is a better approach.

Thanks for the feedback!