Frage zu Out of Memory Error (Ältere Delphi Version)

[himitsu]

Zitat von himitsu:

Ich glaube auch das SetLength wurde später nochmal etwas verbessert, so dass es größere Bereiche neu reservert und dann die nächsten paar Durchläufe nichts machen muß.

Vielleicht war es auch nicht im SetLength selber, sondern im ReallocMem, aber egal.

Delphi-Quellcode:

{$POINTERMATH ON}
{$OVERFLOWCHECKS OFF}

procedure TForm4.FormShow(Sender: TObject);
var
  TheArray: array of string;
  ThePointer: Pointer;
  ReallocCount, ResizeCount, RealSize, i: Integer;
  Start: Cardinal;
begin
  Assert(SizeOf(Pointer) = 4);
  ReallocCount := 0;
  ResizeCount := 0;
  ThePointer := 0;
  RealSize := 0;
  Start := GetTickCount;
  try
    for i := 0 to 1000000 do begin
      SetLength(TheArray, Length(TheArray) + 1);
      TheArray[Length(TheArray) - 1] := IntToStr(Random(100000000));

      if ThePointer <> Pointer(TheArray) then begin
        ThePointer := Pointer(TheArray);
        Inc(ReallocCount);
      end;
      if RealSize <> (PInteger(TheArray) - 1)^ then begin
        RealSize := (PInteger(TheArray) - 1)^;
        Inc(ResizeCount);
      end;
    end;
  except
    Memo1.Lines.Add(Format('BREAK'#13#10'Length = %d'#13#10'%d Reallocs'#13#10'%d ResizeCount'#13#10
      + '%d ms', [Length(TheArray), ReallocCount, ResizeCount, Integer(GetTickCount - Start)]));
    raise
  end;
  Memo1.Lines.Add(Format('%d Reallocs'#13#10'%d ResizeCount'#13#10'%d ms',
    [ReallocCount, ResizeCount, Integer(GetTickCount - Start)]));
end;

aktuelle 11.3:

Code:

27 Reallocs
1000001 ResizeCount
47 ms

[edit]
Ja, grad bemerkt, ResizeCount muß 1000001 sein.
Hier müsste man besser auf die Größenangabe des Speicherblocks zugreifen, oder AllocMem/FreeMem/ReallocMem hooken.
Beim Hook sind dann aber auch die Strings mit enthalten
und die Größenangabe ist bei beiden Speichermanagern unterschiedlich hinterlegt. (kann auf die schnelle eh nicht nachsehn, wie es im alten Delphi MM war)

Versuch: (nicht wundern, dass es etwas langsam ist ... hier nur 13 Sekunden)

Delphi-Quellcode:

{$POINTERMATH ON}
{$OVERFLOWCHECKS OFF}

procedure TForm4.FormShow(Sender: TObject);
var
  TheArray: array of string;
  ThePointer: Pointer;
  ReallocCount, ResizeCount, RealSize, i: Integer;
  Start, Allocated: Cardinal;
begin
  Assert(SizeOf(Pointer) = 4);
  ReallocCount := 0;
  ResizeCount := 0;
  ThePointer := 0;
  RealSize := 0;
  Start := GetTickCount;
  try
    for i := 0 to 1000000 do begin
      Allocated := GetHeapStatus.TotalAllocated;
      SetLength(TheArray, Length(TheArray) + 1);
      Allocated := GetHeapStatus.TotalAllocated - Allocated;

      TheArray[Length(TheArray) - 1] := IntToStr(Random(100000000));

      if ThePointer <> Pointer(TheArray) then begin
        ThePointer := Pointer(TheArray);
        Inc(ReallocCount);
      end;
      if {RealSize <> (PInteger(TheArray) - 1)^} Allocated <> 0 then begin
        RealSize := (PInteger(TheArray) - 1)^;
        Inc(ResizeCount);
      end;
    end;
  except
    Memo1.Lines.Add(Format('BREAK'#13#10'Length = %d'#13#10'%d Reallocs'#13#10'%d ResizeCount'#13#10
      + '%d ms', [Length(TheArray), ReallocCount, ResizeCount, Integer(GetTickCount - Start)]));
    raise
  end;
  Memo1.Lines.Add(Format('%d Reallocs'#13#10'%d ResizeCount'#13#10'%d ms',
    [ReallocCount, ResizeCount, Integer(GetTickCount - Start)]));
end;

PS: siehe System.pas -> DynArraySetLength