memmapper.dpr

delphi开发语言下的源代码分析

program MemMapper;

{$APPTYPE CONSOLE}

uses
//  FastShareMem,
  Tester,
  Windows,
  Classes,
  SysUtils;

type
  TBlock = packed record
    addr: PChar;
    size: Integer;
  end;

type
  PBlockDesc = ^TBlockDesc;
  TBlockDesc = packed record
    next: PBlockDesc;
    prev: PBlockDesc;
    addr: PChar;
    size: Integer;
  end;

type
  PBlockDescBlock = ^TBlockDescBlock;
  TBlockDescBlock = packed record
    next: PBlockDescBlock;
    data: array [0..99] of TBlockDesc;
  end;

type
  PFree = ^TFree;
  TFree = packed record
    prev: PFree;
    next: PFree;
    size: Integer;  // SizeOf(TFree) + Alloced Size + Size of Head Stub.
  end;
  PUsed = ^TUsed;
  TUsed = packed record
    sizeFlags: Integer;
  end;

const
  cAlign        = 4;
  cThisUsedFlag = 2;
  cPrevFreeFlag = 1;
  cFillerFlag   = Integer($80000000);
  cFlags        = cThisUsedFlag or cPrevFreeFlag or cFillerFlag;
  cSmallSize    = 4*1024;
  cDecommitMin  = 15*1024;

type
  TSmallTab    = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree;

type
  THeapBlockEnumFunc = function(hEntry: TProcessHeapEntry; pData: Pointer): Boolean;

var
  ProcessHeaps: array of DWORD;

procedure InitHeapArr; // only process!
begin
  SetLength(ProcessHeaps, 1024);
  SetLength(ProcessHeaps, GetProcessHeaps(20, ProcessHeaps[0]));
end;

function EnumHeapBlock(EnumFun: THeapBlockEnumFunc; var pData): TBlock;
var
  i: integer;
  HEntry: TProcessHeapEntry;
begin
  for i := low(ProcessHeaps) to high(ProcessHeaps) do
  begin
    HEntry.lpData := nil;
    HEntry.wFlags:= PROCESS_HEAP_REGION;
    while HeapWalk(ProcessHeaps[i], HEntry) do
      if EnumFun(HEntry, @pData) then
      begin
        Result.addr := HEntry.lpData;
        Result.size := HEntry.cbData;
        Exit;
      end;
  end;
  Result.addr := nil;
end;

function SearchHeapBlock(n: Integer): TBlock; overload;
  function EnumSize(HEntry: TProcessHeapEntry; pData: Pointer): Boolean;
  begin
    Result := HEntry.cbData = DWORD(pData^);
  end;
begin
  Result := EnumHeapBlock(@EnumSize, n);
end;

function SearchHeapBlock(p: Pointer): TBlock; overload;
  function EnumAddr(HEntry: TProcessHeapEntry; pData: Pointer): Boolean;
  begin
    Result := HEntry.lpData = Pointer(pData^);
  end;
begin
  Result := EnumHeapBlock(@EnumAddr, p);
end;

procedure SearchHeapBlock(PtrList: TList; n: Integer); overload;
  function EnumSize(HEntry: TProcessHeapEntry; pData: Pointer): Boolean;
  begin
    if HEntry.cbData = DWORD(TList(pData^)[0]) then
      TList(pData^).Add(HEntry.lpData);
    Result := false;
  end;
begin
  PtrList.Clear;
  PtrList.Add(Pointer(n));
  EnumHeapBlock(@EnumSize, PtrList);
  PtrList.Delete(0);
end;

// 取指针所指向内存块的对齐长度
function RawGetSize(const p : pointer) : Cardinal;
var
  u : PUsed;
begin
  u := p;
  dec(u);
  result := u.sizeFlags and not cFlags;
end;

function NodeIsValid(p: Pointer; PtrList: TList): boolean;
begin
  Result := (p = nil) or (PtrList.IndexOf(p) >= 0);
end;

// for BDB
// (* 仅单向链表 *)
function NodeInNextOrd(NewPtr, OldPtr: PBlockDescBlock; PtrList: TList): boolean;
begin
  Result := False;
  repeat
    if not NodeIsValid(NewPtr.next, PtrList) then
      Break;

    if OldPtr <> NewPtr.next then
      NewPtr := NewPtr.next
    else
      Result := True;
  until Result or (NewPtr = nil);
end;

// 搜索一个单向链表的根结点.
// (* 在MemMgr中的单向链表仅有blockDescBlockList 和 blockDescFreeList. 链表中所有结点都在堆中. *)
function LinkListRoot(PtrList: TList; FromPtr:PBlockDesc): PBlockDesc;
var
  tmpList: TList;
  i      : Integer;
  isCircle : Boolean;
  CircleRoot : PBlockDesc;
begin
  Result := nil;
  if PtrList.Count < 1 then
    Exit;

  tmpList := TList.Create;
  tmpList.Assign(PtrList);

  // 在tmpList中查找根结点
  repeat
    // 清除掉FromPtr及之后的结点(单向链表)
    Result := FromPtr;
    repeat
      tmpList.Extract(FromPtr);
      FromPtr := FromPtr.next;
    until FromPtr = nil;

    // 查找一个结点
    if tmpList.Count > 0 then
    begin
      isCircle := False;
      FromPtr := tmpList[0];
      repeat
        FromPtr := FromPtr.next;
        isCircle := tmpList.IndexOf(FromPtr) < 0;
      until isCircle or (FromPtr = Result);

      if FromPtr = Result then // tmpList[0] 是单向链表前端(相对于Result)的一个节点. continue...
        FromPtr := tmpList[0]
      else                     // tmpList[0] 及 FromPtr 都是环形链表上的一个节点, 清除这个环
      begin
        CircleRoot := FromPtr;
        repeat
          tmpList.Extract(FromPtr);
          FromPtr := FromPtr.next;
        until FromPtr = CircleRoot;
        FromPtr := Result;     // FromPtr for next repeat
      end;
    end;
  until tmpList.Count = 0;

  tmpList.Free;
end;

// 在一个用于参考的TList中搜索一个TBlockDesc链表的根结点.
// 得到根结点的地址后, 链表中的结点将从PtrList中清除.
// (* 如果是一个TBlockDesc的环形链表, 则必然有一个Root结点不在链表中, 这个结点是在
//    GetMem.inc中定义的Root. 如果是一个单向链表, 则从任一结点依序访问, 将必然到达nil. *)
function SearchRoot(PtrList: TList; var RootNode:PBlockDesc; var isCircle: Boolean): Boolean;
var
  FromPtr: PBlockDesc;
  i      : Integer;
begin
  isCircle := False;
  RootNode := nil;
  Result := False;
  if PtrList.Count < 1 then
    Exit;

  // 任意取一个结点, 检测该结点位于一个单向链表, 亦或环形链表
  RootNode := PtrList[0];
  FromPtr := RootNode;
  repeat
    FromPtr := FromPtr.next;
    if FromPtr = nil then
      Break
    else
      isCircle := (PtrList.IndexOf(FromPtr) < 0) or (FromPtr = RootNode);
  until isCircle;

  if FromPtr = nil then  // 一定是单向链表
    RootNode := LinkListRoot(PtrList, RootNode)
  else                   // FromPtr一定会是真实的Root结点
    RootNode := FromPtr;

  // 在PtrList中清除链表上的全部结点
  FromPtr := RootNode;
  repeat
    PtrList.Extract(FromPtr);
    FromPtr := FromPtr.next;
  until (FromPtr = nil) or (FromPtr = RootNode);

  Result := True;
end;

function PtrInHere(Ptr: PChar; Root: PBlockDesc): boolean;
var
  APtr: PBlockDesc;
begin
  APtr := Root;
  Result := True;
  repeat
    if (Ptr >= APtr.addr) and
       (Ptr <= (APtr.addr + APtr.size)) then
      Exit;

    APtr := APtr.next;
  until APtr = Root;
  Result := False;
end;

function FindDecommittedRoot(Ptr: Pointer; RootList: TList): PBlockDesc;
var
  i: integer;
begin
  Result := nil;
  if RootList.IndexOf(Nil) >= 0 then  // 如果有Nil, 则一定是decommittedRoot, 即 decommittedRoot = nil;
    Exit;

  for i := 0 to RootList.Count - 1 do
    if not PtrInHere(Ptr, RootList[i]) then
    begin
      Result := RootList.Extract(RootList[i]);
      Break;
    end;
end;

function FindSpaceRoot(Ptr: Pointer; RootList: TList): PBlockDesc;
var
  i : integer;
begin
  Result := nil;
  for i := 0 to RootList.Count - 1 do
    if PtrInHere(Ptr, RootList[i]) then
    begin
      Result := RootList.Extract(RootList[i]);
      Break;
    end;
end;

// 检索BDB块链表的头并验证
// 如果有其它块正好与BDB块大小相同, 且正好在第一次就被查找到, 则可能发生不确知的错误
// (* BDB是一个单向链表, 且所有的结点都在堆中分配, 因此PtrList中必然包括全部结点 *)
function FindBDBList(PtrList: TList): PBlockDescBlock;
var
  i : Integer;
begin
  if PtrList.Count = 1 then
    Result := PtrList[0]
  else
  begin
    Result := nil;
    for i := 0 to PtrList.Count - 1 do
      if NodeInNextOrd(PtrList[i], Result, PtrList) then
        Result := PtrList[i];
  end;
end;

type
  TMemBlock = (mbFree, mbUsed, mbGap);
  TEnumMemBlock = function(mPtr: Pointer; mType: TMemBlock; pData: Pointer): Boolean;

const
  cHeapOk           = 0;
  cBadCurAlloc      = 7;          // current allocation zone is bad
  cBadUsedBlock     = 9;          // used block looks bad
  cBadNextBlock     = 11;         // next block after a used block is bad
  cBadFreeBlock     = 13;         // free block is bad