diff --git a/rtl/inc/heap.inc b/rtl/inc/heap.inc index 75860036a3..b8ac5c36ca 100644 --- a/rtl/inc/heap.inc +++ b/rtl/inc/heap.inc @@ -32,7 +32,12 @@ { DEBUG: Dump info when the heap needs to grow } { define DUMPGROW} -{ Default heap settings } +{$ifdef SYSTEMDEBUG} +{$define TestFreeLists} +{ define withbug this leads to crashes below } +{$endif SYSTEMDEBUG} + + const blocksize = 16; { at least size of freerecord } blockshr = 4; { shr value for blocksize=2^blockshr} @@ -80,12 +85,23 @@ type end; { 4 bytes } tfreelists = array[0..maxblock] of pfreerecord; +{$ifdef SYSTEMDEBUG} + tfreecount = array[0..maxblock] of dword; +{$endif SYSTEMDEBUG} pfreelists = ^tfreelists; var internal_memavail : longint; internal_heapsize : longint; freelists : tfreelists; +{$ifdef SYSTEMDEBUG} + freecount : tfreecount; +{$endif SYSTEMDEBUG} +{$ifdef TestFreeLists} +{ this can be turned on by debugger } +const + test_each : boolean = false; +{$endif TestFreeLists} {***************************************************************************** Memory Manager @@ -253,6 +269,28 @@ begin end; {$endif} +{$ifdef TestFreeLists} + procedure TestFreeLists; +var + i,j : longint; + hp : pfreerecord; +begin + for i:=0 to maxblock do + begin + j:=0; + hp:=freelists[i]; + while assigned(hp) do + begin + inc(j); + if (i>0) and ((hp^.size and sizemask) <> i * blocksize) then + RunError(204); + hp:=hp^.next; + end; + if j<>freecount[i] then + RunError(204); + end; +end; +{$endif TestFreeLists} {***************************************************************************** SysGetMem @@ -298,20 +336,33 @@ begin pcurr^.size:=pcurr^.size or usedmask; { update freelist } freelists[s]:=pcurr^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s]); +{$endif SYSTEMDEBUG} if assigned(freelists[s]) then freelists[s]^.prev:=nil; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} exit; end; {$ifdef SMALLATHEAPPTR} - if heapend-heapptr>size then + if heapend-heapptr>=size then begin sysgetmem:=heapptr; - if (heapptr+size=heapend) then + { set end flag if we do not have enough room to add + another tfreerecord behind } + if (heapptr+size+sizeof(tfreerecord)>=heapend) then pheaprecord(sysgetmem)^.size:=size or (usedmask or beforeheapendmask) else pheaprecord(sysgetmem)^.size:=size or usedmask; inc(sysgetmem,sizeof(theaprecord)); inc(heapptr,size); +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} exit; end; {$endif} @@ -380,9 +431,12 @@ begin pcurr^.prev^.next:=pcurr^.next else freelists[s]:=pcurr^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s]); +{$endif SYSTEMDEBUG} { create the left over freelist block, if at least 16 bytes are free } sizeleft:=pcurr^.size-size; - if sizeleft>sizeof(tfreerecord) then + if sizeleft>=sizeof(tfreerecord) then begin pcurr:=pfreerecord(pointer(pcurr)+size); { inherit the beforeheapendmask } @@ -396,6 +450,9 @@ begin if assigned(freelists[s1]) then freelists[s1]^.prev:=pcurr; freelists[s1]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s1]); +{$endif SYSTEMDEBUG} { create the block we need to return } pheaprecord(sysgetmem)^.size:=size or usedmask; end @@ -406,21 +463,29 @@ begin end; inc(sysgetmem,sizeof(theaprecord)); +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} exit; end; { Lastly, the top of the heap is checked, to see if there is } { still memory available. } repeat again:=false; - if heapend-heapptr>size then + if heapend-heapptr>=size then begin sysgetmem:=heapptr; - if (heapptr+size=heapend) then + if (heapptr+size+sizeof(tfreerecord)>=heapend) then pheaprecord(sysgetmem)^.size:=size or (usedmask or beforeheapendmask) else pheaprecord(sysgetmem)^.size:=size or usedmask; inc(sysgetmem,sizeof(theaprecord)); inc(heapptr,size); +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} exit; end; { Call the heaperror proc } @@ -436,9 +501,14 @@ begin else HandleError(203); until not again; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} end; +{$ifdef CONCATFREE} {***************************************************************************** Try concat freerecords *****************************************************************************} @@ -451,14 +521,18 @@ begin pcurrsize:=pcurr^.size and sizemask; hp:=pcurr; repeat - { block used or before a heapptr ? } + { block used or before a heapend ? } if (hp^.size and beforeheapendmask)<>0 then begin + { Peter, why can't we add this one if free ?? } pcurr^.size:=pcurrsize or beforeheapendmask; pcurr^.next:=freelists[0]; if assigned(pcurr^.next) then pcurr^.next^.prev:=pcurr; freelists[0]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[0]); +{$endif SYSTEMDEBUG} break; end; { get next block } @@ -477,6 +551,9 @@ begin if assigned(pcurr^.next) then pcurr^.next^.prev:=pcurr; freelists[0]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[0]); +{$endif SYSTEMDEBUG} break; end; { remove block from freelist and increase the size } @@ -491,9 +568,12 @@ begin hp^.prev^.next:=hp^.next else freelists[s1]:=hp^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s1]); +{$endif SYSTEMDEBUG} until false; end; - +{$endif CONCATFREE} {***************************************************************************** SysFreeMem @@ -526,9 +606,16 @@ begin if assigned(pcurr^.next) then pcurr^.next^.prev:=pcurr; freelists[s]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s]); +{$endif SYSTEMDEBUG} end; p:=nil; SysFreeMem:=pcurrsize; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} end; @@ -576,9 +663,16 @@ begin if assigned(pcurr^.next) then pcurr^.next^.prev:=pcurr; freelists[s]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s]); +{$endif SYSTEMDEBUG} end; p:=nil; SysFreeMemSize:=pcurrsize; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} end; @@ -631,6 +725,10 @@ begin if currsize=size then begin SysTryResizeMem:=true; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} exit; end; { do we need to allocate more memory ? } @@ -689,6 +787,9 @@ begin hp^.prev^.next:=hp^.next else freelists[s]:=hp^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s]); +{$endif SYSTEMDEBUG} until (foundsize>=size); if wasbeforeheapend then pcurr^.size:=foundsize or usedmask or beforeheapendmask @@ -699,6 +800,10 @@ begin begin { we need to call getmem/move/freemem } SysTryResizeMem:=false; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} exit; end; currsize:=pcurr^.size and sizemask; @@ -722,6 +827,9 @@ begin if assigned(freelists[s]) then freelists[s]^.prev:=pnew; freelists[s]:=pnew; +{$ifdef SYSTEMDEBUG} + inc(freecount[s]); +{$endif SYSTEMDEBUG} { fix the size of the current block and leave } pcurr^.size:=size or usedmask; end @@ -733,6 +841,10 @@ begin end; dec(internal_memavail,size-oldsize); SysTryResizeMem:=true; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} end; @@ -792,7 +904,7 @@ end; function growheap(size :longint) : integer; var - sizeleft, + sizeleft,s1, NewPos : longint; pcurr : pfreerecord; begin @@ -842,16 +954,35 @@ begin begin { create freelist entry for old heapptr-heapend } sizeleft:=heapend-heapptr; - if sizeleft>sizeof(tfreerecord) then + if sizeleft>=sizeof(tfreerecord) then begin pcurr:=pfreerecord(heapptr); pcurr^.size:=sizeleft or beforeheapendmask; - { insert the block in the freelist } +{$ifdef Withbug} + { this code was wrong because + in TryConcat an freerecord sets freelists[s] where s is size shr blockshr PM } pcurr^.next:=freelists[0]; pcurr^.prev:=nil; if assigned(freelists[0]) then freelists[0]^.prev:=pcurr; freelists[0]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[0]); +{$endif SYSTEMDEBUG} +{$else not Withbug} + { insert the block in the freelist } + s1:=sizeleft shr blockshr; + if s1>maxblock then + s1:=0; + pcurr^.next:=freelists[s1]; + pcurr^.prev:=nil; + if assigned(freelists[s1]) then + freelists[s1]^.prev:=pcurr; + freelists[s1]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s1]); +{$endif SYSTEMDEBUG} +{$endif Withbug} end; { now set the new heapptr,heapend to the new block } heapptr:=pointer(newpos); @@ -862,6 +993,9 @@ begin inc(internal_heapsize,size); { try again } GrowHeap:=2; +{$ifdef TestFreeLists} + TestFreeLists; +{$endif TestFreeLists} end; @@ -874,6 +1008,9 @@ end; procedure InitHeap; begin FillChar(FreeLists,sizeof(TFreeLists),0); +{$ifdef SYSTEMDEBUG} + FillChar(FreeCount,sizeof(TFreeCount),0); +{$endif SYSTEMDEBUG} internal_heapsize:=GetHeapSize; internal_memavail:=internal_heapsize; HeapOrg:=GetHeapStart; @@ -884,7 +1021,10 @@ end; { $Log$ - Revision 1.37 2000-04-07 21:10:35 pierre + Revision 1.38 2000-04-20 15:29:15 pierre + fix for heap problem + + Revision 1.37 2000/04/07 21:10:35 pierre + ReturnNilIfGrowHeapFails used in objects unit to handle TMemoryStream out of memory properly as MaxAvail is not a good test anymore.