swaptestu.pas

DelphiWin32核心API参考光盘内容.是学习书籍中的源码,便于学习.

unit swaptestu;
//  Win95 API memory allocation swapfile test & example
//  written by Phil Dorcas  4/4/97 - 4/7/97
//  "Run test" button allocates memory with error checking on each press
//  "Release memory" button deallocates memory
//  "Quit" button deallocates memory and closes the app
//  See notes with the constants below
//  Read the Memory Management chapter for more info.

interface

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

type
  TForm1 = class(TForm)
    ButtonRun: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    ButtonRelease: TButton;
    Panel1: TPanel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure ButtonRunClick(Sender: TObject);
    procedure ButtonReleaseClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

const
  MyArraySize = 8180;     // approx size of each allocation
  MaxAllocations = 20;    // number of loops on each run

// you can change MaxAllocations to a low number if you just want to
//   observe memory tests that don't max the system.
// MyArraySize of 7800 will get 2 blocks of 4K on each allocation
// MaxAllocations of 500,000 times 7800 is 3.9G
//   which exceeds the 2G Virtal Memory Size that is available,
//   but this program stops when you reach the size of available swap file.
//*********************************************************************
// **
// **     WARNING:  Setting MyArraySize to a large number (ie, 7800)
// **               and MaxAllocations to a large number (ie, 100,000)
// **               can eat up all your swap file and memory and lock
// **               up your system.  It will not be "locked" locked, but
// **               will have no memory available for other operations.
// **               You will have to quit this program before your system
// **               will return to normal!
// **               Change these settings at your own risk.
// **
//***********************************************************************

type
  MySpaceRecord = record
    PrevSpace : pointer;   // backward link
    Spacecount: longint;   // taco bell order number, total allocations
    spacesize : longint;   // size of this allocation
    eat_up_space : array[1..MyArraySize div 4] of longint;
  end;

var
  Form1: TForm1;
  committed_total: longint;                // total bytes allocated
  committed_good: boolean;                 // error flag
  total_allocations: longint;              // number of requests
  MySpace: ^MySpaceRecord;                 // pointer to current record
  MyTemp: ^MySpaceRecord;                  // temp pointer to record
  StatusMsg: string;                       // for screen updates

implementation

{$R *.DFM}


Procedure ShowMemoryStatus;
var
{  MyMemory : PMemoryStatus;
  MyMemoryRecord : TMemoryStatus;}
  MyMemory: TMemoryStatus;
begin
//  MyMemory := @MyMemoryRecord;
  // set the size of the structure before the call.
  MyMemory.dwLength := sizeof(TMemoryStatus);  // 8 entries * 4 bytes = 32
  GlobalMemoryStatus(MyMemory);

  Form1.Label7.caption :=
     'Memory load percent is '
     + IntToStr(MyMemory.dwMemoryLoad) + '%';
  Form1.Label8.caption :=
     'Total available physical memory in bytes is '
     + IntToStr(MyMemory.dwAvailPhys);
  Form1.Label9.caption :=
     'Total bytes in the paging file is '
     + IntToStr(MyMemory.dwTotalPageFile);
  Form1.Label10.Caption :=
     'Total bytes available in the paging file is '
     + IntToStr(MyMemory.dwAvailPageFile);
  Form1.Label11.caption :=
     'Total virtual memory in bytes is '
     + IntToStr(MyMemory.dwTotalVirtual);
  Form1.Label12.caption :=
     'Total available virtual memory in bytes is '
     + IntToStr(MyMemory.dwAvailVirtual);
end;
  // end of ShowMemoryStatus


procedure Update_Screen;                   // display current status
begin
  Form1.Label1.Caption := IntToStr(committed_total);
  Form1.Label6.Caption := IntToStr(total_allocations);
  if not committed_good
    then form1.label4.caption := 'memory full'
    else form1.label4.caption := StatusMsg;
  ShowMemoryStatus;
end;

procedure Release_Memory;            // return memory to the system
var
  MySize : longint;                  // amount of memory granted by OS
begin
  if MySpace = nil then exit;        // do nothing if there is nothing
  MyTemp := pointer(MySpace^.PrevSpace);    // point to the last dog in line
  while MySpace <> nil do             // any memory left to release?
  begin
    MyTemp := MySpace^.prevspace; //  save previous before we lose pointer
    MySize := MySpace^.spacesize;
    // Mysize := 0;                // must be zero if MEM_RELEASE is used
    if VirtualFree(MySpace,
                   Mysize,
                   MEM_DECOMMIT)
      and                          // do not combine flags on same call
       VirtualFree(MySpace,
                   0,              {must be zero comment here}
                   MEM_RELEASE)
      then
      begin
        dec(total_allocations);
        committed_total := committed_total - mysize;
        statusmsg := 'returning memory';
      end
      else committed_good := false;
    MySpace := pointer(MyTemp);  // look at previous location;
    Application.processmessages;  // don't lock anything up
    Update_Screen;
    Sleep(3);  {?!? what's this for?}
 //   showmessage('total_allocations = ' + IntToStr(total_allocations));
  end;
  statusmsg := 'good';
  update_screen;
end;   // end of Release_Memory


procedure TForm1.FormCreate(Sender: TObject);           // init globals
begin
  committed_total := 0;
  total_allocations := 0;
  committed_good := true;
  MySpace := nil;
  MyTemp := nil;
  StatusMsg := 'good';
  ShowMemoryStatus;
end;

procedure TForm1.ButtonRunClick(Sender: TObject);
var
  NewAlloc : pointer;       // pointer to allocated memory block
  NewSize  : longint;       // size of memory block that was granted
  NewGrabs : longint;       // current number of allocations on this click
begin
  NewGrabs := 0;                             // init loop counter
  NewSize := sizeof(MySpaceRecord);
  committed_good := true;
  Update_Screen;
  while committed_good and (NewGrabs < MaxAllocations) do begin

    NewAlloc := VirtualAlloc(nil,
                             NewSize,
                             MEM_RESERVE or MEM_COMMIT,
                             PAGE_READWRITE);
    if NewAlloc = nil then
    begin
      committed_good := false;
      Update_Screen;
      exit;
    end;
    inc(NewGrabs);
    inc(total_allocations);
    committed_total := committed_total + NewSize;
    MyTemp := NewAlloc;
    MyTemp^.SpaceCount := total_allocations;
    MyTemp^.SpaceSize := NewSize;
    MyTemp^.PrevSpace := MySpace;
    MySpace := pointer(MyTemp);
    Update_Screen;
    Application.processmessages;
  end;
end;

procedure TForm1.ButtonReleaseClick(Sender: TObject);
begin
  Release_Memory;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    Release_Memory;
end;

end.