RTC Forums

type TByteArr=array of byte;
var arr:array[0..1000] of TByteArr;

procedure TForm1.AllocateThousandClick(Sender: TObject);
  var
    i:integer;
  begin
  // Dynamic arrays can be of any size, but 1.000 x 64KB 
  // should be high enough to show in the Task Manager
  for i:=0 to 999 do SetLength(arr[i],64000);
  end;

procedure TForm1.AllocateOneClick(Sender: TObject);
  begin
  // 100 KB does the trick
  SetLength(arr[1000],100000);
  end;

procedure TForm1.ReleaseThousandClick(Sender: TObject);
  var
    i:integer;
  begin
  // Setting Length to zero "deallocates" the array
  for i:=0 to 999 do SetLength(arr[i],0);
  end;

procedure TForm1.ReleaseOneClick(Sender: TObject);
  begin
  // Setting Length to zero "deallocates" the array
  SetLength(arr[1000],0);
  end;

var arr:array[0..1000] of pointer;

procedure TForm1.AllocateThousandClick(Sender: TObject);
  var
    i:integer;
  begin
  for i:=0 to 999 do GetMem(arr[i],64000);
  end;

procedure TForm1.AllocateOneClick(Sender: TObject);
  begin
  GetMem(arr[1000],100000);
  end;

procedure TForm1.ReleaseThousandClick(Sender: TObject);
  var
    i:integer;
  begin
  for i:=0 to 999 do
    begin
    FreeMem(arr[i]);
    arr[i]:=nil;
    end;
  end;

procedure TForm1.ReleaseOneClick(Sender: TObject);
  begin
  FreeMem(arr[1000]);
  arr[1000]:=nil;
  end;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Open: TButton;
    Close: TButton;
    lMemUse: TLabel;
    Timer1: TTimer;
    Start: TButton;
    Stop: TButton;
    lRun: TLabel;
    lWork: TLabel;
    procedure OpenClick(Sender: TObject);
    procedure CloseClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure StartClick(Sender: TObject);
    procedure StopClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  TEST_SIZE=1*1000;       // 1.000 arrays per Thread
  TEST_MAX=10*1000*1000;  // up to 10 MB per Thread

type
  TByteArr=array of byte;
  TThr=class(TThread)
     public
      arr:array[0..TEST_SIZE] of TByteArr;
      memuse:longint;
      run,work:boolean;
      procedure Execute; override;
      end;

procedure TThr.Execute;
  var
    i,olen,nlen:integer;
  function doRun:boolean;
    begin
    result:=run;
    end;
  begin
  i:=0;memuse:=0;
  while doRun do
    begin
    if work or (memuse>0) then
      begin
      olen:=length(arr[i]);
      SetLength(arr[i],0);
      Dec(memuse,olen);
      if work then
        begin
        case random(6) of
          0: nlen:=random(100)+1;
          1: nlen:=random(1000)+100;
          2: nlen:=random(10000)+1000;
          3: nlen:=random(100000)+10000;
          4: nlen:=random(100000)+30000;
          else nlen:=0;
          end;
        end
      else
         nlen:=0;
     if (nlen>0) and (memuse<TEST_MAX) then
        begin
        if (nlen+memuse>TEST_MAX) then nlen:=TEST_MAX-memuse;
        SetLength(arr[i],nlen);
        Inc(memuse,nlen);
        end;
      end;
    if(i<TEST_SIZE) then
      Inc(i)
    else if Application.Terminated then
      break
    else
      begin
      i:=0;
      Sleep(0);
      end;
    end;
  for i:=0 to TEST_SIZE do Setlength(arr[i],0);
  end;

var
   thr:array of TThr;

procedure TForm1.OpenClick(Sender: TObject);
  var
    i:integer;
  begin
  randomize;
  i:=length(thr);
  SetLength(thr,i+1);
  thr[i]:=TThr.Create(true);
  thr[i].FreeOnTerminate:=true;
  thr[i].memuse:=0;
  thr[i].work:=True;
  thr[i].run:=True;
  thr[i].Suspended:=False;
  end;

procedure TForm1.CloseClick(Sender: TObject);
  var
    i:integer;
    mt:TThr;
  begin
  i:=length(thr);
  if i>0 then
    begin
    Dec(i);
    mt:=thr[i];
    thr[i]:=nil;
    mt.run:=False;
    SetLength(thr,i);
    end;
  end;

procedure TForm1.StartClick(Sender: TObject);
  var
    i:integer;
  begin
  for i:=0 to length(thr)-1 do thr[i].work:=True;
  end;

procedure TForm1.StopClick(Sender: TObject);
  var
    i:integer;
  begin
  for i:=0 to length(thr)-1 do thr[i].work:=False;
  end;

procedure TForm1.Timer1Timer(Sender: TObject);
  var
    i,sumuse,srun,swork:integer;
  begin
  sumuse:=0;srun:=0;swork:=0;
  for i:=0 to length(thr)-1 do
    begin
    Inc(sumuse,thr[i].memuse);
    if thr[i].run then Inc(srun);
    if thr[i].work then Inc(swork);
    end;
  lRun.Caption:='Open '+IntToStr(srun)+' Threads';
  lWork.Caption:='Working '+IntToStr(swork)+' Threads';
  lMemUse.Caption:='Using '+IntToStr(round(sumuse/1024))+' KB RAM';
  end;

end.

object Form1: TForm1
  Left = 317
  Top = 193
  Caption = 'Form1'
  ClientHeight = 193
  ClientWidth = 205
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 120
  TextHeight = 16
  object lMemUse: TLabel
    Left = 8
    Top = 160
    Width = 82
    Height = 16
    Caption = 'Using 0 Bytes'
  end
  object lRun: TLabel
    Left = 8
    Top = 112
    Width = 97
    Height = 16
    Caption = 'Open 0 Threads'
  end
  object lWork: TLabel
    Left = 8
    Top = 136
    Width = 114
    Height = 16
    Caption = 'Working 0 Threads'
  end
  object Open: TButton
    Left = 8
    Top = 8
    Width = 85
    Height = 41
    Caption = 'Open 1'
    TabOrder = 0
    OnClick = OpenClick
  end
  object Close: TButton
    Left = 99
    Top = 8
    Width = 89
    Height = 41
    Caption = 'Close 1'
    TabOrder = 1
    OnClick = CloseClick
  end
  object Start: TButton
    Left = 8
    Top = 52
    Width = 85
    Height = 41
    Caption = 'Start All'
    TabOrder = 2
    OnClick = StartClick
  end
  object Stop: TButton
    Left = 96
    Top = 52
    Width = 89
    Height = 41
    Caption = 'Stop All'
    TabOrder = 3
    OnClick = StopClick
  end
  object Timer1: TTimer
    OnTimer = Timer1Timer
    Left = 148
    Top = 104
  end
end