Faster way to get virtual allocation addresses - delphi

Question

I would like to process (save) the virtual memory blocks allocated to the current process. Here is the code I am using:
program Project38;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
Winapi.Windows;
procedure DoProcess(aStart: Pointer; aSize: Cardinal);
begin
// process it
end;
procedure ProcessVirtualMemory;
var
addr: Pointer;
i: Integer;
p: Pointer;
systemInfo: SYSTEM_INFO;
startAddress, stopAddress: Pointer;
size: size_t;
memInfo: MEMORY_BASIC_INFORMATION;
begin
GetSystemInfo(systemInfo);
startAddress := systemInfo.lpMinimumApplicationAddress;
stopAddress := systemInfo.lpMaximumApplicationAddress;
addr := startAddress;
while NativeUInt(addr) < NativeUInt(stopAddress) do begin
size:= VirtualQuery(Pointer(addr), memInfo, SizeOf(MEMORY_BASIC_INFORMATION));
if (size = SizeOf(MEMORY_BASIC_INFORMATION)) and
(memInfo.State = MEM_COMMIT) and
(memInfo.Type_9 = MEM_PRIVATE) and
(memInfo.RegionSize > 0) and
(memInfo.Protect = PAGE_READWRITE) then
begin
DoProcess(memInfo.BaseAddress, memInfo.RegionSize);
addr := Pointer(NativeUInt(addr) + memInfo.RegionSize);
end
else
addr := Pointer(NativeUInt(addr) + systemInfo.dwPageSize);
end;
end;
begin
ProcessVirtualMemory;
end.
This code is run with a huge application and collecting this information without processing is 10-12 seconds. Is there a faster way of getting the addresses of the virtual memory blocks?

Answer 1

Your program does contain a mistake. In case the memory block does not match your search criteria, you only increment by the page size rather than the region size. Your loop should really look like this:
while NativeUInt(addr) < NativeUInt(stopAddress) do begin
size := VirtualQuery(Pointer(addr), memInfo, SizeOf(MEMORY_BASIC_INFORMATION));
if size = 0 then begin
// handle error
break
end;
if (size = SizeOf(MEMORY_BASIC_INFORMATION)) and
(memInfo.State = MEM_COMMIT) and
(memInfo.Type_9 = MEM_PRIVATE) and
(memInfo.RegionSize > 0) and
(memInfo.Protect = PAGE_READWRITE) then begin
DoProcess(memInfo.BaseAddress, memInfo.RegionSize);
end;
addr := Pointer(NativeUInt(addr) + memInfo.RegionSize);
end;
The problem with your version is that when there are gaps in the virtual address space, your code walks over them one page at a time, rather than skipping the entire region.
Even without that change, I don't believe that enumeration was the bottleneck. I made the following alteration to your original program, to report the time taken:
var
Stopwatch: TStopwatch;
begin
Stopwatch := TStopwatch.StartNew;
ProcessVirtualMemory;
Writeln(Stopwatch.ElapsedMilliseconds);
Readln;
end.
On my machine, for a 32 bit release build, this reported around 500ms.
Then I allocated some memory:
var
i: Integer;
Stopwatch: TStopwatch;
begin
for i := 1 to 100000 do begin
HeapAlloc(GetProcessHeap, 0, Random(100000));
end;
Stopwatch := TStopwatch.StartNew;
ProcessVirtualMemory;
Writeln(Stopwatch.ElapsedMilliseconds);
Readln;
end.
No matter what I did, playing around with the constants, the program still reports around 500ms. If you fix the non-matching increment code as described at the start of this answer then the times come down to around 100ms.
Of course, for a 64 bit process, it's a little different. The defect in your code means that the program effectively gets stuck walking the huge 64 bit address space one page at a time, calling VirtualQuery for each page in the address space. I never even waited for that process to finish.
My conclusion therefore is that the main bottleneck in your program is not the code that your present, the code that finds the virtual memory blocks. That is the code inside DoProcess, the code that you have that we don't. So even when you fix the defect I described at the start, you will still spend significant time in that function. You should expect the virtual memory space enumeration to take in the region of 100ms.