Skip to content

Instantly share code, notes, and snippets.

@BeRo1985
Created Apr 8, 2020
Embed
What would you like to do?
A very old experimental garbage collector memory manager project for Delphi and FreePascal
//////////////////////////////////////////////////////////////////////////////////////
//
// 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.
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment