bigbrainpro.pas

内存管理程序

unit BigBrainPro;
{VERSION 2.0.4}
(*
BigBrain licensing
Comercial customers who purchased BigBrainPro from Digital Tundra LLC are
granted license to distribute unlimited quantities of COMPILED applications from
BigBrainPro.pas and to redistribute the BigBrainShareMem.dll included in the
package, so long as:
1) The source code for BigBrainPro.pas is NOT included in your product.
2) The source license is not transferred to another 3rd party.  (For example, if you
are a consultant, the company you are consulting for is responsible for their
own license)
3) The product is NOT a competing product with any Digital Tundra LLC product.

YOU MAY NOT use BigBrain.pas or BigBrainPro.pas or any files packaged
with these files as a basis for a competing memory manager or any other product
that directly competes with Digital Tundra LLC.

In the event that Digital Tundra LLC relases a competing product after you
received this license you will retain all rights mentioned in this agreement.
*)
{$O+}               //Force compiler optimization on
{$D-}               //Force debug information off ... if set to +, your code
                    // will be harder to debug
//NEW! TWEAKABLES!
//Please note that NOT all conditional defines defined within this unit will
//yield stable results.  Please use care when changing these settings.
//Defines beginining with "$DEFINE" are enabled... "xDEFINE" means disabled

{xDEFINE FREEMAN}       //Attempts to free unused block managers.
                        //Freeing block managers is potentially dangerous and
                        //not recommended for mission critical applications.
                        //if you app runs up many threads ( > 150-200) you
                        //may find that it bogs down permanently.  These problems
                        //may be eased by enabling this setting.

{$DEFINE LOCKLISTS}     //Should always be on.  If off (untested) it will
                        //behave more like the non-Pro BigBrain.  The "off" setting
                        //however has not been tested recently and there is no reason to.
{$DEFINE USELISTCLASS}  //Should always be on.  If off (untested) some classes
                        //will be compiled as records instead.  The manager was
                        //originally built with records then upgraded to classes
                        //have shown no performance difference.
{xDEFINE LOCKMAN}       //Should always be off.  If on (untested) the entire
                        //thread-memory-manager will be locked during memory
                        //operations, whereas locks on the block-lists (there
                        //are 64 block lists in the thread-memory-manager) are
                        //really all thats necessary and perform much better
{$DEFINE LESSWASTE}     //recommended ON --
                        //  [on] - Blocks are more widely distributed across
                        //  the linked lists because the header size is NOT taken
                        //  into consideration when choosing the size index.
                        //  [off] - Header is considered part as part of the payload
                        //  when choosing the size index which means that
                        //  no blocks are allocated in the smallest indexes.
                        //  and blocks are reused more often, but chance for contention
                        //  is higher.

{$IFDEF VER170}        //  "NOINLINE" must be defined for PRE-Delphi2005
{$DEFINE ALLOW_INLINE}  //  if [ON] disables use of the inline directive in Delphi
{$ENDIF}                //  2005.  Turn [ON] (for Delphi2005) only if you
                        //  experience problems.
                        //  !!Must be [ON] (NOINLINE=true) for earlier Delphi versions!!

{$IFDEF VER180}        //  "NOINLINE" must be defined for PRE-Delphi2005
{$DEFINE ALLOW_INLINE}  //  if [ON] disables use of the inline directive in Delphi
{$ENDIF}                //  2006.  Turn [ON] (for Delphi2005) only if you
                        //  experience problems.
                        //  !!Must be [ON] (NOINLINE=true) for earlier Delphi versions!!
{$IFNDEF ALLOW_INLINE}
{$DEFINE NOINLINE}
{$ENDIF}

{$DEFINE WINDOWS2000_COMPATIBLE}
                        //if you require windows 2000 compatability enable this
                        //--note using this option nulls the effect of
                        //  low-frag and high performance heaps, but BigBrain
                        //  does quite well without these features.

{xDEFINE ENABLE_ON_SINGLE_CPU}
                        //  Enables the memory manager even if the machine only
                        //  has 1 CPU.  BigBrain is designed only for multi-
                        //  processor/multi-core machines.

{xDEFINE LITEMODE}      // Don't enable this.  Disables most memory-manager
                        // operation in favor of a simple round-robin heap
                        // system.  This "Lite" mode however, can be used
                        // as an underlying layer, which is useful.

{xDEFINE USELITEASOS}   // WARNING* Requires Windows 2000 SP4 or later!
                        // Uses the above mentioned "Lite mode" to supply
                        // new blocks of memory.  This layer sits BELOW the bulk
                        // of the Big Brain functionality.  And replaces operations
                        // that were left to the Delphi standard memory maanger
                        // in version 1.0


//NOTE! Not all of these combinations are valid.  Use are your own risk.
//Some valid combinations
//  USELITEASOS+LOOK_ASIDE
//  USELITEASOS+LOOK_ASIDE+LITE_EXTERNAL_LOCKS
//  USELITEASOS+LOW_FRAG

{$DEFINE LOOK_ASIDE}    // [on] Faster than LOW_FRAG (LOW_FRAG must be disable
                        // when this is enabled).  But doesn't provide
                        // extra support for reducing memory fragmentation.
{xDEFINE LOW_FRAG}      // [on] Uses slightly slower OS Heaps that can reduce
                        // fragmentation.  You MUST disable LOOK_ASIDE
                        // when enabling this


{xDEFINE LITE_EXTERNAL_LOCKS}
                        // If [on] BigBrain manages the locks on windows heap
                        // allocations in the "Lite" layer.  If [off] the heaps
                        // are created with
                        // the OS serialization flags which are faster according
                        // to my tests.
                        // Do NOT enable this in conjunction with LOW_FRAG

{xDEFINE DISABLE_ALL}   // If [on] the memory manager will not be installed.
                        // useful for comparing against the native Borland MM.
                        // Although note that the cleanup thread will still run.

{xDEFINE EXTRA_ERR_CHECKING}
                        // RECOMMENDED OFF
                        // If enabled:
                        // Includes extra code that generally conforms to
                        // "good" programming practices, however when put in
                        // context is unnecessary and takes up CPU time.

interface


//uses CLX_Windows, Libc;
//----------------------------KERNEL--------------------------------------------
const
  MAXBIT = 31;
  LITE_HEADER_SIZE = 4;
  MANAGER_TIMEOUT = 10000;

{$IFNDEF LINUX}
  kern = 'kernel32.dll';

//  PAGE_NOACCESS  = 1;
  PAGE_READWRITE = 4;
  LMEM_FIXED = 0;
  LMEM_MOVEABLE = 2;
  LMEM_ZEROINIT = $40;
  MEM_COMMIT   = $1000;
  MEM_RESERVE  = $2000;
  MEM_DECOMMIT = $4000;
  MEM_RELEASE  = $8000;

type
  DWORD = cardinal;
  TSystemInfo = record
    case Integer of
      0: (
        dwOemId: DWORD);
      1: (
        wProcessorArchitecture: Word;
        wReserved: Word;
        dwPageSize: DWORD;
        lpMinimumApplicationAddress: Pointer;
        lpMaximumApplicationAddress: Pointer;
        dwActiveProcessorMask: DWORD;
        dwNumberOfProcessors: DWORD;
        dwProcessorType: DWORD;
        dwAllocationGranularity: DWORD;
        wProcessorLevel: Word;
        wProcessorRevision: Word);
  end;
{$ENDIF}

{$IFNDEF LINUX}
procedure GetSystemInfo(var lpSystemInfo: TSystemInfo); stdcall;
{$EXTERNALSYM GetSystemInfo}
procedure GetSystemInfo; external kern name 'GetSystemInfo';
{$ELSE}
procedure GetSystemInfo(var lpSystemInfo: TsystemInfo); stdcall;
{$ENDIF}


const
  libcmodulename = 'libc.so.6';
  libcryptmodulename = 'libcrypt.so.1';
  libdlmodulename = 'libdl.so.2';
  libmmodulename = 'libm.so.6';
  libpthreadmodulename = 'libpthread.so.0';
  libresolvmodulename = 'libresolv.so.2';
  librtmodulename = 'librt.so.1';
  libutilmodulename = 'libutil.so.1';


type
  THandle = Integer;
  BOOL  = LongBool;

  _RTL_CRITICAL_SECTION = record
    DebugInfo: Pointer;
    LockCount: Longint;
    RecursionCount: Longint;
    OwningThread: Integer;
    LockSemaphore: Integer;
    Reserved: DWORD;
  end;

  TAtomicLock = record
    lock: integer;
    handle: integer;
  end;

{$IFNDEF ATOMICLOCKS}
  TCLXCriticalSection = _RTL_CRITICAL_SECTION;
{$ELSE}

  TCLXCriticalSection = TAtomicLock;
{$ENDIF}



{$IFDEF LINUX}
{L}
{L}const
{L}  EBUSY                      = 16;        {  Device or resource busy  }
{L}  PTHREAD_MUTEX_RECURSIVE_NP = 1;
{L}  PTHREAD_MUTEX_RECURSIVE = PTHREAD_MUTEX_RECURSIVE_NP;
{L}type
{L}  _pthread_descr = Pointer;
{L}  _pthread_fastlock = {packed} record
{L}    __status: Longint;          { "Free" or "taken" or head of waiting list }
{L}    __spinlock: Integer;        { For compare-and-swap emulation }
{L}  end;
{L}  TPthreadFastlock = _pthread_fastlock;
{L}  PPthreadFastlock = ^TPthreadFastlock;
{L}
{L}  TPthreadMutex = {packed} record
{L}    __m_reserved: Integer;        { Reserved for future use }
{L}    __m_count: Integer;           { Depth of recursive locking }
{L}    __m_owner: _pthread_descr;    { Owner thread (if recursive or errcheck) }
{L}    __m_kind: Integer;            { Mutex kind: fast, recursive or errcheck }
{L}    __m_lock: _pthread_fastlock;     { Underlying fast lock }
{L}  end;
{L}
{L}  {$EXTERNALSYM TPthreadMutex}
{L}  pthread_mutex_t = TPthreadMutex;
{L}  {$EXTERNALSYM pthread_mutex_t}
{L}  TRTLCriticalSection = TPthreadMutex;
{L}  PRTLCriticalSection = ^TRTLCriticalSection;
{L}  {$EXTERNALSYM PRTLCriticalSection}
{L}
{L}{ Attribute for mutex.  }
{L}  pthread_mutexattr_t = {packed} record
{L}    __mutexkind: Integer;
{L}  end;
{L}  {$EXTERNALSYM pthread_mutexattr_t}
{L}  TMutexAttribute = pthread_mutexattr_t;
{L}  {$EXTERNALSYM TMutexAttribute}
{L}  PMutexAttribute = ^TMutexAttribute;
{L}  {$EXTERNALSYM PMutexAttribute}
{L}
{L}  __time_t = type Longint;
{L}  __useconds_t = Cardinal;
{L}  __suseconds_t = Longint;
{L}
{L}  timeval = {packed} record
{L}    tv_sec: __time_t;           { Seconds.  }
{L}    tv_usec: __suseconds_t;     { Microseconds.  }
{L}
{L}  end;
{L}
{L}  timespec = {packed} record
{L}    tv_sec: Longint;            { Seconds.  }
{L}    tv_nsec: Longint;           { Nanoseconds.  }
{L}  end;
{L}  {$EXTERNALSYM timespec}
{L}  TTimeSpec = timespec;
{L}  {$EXTERNALSYM TTimeSpec}
{L}  PTimeSpec = ^TTimeSpec;
{L}  {$EXTERNALSYM PTimeSpec}
{L}  timezone = {packed} record
{L}    tz_minuteswest: Integer;    { Minutes west of GMT.  }
{L}    tz_dsttime: Integer;        { Nonzero if DST is ever in effect.  }
{L}  end;
{L}
{L}
{L}  TTimeZone = timezone;
{L}  PTimeZone = ^TTimeZone;
{L}
{L}
{L}  TTimeVal = timeval;
{L}  PTimeVal = ^TTimeVal;
{L}
{L}
{L}{ Attributes for threads.  }
{L}  pthread_attr_t = TThreadAttr;  // TThreadAttr in System.pas
{L}  {$EXTERNALSYM pthread_attr_t}
{L}
{L}
{L}  TCLXCriticalSection = TRTLCriticalSection;
{L}
{L}
{L}
{L}//function gettimeofday(var timeval: TTimeVal; var timezone: TTimeZone): Integer; external libcmodulename name 'gettimeofday';
{L}function gettimeofday(var timeval: TTimeVal; timezone: PTimeZone): Integer; external libcmodulename name 'gettimeofday';
{L}
{L}function DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection): Integer; cdecl;
{L}function pthread_mutex_trylock(var Mutex: TRTLCriticalSection): Integer; cdecl;
{L}
{L}function pthread_mutex_init(var Mutex: TRTLCriticalSection;
{L}  var Attr: TMutexAttribute): Integer; cdecl; overload;
{L}function pthread_mutex_init(var Mutex: TRTLCriticalSection;
{L}  Attr: PMutexAttribute): Integer; cdecl; overload;
{L}function pthread_mutex_destroy(var Mutex: TRTLCriticalSection): Integer; cdecl;
{L}function pthread_mutex_timedlock(var Mutex: TRTLCriticalSection; const AbsTime: timespec): Integer; cdecl;
{L}function pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl;
{L}function pthread_mutexattr_init(var Attr: TMutexAttribute): Integer; cdecl;
{L}function pthread_mutexattr_destroy(var Attr: TMutexAttribute): Integer; cdecl;
{L}function pthread_mutexattr_getpshared(var Attr: TMutexAttribute; // Actually __const pthread_mutexattr_t *
{L}  var ProcessShared: Integer): Integer; cdecl;
{L}function pthread_mutexattr_setpshared(var Attr: TMutexAttribute;
{L}  ProcessShared: Integer): Integer; cdecl;
{L}function pthread_mutexattr_settype(var Attr: TMutexAttribute; Kind: Integer): Integer; cdecl;
{L}function pthread_mutexattr_gettype(var Attr: TMutexAttribute; var Kind: Integer): Integer; cdecl;
{L}
{L}
{L}function pthread_mutex_destroy;         external libpthreadmodulename name 'pthread_mutex_destroy';
{L}function pthread_mutex_init(var Mutex: TRTLCriticalSection; var Attr: TMutexAttribute): Integer; external libpthreadmodulename name 'pthread_mutex_init';
{L}function pthread_mutex_init(var Mutex: TRTLCriticalSection; Attr: PMutexAttribute): Integer; external libpthreadmodulename name 'pthread_mutex_init';
{L}function pthread_mutex_timedlock;       external libpthreadmodulename name 'pthread_mutex_timedlock';
{L}//function pthread_mutex_trylock;         external libpthreadmodulename name 'pthread_mutex_trylock';
{L}function pthread_mutex_unlock;          external libpthreadmodulename name 'pthread_mutex_unlock';
{L}function pthread_mutexattr_destroy;     external libpthreadmodulename name 'pthread_mutexattr_destroy';
{L}function pthread_mutexattr_getpshared;  external libpthreadmodulename name 'pthread_mutexattr_getpshared';
{L}function pthread_mutexattr_setpshared;  external libpthreadmodulename name 'pthread_mutexattr_setpshared';
{L}function pthread_mutexattr_gettype;     external libpthreadmodulename name 'pthread_mutexattr_gettype';
{L}function pthread_mutexattr_init;        external libpthreadmodulename name 'pthread_mutexattr_init';
{L}function pthread_mutexattr_settype;     external libpthreadmodulename name 'pthread_mutexattr_settype';
{L}function pthread_mutex_trylock;         external libpthreadmodulename name 'pthread_mutex_trylock';
{L}
{L}function InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection): Integer; cdecl;
{L}function EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection): Integer; cdecl;
{L}function LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection): Integer; cdecl;
{L}function TryEnterCriticalSection(var lpCriticalSection: TRTLCriticalSection): Boolean; cdecl;
{L}{$IFNDEF ATOMICLOCKS}
{L}function EnterCriticalSection;   external libcmodulename name 'pthread_mutex_lock';
{L}function LeaveCriticalSection;   external libcmodulename name 'pthread_mutex_unlock';
{L}function DeleteCriticalSection;  external libcmodulename name 'pthread_mutex_destroy';
{L}{$ENDIF}
{L}
{L}procedure pthread_exit(pexit: pointer);   external libpthreadmodulename name 'pthread_exit';
{L}procedure Beep(freq, duration: integer);
{L}function GetTickCount: Cardinal;
{L}
{L}{$ENDIF}

{$IFNDEF LINUX}
function FlushInstructionCache(hProcess: THandle; const lpBaseAddress:
  Pointer; dwSize: DWORD): BOOL; stdcall;
  external kern name 'FlushInstructionCache';
function GetCurrentProcess: THandle; stdcall;
  external kern name 'GetCurrentProcess';
function GetCurrentThreadId: integer; external kern name 'GetCurrentThreadId';

function VirtualProtect(lpAddress:pointer; dwSize, flNewProtect: DWORD;
  var lpflOldProtect:DWord):BOOL; stdcall;
  external kern name 'VirtualProtect';
{$IFNDEF ATOMICLOCKS}
procedure InitializeCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
  external kern name 'InitializeCriticalSection';
procedure EnterCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
  external kern name 'EnterCriticalSection';
function TryEnterCriticalSection(var lpCriticalSection: TCLXCriticalSection): BOOL; stdcall;
  external kern name 'TryEnterCriticalSection';
procedure LeaveCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
  external kern name 'LeaveCriticalSection';
procedure DeleteCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
  external kern name 'DeleteCriticalSection';
{$ELSE}
procedure InitializeCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
procedure EnterCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
function TryEnterCriticalSection(var lpCriticalSection: TCLXCriticalSection): BOOL; stdcall;
procedure LeaveCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;
procedure DeleteCriticalSection(var lpCriticalSection: TCLXCriticalSection); stdcall;


{$ENDIF}

procedure ExitThread(ExitCode: Integer); stdcall;
  external kern name 'ExitThread';
function LocalAlloc(flags, size: Integer): Pointer; stdcall;
  external kern name 'LocalAlloc';
function HeapCreate(flOptions, dwInitialSize, dwMaximumSize: DWORD): THandle; stdcall;
{$EXTERNALSYM HeapCreate}
function HeapDestroy(hHeap: THandle): BOOL; stdcall;
{$EXTERNALSYM HeapDestroy}
function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: DWORD): Pointer; stdcall;
{$EXTERNALSYM HeapAlloc}
function HeapReAlloc(hHeap: THandle; dwFlags: DWORD; lpMem: Pointer; dwBytes: DWORD): Pointer; stdcall;
{$EXTERNALSYM HeapReAlloc}
function HeapFree(hHeap: THandle; dwFlags: DWORD; lpMem: Pointer): BOOL; stdcall;
{$EXTERNALSYM HeapFree}
function HeapSize(hHeap: THandle; dwFlags: DWORD; lpMem: Pointer): DWORD; stdcall;
{$EXTERNALSYM HeapSize}
function HeapValidate(hHeap: THandle; dwFlags: DWORD; lpMem: Pointer): BOOL; stdcall;
{$EXTERNALSYM HeapValidate}

function HeapSetInformation(hHeap: THandle; heapinfo: pointer; var HeapFragValue; ValueSize: integer): BOOL; stdcall;
{$IFNDEF WINDOWS2000_COMPATIBLE}
{$EXTERNALSYM HeapSetInformation}
{$ENDIF}

function HeapCompact(hHeap: THandle; dwFlags: DWORD): integer; stdcall;
{$EXTERNALSYM HeapCompact}
function GetProcessHeap: THandle; stdcall;
{$EXTERNALSYM GetProcessHeap}
function LocalReAlloc(addr:Pointer; size,flags : Integer): Pointer; stdcall;
  external kern name 'LocalReAlloc';
function LocalFree(addr: Pointer): Pointer; stdcall;
  external kern name 'LocalFree';
function VirtualAlloc(lpAddress: Pointer;
  dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall;
  external kern name 'VirtualAlloc';
function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall;
  external kern name 'VirtualFree';
function Beep(dwFreq, dwDuration: DWORD): BOOL; stdcall; external kern name 'Beep';
function GetTickCount: cardinal; stdcall; external kern name 'GetTickCount';
function InterlockedIncrement(var Addend: Integer): Integer; stdcall; external kern name 'InterlockedIncrement';
function InterlockedCompareExchangePointer(var destination: pointer; var Exchange: integer; var Comperand: integer): pointer; stdcall; external kern name 'InterlockedCompareExhangePointer';

function InterlockedDecrement(var Addend: Integer): Integer; stdcall; external kern name 'InterlockedDecrement';
function HeapLock(hHeap: THandle): BOOL; stdcall;
{$EXTERNALSYM HeapLock}
function HeapUnlock(hHeap: THandle): BOOL; stdcall;
{$EXTERNALSYM HeapUnlock}
function HeapAlloc; external kern name 'HeapAlloc';
function HeapCompact; external kern name 'HeapCompact';
function HeapCreate; external kern name 'HeapCreate';
function HeapDestroy; external kern name 'HeapDestroy';
function HeapFree; external kern name 'HeapFree';
function HeapLock; external kern name 'HeapLock';
function HeapReAlloc; external kern name 'HeapReAlloc';
{$IFNDEF WINDOWS2000_COMPATIBLE}
function HeapSetInformation; external kern name 'HeapSetInformation';
{$ENDIF}
function HeapSize; external kern name 'HeapSize';
function HeapUnlock; external kern name 'HeapUnlock';
function HeapValidate; external kern name 'HeapValidate';
function GetProcessHeap; external kern name 'GetProcessHeap';


{$ENDIF}

//----------------------------KERNEL--------------------------------------------
type
  PSuperMemBlock = ^TSuperMemBlock;

  TSuperMemBlock = packed record
    FPreviousBlock: pointer;
    FNextBlock: pointer;
    ManagedBy: pointer;
    UsedBytes: integer;
    ReportedUsedBytes: integer;
    Flags: byte;
    SizeIndex: byte;
  end;
    procedure smb_SetNextBlock(self: PSuperMemBlock; const Value: pointer);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure smb_SetPreviousBlock(self: PSuperMemBlock; const Value: pointer);{$IFNDEF NOINLINE}inline;{$ENDIF}
    function smb_GetisLinked(self: PSuperMemBlock): boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure smb_Init(self: PSuperMemBlock; UserSize: integer);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure smb_SetAvailable(self: PSuperMemBlock; b: boolean);{$IFNDEF NOINLINE}inline;{$ENDIF}