{ 需要修改Forms.pas单元或这是其他单元中相应的代码 }
// While discussing one memory leak in Russian FidoNet Delphi conference, it
// seemed to turn out that Object Instancing is subject to be buggy.
// I tried to mend those problem. Thanx to anyone, who's posts i used in this patch
// These are changes for forms.pas (Delphi 5 and prior) or classes.pas (Delphi 6 or above)
// Made by Arioch@nm.ru
// PS: I wonder if publishing bugfixes to Borland's RTL violates its licanse, since bugfix
// is certainly a 'derived software'
// Resume of trouble:
// Seems that MakeObjInstance been made in Delphi 1, where it tried to mimic MS-DOS styled
// chained lists (file handles, fcbs, mcbs, disk buffers, etc...)
// But the job was not finished and so there is an issues:
// 1) if one uses dll's with forms, Delphi leaks 4kb of RAM at each freeing of the last form,
// created in DLL.
// 2) more generic: RAM will leak at each subsequent call to MakeObjInstance having (mod 314 = 0)
// i hope it will fix it.
const
InstanceCount = 313 ;
{ Object instance management }
type
PObjectInstance = ^ TObjectInstance ;
TObjectInstance = packed record
Code : Byte ;
Offset : Integer ;
case Integer of
0 : ( Next : PObjectInstance );
1 : ( Method : TWndMethod );
end ;
type
PInstanceBlock = ^ TInstanceBlock ;
TInstanceBlock = packed record
Next : PInstanceBlock ;
Counter : word ; //Arioch - aligning WndProcPtr to 32-bit boundary.
// We sure can add this after Instances to keep binary compatibility,
// but possibly loose in spead since no boundary for pointer and since
// counter would not be cached in CPU when reading record header
// after this addition record size is 4094 bytes. There are 2 bytes more for a i386 page
Code : array [ 1 .. 2 ] of Byte ;
WndProcPtr : Pointer ;
Instances : array [ 0 .. InstanceCount ] of TObjectInstance ;
end ;
var
InstBlockList : PInstanceBlock ;
InstFreeList : PObjectInstance ;
InstCritSect : TCriticalSection ; //Arioch: multi-thread blocker
implementation
uses SyncObjs , //Arioch: add the rest of uses clause.... Need TCriticalSection from unit.
function CalcJmpOffset ( Src , Dest : Pointer ): Longint ;
begin
Result := Longint ( Dest ) - ( Longint ( Src ) + 5 );
end ;
function CalcJmpTarget ( Src : Pointer , Offs : integer ): Pointer ; //Arioch
begin
Integer ( Result ) := Offs + ( Longint ( Src ) + 5 );
end ;
function GetInstanceBlock ( ObjectInstance : Pointer ): PInstanceBlock ; //Arioch
var oi : PObjectInstance absolute ObjectInstance ; //i'mm to lazy to use with and typecast :-)
begin Result := nil ; if ObjectInstance = nil then exit ;
Pointer ( Result ) := CalcJmpTarget ( ObjectInstance , oi ^. Offset )
- sizeof ( TInstanceBlock . Counter ) - sizeof ( TInstanceBlock . Next );
end ;
function MakeObjectInstance ( Method : TWndMethod ): Pointer ;
const
BlockCode : array [ 1 .. 2 ] of Byte = (
$59 , { POP ECX }
$E9 ); { JMP StdWndProc }
PageSize = 4096 ;
var
Block : PInstanceBlock ;
Instance : PObjectInstance ;
begin
try InstCritSect . Enter ;
if InstFreeList = nil then
begin
Block := VirtualAlloc ( nil , PageSize , MEM_COMMIT , PAGE_EXECUTE_READWRITE );
Block ^. Next := InstBlockList ; //Arioch: seems inherited from D1 -
// not finished MS-DOS styled array-chains model
// Move(BlockCode, Block^.Code, SizeOf(BlockCode));
//Arioch: since the procedure is not inline - it is CPU loss
Word ( Block ^. Code ) := Word ( BlockCode );
//Arioch: here we assume size of 2 bytes - but here is so lot of hacks, that one more will not hurt
Block ^. WndProcPtr := Pointer ( CalcJmpOffset (@ Block ^. Code [ 2 ], @ StdWndProc ));
Block ^. Counter := 0 ; // Arioch: here we will init counter
Instance := @ Block ^. Instances ;
repeat
Instance ^. Code := $E8 ; { CALL NEAR PTR Offset }
Instance ^. Offset := CalcJmpOffset ( Instance , @ Block ^. Code );
Instance ^. Next := InstFreeList ; //Nil, then prev. Instance
InstFreeList := Instance ;
//Inc(Longint(Instance), SizeOf(TObjectInstance));
//Arioch: LongInt? certainly D1 code, not even D3! Let's avoid misty code!
Instance := Succ ( Instance );
until Longint ( Instance ) - Longint ( Block ) >= SizeOf ( TInstanceBlock );
InstBlockList := Block ;
end ;
Result := InstFreeList ;
Instance := InstFreeList ;
InstFreeList := Instance ^. Next ;
Instance ^. Method := Method ;
Inc ( GetInstanceBlock ( Instance )^. Counter ); //Arioch: need not check for overflow
// since last one will have NExt = nil, making RTL to allocate new block
finally InstCritSect . Leave ; end ;
end ;
function FreeInstanceBlock ( block : pointer ): boolean ;
var bi : PInstanceBlock absolute block ;
oi , poi , noi : PObjectInstance ; // needed to free block
begin
Result := false ; if bi = nil then exit ; if bi ^. Counter <> 0 then exit ;
oi := InstFreeList ; poi := nil ;
while oi <> nil do begin
noi := oi ^. next ;
// Here we must remove instances from the free-list before freeing block
// Othewise MakeObjectInstance will reuse it :-( leading to GPF
// I hope we do not need oi any more! We have bi instead.
if GetInstanceBlock ( oi ) = bi then // our victim! steal it away!
if poi <> nil then poi ^. Next := noi ;
if oi = InstFreeList then InstFreeList := noi ;
// not effective, but simple, stupid, and solid (i hope)
end ;
poi := oi ; oi := noi ;
end ;
VirtualFree ( block , 0 , MEM_RELEASE ); // no more memory leaks! at last! i hope!!!
Result := true ;
end ;
procedure FreeInstanceBlocks ; //Garbage collection. Queerest of the queer.
var pbi , bi , nbi : PBlockInstance ;
begin
pbi := nil ; bi := InstBlockList ;
while bi <> nil do begin
nbi := bi ^. Next ;
if FreeInstanceBlock ( bi ) then begin
if pbi <> nil then pbi ^. Next := nbi ;
if bi = InstBlockList then InstBlockList := nbi ;
// not effective, but simple, stupid, and solid (i hope)
end ;
pbi := bi ; bi := nbi ;
end ;
end ;
{ Free an object instance }
procedure FreeObjectInstance ( ObjectInstance : Pointer );
var bi : PInstanceBlock ; i : integer ; //Arioch
oi : PObjectInstance absolute ObjectInstance ; //i'm to lazy to use with and typecast :-)
begin
if ObjectInstance <> nil then
try InstCritSect . Enter ;
bi := GetInstanceBlock ( ObjectInstance ); // what the block did we cleaned a bit?
if bi = nil then exit ; // i cannot tell how may this be - but it is a crush!
if ( bi ^. Counter <= 0 ) or ( bi ^. Counter > InstanceCount + 1 ) then exit ;
// crash! it was not TObjectInstance???
PObjectInstance ( ObjectInstance )^. Next := InstFreeList ;
InstFreeList := ObjectInstance ;
//saving freed instance for the further re-use in never-sorting list.
//maybe it would be better to keep tracks in easc of blocks separately
//(for example checking if Instance^.Next=nil), but... To much to change.
Dec ( bi ^. Counter ); if bi ^. Counter <= 0 then FreeInstanceBlocks ;
//full garbage collection - no one tells that we're freeing the top block!
finally InstCritSect . Leave ; end ;
end ;
initialization
InstCritSect := TCriticalSection . Create ();
//Arioch: here put the rest of original initialisation of unit
finalization
InstCritSect . Free ();
//Arioch: here put the rest of original finalisation of unit