A very old experimental garbage collector memory manager project for Delphi and FreePascal

BGCMM.pas

//////////////////////////////////////////////////////////////////////////////////////
//
// BeRo Garbage Collector Memory Manager - Copyright (C) 2011, Benjamin 'BeRo' Rosseaux
// Warning: CODED IN FEW HOURS ON A SINGLE DAY, SO USE IT ON YOUR OWN RISK!
//
//////////////////////////////////////////////////////////////////////////////////////
// Version: 2011.03.14.0013
//////////////////////////////////////////////////////////////////////////////////////
//
// Description:
//
// BGCMM is a incremental conserative mark-and-sweep garbage collector for Delphi and
// FreePascal.
//
//////////////////////////////////////////////////////////////////////////////////////
//
//                         P R I M A R Y     L I C E N S E
//
//////////////////////////////////////////////////////////////////////////////////////
//
// BGCMM is copyrighted free software by Benjamin Rosseaux <benjamin@rosseaux.de>.
// You can redistribute it and/or modify it under either the terms of the LGPLv3
// (see copying.txt file or below after this primary license), or the conditions below:
//
//   1. You may make and give away verbatim copies of the source form of the
//      software without restriction, provided that you duplicate all of the
//      original copyright notices and associated disclaimers.
//
//   2. You may modify your copy of the software in any way, provided that
//      you do at least ONE of the following:
//
//        a) place your modifications in the Public Domain or otherwise
//           make them Freely Available, such as by posting said
// 	  modifications to Usenet or an equivalent medium, or by allowing
// 	  the author to include your modifications in the software.
//
//        b) use the modified software only within your corporation or
//           organization.
//
//        c) make other distribution arrangements with the author.
//
//   3. You may distribute the software in object code or executable
//      form, provided that you do at least ONE of the following:
//
//        a) distribute the executables and library files of the software,
// 	  together with instructions (in the manual page or equivalent)
// 	  on where to get the original distribution.
//
//        b) accompany the distribution with the machine-readable source of
// 	  the software.
//
//        c) make other distribution arrangements with the author.
//
//   4. You may modify and include the part of the software into any other
//      software (possibly commercial). But some files in the distribution
//      are not written by the author, so that they are not under this terms.
//
//      These 3rd parts are marked, so far if any 3rd parts are present.
//
//      See each file for the copying condition.
//
//   5. The scripts and library files supplied as input to or produced as
//      output from the software do not automatically fall under the
//      copyright of the software, but belong to whomever generated them,
//      and may be sold commercially, and may be aggregated with this
//      software.
//
//   6. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
//      "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
//      LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
//      FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
//      COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
//      INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
//      BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
//      OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
//      AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
//      OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
//      THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
//      DAMAGE.
//
//////////////////////////////////////////////////////////////////////////////////////
//
//                         S E C O U N D     L I C E N S E
//
//////////////////////////////////////////////////////////////////////////////////////
//
//		   GNU LESSER GENERAL PUBLIC LICENSE
//                       Version 3, 29 June 2007
//
// Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
// Everyone is permitted to copy and distribute verbatim copies
// of this license document, but changing it is not allowed.
//
//
//  This version of the GNU Lesser General Public License incorporates
// the terms and conditions of version 3 of the GNU General Public
// License, supplemented by the additional permissions listed below.
//
//  0. Additional Definitions.
//
//  As used herein, "this License" refers to version 3 of the GNU Lesser
// General Public License, and the "GNU GPL" refers to version 3 of the GNU
// General Public License.
//
//  "The Library" refers to a covered work governed by this License,
// other than an Application or a Combined Work as defined below.
//
//  An "Application" is any work that makes use of an interface provided
// by the Library, but which is not otherwise based on the Library.
// Defining a subclass of a class defined by the Library is deemed a mode
// of using an interface provided by the Library.
//
//  A "Combined Work" is a work produced by combining or linking an
// Application with the Library.  The particular version of the Library
// with which the Combined Work was made is also called the "Linked
// Version".
//
//  The "Minimal Corresponding Source" for a Combined Work means the
// Corresponding Source for the Combined Work, excluding any source code
// for portions of the Combined Work that, considered in isolation, are
// based on the Application, and not on the Linked Version.
//
//  The "Corresponding Application Code" for a Combined Work means the
// object code and/or source code for the Application, including any data
// and utility programs needed for reproducing the Combined Work from the
// Application, but excluding the System Libraries of the Combined Work.
//
//  1. Exception to Section 3 of the GNU GPL.
//
//  You may convey a covered work under sections 3 and 4 of this License
// without being bound by section 3 of the GNU GPL.
//
//  2. Conveying Modified Versions.
//
//  If you modify a copy of the Library, and, in your modifications, a
// facility refers to a function or data to be supplied by an Application
// that uses the facility (other than as an argument passed when the
// facility is invoked), then you may convey a copy of the modified
// version:
//
//   a) under this License, provided that you make a good faith effort to
//   ensure that, in the event an Application does not supply the
//   function or data, the facility still operates, and performs
//   whatever part of its purpose remains meaningful, or
//
//   b) under the GNU GPL, with none of the additional permissions of
//   this License applicable to that copy.
//
//  3. Object Code Incorporating Material from Library Header Files.
//
//  The object code form of an Application may incorporate material from
// a header file that is part of the Library.  You may convey such object
// code under terms of your choice, provided that, if the incorporated
// material is not limited to numerical parameters, data structure
// layouts and accessors, or small macros, inline functions and templates
// (ten or fewer lines in length), you do both of the following:
//
//   a) Give prominent notice with each copy of the object code that the
//   Library is used in it and that the Library and its use are
//   covered by this License.
//
//   b) Accompany the object code with a copy of the GNU GPL and this license
//   document.
//
//  4. Combined Works.
//
//  You may convey a Combined Work under terms of your choice that,
// taken together, effectively do not restrict modification of the
// portions of the Library contained in the Combined Work and reverse
// engineering for debugging such modifications, if you also do each of
// the following:
//
//   a) Give prominent notice with each copy of the Combined Work that
//   the Library is used in it and that the Library and its use are
//   covered by this License.
//
//   b) Accompany the Combined Work with a copy of the GNU GPL and this license
//   document.
//
//   c) For a Combined Work that displays copyright notices during
//   execution, include the copyright notice for the Library among
//   these notices, as well as a reference directing the user to the
//   copies of the GNU GPL and this license document.
//
//   d) Do one of the following:
//
//       0) Convey the Minimal Corresponding Source under the terms of this
//       License, and the Corresponding Application Code in a form
//       suitable for, and under terms that permit, the user to
//       recombine or relink the Application with a modified version of
//       the Linked Version to produce a modified Combined Work, in the
//       manner specified by section 6 of the GNU GPL for conveying
//       Corresponding Source.
//
//       1) Use a suitable shared library mechanism for linking with the
//       Library.  A suitable mechanism is one that (a) uses at run time
//       a copy of the Library already present on the user's computer
//       system, and (b) will operate properly with a modified version
//       of the Library that is interface-compatible with the Linked
//       Version.
//
//   e) Provide Installation Information, but only if you would otherwise
//   be required to provide such information under section 6 of the
//   GNU GPL, and only to the extent that such information is
//   necessary to install and execute a modified version of the
//   Combined Work produced by recombining or relinking the
//   Application with a modified version of the Linked Version. (If
//   you use option 4d0, the Installation Information must accompany
//   the Minimal Corresponding Source and Corresponding Application
//   Code. If you use option 4d1, you must provide the Installation
//   Information in the manner specified by section 6 of the GNU GPL
//   for conveying Corresponding Source.)
//
//  5. Combined Libraries.
//
//  You may place library facilities that are a work based on the
// Library side by side in a single library together with other library
// facilities that are not Applications and are not covered by this
// License, and convey such a combined library under terms of your
// choice, if you do both of the following:
//
//   a) Accompany the combined library with a copy of the same work based
//   on the Library, uncombined with any other library facilities,
//   conveyed under the terms of this License.
//
//   b) Give prominent notice with the combined library that part of it
//   is a work based on the Library, and explaining where to find the
//   accompanying uncombined form of the same work.
//
//  6. Revised Versions of the GNU Lesser General Public License.
//
//  The Free Software Foundation may publish revised and/or new versions
// of the GNU Lesser General Public License from time to time. Such new
// versions will be similar in spirit to the present version, but may
// differ in detail to address new problems or concerns.
//
//  Each version is given a distinguishing version number. If the
// Library as you received it specifies that a certain numbered version
// of the GNU Lesser General Public License "or any later version"
// applies to it, you have the option of following the terms and
// conditions either of that published version or of any later version
// published by the Free Software Foundation. If the Library as you
// received it does not specify a version number of the GNU Lesser
// General Public License, you may choose any version of the GNU Lesser
// General Public License ever published by the Free Software Foundation.
//
//  If the Library as you received it specifies that a proxy can decide
// whether future versions of the GNU Lesser General Public License shall
// apply, that proxy's public statement of acceptance of any version is
// permanent authorization for you to choose that version for the
// Library.
//
//////////////////////////////////////////////////////////////////////////////////////
unit BGCMM;
{$ifdef fpc}
 {$mode delphi}
 {$ifdef cpui386}
  {$define cpu386}
 {$endif}
 {$ifdef cpu386}
  {$asmmode intel}
 {$endif}
 {$ifdef cpuamd64}
  {$asmmode intel}
 {$endif}
 {$ifdef FPC_LITTLE_ENDIAN}
  {$define LITTLE_ENDIAN}
 {$else}
  {$ifdef FPC_BIG_ENDIAN}
   {$define BIG_ENDIAN}
  {$endif}
 {$endif}
 {$define caninline}
{$else}
 {$define LITTLE_ENDIAN}
 {$ifndef cpu64}
  {$define cpu32}
 {$endif}
 {$ifndef BCB}
  {$ifdef ver120}
   {$define Delphi4or5}
  {$endif}
  {$ifdef ver130}
   {$define Delphi4or5}
  {$endif}
  {$ifdef ver140}
   {$define Delphi6}
  {$endif}
  {$ifdef ver150}
   {$define Delphi7}
  {$endif}
  {$ifdef ver170}
    {$define Delphi2005}
  {$endif}
 {$else}
  {$ifndef PatchBCBTerminate}
   {$define NeverUninstall}
   {$undef EnableMemoryLeakReporting}
  {$endif}
  {$ifdef ver120}
   {$define Delphi4or5}
   {$define BCB4}
  {$endif}
  {$ifdef ver130}
   {$define Delphi4or5}
  {$endif}
 {$endif}
 {$ifdef ver180}
   {$define BDS2006}
 {$endif}
 {$ifndef Delphi4or5}
  {$ifndef BCB}
   {$define Delphi6AndUp}
  {$endif}
   {$ifndef Delphi6}
    {$define BCB6OrDelphi7AndUp}
    {$ifndef BCB}
      {$define Delphi7AndUp}
    {$endif}
    {$ifndef BCB}
      {$ifndef Delphi7}
        {$ifndef Delphi2005}
          {$define BDS2006AndUp}
        {$endif}
      {$endif}
    {$endif}
   {$endif}
 {$endif}
 {$ifdef Delphi6AndUp}
  {$WARN SYMBOL_PLATFORM OFF}
  {$WARN SYMBOL_DEPRECATED OFF}
 {$endif}
 {$ifdef BCB}
  {$ifdef borlndmmdll}
   {$OBJEXPORTALL OFF}
  {$endif}
 {$endif}
{$endif}
{$ifdef win32}
 {$define windows}
{$endif}
{$ifdef win64}
 {$define windows}
{$endif}
{$ifdef wince}
 {$define windows}
{$endif}
{$rangechecks off}
{$ifdef cpu386}
 {$define stack}
 {$define registers}
{$endif}
{$ifdef cpuamd64}
 {$define stack}
 {$define registers}
{$endif}

interface

{$ifdef windows}
uses Windows;
{$endif}

{$ifndef fpc}
{$ifdef cpu64}
type ptruint=qword;
     ptrint=int64;
{$else}
type ptruint=longword;
     ptrint=longint;
{$endif}
{$endif}

type TBGCMMFinalizer=procedure(Ptr:pointer;Size:ptruint;Data:pointer);

var BGCMMGrayAll:boolean;

    BGCMMMarkCount:integer;
    BGCMMFinalizeCount:integer;
    BGCMMSweepCount:integer;
    BGCMMCleanUpCount:integer;

    BGCMMMaxAllocsPerCollect:integer;

    BGCMMMaxItemsPerHashBucket:integer;

    BGCMMUseFullCollects:boolean;

{$ifdef fpc}
function BGCMMGetMem(Size:ptruint):pointer;
function BGCMMFreeMem(p:pointer):ptruint;
function BGCMMFreeMemSize(p:pointer;Size:ptruint):ptruint;
function BGCMMAllocMem(size:ptruint):pointer;
function BGCMMReallocMem(var p:pointer;size:ptruint):pointer;
function BGCMMMemSize(p:pointer):ptruint;
procedure BGCMMInitThread;
procedure BGCMMDoneThread;
procedure BGCMMRelocateHeap;
function BGCMMGetHeapStatus:THeapStatus;
function BGCMMGetFPCHeapStatus:TFPCHeapStatus;
{$else}
function BGCMMGetMem(Size:integer):pointer;
function BGCMMFreeMem(p:pointer):integer;
function BGCMMReallocMem(p:pointer;Size:integer):pointer;
{$ifdef BDS2006AndUp}
function BGCMMAllocMem(ASize:cardinal):pointer;
function BGCMMRegisterExpectedMemoryLeak(APointer:pointer):boolean;
function BGCMMRUnregisterExpectedMemoryLeak(APointer:pointer):boolean;
{$endif}
{$endif}

procedure BGCMMSetFinalizer(p:pointer;const Finalizer:TBGCMMFinalizer;FinalizerData:pointer);
procedure BGCMMAdd(p:pointer);
procedure BGCMMRemove(p:pointer);
procedure BGCMMAddRoot(p:pointer);
procedure BGCMMAddRootRange(Bottom,Top:pointer);
procedure BGCMMUse(p:pointer);

function BGCMMCollect:boolean;
procedure BGCMMFullCollect;

procedure BGCMMLock;
procedure BGCMMUnlock;

implementation

{$ifdef fpc}
const NewMemoryManager:TMemoryManager=(NeedLock:false;
                                       GetMem:BGCMMGetMem;
                                       FreeMem:BGCMMFreeMem;
                                       FreeMemSize:BGCMMFreeMemSize;
                                       AllocMem:BGCMMAllocMem;
                                       ReallocMem:BGCMMReallocMem;
                                       MemSize:BGCMMMemSize;
                                       InitThread:BGCMMInitThread;
                                       DoneThread:BGCMMDoneThread;
                                       RelocateHeap:BGCMMRelocateHeap;
                                       GetHeapStatus:BGCMMGetHeapStatus;
                                       GetFPCHeapStatus:BGCMMGetFPCHeapStatus;
                                      );
{$else}
const NewMemoryManager:{$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif}=(GetMem:BGCMMGetMem;
                                                                                            FreeMem:BGCMMFreeMem;
                                                                                            ReallocMem:BGCMMReallocMem;
{$ifdef BDS2006AndUp}
                                                                                            AllocMem:BGCMMAllocMem;
                                                                                            RegisterExpectedMemoryLeak:BGCMMRegisterExpectedMemoryLeak;
                                                                                            UnregisterExpectedMemoryLeak:BGCMMUnregisterExpectedMemoryLeak;
{$endif}                                                                                   );
{$endif}

      PointerXorValue:ptruint={$ifdef cpu64}ptruint($ffffffffffffffff){$else}ptruint($ffffffff){$endif};

      POINTER_BITS=sizeof(pointer) shl 3;

const FreeSpin=pointer(ptruint(3));
      BusySpin=pointer(ptruint(4));

type PPtrUIntArray=^TPtrUIntArray;
     TPtrUIntArray=array[0..($7fffffff div sizeof(ptruint))-1] of ptruint;

     PPointerList=^TPointerList;

     PPointerItem=^TPointerItem;
     TPointerItem=record
      Previous,Next:PPointerItem;
      HashPrevious,HashNext:PPointerItem;
      ListPrevious,ListNext:PPointerItem;
      List:PPointerList;
      Hash:longword;
      Ptr:pointer;
      Size:ptruint;
      Finalizer:TBGCMMFinalizer;
      FinalizerData:pointer;
     end;

     TPointerList=record
      First,Last:PPointerItem;
     end;

     TPointerHashBucket=record
      First,Last:PPointerItem;
     end;

     PAATreeNode=^TAATreeNode;
     TAATreeNode=record
      Parent,Left,Right:PAATreeNode;
      Level:ptrint;
      Key:ptruint;
      PointerItem:PPointerItem;
     end;

     PRange=^TRange;
     TRange=record
      Next:PRange;
      Bottom,Top:pointer;
     end;

     TPointerHashBuckets=array[word] of TPointerHashBucket;

     THashShift=array[0..$fff] of integer;

{$ifdef registers}
     TRegisters=array[byte] of ptruint;
{$endif}

     TState=(sINIT,sMARKROOTRANGES,sMARKROOTS,sMARKGRAYS,sFINALIZEWHITES,sSWEEPWHITES,sCLEANUP,sDONE);

var OldMemoryManager:{$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};

    WhiteList,GrayList,BlackList,RootList,ScanList,AlreadyScannedList:PPointerList;

    CurrentPointerItem,NextPointerItem,FirstPointerItem,LastPointerItem:PPointerItem;

    HashBuckets:TPointerHashBuckets;

{$ifdef stack}
{$ifndef fpc}
    StackBottom:pointer;
    StackTop:pointer;
{$endif}
{$endif}

    LocalCriticalSection:TRTLCriticalSection;

    HashShift:THashShift;

{$ifdef registers}
    Registers:TRegisters;
{$endif}

    State:TState;

    AllocCounter:integer;

    CountPointers,CountHashBuckets:ptrint;

    UseHashTableForSearching:boolean;

    Ranges:PRange;

    CurrentRange:PRange;

    PointerAATree:TAATreeNode;

    PointerBottom,PointerTop:pointer;

    LockCounter:ptruint;

    Notice:string='BGCMM -  BeRo Garbage Collector Memory Manager - Copyright (C) 2010, Benjamin ''BeRo'' Rosseaux - http://www.rosseaux.net/ - benjamin@rosseaux.com ';
          
function PointerXor(p:pointer):pointer;
begin
 ptruint(result):=ptruint(p) xor PointerXorValue;
end;

function PointerValueXor(p:ptruint):ptruint;
begin
 result:=p xor PointerXorValue;
end;

function HashPointer(p:pointer):ptruint;
begin
 result:=((ptruint(p) shr HashShift[ptruint(p) and $fff]) or (ptruint(p) shl (POINTER_BITS-HashShift[ptruint(p) and $fff]))) and $ffff;
end;

function LocalGetMem(Size:ptruint):pointer;
begin
 result:=OldMemoryManager.GetMem(Size);
end;

function LocalFreeMem(p:pointer):ptruint;
begin
 result:=OldMemoryManager.FreeMem(p);
end;

function LocalReallocMem(p:pointer;Size:ptruint):pointer;
begin
 result:=OldMemoryManager.ReallocMem(p,Size);
end;

procedure InitLocalCriticalSection(var LocalCriticalSection:TRTLCriticalSection);
begin
{$ifdef fpc}
 InitCriticalSection(LocalCriticalSection);
{$else}
 InitializeCriticalSection(LocalCriticalSection);
{$endif}
end;

procedure DoneLocalCriticalSection(var LocalCriticalSection:TRTLCriticalSection);
begin
{$ifdef fpc}
 DoneCriticalSection(LocalCriticalSection);
{$else}
 DeleteCriticalSection(LocalCriticalSection);
{$endif}
end;

procedure AATreeClearNode(Root:PAATreeNode;var Node:PAATreeNode);
begin
 if assigned(Node) then begin
  AATreeClearNode(Root,Node^.Left);
  AATreeClearNode(Root,Node^.Right);
  if Node<>Root then begin
   LocalFreeMem(Node);
   Node:=nil;
  end;
 end;
end;

procedure AATreeInit(Root:PAATreeNode);
begin
 fillchar(Root^,sizeof(TAATreeNode),#0);
 Root^.Level:={$ifdef cpu64}$7fffffffffffffff{$else}$7fffffff{$endif};
end;

procedure AATreeDone(Root:PAATreeNode);
begin
 AATreeClearNode(Root,Root);
 Root^.Level:={$ifdef cpu64}$7fffffffffffffff{$else}$7fffffff{$endif};
end;

function AATreeFirst(Root:PAATreeNode):PAATreeNode;
begin
 if assigned(Root^.Left) then begin
  result:=Root;
  while assigned(result^.Left) do begin
   result:=result^.Left;
  end;
 end else begin
  result:=nil;
 end;
end;

function AATreeNext(Root,n:PAATreeNode):PAATreeNode;
begin
 if assigned(n^.Right) then begin
  result:=n^.Right;
  while assigned(result^.Left) do begin
   result:=result^.Left;
  end;
 end else begin
  while assigned(n^.Parent) and (n^.Parent^.Right=n) do begin
   n:=n^.Parent;
  end;
  n:=n^.Parent;
  if assigned(n^.Parent) then begin
   result:=n;
  end else begin
   result:=nil;
  end;
 end;
end;

procedure AATreeSkew(Root,OldParent:PAATreeNode);
var NewParent:PAATreeNode;
begin
 Assert(assigned(OldParent));
 NewParent:=OldParent^.Left;
 Assert(assigned(NewParent));
 if OldParent^.Parent^.Left=OldParent then begin
  OldParent^.Parent^.Left:=NewParent;
 end else begin
  OldParent^.Parent^.Right:=NewParent;
 end;
 NewParent^.Parent:=OldParent^.Parent;
 OldParent^.Parent:=NewParent;

 OldParent^.Left:=NewParent^.Right;
 if assigned(OldParent^.Left) then begin
  OldParent^.Left^.Parent:=OldParent;
 end;
 NewParent^.Right:=OldParent;

 if assigned(OldParent^.Left) then begin
  OldParent^.Level:=OldParent^.Left^.Level+1;
 end else begin
  OldParent^.Level:=1;
 end;
end;

function AATreeSplit(Root,OldParent:PAATreeNode):boolean;
var NewParent:PAATreeNode;
begin
 Assert(assigned(OldParent));
 NewParent:=OldParent^.Right;
 if assigned(NewParent) and assigned(NewParent^.Right) and (NewParent^.Right^.Level=OldParent^.Level) then begin
  if OldParent^.Parent^.Left=OldParent then begin
   OldParent^.Parent^.Left:=NewParent;
  end else begin
   OldParent^.Parent^.Right:=NewParent;
  end;
  NewParent^.Parent:=OldParent^.Parent;
  OldParent^.Parent:=NewParent;

  OldParent^.Right:=NewParent^.Left;
  if assigned(OldParent^.Right) then begin
   OldParent^.Right^.Parent:=OldParent;
  end;
  NewParent^.Left:=OldParent;

  NewParent^.Level:=OldParent^.Level+1;

  result:=true;
 end else begin
  result:=false;
 end;
end;

procedure AATreeRebalanceAfterLeafAdd(Root,n:PAATreeNode);
begin
 // n is a node that has just been inserted and is now a Leaf node.
 n^.Level:=1;
 n^.Left:=nil;
 n^.Right:=nil;
 n:=n^.Parent;
 while n<>Root do begin
  if (assigned(n^.Left) and (n^.Level<>(n^.Left^.Level+1))) or ((not assigned(n^.Left)) and (n^.Level<>1)) then begin
   // this point the tree is correct, except (AA2) for n^.Parent
   AATreeSkew(Root,n);
   // We handle it (a Left add) by changing it into a Right add using Skew
   // If the original add was to the Left side of a node that is on the
   // Right side of a horisontal link, n now points to the rights side
   // of the second horisontal link, which is correct.
   // However if the original add was to the Left of node with a horisontal
   // link, we must get to the Right side of the second link. 
   if (not assigned(n^.Right)) or (n^.Level<>n^.Right^.Level) then begin
    n:=n^.Parent;
   end;
  end;
  if not AATreeSplit(Root,n^.Parent) then begin
   break;
  end;
  n:=n^.Parent;
 end;
end;

function AATreeFindNode(Root:PAATreeNode;Key:ptruint):PAATreeNode;
var n:PAATreeNode;
begin
 result:=nil;
 n:=Root^.Left;
 while assigned(n) do begin
  if Key=PointerValueXor(n^.Key) then begin
   result:=n;
   break;
  end else if Key<PointerValueXor(n^.Key) then begin
   n:=n^.Left;
  end else begin
   n:=n^.Right;
  end;
 end;
 Key:=0;
 if Key<>0 then begin
 end;
end;

function AATreeFindSmallerOrEqualNode(Root:PAATreeNode;Key:ptruint):PAATreeNode;
var n:PAATreeNode;
begin
 result:=nil;
 n:=Root^.Left;
 while assigned(n) do begin
  if Key=PointerValueXor(n^.Key) then begin
   result:=n;
   break;
  end else if Key<PointerValueXor(n^.Key) then begin
   n:=n^.Left;
  end else begin
   result:=n;
   n:=n^.Right;
  end;
 end;
 Key:=0;
 if Key<>0 then begin
 end;
end;

function AATreeFindBiggerOrEqualNode(Root:PAATreeNode;Key:ptruint):PAATreeNode;
var n:PAATreeNode;
begin
 result:=nil;
 n:=Root^.Left;
 while assigned(n) do begin
  if Key=PointerValueXor(n^.Key) then begin
   result:=n;
   break;
  end else if Key<PointerValueXor(n^.Key) then begin
   result:=n;
   n:=n^.Left;
  end else begin
   n:=n^.Right;
  end;
 end;
 Key:=0;
 if Key<>0 then begin
 end;
end;

procedure AATreeInsertNode(Root:PAATreeNode;Key:ptruint;PointerItem:PPointerItem);
var n,s:PAATreeNode;
    LessThan:boolean;
begin
 if assigned(AATreeFindNode(Root,Key)) then begin
  Key:=0;
  if Key<>0 then begin
  end;
  exit;
 end;
 n:=LocalGetMem(sizeof(TAATreeNode));
 fillchar(n^,sizeof(TAATreeNode),#0);
 n^.Key:=PointerValueXor(Key);
 n^.PointerItem:=PointerItem;
 s:=Root;
 LessThan:=true;
 while (LessThan and assigned(s^.Left)) or ((not LessThan) and assigned(s^.Right)) do begin
  if LessThan then begin
   s:=s^.Left;
  end else begin
   s:=s^.Right;
  end;
  LessThan:=Key<PointerValueXor(s^.Key);
 end;
 if LessThan then begin
  s^.Left:=n;
 end else begin
  s^.Right:=n;
 end;
 n^.Parent:=s;
 AATreeRebalanceAfterLeafAdd(Root,n);
 Key:=0;
 if Key<>0 then begin
 end;
end;

procedure AATreeDeleteNodeEx(Root,n:PAATreeNode);
var Leaf,Temp:PAATreeNode;
begin
 // If n is not a Leaf, we first swap it out with the Leaf node that just
 // precedes it.
 Leaf:=n;
 if assigned(n^.Left) then begin
  Leaf:=n^.Left;
  while assigned(Leaf^.Right) do begin
   Leaf:=Leaf^.Right;
  end;
 end else if assigned(n^.Right) then begin
  Leaf:=n^.Right;
 end;

 if Leaf^.Parent=n then begin
  Temp:=Leaf;
 end else begin
  Temp:=Leaf^.Parent;
 end;
 if Leaf^.Parent^.Left=Leaf then begin
  Leaf^.Parent^.Left:=nil;
 end else begin
  Leaf^.Parent^.Right:=nil;
 end;

 if n<>Leaf then begin
  if n^.Parent^.Left=n then begin
   n^.Parent^.Left:=Leaf;
  end else begin
   n^.Parent^.Right:=Leaf;
  end;
  Leaf^.Parent:=n^.Parent;
  if assigned(n^.Left) then begin
   n^.Left^.Parent:=Leaf;
  end;
  Leaf^.Left:=n^.Left;
  if assigned(n^.Right) then begin
   n^.Right^.Parent:=Leaf;
  end;
  Leaf^.Right:=n^.Right;
  Leaf^.Level:=n^.Level;
 end;
 if n<>Root then begin
  LocalFreeMem(n);
 end;

 while Temp<>Root do begin
  if (assigned(Temp^.Left) and (Temp^.Level>(Temp^.Left^.Level+1))) or ((not assigned(Temp^.Left)) and (Temp^.Level>1)) then begin
   dec(Temp^.Level);
   if AATreeSplit(Root,Temp) then begin
    if AATreeSplit(Root,Temp) then begin
     AATreeSkew(Root,Temp^.Parent^.Parent);
    end;
    break;
   end;
   Temp:=Temp^.Parent;
  end else if (assigned(Temp^.Right) and (Temp^.Level<=(Temp^.Right^.Level+1))) or ((not assigned(Temp^.Right)) and (Temp^.Level<=1)) then begin
   break;
  end else begin
   AATreeSkew(Root,Temp);
{  if assigned(Temp^.Right) then begin
    if assigned(Temp^.Right^.Left) then begin
     Temp^.Right^.Level:=Temp^.Right^.Level+1;
    end else begin
     Temp^.Right^.Level:=1;
    end;
   end;}
   if Temp^.Level>Temp^.Parent^.Level then begin
    AATreeSkew(Root,Temp);
    AATreeSplit(Root,Temp^.Parent^.Parent);
    break;
   end;
   Temp:=Temp^.Parent^.Parent;
  end;
 end;
end;

procedure AATreeDeleteNode(Root:PAATreeNode;Key:ptruint);
var n:PAATreeNode;
begin
 n:=Root^.Left;
 while assigned(n) do begin
  if Key=PointerValueXor(n^.Key) then begin
   AATreeDeleteNodeEx(Root,n);
   break;
  end else if Key<PointerValueXor(n^.Key) then begin
   n:=n^.Left;
  end else begin
   n:=n^.Right;
  end;
 end;
 Key:=0;
 if Key<>0 then begin
 end;
end;

function PointerListCreate:PPointerList;
begin
 result:=LocalGetMem(sizeof(TPointerList));
 result^.First:=nil;
 result^.Last:=nil;
end;

procedure PointerListDestroy(List:PPointerList);
var p,np:PPointerItem;
begin
 p:=List^.First;
 while assigned(p) do begin
  np:=p^.Next;
  LocalFreeMem(p);
  p:=np;
 end;
 List^.First:=nil;
 List^.Last:=nil;
 LocalFreeMem(List);
end;

procedure PointerListRemove(List:PPointerList;PointerItem:PPointerItem);
begin
 if PointerItem^.List=List then begin
  if assigned(PointerItem^.ListPrevious) then begin
   PointerItem^.ListPrevious^.ListNext:=PointerItem^.ListNext;
  end else if List^.First=PointerItem then begin
   List^.First:=PointerItem^.ListNext;
  end;
  if assigned(PointerItem^.ListNext) then begin
   PointerItem^.ListNext^.ListPrevious:=PointerItem^.ListPrevious;
  end else if List^.Last=PointerItem then begin
   List^.Last:=PointerItem^.ListPrevious;
  end;
  PointerItem^.ListPrevious:=nil;
  PointerItem^.ListNext:=nil;
  PointerItem^.List:=nil;
 end;
end;

procedure PointerListAdd(List:PPointerList;PointerItem:PPointerItem);
begin
 if assigned(PointerItem^.List) then begin
  PointerListRemove(PointerItem^.List,PointerItem);
 end;
 PointerItem^.List:=List;
 if assigned(List^.Last) then begin
  List^.Last^.ListNext:=PointerItem;
  PointerItem^.ListPrevious:=List^.Last;
  List^.Last:=PointerItem;
 end else begin
  List^.First:=PointerItem;
  List^.Last:=PointerItem;
 end;
end;

procedure PointerAdd(p:pointer;Size:ptruint);
var PointerItem:PPointerItem;
    Hash:longword;
begin
 if ptruint(p)<ptruint(PointerXor(PointerBottom)) then begin
  PointerBottom:=PointerXor(p);
 end;
 if ptruint(p)>ptruint(PointerXor(PointerTop)) then begin
  PointerTop:=PointerXor(p);
 end;
 Hash:=HashPointer(p);
 PointerItem:=LocalGetMem(sizeof(TPointerItem));
 fillchar(PointerItem^,sizeof(TPointerItem),#0);
 PointerItem^.Hash:=Hash;
 PointerItem^.Ptr:=PointerXor(p);
 PointerItem^.Size:=Size;
 PointerItem^.Finalizer:=nil;
 PointerItem^.FinalizerData:=nil;
 if assigned(LastPointerItem) then begin
  LastPointerItem^.Next:=PointerItem;
  PointerItem^.Previous:=LastPointerItem;
  LastPointerItem:=PointerItem;
 end else begin
  FirstPointerItem:=PointerItem;
  LastPointerItem:=PointerItem;
 end;
 inc(CountPointers);
 if assigned(HashBuckets[Hash].Last) then begin
  HashBuckets[Hash].Last^.HashNext:=PointerItem;
  PointerItem^.HashPrevious:=HashBuckets[Hash].Last;
  HashBuckets[Hash].Last:=PointerItem;
 end else begin
  HashBuckets[Hash].First:=PointerItem;
  HashBuckets[Hash].Last:=PointerItem;
  inc(CountHashBuckets);
 end;
 UseHashTableForSearching:=CountPointers<(CountHashBuckets*BGCMMMaxItemsPerHashBucket);
 AATreeInsertNode(@PointerAATree,ptruint(PointerXor(PointerItem^.Ptr)),PointerItem);
 if BGCMMGrayAll then begin
  PointerListAdd(GrayList,PointerItem);
 end;
end;

function PointerFind(p:pointer):PPointerItem;
var Hash:longword;
    n:PAATreeNode;
begin
 result:=nil;
 if (ptruint(p)>=ptruint(PointerXor(PointerBottom))) and (ptruint(p)<=ptruint(PointerXor(PointerTop))) then begin
  if UseHashTableForSearching then begin
   Hash:=HashPointer(p);
   result:=HashBuckets[Hash].First;
   while assigned(result) and (PointerXor(result^.Ptr)<>p) do begin
    result:=result^.HashNext;
   end;
  end;
  if not assigned(result) then begin
   n:=AATreeFindSmallerOrEqualNode(@PointerAATree,ptruint(p));
   if assigned(n) and assigned(n^.PointerItem) then begin
    if (ptruint(PointerXor(n^.PointerItem^.Ptr))<=ptruint(p)) and ((ptruint(PointerXor(n^.PointerItem^.Ptr))+n^.PointerItem^.Size)>ptruint(p)) then begin
     result:=n^.PointerItem;
    end;
   end;
  end;
 end;
end;

procedure PointerRemove(p:pointer);
var PointerItem:PPointerItem;
begin
 PointerItem:=PointerFind(p);
 if assigned(PointerItem) then begin
  dec(CountPointers);
  if State<>sINIT then begin
   case State of
    sMARKROOTS:begin
     if CurrentPointerItem=PointerItem then begin
      CurrentPointerItem:=PointerItem^.ListNext;
     end;
    end;
    sFINALIZEWHITES:begin
     if NextPointerItem=PointerItem then begin
      NextPointerItem:=PointerItem^.ListNext;
     end;
     if CurrentPointerItem=PointerItem then begin
      CurrentPointerItem:=PointerItem^.ListNext;
     end;
    end;
   end;
  end;
  AATreeDeleteNode(@PointerAATree,ptruint(PointerXor(PointerItem^.Ptr)));
  if assigned(PointerItem^.List) then begin
   PointerListRemove(PointerItem^.List,PointerItem);
  end;
  if assigned(PointerItem^.HashPrevious) then begin
   PointerItem^.HashPrevious^.HashNext:=PointerItem^.HashNext;
  end else if HashBuckets[PointerItem^.Hash and $ffff].First=PointerItem then begin
   HashBuckets[PointerItem^.Hash and $ffff].First:=PointerItem^.HashNext;
  end;
  if assigned(PointerItem^.HashNext) then begin
   PointerItem^.HashNext^.HashPrevious:=PointerItem^.HashPrevious;
  end else if HashBuckets[PointerItem^.Hash and $ffff].Last=PointerItem then begin
   HashBuckets[PointerItem^.Hash and $ffff].Last:=PointerItem^.HashPrevious;
   if not assigned(HashBuckets[PointerItem^.Hash and $ffff].Last) then begin
    dec(CountHashBuckets);
   end;
  end;
  if assigned(PointerItem^.Previous) then begin
   PointerItem^.Previous^.Next:=PointerItem^.Next;
  end else if FirstPointerItem=PointerItem then begin
   FirstPointerItem:=PointerItem.Next;
  end;
  if assigned(PointerItem^.Next) then begin
   PointerItem^.Next^.Previous:=PointerItem^.Previous;
  end else if LastPointerItem=PointerItem then begin
   LastPointerItem:=PointerItem^.Previous;
  end;
  fillchar(PointerItem^,sizeof(TPointerItem),#0);
  LocalFreeMem(PointerItem);
  UseHashTableForSearching:=CountPointers<(CountHashBuckets*BGCMMMaxItemsPerHashBucket);
 end;
end;

procedure MarkPointer(p:pointer);
var PointerItem:PPointerItem;
begin
 if assigned(p) then begin
  PointerItem:=PointerFind(p);
  if assigned(PointerItem) then begin
   if assigned(PointerItem^.List) then begin
    if PointerItem^.List=WhiteList then begin
     PointerListAdd(GrayList,PointerItem);
    end;
   end else begin
    PointerListAdd(ScanList,PointerItem);
   end;
  end;
 end;
end;

procedure Mark(Bottom,Top:pointer);
var p1,p2:pointer;
begin
 p1:=Bottom;
 p2:=Top;
 while ptruint(p1)<=(ptruint(p2)-sizeof(ptruint)) do begin
  MarkPointer(pointer(p1^));
  inc(ptruint(p1));
 end;
end;

function Collect:boolean;
const RegCount={$ifdef cpuamd64}16{$else}{$ifdef cpu386}8{$else}0{$endif}{$endif};
var PointerItem:PPointerItem;
    TempList:PPointerList;
    i:integer;
    p:pointer;
begin
 result:=false;
 EnterCriticalSection(LocalCriticalSection);
 if LockCounter=0 then begin
  while true do begin
   case State of
    sINIT:begin
{$ifdef cpuamd64}
     asm
      mov qword ptr [Registers+0],rax
      mov qword ptr [Registers+1],rbx
      mov qword ptr [Registers+2],rcx
      mov qword ptr [Registers+3],rdx
      mov qword ptr [Registers+4],rsi
      mov qword ptr [Registers+5],rdi
      mov qword ptr [Registers+6],rsp
      mov qword ptr [Registers+7],rbp
      mov qword ptr [Registers+8],r8
      mov qword ptr [Registers+9],r9
      mov qword ptr [Registers+10],r10
      mov qword ptr [Registers+11],r11
      mov qword ptr [Registers+12],r12
      mov qword ptr [Registers+13],r13
      mov qword ptr [Registers+14],r14
      mov qword ptr [Registers+15],r15
{$ifndef fpc}
      mov qword ptr StackTop,rsp
{$endif}
     end;
{$endif}
{$ifdef cpu386}
     asm
      mov dword ptr [Registers+0],eax
      mov dword ptr [Registers+1],ebx
      mov dword ptr [Registers+2],ecx
      mov dword ptr [Registers+3],edx
      mov dword ptr [Registers+4],esi
      mov dword ptr [Registers+5],edi
      mov dword ptr [Registers+6],esp
      mov dword ptr [Registers+7],ebp
{$ifndef fpc}
      mov dword ptr StackTop,esp
{$endif}
     end;
{$endif}
{$ifdef registers}
     for i:=0 to RegCount-1 do begin
      if Registers[i]<>0 then begin
       MarkPointer(pointer(Registers[i]));
      end;
     end;
{$endif}
{$ifdef stack}
     Mark(StackBottom,StackTop);
{$endif}
     CurrentPointerItem:=RootList.First;
     CurrentRange:=Ranges;
     State:=sMARKROOTRANGES;
    end;
    sMARKROOTRANGES:begin
     for i:=1 to BGCMMMarkCount do begin
      if not assigned(CurrentRange) then begin
       State:=sMARKROOTS;
       break;
      end;
      Mark(PointerXor(CurrentRange^.Bottom),PointerXor(CurrentRange^.Top));
      CurrentRange:=CurrentRange^.Next;
     end;
     if assigned(CurrentRange) then begin
      result:=true;
      break;
     end;
    end;
    sMARKROOTS:begin
     for i:=1 to BGCMMMarkCount do begin
      if not assigned(CurrentPointerItem) then begin
       State:=sMARKGRAYS;
       break;
      end;
      Mark(PointerXor(CurrentPointerItem^.Ptr),@pansichar(PointerXor(CurrentPointerItem^.Ptr))[CurrentPointerItem^.Size]);
      CurrentPointerItem:=CurrentPointerItem^.ListNext;
     end;
     if assigned(CurrentPointerItem) then begin
      result:=true;
      break;
     end;
    end;
    sMARKGRAYS:begin
     for i:=1 to BGCMMMarkCount do begin
      PointerItem:=ScanList.Last;
      if assigned(PointerItem) then begin
       PointerListAdd(AlreadyScannedList,PointerItem);
       Mark(PointerXor(PointerItem^.Ptr),@pansichar(PointerXor(PointerItem^.Ptr))[PointerItem^.Size]);
       continue;
      end;

      PointerItem:=GrayList.Last;
      if assigned(PointerItem) then begin
       PointerListAdd(BlackList,PointerItem);
       Mark(PointerXor(PointerItem^.Ptr),@pansichar(PointerXor(PointerItem^.Ptr))[PointerItem^.Size]);
       continue;
      end;

      State:=sFINALIZEWHITES;
      CurrentPointerItem:=WhiteList.First;
      break;
     end;
     if assigned(ScanList.Last) or assigned(GrayList.Last) then begin
      result:=true;
      break;
     end;
    end;
    sFINALIZEWHITES:begin
     for i:=1 to BGCMMFinalizeCount do begin
      if not assigned(CurrentPointerItem) then begin
       State:=sSWEEPWHITES;
       break;
      end;
      NextPointerItem:=CurrentPointerItem^.ListNext;
      if assigned(CurrentPointerItem^.Finalizer) then begin
       CurrentPointerItem^.Finalizer(PointerXor(CurrentPointerItem^.Ptr),CurrentPointerItem^.Size,CurrentPointerItem^.FinalizerData);
      end;
      CurrentPointerItem:=NextPointerItem;
     end;
     if assigned(CurrentPointerItem) then begin
      result:=true;
      break;
     end;
    end;
    sSWEEPWHITES:begin
     for i:=1 to BGCMMSweepCount do begin
      PointerItem:=WhiteList.First;
      if not assigned(PointerItem) then begin
       State:=sCLEANUP;
       break;
      end;
      p:=PointerXor(PointerItem^.Ptr);
      fillchar(p^,PointerItem^.Size,#0);
      PointerRemove(p);
      LocalFreemem(p);
     end;
     if assigned(WhiteList.Last) then begin
      result:=true;
      break;
     end;
    end;
    sCLEANUP:begin
     for i:=1 to BGCMMCleanUpCount do begin
      if assigned(AlreadyScannedList.First) and (AlreadyScannedList.First.List=AlreadyScannedList) then begin
       PointerListRemove(AlreadyScannedList,AlreadyScannedList.First);
      end else begin
       State:=sDONE;
       break;
      end;
     end;
     if assigned(AlreadyScannedList.First) and (AlreadyScannedList.First.List=AlreadyScannedList) then begin
      result:=true;
      break;
     end;
    end;
    sDONE:begin
     TempList:=WhiteList;
     WhiteList:=BlackList;
     BlackList:=TempList;
     State:=sINIT;
     result:=false;
     break;
    end;
   end;
  end;
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure FullCollect;
begin
 while Collect do begin
 end;
end;

{$ifdef fpc}
function BGCMMGetMem(Size:ptruint):pointer;
begin
 EnterCriticalSection(LocalCriticalSection);
 inc(AllocCounter);
 if AllocCounter>=BGCMMMaxAllocsPerCollect then begin
  AllocCounter:=0;
  if BGCMMUseFullCollects then begin
   FullCollect;
  end else begin
   Collect;
  end;
 end;
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.GetMem(Size);
 EnterCriticalSection(LocalCriticalSection);
 PointerAdd(result,Size);
 LeaveCriticalSection(LocalCriticalSection);
end;

function BGCMMFreeMem(p:pointer):ptruint;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerRemove(p);
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.FreeMem(p);
end;

function BGCMMFreeMemSize(p:pointer;Size:ptruint):ptruint;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerRemove(p);
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.FreeMemSize(p,Size);
end;

function BGCMMAllocMem(size:ptruint):pointer;
begin
 EnterCriticalSection(LocalCriticalSection);
 inc(AllocCounter);
 if AllocCounter>=BGCMMMaxAllocsPerCollect then begin
  AllocCounter:=0;
  if BGCMMUseFullCollects then begin
   FullCollect;
  end else begin
   Collect;
  end;
 end;
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.AllocMem(Size);
 EnterCriticalSection(LocalCriticalSection);
 PointerAdd(result,Size);
 LeaveCriticalSection(LocalCriticalSection);
end;

function BGCMMReallocMem(var p:pointer;size:ptruint):pointer;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerRemove(p);
 result:=OldMemoryManager.ReallocMem(p,Size);
 PointerAdd(result,Size);
 LeaveCriticalSection(LocalCriticalSection);
end;

function BGCMMMemSize(p:pointer):ptruint;
begin
 result:=OldMemoryManager.MemSize(p);
end;

procedure BGCMMInitThread;
begin
 if assigned(OldMemoryManager.InitThread) then begin
  OldMemoryManager.InitThread;
 end;
end;

procedure BGCMMDoneThread;
begin
 if assigned(OldMemoryManager.DoneThread) then begin
  OldMemoryManager.DoneThread;
 end;
end;

procedure BGCMMRelocateHeap;
begin
 if assigned(OldMemoryManager.RelocateHeap) then begin
  OldMemoryManager.RelocateHeap;
 end;
end;

function BGCMMGetHeapStatus:THeapStatus;
begin
 result:=OldMemoryManager.GetHeapStatus;
end;

function BGCMMGetFPCHeapStatus:TFPCHeapStatus;
begin
 result:=OldMemoryManager.GetFPCHeapStatus;
end;
{$else}      
function BGCMMGetMem(Size:integer):pointer;
begin
 EnterCriticalSection(LocalCriticalSection);
 inc(AllocCounter);
 if AllocCounter>=BGCMMMaxAllocsPerCollect then begin
  AllocCounter:=0;
  if BGCMMUseFullCollects then begin
   FullCollect;
  end else begin
   Collect;
  end;
 end;
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.GetMem(Size);
 EnterCriticalSection(LocalCriticalSection);
 PointerAdd(result,Size);
 LeaveCriticalSection(LocalCriticalSection);
end;

function BGCMMFreeMem(p:pointer):integer;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerRemove(p);
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.FreeMem(p);
end;

function BGCMMReallocMem(p:pointer;Size:integer):pointer;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerRemove(p);
 result:=OldMemoryManager.ReallocMem(p,Size);
 PointerAdd(result,Size);
 LeaveCriticalSection(LocalCriticalSection);
end;

{$ifdef BDS2006AndUp}
function BGCMMAllocMem(ASize:cardinal):pointer;
begin
 EnterCriticalSection(LocalCriticalSection);
 inc(AllocCounter);
 if AllocCounter>=BGCMMaxAllocsPerCollect then begin
  AllocCounter:=0;
  if BGCMMUseFullCollects then begin
   FullCollect;
  end else begin
   Collect;
  end;
 end;
 LeaveCriticalSection(LocalCriticalSection);
 result:=OldMemoryManager.AllocMem(Size);
 EnterCriticalSection(LocalCriticalSection);
 PointerAdd(result,Size);
 LeaveCriticalSection(LocalCriticalSection);
end;

function BGCMMRegisterExpectedMemoryLeak(APointer:pointer):boolean;
begin
 result:=OldMemoryManager.RegisterExpectedMemoryLeak(Size);
end;

function BGCMMRUnregisterExpectedMemoryLeak(APointer:pointer):boolean;
begin
 result:=OldMemoryManager.UnregisterExpectedMemoryLeak(Size);
end;
{$endif}
{$endif}

function BGCMMCollect:boolean;
begin
 result:=Collect;
end;

procedure BGCMMFullCollect;
begin
 FullCollect;
end;

procedure BGCMMLock;
begin
 EnterCriticalSection(LocalCriticalSection);
 inc(LockCounter);
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMUnlock;
begin
 EnterCriticalSection(LocalCriticalSection);
 if LockCounter>0 then begin
  dec(LockCounter);
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMSetFinalizer(p:pointer;const Finalizer:TBGCMMFinalizer;FinalizerData:pointer);
var PointerItem:PPointerItem;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerItem:=PointerFind(p);
 if assigned(PointerItem) then begin
  PointerItem^.Finalizer:=Finalizer;
  PointerItem^.FinalizerData:=FinalizerData;
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMAdd(p:pointer);
var PointerItem:PPointerItem;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerItem:=PointerFind(p);
 if assigned(PointerItem) then begin
  PointerListAdd(GrayList,PointerItem);
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMRemove(p:pointer);
var PointerItem:PPointerItem;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerItem:=PointerFind(p);
 if assigned(PointerItem) and assigned(PointerItem^.List) then begin
  PointerListRemove(PointerItem^.List,PointerItem);
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMAddRoot(p:pointer);
var PointerItem:PPointerItem;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerItem:=PointerFind(p);
 if assigned(PointerItem) then begin
  PointerListAdd(RootList,PointerItem);
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMAddRootRange(Bottom,Top:pointer);
var Range:PRange;
begin
 EnterCriticalSection(LocalCriticalSection);
 Range:=LocalGetMem(sizeof(TRange));
 Range^.Next:=Ranges;
 Ranges:=Range;
 Range^.Bottom:=PointerXor(Bottom);
 Range^.Top:=PointerXor(Top);
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure BGCMMUse(p:pointer);
var PointerItem:PPointerItem;
begin
 EnterCriticalSection(LocalCriticalSection);
 PointerItem:=PointerFind(p);
 if assigned(PointerItem) then begin
  if (PointerItem^.List=WhiteList) and (State>=sFINALIZEWHITES) then begin
   State:=sINIT;
  end;
  PointerListAdd(GrayList,PointerItem);
 end;
 LeaveCriticalSection(LocalCriticalSection);
end;

procedure InitMemoryManager;
var i:integer;
begin
 if length(Notice)<>0 then begin
 end;
 BGCMMGrayAll:=false;
 BGCMMMarkCount:=128;
 BGCMMFinalizeCount:=128;
 BGCMMSweepCount:=128;
 BGCMMCleanUpCount:=128;
 BGCMMMaxAllocsPerCollect:=16;
 BGCMMMaxItemsPerHashBucket:=5;
 BGCMMUseFullCollects:=false;
 AllocCounter:=0;
 CountPointers:=0;
 CountHashBuckets:=0;
 UseHashTableForSearching:=true;
 LockCounter:=0;
 GetMemoryManager(OldMemoryManager);
 SetMemoryManager(NewMemoryManager);
 InitLocalCriticalSection(LocalCriticalSection);
 Ranges:=nil;
 State:=sINIT;
 WhiteList:=PointerListCreate;
 GrayList:=PointerListCreate;
 BlackList:=PointerListCreate;
 RootList:=PointerListCreate;
 ScanList:=PointerListCreate;
 AlreadyScannedList:=PointerListCreate;
 FirstPointerItem:=nil;
 LastPointerItem:=nil;
 PointerTop:=PointerXor(nil);
 PointerBottom:=PointerXor(pointer(ptruint(not ptruint(PointerXor(PointerTop)))));
 AATreeInit(@PointerAATree);
{$ifdef registers}
 fillchar(Registers,sizeof(TRegisters),#0);
{$endif}
 fillchar(HashBuckets,sizeof(TPointerHashBuckets),#0);
 for i:=0 to $fff do begin
  if (i and $fff)=0 then begin
   HashShift[i]:=12;
  end else if (i and $7ff)=0 then begin
   HashShift[i]:=11;
  end else if (i and $3ff)=0 then begin
   HashShift[i]:=10;
  end else if (i and $1ff)=0 then begin
   HashShift[i]:=9;
  end else if (i and $ff)=0 then begin
   HashShift[i]:=8;
  end else if (i and $7f)=0 then begin
   HashShift[i]:=7;
  end else if (i and $3f)=0 then begin
   HashShift[i]:=6;
  end else if (i and $1f)=0 then begin
   HashShift[i]:=5;
  end else if (i and $f)=0 then begin
   HashShift[i]:=4;
  end else if (i and $7)=0 then begin
   HashShift[i]:=3;
  end else if (i and $3)=0 then begin
   HashShift[i]:=2;
  end else if (i and $1)=0 then begin
   HashShift[i]:=1;
  end else begin
   HashShift[i]:=0;
  end;
 end;
end;

procedure DoneMemoryManager;
var PointerItem,NextPointerItem:PPointerItem;
    Range:PRange;
begin
 while assigned(Ranges) do begin
  Range:=Ranges;
  Ranges:=Ranges^.Next;
  LocalFreeMem(Range);
 end;
 PointerItem:=FirstPointerItem;
 while assigned(PointerItem) do begin
  NextPointerItem:=PointerItem^.Next;
  PointerItem^.Ptr:=PointerXor(PointerItem^.Ptr);
  if assigned(PointerItem^.Ptr) then begin
   LocalFreeMem(PointerItem^.Ptr);
   PointerItem^.Ptr:=nil;
  end;
  LocalFreeMem(PointerItem);
  PointerItem:=NextPointerItem;
 end;
 AATreeDone(@PointerAATree);
 FirstPointerItem:=nil;
 LastPointerItem:=nil;
 PointerListDestroy(WhiteList);
 PointerListDestroy(GrayList);
 PointerListDestroy(BlackList);
 PointerListDestroy(RootList);
 PointerListDestroy(ScanList);
 PointerListDestroy(AlreadyScannedList);
 DoneLocalCriticalSection(LocalCriticalSection);
 SetMemoryManager(OldMemoryManager);
End;

initialization
 InitMemoryManager;
{$ifndef fpc}
{$ifdef cpuamd64}
 asm
  mov qword ptr StackBottom,rsp
 end;
{$endif}
{$ifdef cpu386}
 asm
  mov dword ptr StackBottom,esp
 end;
{$endif}
{$endif}
finalization
{$ifndef NeverUninstall}
 DoneMemoryManager;
{$endif}
end.

BGCMMTest.dpr

program BGCMMTest;
{$ifdef fpc}
 {$mode delphi}
{$endif}
{$ifdef win32}
 {$apptype console}
{$endif}

uses
  BGCMM{$ifdef win32},Windows{$endif};

type PMyRoot=^TMyRoot;
     TMyRoot=record
      bla:pointer;
     end;

var Count:int64;

procedure MyFinalizer(Ptr:pointer;Size:ptruint;Data:pointer);
begin
 inc(Count);
 write(#13,'Pointer killed! Count: ',Count);
end;

var p:pointer;
    MyRoot:PMyRoot;
begin
 Count:=0;
 new(MyRoot);
 BGCMMAddRoot(MyRoot);
 while true do begin
  getmem(p,4096);
  MyRoot.bla:=p;
  BGCMMAdd(p);
  BGCMMSetFinalizer(p,MyFinalizer,p);
 end;
{$ifdef win32}
 readln;
{$endif}
end.