qmemory.pas

delphi源代码分析源码

        DEC     EDX
        JNE     @@lp
@@xx:   MOV     EDI,[EAX+ESI*4]
@@nq:   AND     EDI,EBX
        JE      @@zq
@@ne:   BSR     ECX,EDI
@@qt:   SHL     ESI,5
        LEA     EAX,[ECX+ESI]
        POP     EDI
        POP     ESI
        POP     EBX
        RET
@@ut:   SUB     EDX,ECX
        JG      @@zq
@@uk:   BT      [EAX],ECX
        JC      @@iq
        DEC     ECX
        INC     EDX
        JNG     @@uk
@@zq:   MOV     EAX,$FFFFFFFF
        POP     EDI
        POP     ESI
        POP     EBX
        RET
@@iq:   MOV     EAX,ECX
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure IntResetBits(P: Pointer; FirstBit, LastBit: Integer);
asm
        PUSH    EDI
        PUSH    ESI
        PUSH    EBX
        LEA     ESI,[EDX+8]
        CMP     ECX,ESI
        JL      @@ut
        MOV     EBX,$FFFFFFFF
        MOV     ESI,ECX
        MOV     EDI,$0000001F
        AND     ECX,EDI
        AND     ESI,$FFFFFFE0
        SUB     EDI,ECX
        SHR     ESI,5
        MOV     ECX,EDI
        MOV     EDI,EBX
        SHR     EDI,CL
        MOV     ECX,EDX
        AND     EDX,$FFFFFFE0
        AND     ECX,$0000001F
        SHR     EDX,5
        SHL     EBX,CL
        NOT     EDI
        NOT     EBX
        SUB     ESI,EDX
        JE      @@xx
        AND     [EAX+EDX*4],EBX
        INC     EDX
        DEC     ESI
        JE      @@ne
        XOR     EBX,EBX
@@lp:   MOV     [EAX+EDX*4],EBX
        INC     EDX
        DEC     ESI
        JNE     @@lp
@@xx:   OR      EDI,EBX
@@ne:   AND     [EAX+EDX*4],EDI
        POP     EBX
        POP     ESI
        POP     EDI
        RET
@@ut:   SUB     ECX,EDX
        JS      @@qt
@@uk:   BTR     [EAX],EDX
        INC     EDX
        DEC     ECX
        JNS     @@uk
@@qt:   POP     EBX
        POP     ESI
        POP     EDI
end;

function QMemDecommitOverstock: Integer;
label
  99;
var
  E: PEntryPoint;
  L,R: Integer;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      E := ListLeft;
      while E <> nil do
      begin
        if E^.Space shr 17 > 0 then
        begin
          L := (E^.Address+$FFFF-StartAddr) shr 16;
          R := (E^.Address+E^.Space-$10000-StartAddr) shr 16;
          L := IntSetBitScanForward(Pointer(StartAddr),L,R);
          if L >= 0 then
          begin
            R := IntSetBitScanReverse(Pointer(StartAddr),L,R);
            if not VirtualFree(Pointer(StartAddr+LongWord(L) shl 16),
              LongWord(R-L+1) shl 16, MEM_DECOMMIT) then
            begin
              Result := -1;
              goto 99;
            end;
            IntResetBits(Pointer(StartAddr),L,R);
          end;
        end;
        E := E^.AdrRight;
      end;
      Result := 0;
    99:
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemSize(P: Pointer): Integer;
begin
  Dec(LongWord(P),4);
  if (LongWord(P)>=SpaceBegin) and
      (PLongWord(P)^+LongWord(P)<=LongWord(EFreeArr)) then
    Result := PInteger(P)^-4
  else
    Result := -1;
end;

function QMemTotalAddrSpace: Integer;
begin
  if QMemIsInstalled then
    Result := LongWord(EFreeArr)-StartAddr
  else
    Result := -1;
end;

const
  BitTable: array[0..255] of Byte =
    (0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,
     1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,
     1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,
     2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,
     1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,
     2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,
     2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,
     3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,4,5,5,6,5,6,6,7,5,6,6,7,6,7,7,8);

function IntCountOfSetBits(P: Pointer; L: Cardinal): Cardinal;
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        XOR     EAX,EAX
        SUB     EDX,2
        JS      @@nx
@@lp:   MOVZX   ECX,BYTE PTR [EBX+EDX]
        MOVZX   ESI,BYTE PTR [EBX+EDX+1]
        MOVZX   ECX,BYTE PTR [ECX+BitTable]
        ADD     EAX,ECX
        MOVZX   ESI,BYTE PTR [ESI+BitTable]
        ADD     EAX,ESI
        SUB     EDX,2
        JNS     @@lp
@@nx:   INC     EDX
        JZ      @@qt2
        POP     ESI
        POP     EBX
        RET
@@qt2:  MOVZX   ECX,BYTE PTR [EBX]
        MOVZX   ECX,BYTE PTR [ECX+BitTable]
        ADD     EAX,ECX
        POP     ESI
        POP     EBX
end;

function IntCountOfFreeBits(P: Pointer; L: Cardinal): Cardinal;
asm
        PUSH    EDX
        CALL    IntCountOfSetBits
        NEG     EAX
        POP     EDX
        LEA     EAX,[EAX+EDX*8]
end;

function QMemTotalCommitted: Integer;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      Result := IntCountOfSetBits(Pointer(StartAddr),
        (LongWord(EFreeArr)-StartAddr) shr 19) shl 16;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemTotalUncommitted: Integer;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      Result := IntCountOfFreeBits(Pointer(StartAddr),
        (LongWord(EFreeArr)-StartAddr) shr 19) shl 16;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemTotalAllocated: Integer;
var
  E: PEntryPoint;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      Result := LongWord(EFreeArr)-SpaceBegin;
      E := ListLeft;
      while E <> nil do
      begin
        Dec(Result,E^.Space);
        E := E^.AdrRight;
      end;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemTotalFree: Integer;
var
  E: PEntryPoint;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      Result := 0;
      E := ListLeft;
      while E <> nil do
      begin
        Inc(Result,E^.Space);
        E := E^.AdrRight;
      end;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemMaxFreeBlock: Integer;
var
  E: PEntryPoint;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      Result := 0;
      E := ListLeft;
      while E <> nil do
      begin
        if E^.Space > LongWord(Result) then
          Result := E^.Space;
        E := E^.AdrRight;
      end;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemCountOfFreeBlocks: Integer;
begin
  if QMemIsInstalled then
  begin
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      Result := MaxECount-EFreeCount;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end;
  end else
    Result := -1;
end;

function QMemOverhead: Integer;
begin
  if QMemIsInstalled then
    Result := MaxECount*28
  else
    Result := -1;
end;

function QMemGetHeapStatus: TQMemHeapStatus;
var
  E: PEntryPoint;
  X1,X2: LongWord;
begin
  if QMemIsInstalled then
    try
      if IsMultiThread then
        EnterCriticalSection(lpCriticalSection);
      with Result do
      begin
        TotalAddrSpace := LongWord(EFreeArr)-StartAddr;
        TotalCommitted := IntCountOfSetBits(Pointer(StartAddr),
          TotalAddrSpace shr 19) shl 16;
        TotalUncommitted := TotalAddrSpace - TotalCommitted;
        X1 := 0;
        X2 := 0;
        E := ListLeft;
        while E <> nil do
        begin
          Inc(X1,E^.Space);
          if E^.Space > X2 then
            X2 := E^.Space;
          E := E^.AdrRight;
        end;
        TotalFree := X1;
        TotalAllocated := LongWord(EFreeArr)-SpaceBegin-X1;
        MaxFreeBlock := X2;
        CountOfFreeBlocks := MaxECount-EFreeCount;
        Overhead := MaxECount*28;;
      end;
    finally
      if IsMultiThread then
        LeaveCriticalSection(lpCriticalSection);
    end
  else
    with Result do
    begin
      TotalAddrSpace := 0;
      TotalCommitted := 0;
      TotalUncommitted := 0;
      TotalAllocated := 0;
      TotalFree := 0;
      MaxFreeBlock := 0;
      CountOfFreeBlocks := 0;
      Overhead := 0;
    end;
end;

function QMemSetMaxECount(Value: Integer): Integer;
begin
  if (not QMemIsInstalled) and (Value>0) then
  begin
    MaxECount := (Value+$3FFF) and $FFFFC000;
    Result := 0;
  end else
    Result := -1;
end;

procedure IntFillLong(Value: LongWord; P: Pointer; Count: Cardinal);
asm
        XCHG    EDI,EDX
        REP     STOSD
        MOV     EDI,EDX
end;

const
  QMemManager: TMemoryManager = (
    GetMem: IntGetMem;
    FreeMem: IntFreeMem;
    ReallocMem: IntReallocMem);

function QMemInstall(InitialSize, MaximumSize: Integer): Integer;
var
  L: LongWord;
  E: PEntryPoint;
  P: PLongWord;
begin
  if (not QMemIsInstalled) and (MaximumSize>0) then
  begin
    Inc(MaximumSize,$7FFFF);
    MaximumSize := MaximumSize and $FFF80000;
    L := MaxECount*28;
    StartAddr := LongWord(VirtualAlloc(nil, L+LongWord(MaximumSize),
      MEM_RESERVE or MEM_TOP_DOWN, PAGE_READWRITE));
    if StartAddr = 0 then
    begin
      Result := -1;
      Exit;
    end;
    EFreeArr := Pointer(StartAddr+LongWord(MaximumSize));
    if VirtualAlloc(EFreeArr, L, MEM_COMMIT, PAGE_READWRITE) = nil then
    begin
      VirtualFree(Pointer(StartAddr),0,MEM_RELEASE);
      Result := -1;
      Exit;
    end;
    EFreeCount := MaxECount;
    E := Pointer(LongWord(EFreeArr)+LongWord(MaxECount) shl 2);
    P := @EFreeArr^[EFreeCount];
    for L := 1 to EFreeCount do
    begin
      P^ := LongWord(E);
      Inc(E);
      Dec(P);
    end;
    if InitialSize < $10000 then
      InitialSize := $10000
    else if InitialSize > MaximumSize then
      InitialSize := MaximumSize
    else
    begin
      Inc(InitialSize,$FFFF);
      InitialSize := InitialSize and $FFFF0000;
    end;
    if VirtualAlloc(Pointer(StartAddr), InitialSize, MEM_COMMIT,
      PAGE_READWRITE) = nil then
    begin
      VirtualFree(Pointer(StartAddr),0,MEM_RELEASE);
      Result := -1;
      Exit;
    end;
    L := LongWord(MaximumSize) shr 19;
    IntFillLong(0,Pointer(StartAddr),(L+3) shr 2);
    IntSetBits(Pointer(StartAddr),0,InitialSize shr 16 - 1);
    SpaceBegin := (L+35) and $FFFFFFE0 - 4;
    Inc(SpaceBegin,StartAddr);
    Dec(EFreeCount);
    E := EFreeArr^[EFreeCount];
    ListLeft := E;
    ListRight := E;
    with E^ do
    begin
      Address := SpaceBegin;
      Space := LongWord(EFreeArr)-SpaceBegin;
      AdrLeft := nil;
      AdrRight := nil;
      SpLeft := nil;
      SpRight := nil;
    end;
    IntFillLong(0,@SizeTable,31);
    InitializeCriticalSection(lpCriticalSection);
    GetMemoryManager(OldMemManager);
    QMemIsInstalled := True;
    SetMemoryManager(QMemManager);
    Result := 0;
  end else
    Result := -1;
end;

function QMemRelease: Integer;
begin
  if QMemIsInstalled then
  begin
    SetMemoryManager(OldMemManager);
    QMemIsInstalled := False;
    DeleteCriticalSection(lpCriticalSection);
    if VirtualFree(Pointer(StartAddr), 0, MEM_RELEASE) then
    begin
      Result := 0;
      Exit;
    end;
  end;
  Result := -1;
end;

initialization
  QMemInstall(65536,268435456);

finalization
  QMemRelease;

end.