//////////////////////////////////////////////////
//                                              //
//   QMemory 2.01a                              //
//                                              //
//   The alternative quick memory manager       //
//                                              //
//   Copyright (c) 2000,2001 Andrew Driazgov    //
//   e-mail: andrewdr@newmail.ru                //
//                                              //
//   Last updated: February 15, 2002            //
//                                              //
//////////////////////////////////////////////////

unit QMemory;

{$Q-}

interface

{ QMemory is a new memory manager. You can use it as a replacement of the
  default system memory manager. To do this simply add QMemory unit in your
  project (as the first unit listed in the project file). Don't forget to call
  the QMemDecommitOverstock function when your application is idle. This
  subroutine decommits the unused memory blocks (it's only way for program to
  return the memory to the operation system). All allocated memory blocks are
  32 byte aligned. The minimum size of the block is 32 bytes. As it is
  necessary to store some information with each block a dword is attached to
  the front of each block at -4 the aligned  address. Thus, memory request for
  up to 28 bytes allocates a 32-bytes block, request for 29 to 60 bytes
  allocates a 64-bytes block, etc (as power of 2). This idea was adopted from
  HPMM project of Robert Lee (rhlee@optimalcode.com). The memory is committed
  and decommitted in 64K blocks. The maximum amount of the memory is specified
  when QMemInstall function is called (from the initialization section of the
  unit). You can't change this value later. If some parts of your program
  implemented as DLLs you have to use ShareQmm instead of QMemory unit. }

(*
  QMemory should always be the first unit listed in program uses clause:

  program Project1;

  uses
    QMemory in 'QMemory.pas',        // first unit !!!
    Forms,
    MainUnit in 'MainUnit.pas' {MainForm},
    ...

  {$R *.RES}

  begin
    Application.Initialize;
    Application.Title := 'Project1';
    Application.CreateForm(TMainForm, MainForm);
    ...
    Application.Run;
  end.
*)

{ QMemInstall creates a custom heap and sets the entry points of the memory
  manager to the three functions of this unit which work with a created heap.
  The function reserves space in the virtual address space of the process and
  allocates physical storage for a specified initial portion of this block.
  InitialSize specifies the initial size, in bytes, of the heap. This value
  determines the initial amount of physical storage that is allocated for the
  heap. The value is rounded up to the next 64-kilobyte boundary. MaximumSize
  specifies the maximum size, in bytes, of the heap. The QMemInstall function
  rounds MaximumSize up to the next 512-kilobyte boundary, and then reserves
  a block of that size in the process's virtual address space for the heap.
  If allocation requests made by the GetMem or ReallocMem (or New) exceed the
  initial amount of physical storage specified by InitialSize, the system
  allocates additional pages of physical storage for the heap, up to the
  heap's maximum size. If the function succeeds, the return value is 0. If
  the function fails, it returns -1.

  QMemInstall is called from the initialization section of this unit. }

function QMemInstall(InitialSize, MaximumSize: Integer): Integer;

{ QMemRelease destroys the custom heap and restores the previous memory
  manager. QMemRelease decommits and releases all the pages of a heap. If the
  function succeeds, the return value is 0. If the function fails, the return
  value is -1.

  QMemRelease is called from the finalization section of this unit. }

function QMemRelease: Integer;

{ QMemDecommitOverstock decommits large free blocks of the memory. You may
  want to call the function from Application.Idle event handler. This function
  is only way (except QMemRelease) for decommit pages of the physical storage.
  If the function succeeds, the return value is 0, otherwise it returns -1. }

function QMemDecommitOverstock: Integer;

{ QMemSize returns the size, in bytes, of a memory block allocated from a
  custom heap. P is a pointer to the memory block whose size the function
  will obtain. The custom heap has to be installed. If the function succeeds,
  the return value is the size, in bytes, of the allocated memory block.
  If the function fails, the return value is -1. }

function QMemSize(P: Pointer): Integer;

{ QMemTotalAddrSpace returns the total address space of the custom heap,
  in bytes. This is fixed and will not grow as your program's dynamic memory
  usage grows. TotalUncommitted + TotalCommitted = TotalAddrSpace. The value
  is equal to MaximumSize, which you have specified when called QMemInstall
  function. If QMemTotalAddrSpace function fails, the return value is -1. }

function QMemTotalAddrSpace: Integer;

{ QMemTotalCommitted returns the total number of bytes (of TotalAddrSpace)
  for which space has been allocated in the swap file. If the function fails,
  the return value is -1. }

function QMemTotalCommitted: Integer;

{ QMemTotalUncommitted returns the total number of bytes (of TotalAddrSpace)
  for which space has not been allocated in the swap file. If the function
  fails, the return value is -1. }

function QMemTotalUncommitted: Integer;

{ QMemTotalAllocated returns the total number of bytes dynamically allocated
  by your program. It includes 4 bytes at the beginning of each memory block
  and the trailing bytes for maintain of 32-bytes align of a memory blocks.
  If the function fails, the return value is -1. }

function QMemTotalAllocated: Integer;

{ QMemTotalFree returns the total number of free bytes available in the
  custom heap for allocation by your program. If the function fails, the
  return value is -1. }

function QMemTotalFree: Integer;

{ QMemMaxFreeBlock returns the size, in bytes, of the maximum memory block
  which you can allocate in the custom heap. You can pass this value to
  the GetMem procedure (if you have physical storage of enought size).
  If the function fails, the return value is -1. }

function QMemMaxFreeBlock: Integer;

{ QMemCountOfFreeBlocks returns the total number of free blocks in the custom
  heap address space. If the function fails, the return value is -1. }

function QMemCountOfFreeBlocks: Integer;

{ QMemOverhead returns the total number of bytes required by the heap manager
  to manage all the blocks dynamically allocated by your program. More
  precisely, it returns the total size, in bytes, of additional committed
  space. If the function fails, the return value is -1. }

function QMemOverhead: Integer;

{ QMemGetHeapStatus returns the current status of the custom memory manager
  in a TQMemHeapStatus record. The fields of this record have been described
  above (they are analogues of the corresponding functions). If the function
  fails, all fields are 0. }

type
  TQMemHeapStatus = record
    TotalAddrSpace: Cardinal;
    TotalCommitted: Cardinal;
    TotalUncommitted: Cardinal;
    TotalAllocated: Cardinal;
    TotalFree: Cardinal;
    MaxFreeBlock: Cardinal;
    CountOfFreeBlocks: Cardinal;
    Overhead: Cardinal;
  end;

function QMemGetHeapStatus: TQMemHeapStatus;

{ QMemSetMaxECount assigns a new value to the internal variable which limits
  maximum number of free fragments in the custom heap. The default value is
  65536. If you want to save some virtual address space you may set this
  variable less (or more, if it is necessary). This function should be called
  before QMemInstall (when the memory manager is not installed yet). If the
  function succeeds, it returns 0. If the function fails, it returns -1. }

function QMemSetMaxECount(Value: Integer): Integer;

implementation

uses Windows;

type
  PEntryPoint = ^TEntryPoint;
  TEntryPoint = packed record
    Address: LongWord;
    Space: LongWord;
    AdrLeft: PEntryPoint;
    AdrRight: PEntryPoint;
    SpLeft: PEntryPoint;
    SpRight: PEntryPoint;
  end;

  PEFreeArr = ^TEFreeArr;
  TEFreeArr = array[0..$7FFFFF] of PEntryPoint;

var
  lpCriticalSection:_RTL_CRITICAL_SECTION;

  ListLeft: PEntryPoint;
  ListRight: PEntryPoint;

  SizeTable: array[0..30] of PEntryPoint;

  EFreeCount: Integer;
  EFreeArr: PEFreeArr;

  StartAddr: LongWord;
  SpaceBegin: LongWord;

  MaxECount: Integer = $10000;

  QMemIsInstalled: Boolean = False;

  OldMemManager: TMemoryManager;

function GetNormalSize(Size: Integer): Integer;
asm
        ADD     EAX,3
        TEST    EAX,$FFFFFFE0
        JE      @@sm
        BSR     ECX,EAX
        MOV     EAX,2
        SHL     EAX,CL
        RET
@@sm:   MOV     EAX,32
end;

function GetRegionOfSize(Size: Integer): Pointer;
asm
        BSF     ECX,EAX
        LEA     EDX,[ECX*4+SizeTable]
        MOV     ECX,[EDX]
        TEST    ECX,ECX
        JE      @@nx
        MOV     EAX,ECX
        MOV     ECX,[ECX].TEntryPoint.SpRight
        MOV     [EDX],ECX
        TEST    ECX,ECX
        JE      @@qm
        XOR     EDX,EDX
        MOV     [ECX].TEntryPoint.SpLeft,EDX
@@qm:   RET
@@nx:   MOV     EDX,EAX
        MOV     EAX,ListLeft
        TEST    EAX,EAX
        JE      @@qt
@@lp:   CMP     EDX,[EAX].TEntryPoint.Space
        JLE     @@qt
        MOV     EAX,[EAX].TEntryPoint.AdrRight
        TEST    EAX,EAX
        JNE     @@lp
@@qt:
end;

function IntBitTest(P: Pointer; Index: Integer): Boolean;
asm
        BT      [EAX],EDX
        SETC    AL
end;

procedure IntBitSet(P: Pointer; Index: Integer);
asm
        BTS     [EAX],EDX
end;

function IntFreeBitScanForward(P: Pointer; FirstBit, LastBit: Integer): Integer;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        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
        MOV     ECX,[EAX+EDX*4]
        NOT     ECX
        AND     EBX,ECX
        SUB     ESI,EDX
        JE      @@nq
        TEST    EBX,EBX
        JNE     @@ne
        INC     EDX
        DEC     ESI
        JE      @@xx
@@lp:   MOV     EBX,[EAX+EDX*4]
        NOT     EBX
        TEST    EBX,EBX
        JNE     @@ne
        INC     EDX
        DEC     ESI
        JNE     @@lp
@@xx:   MOV     EBX,[EAX+EDX*4]
        NOT     EBX
@@nq:   AND     EBX,EDI
        JE      @@zq
@@ne:   BSF     ECX,EBX
@@qt:   SHL     EDX,5
        LEA     EAX,[ECX+EDX]
        POP     EDI
        POP     ESI
        POP     EBX
        RET
@@ut:   SUB     ECX,EDX
        JS      @@zq
@@uk:   BT      [EAX],EDX
        JNC     @@iq
        INC     EDX
        DEC     ECX
        JNS     @@uk
@@zq:   MOV     EAX,$FFFFFFFF
        POP     EDI
        POP     ESI
        POP     EBX
        RET
@@iq:   MOV     EAX,EDX
        POP     EDI
        POP     ESI
        POP     EBX
end;

function IntFreeBitScanReverse(P: Pointer; FirstBit, LastBit: Integer): Integer;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        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
        MOV     ECX,[EAX+ESI*4]
        NOT     ECX
        AND     EDI,ECX
        SUB     EDX,ESI
        JE      @@nq
        TEST    EDI,EDI
        JNE     @@ne
        NEG     EDX
        DEC     ESI
        DEC     EDX
        JE      @@xx
@@lp:   MOV     EDI,[EAX+ESI*4]
        NOT     EDI
        TEST    EDI,EDI
        JNE     @@ne
        DEC     ESI
        DEC     EDX
        JNE     @@lp
@@xx:   MOV     EDI,[EAX+ESI*4]
        NOT     EDI
@@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
        JNC     @@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 IntSetBits(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
        SUB     ESI,EDX
        JE      @@xx
        OR      [EAX+EDX*4],EBX
        INC     EDX
        DEC     ESI
        JE      @@ne
        MOV     EBX,$FFFFFFFF
@@lp:   MOV     [EAX+EDX*4],EBX
        INC     EDX
        DEC     ESI
        JNE     @@lp
@@xx:   AND     EDI,EBX
@@ne:   OR      [EAX+EDX*4],EDI
        POP     EBX
        POP     ESI
        POP     EDI
        RET
@@ut:   SUB     ECX,EDX
        JS      @@qt
@@uk:   BTS     [EAX],EDX
        INC     EDX
        DEC     ECX
        JNS     @@uk
@@qt:   POP     EBX
        POP     ESI
        POP     EDI
end;

procedure DelFromSizeTable(E: PEntryPoint);
asm
        MOV     EDX,[EAX].TEntryPoint.SpLeft
        TEST    EDX,EDX
        JNE     @@nx
        MOV     EDX,[EAX].TEntryPoint.Space
        BSF     ECX,EDX
        LEA     EDX,[ECX*4+SizeTable]
        CMP     EAX,[EDX]
        JNE     @@qt
        MOV     ECX,[EAX].TEntryPoint.SpRight
        MOV     [EDX],ECX
        TEST    ECX,ECX
        JE      @@qt
        XOR     EDX,EDX
        MOV     [ECX].TEntryPoint.SpLeft,EDX
@@qt:   RET
@@nx:   MOV     ECX,[EAX].TEntryPoint.SpRight
        MOV     [EDX].TEntryPoint.SpRight,ECX
        TEST    ECX,ECX
        JE      @@qx
        MOV     [ECX].TEntryPoint.SpLeft,EDX
@@qx:
end;

function IntGetMem(Size: Integer): Pointer;
label
  99;
var
  E: PEntryPoint;
  I,J: Integer;
begin
  try
    if IsMultiThread then
      EnterCriticalSection(lpCriticalSection);
    Size := GetNormalSize(Size);
    E := GetRegionOfSize(Size);
    if E <> nil then
    begin