paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-10 18:19:39 +01:00
Code Issues Packages Projects Releases Wiki Activity

* changed formatting to conform to the rest of the compiler/rtl

Browse Source 
* fixed SysMaxAvail so it also looks at the free fixed size blocks
This commit is contained in:
Jonas Maebe 2004-08-10 18:58:36 +00:00
parent 75680eaa31
commit 6840bd8ece
1 changed files with 232 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

428
rtl/inc/heap.inc
View File

@ -502,15 +502,25 @@ end;
function SysMaxavail: ptrint; function SysMaxavail: ptrint;
var var
pmc : pmemchunk_var; pmc : pmemchunk_var;
i: longint;
begin begin
pmc := freelist_var; pmc := freelist_var;
sysmaxavail := 0; sysmaxavail := 0;
while assigned(pmc) do while assigned(pmc) do
begin begin
if pmc^.size>sysmaxavail then if pmc^.size>sysmaxavail then
sysmaxavail := pmc^.size; sysmaxavail := pmc^.size;
pmc := pmc^.next_var; pmc := pmc^.next_var;
end; end;
if sysmaxavail = 0 then
begin
for i := maxblockindex downto 1 do
if assigned(freelists_fixed[i]) then
begin
sysmaxavail := i shl blockshr;
exit;
end;
end;
end; end;
@ -615,20 +625,22 @@ begin
{ decide whether to free block or add to list } { decide whether to free block or add to list }
{$ifdef HAS_SYSOSFREE} {$ifdef HAS_SYSOSFREE}
if freeoslistcount >= 3 then if freeoslistcount >= 3 then
begin begin
dec(internal_heapsize, poc^.size); dec(internal_heapsize, poc^.size);
dec(internal_memavail, poc^.size); dec(internal_memavail, poc^.size);
SysOSFree(poc, poc^.size); SysOSFree(poc, poc^.size);
end else begin end
else
begin
{$endif} {$endif}
poc^.prev := nil; poc^.prev := nil;
poc^.next := freeoslist; poc^.next := freeoslist;
if freeoslist <> nil then if freeoslist <> nil then
freeoslist^.prev := poc; freeoslist^.prev := poc;
freeoslist := poc; freeoslist := poc;
inc(freeoslistcount); inc(freeoslistcount);
{$ifdef HAS_SYSOSFREE} {$ifdef HAS_SYSOSFREE}
end; end;
{$endif} {$endif}
end; end;
@ -638,7 +650,7 @@ begin
poc^.next^.prev := poc^.prev; poc^.next^.prev := poc^.prev;
if assigned(poc^.prev) then if assigned(poc^.prev) then
poc^.prev^.next := poc^.next poc^.prev^.next := poc^.next
else else
freeoslist := poc^.next; freeoslist := poc^.next;
dec(freeoslistcount); dec(freeoslistcount);
end; end;
@ -661,10 +673,10 @@ begin
count := (poc^.size - sizeof(toschunk)) div chunksize; count := (poc^.size - sizeof(toschunk)) div chunksize;
pmc := pmemchunk_fixed(pointer(poc)+sizeof(toschunk)); pmc := pmemchunk_fixed(pointer(poc)+sizeof(toschunk));
for i := 0 to count - 1 do for i := 0 to count - 1 do
begin begin
remove_from_list_fixed(blockindex, pmc); remove_from_list_fixed(blockindex, pmc);
pmc := pointer(pmc)+chunksize; pmc := pointer(pmc)+chunksize;
end; end;
append_to_oslist(poc); append_to_oslist(poc);
end; end;
@ -679,20 +691,20 @@ var
begin begin
sizeleft := (pcurr^.size and sizemask)-size; sizeleft := (pcurr^.size and sizemask)-size;
if sizeleft>=blocksize then if sizeleft>=blocksize then
begin begin
pcurr_tmp := pmemchunk_var(pointer(pcurr)+size); pcurr_tmp := pmemchunk_var(pointer(pcurr)+size);
{ update prevsize of block to the right } { update prevsize of block to the right }
if (pcurr^.size and lastblockflag) = 0 then if (pcurr^.size and lastblockflag) = 0 then
pmemchunk_var(pointer(pcurr)+(pcurr^.size and sizemask))^.prevsize := sizeleft; pmemchunk_var(pointer(pcurr)+(pcurr^.size and sizemask))^.prevsize := sizeleft;
{ inherit the lastblockflag } { inherit the lastblockflag }
pcurr_tmp^.size := sizeleft or (pcurr^.size and lastblockflag); pcurr_tmp^.size := sizeleft or (pcurr^.size and lastblockflag);
pcurr_tmp^.prevsize := size; pcurr_tmp^.prevsize := size;
{ the block we return is not the last one anymore (there's now a block after it) } { the block we return is not the last one anymore (there's now a block after it) }
{ decrease size of block to new size } { decrease size of block to new size }
pcurr^.size := size or (pcurr^.size and (not sizemask and not lastblockflag)); pcurr^.size := size or (pcurr^.size and (not sizemask and not lastblockflag));
{ insert the block in the freelist } { insert the block in the freelist }
append_to_list_var(pcurr_tmp); append_to_list_var(pcurr_tmp);
end; end;
end; end;
{***************************************************************************** {*****************************************************************************
@ -709,13 +721,15 @@ begin
inc(mc_left^.size, size_right); inc(mc_left^.size, size_right);
// if right-block was last block, copy flag // if right-block was last block, copy flag
if (mc_right^.size and lastblockflag) <> 0 then if (mc_right^.size and lastblockflag) <> 0 then
begin begin
mc_left^.size := mc_left^.size or lastblockflag; mc_left^.size := mc_left^.size or lastblockflag;
end else begin end
// there is a block to the right of the right-block, adjust it's prevsize else
mc_tmp := pmemchunk_var(pointer(mc_right)+size_right); begin
mc_tmp^.prevsize := mc_left^.size and sizemask; // there is a block to the right of the right-block, adjust it's prevsize
end; mc_tmp := pmemchunk_var(pointer(mc_right)+size_right);
mc_tmp^.prevsize := mc_left^.size and sizemask;
end;
// remove right-block from doubly linked list // remove right-block from doubly linked list
remove_from_list_var(mc_right); remove_from_list_var(mc_right);
end; end;
@ -727,13 +741,13 @@ begin
{ try concat forward } { try concat forward }
if (mc^.size and lastblockflag) = 0 then if (mc^.size and lastblockflag) = 0 then
begin begin
mc_tmp := pmemchunk_var(pointer(mc)+(mc^.size and sizemask)); mc_tmp := pmemchunk_var(pointer(mc)+(mc^.size and sizemask));
if (mc_tmp^.size and usedflag) = 0 then if (mc_tmp^.size and usedflag) = 0 then
begin begin
// next block free: concat // next block free: concat
concat_two_blocks(mc, mc_tmp); concat_two_blocks(mc, mc_tmp);
end;
end; end;
end;
end; end;
function try_concat_free_chunk(mc: pmemchunk_var): pmemchunk_var; function try_concat_free_chunk(mc: pmemchunk_var): pmemchunk_var;
@ -744,15 +758,15 @@ begin
{ try concat backward } { try concat backward }
if (mc^.size and firstblockflag) = 0 then if (mc^.size and firstblockflag) = 0 then
begin
mc_tmp := pmemchunk_var(pointer(mc)-mc^.prevsize);
if (mc_tmp^.size and usedflag) = 0 then
begin begin
// prior block free: concat mc_tmp := pmemchunk_var(pointer(mc)-mc^.prevsize);
concat_two_blocks(mc_tmp, mc); if (mc_tmp^.size and usedflag) = 0 then
mc := mc_tmp; begin
end; // prior block free: concat
end; concat_two_blocks(mc_tmp, mc);
mc := mc_tmp;
end;
end;
result := mc; result := mc;
end; end;
@ -773,46 +787,46 @@ begin
{ blocks available in freelist? } { blocks available in freelist? }
result := freeoslist; result := freeoslist;
while result <> nil do while result <> nil do
begin begin
if poschunk(result)^.size > size then if poschunk(result)^.size > size then
begin begin
size := poschunk(result)^.size; size := poschunk(result)^.size;
remove_from_oslist(poschunk(result)); remove_from_oslist(poschunk(result));
break; break;
end; end;
result := poschunk(result)^.next; result := poschunk(result)^.next;
end; end;
if result = nil then if result = nil then
begin begin
{$ifdef DUMPGROW} {$ifdef DUMPGROW}
writeln('growheap(',size,') allocating ',(size+$ffff) and $ffff0000); writeln('growheap(',size,') allocating ',(size+$ffff) and $ffff0000);
DumpBlocks; DumpBlocks;
{$endif} {$endif}
{ allocate by 64K size } { allocate by 64K size }
size := (size+$ffff) and not $ffff; size := (size+$ffff) and not $ffff;
{ allocate smaller blocks for fixed-size chunks } { allocate smaller blocks for fixed-size chunks }
if blockindex<>0 then if blockindex<>0 then
begin begin
result := SysOSAlloc(GrowHeapSizeSmall); result := SysOSAlloc(GrowHeapSizeSmall);
if result<>nil then if result<>nil then
size := GrowHeapSizeSmall; size := GrowHeapSizeSmall;
end else end
{ first try 256K (default) } { first try 256K (default) }
if size<=GrowHeapSize1 then else if size<=GrowHeapSize1 then
begin begin
result := SysOSAlloc(GrowHeapSize1); result := SysOSAlloc(GrowHeapSize1);
if result<>nil then if result<>nil then
size := GrowHeapSize1; size := GrowHeapSize1;
end else end
{ second try 1024K (default) } { second try 1024K (default) }
if size<=GrowHeapSize2 then else if size<=GrowHeapSize2 then
begin begin
result := SysOSAlloc(GrowHeapSize2); result := SysOSAlloc(GrowHeapSize2);
if result<>nil then if result<>nil then
size := GrowHeapSize2; size := GrowHeapSize2;
end end
{ else allocate the needed bytes } { else allocate the needed bytes }
else else
result := SysOSAlloc(size); result := SysOSAlloc(size);
{ try again } { try again }
if result=nil then if result=nil then
@ -835,34 +849,38 @@ begin
poschunk(result)^.size := size; poschunk(result)^.size := size;
inc(result, sizeof(toschunk)); inc(result, sizeof(toschunk));
if blockindex<>0 then if blockindex<>0 then
begin begin
{ chop os chunk in fixedsize parts } { chop os chunk in fixedsize parts }
chunksize := blockindex shl blockshr; chunksize := blockindex shl blockshr;
count := (size-sizeof(toschunk)) div chunksize; count := (size-sizeof(toschunk)) div chunksize;
pmc := pmemchunk_fixed(result); pmc := pmemchunk_fixed(result);
pmc^.prev_fixed := nil; pmc^.prev_fixed := nil;
i := 0; i := 0;
repeat repeat
pmc^.size := fixedsizeflag or chunksize or (i shl 16); pmc^.size := fixedsizeflag or chunksize or (i shl 16);
pmc^.next_fixed := pointer(pmc)+chunksize; pmc^.next_fixed := pointer(pmc)+chunksize;
inc(i); inc(i);
if i < count then if i < count then
begin begin
pmc := pmemchunk_fixed(pointer(pmc)+chunksize); pmc := pmemchunk_fixed(pointer(pmc)+chunksize);
pmc^.prev_fixed := pointer(pmc)-chunksize; pmc^.prev_fixed := pointer(pmc)-chunksize;
end else begin end
break; else
end; begin
until false; break;
append_to_list_fixed(blockindex, pmc); end;
pmc^.prev_fixed := pointer(pmc)-chunksize; until false;
freelists_fixed[blockindex] := pmemchunk_fixed(result); append_to_list_fixed(blockindex, pmc);
end else begin pmc^.prev_fixed := pointer(pmc)-chunksize;
pmcv := pmemchunk_var(result); freelists_fixed[blockindex] := pmemchunk_fixed(result);
append_to_list_var(pmcv); end
pmcv^.size := ((size-sizeof(toschunk)) and sizemask) or (firstblockflag or lastblockflag); else
pmcv^.prevsize := 0; begin
end; pmcv := pmemchunk_var(result);
append_to_list_var(pmcv);
pmcv^.size := ((size-sizeof(toschunk)) and sizemask) or (firstblockflag or lastblockflag);
pmcv^.prevsize := 0;
end;
{$ifdef TestFreeLists} {$ifdef TestFreeLists}
TestFreeLists; TestFreeLists;
{$endif TestFreeLists} {$endif TestFreeLists}
@ -917,28 +935,30 @@ begin
pbest := nil; pbest := nil;
{$endif} {$endif}
pcurr := freelist_var; pcurr := freelist_var;
while assigned(pcurr) do while assigned(pcurr) do
begin begin
{$ifdef BESTMATCH} {$ifdef BESTMATCH}
if pcurr^.size=size then if pcurr^.size=size then
begin begin
break; break;
end else begin end
if (pcurr^.size>size) then else
begin
if (pcurr^.size>size) then
begin begin
if (not assigned(pbest)) or if (not assigned(pbest)) or
(pcurr^.size<pbest^.size) then (pcurr^.size<pbest^.size) then
pbest := pcurr; pbest := pcurr;
end; end;
end; end;
{$else BESTMATCH} {$else BESTMATCH}
if pcurr^.size>=size then if pcurr^.size>=size then
break; break;
{$endif BESTMATCH} {$endif BESTMATCH}
pcurr := pcurr^.next_var; pcurr := pcurr^.next_var;
end; end;
{$ifdef BESTMATCH} {$ifdef BESTMATCH}
if not assigned(pcurr) then if not assigned(pcurr) then
pcurr := pbest; pcurr := pbest;
{$endif} {$endif}
@ -948,20 +968,20 @@ begin
pcurr := alloc_oschunk(0, size); pcurr := alloc_oschunk(0, size);
if not assigned(pcurr) then if not assigned(pcurr) then
exit; exit;
end; end;
{ get pointer of the block we should return } { get pointer of the block we should return }
result := pointer(pcurr)+sizeof(tmemchunk_var_hdr); result := pointer(pcurr)+sizeof(tmemchunk_var_hdr);
{ remove the current block from the freelist } { remove the current block from the freelist }
remove_from_list_var(pcurr); remove_from_list_var(pcurr);
{ create the left over freelist block, if at least 16 bytes are free } { create the left over freelist block, if at least 16 bytes are free }
split_block(pcurr, size); split_block(pcurr, size);
{ flag block as used } { flag block as used }
pcurr^.size := pcurr^.size or usedflag; pcurr^.size := pcurr^.size or usedflag;
{$ifdef TestFreeLists} {$ifdef TestFreeLists}
if test_each then if test_each then
TestFreeLists; TestFreeLists;
{$endif TestFreeLists} {$endif TestFreeLists}
end; end;
@ -969,23 +989,25 @@ function SysGetMem(size : ptrint):pointer;
begin begin
{ Something to allocate ? } { Something to allocate ? }
if size<=0 then if size<=0 then
begin begin
{ give an error for < 0 } { give an error for < 0 }
if size<0 then if size<0 then
HandleError(204); HandleError(204);
{ we always need to allocate something, using heapend is not possible, { we always need to allocate something, using heapend is not possible,
because heappend can be changed by growheap (PFV) } because heappend can be changed by growheap (PFV) }
size := 1; size := 1;
end; end;
{ calc to multiple of 16 after adding the needed bytes for memchunk header } { calc to multiple of 16 after adding the needed bytes for memchunk header }
if size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr)) then if size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr)) then
begin begin
size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask; size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask;
sysgetmem := sysgetmem_fixed(size); sysgetmem := sysgetmem_fixed(size);
end else begin end
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask; else
sysgetmem := sysgetmem_var(size); begin
end; size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
sysgetmem := sysgetmem_var(size);
end;
dec(internal_memavail,size); dec(internal_memavail,size);
end; end;
@ -1057,11 +1079,13 @@ begin
pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size; pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size;
{ check if this is a fixed- or var-sized chunk } { check if this is a fixed- or var-sized chunk }
if (pcurrsize and fixedsizeflag) = 0 then if (pcurrsize and fixedsizeflag) = 0 then
begin begin
result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)), pcurrsize and sizemask); result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)), pcurrsize and sizemask);
end else begin end
result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)), pcurrsize and fixedsizemask); else
end; begin
result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)), pcurrsize and fixedsizemask);
end;
end; end;
{***************************************************************************** {*****************************************************************************
@ -1074,24 +1098,26 @@ var
begin begin
SysFreeMemSize := 0; SysFreeMemSize := 0;
if size<=0 then if size<=0 then
begin begin
if size<0 then if size<0 then
HandleError(204); HandleError(204);
exit; exit;
end; end;
if p=nil then if p=nil then
HandleError(204); HandleError(204);
pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size; pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size;
{ check if this is a fixed- or var-sized chunk } { check if this is a fixed- or var-sized chunk }
if (pcurrsize and fixedsizeflag) = 0 then if (pcurrsize and fixedsizeflag) = 0 then
begin begin
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask; size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)), size); result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)), size);
end else begin end
size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask; else
result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)), size); begin
end; size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask;
result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)), size);
end;
end; end;
@ -1103,13 +1129,15 @@ function SysMemSize(p: pointer): ptrint;
begin begin
SysMemSize := pmemchunk_fixed(pointer(p)-sizeof(tmemchunk_fixed_hdr))^.size; SysMemSize := pmemchunk_fixed(pointer(p)-sizeof(tmemchunk_fixed_hdr))^.size;
if (SysMemSize and fixedsizeflag) = 0 then if (SysMemSize and fixedsizeflag) = 0 then
begin begin
SysMemSize := SysMemSize and sizemask; SysMemSize := SysMemSize and sizemask;
dec(SysMemSize, sizeof(tmemchunk_var_hdr)); dec(SysMemSize, sizeof(tmemchunk_var_hdr));
end else begin end
SysMemSize := SysMemSize and fixedsizemask; else
dec(SysMemSize, sizeof(tmemchunk_fixed_hdr)); begin
end; SysMemSize := SysMemSize and fixedsizemask;
dec(SysMemSize, sizeof(tmemchunk_fixed_hdr));
end;
end; end;
@ -1140,30 +1168,34 @@ var
begin begin
{ fix needed size } { fix needed size }
if size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr)) then if size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr)) then
begin begin
size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask; size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask;
end else begin end
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask; else
end; begin
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
end;
{ fix p to point to the heaprecord } { fix p to point to the heaprecord }
pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size; pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size;
if (pcurrsize and fixedsizeflag) = 0 then if (pcurrsize and fixedsizeflag) = 0 then
begin begin
currsize := pcurrsize and sizemask; currsize := pcurrsize and sizemask;
end else begin end
currsize := pcurrsize and fixedsizemask; else
end; begin
currsize := pcurrsize and fixedsizemask;
end;
oldsize := currsize; oldsize := currsize;
{ is the allocated block still correct? } { is the allocated block still correct? }
if (currsize>=size) and (size>(currsize-16)) then if (currsize>=size) and (size>(currsize-16)) then
begin begin
SysTryResizeMem := true; SysTryResizeMem := true;
{$ifdef TestFreeLists} {$ifdef TestFreeLists}
if test_each then if test_each then
TestFreeLists; TestFreeLists;
{$endif TestFreeLists} {$endif TestFreeLists}
exit; exit;
end; end;
{ don't do resizes on fixed-size blocks } { don't do resizes on fixed-size blocks }
@ -1303,7 +1335,11 @@ end;
{ {
$Log$ $Log$
Revision 1.35 2004-06-29 20:50:32 peter Revision 1.36 2004-08-10 18:58:36 jonas
* changed formatting to conform to the rest of the compiler/rtl
* fixed SysMaxAvail so it also looks at the free fixed size blocks
Revision 1.35 2004/06/29 20:50:32 peter
* readded support for ReturnIfGrowHeapFails * readded support for ReturnIfGrowHeapFails
Revision 1.34 2004/06/27 19:47:27 florian Revision 1.34 2004/06/27 19:47:27 florian