unit PagerF;
//*******************************************************
// Example program that allocates lots of memory
// to cause paging and thrashing.
//*******************************************************
// Copyright (C) 1998 John Wiley & Sons, Inc.
// All rights reserved. See additional copyright
// information in Readme.txt.
//*******************************************************

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, StdCtrls;
type
  TPagerForm = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Help1: TMenuItem;
    Exit1: TMenuItem;
    AboutthisProgram1: TMenuItem;
    Label1: TLabel;
    MemText: TEdit;
    CmdPage: TButton;
    CmdThrash: TButton;
    Label2: TLabel;
    TimeLabel: TLabel;
    procedure mnuExitClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure CmdPageClick(Sender: TObject);
    procedure ResizeArray;
    procedure FormCreate(Sender: TObject);
    procedure CmdThrashClick(Sender: TObject);
  private
    { Private declarations }
    procedure Runtest(thrash: Boolean);
  public
    { Public declarations }
  end;

var
  PagerForm : TPagerForm;

implementation
type
    TLongArray = array[1..100000000] of Longint;
    PLongArray = ^TLongArray;
var
    the_array : PLongArray; // The array we will resize.
    num_items : Longint;    // The number of items.

{$R *.DFM}

procedure TPagerForm.mnuExitClick(Sender: TObject);
begin
    Close;
end;

procedure TPagerForm.mnuAboutClick(Sender: TObject);
const
    CRCR = #13#10#13#10;
begin
    MessageDlg(
        'This program allows you to allocate bigger and bigger arrays until paging occurs.' + CRCR +
        'Page: The program allocates the indicated amount of memory and traverses it in an orderly fashion. This will cause paging if the array is larger than the amount of real memory your computer has.' + CRCR +
        'Thrash: The program allocates the indicated amount of memory and accesses it randomly. This will cause LOTS of paging if the array is larger than the amount of real memory your computer has.' + CRCR +
        'Note that the times shown will probably be less than the actual time you wait for the program. This is because the time shown does not include time to allocate the array.'
        , mtInformation, [mbOK], 0);
end;

procedure TPagerForm.CmdPageClick(Sender: TObject);
begin
    RunTest(False);
    MemText.SetFocus;
end;

procedure TPagerForm.RunTest(thrash: Boolean);
const
    LONGS_PER_MEG = 1048576 div SizeOf(Longint);
var
    start_time, stop_time : TDateTime;
    new_num, i, index     : Longint;
    h, m, s, ms           : Word;
begin
    TimeLabel.Caption := '';
    Screen.Cursor := crHourGlass;
    Update;

    // Resize the array if necessary.
    new_num := StrToInt(MemText.Text) * LONGS_PER_MEG;
    if (num_items <> new_num) then
    begin
        num_items := new_num;
        ResizeArray;
    end;

    // Traverse the memory to cause paging
    start_time := Time;
    if thrash then
    begin
        // Jump all over to causing thrashing.
        for i := 1 to num_items do
        begin
            index := Trunc(Random(num_items)) + 1;
            the_array^[index] := index;
        end;
    end else begin
        // Traverse the array in an orderly fashion.
        for i := 1 to num_items do
        begin
            // Assign index so the two perform about
            // the same amount of work.
            index := Trunc(Random(num_items)) + 1;
            the_array^[i] := index;
        end;
    end;
    stop_time := Time;
    DecodeTime(stop_time - start_time, h, m, s, ms);
    TimeLabel.Caption := Format('%.2f',
        [ms / 1000.0 + s + 60 * (m + h * 60)]);
    Screen.Cursor := crDefault;
    Beep;
end;

procedure TPagerForm.ResizeArray;
begin
    // Free previously allocated memory.
    FreeMem(the_array);

    // Reallocate new memory.
    GetMem(the_array, num_items * SizeOf(Longint));
end;

procedure TPagerForm.FormCreate(Sender: TObject);
begin
    Randomize;

    // Allocate 1 array entry to free later.
    num_items := 1;
    GetMem(the_array, 1 * SizeOf(Longint));
end;

procedure TPagerForm.CmdThrashClick(Sender: TObject);
begin
    RunTest(True);
    MemText.SetFocus;
end;

end.
