paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 10:49:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

* optimize by removing expensive calculations

Browse Source 
git-svn-id: trunk@1973 -
This commit is contained in:
peter 2005-12-16 17:19:37 +00:00
parent ef2a0c7ddf
commit 9d817056ce
1 changed files with 217 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

492
rtl/inc/heap.inc
View File

@ -21,29 +21,25 @@
{ DEBUG: Dump info when the heap needs to grow } { DEBUG: Dump info when the heap needs to grow }
{ define DUMPGROW} { define DUMPGROW}
{ DEBUG: Test the FreeList on correctness }
{$ifdef SYSTEMDEBUG}
{$define TestFreeLists}
{$endif SYSTEMDEBUG}
const const
{$ifdef CPU64} {$ifdef CPU64}
blocksize = 32; { at least size of freerecord } blocksize = 32; { at least size of freerecord }
blockshr = 5; { shr value for blocksize=2^blockshr} blockshift = 5; { shr value for blocksize=2^blockshift}
maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord } maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
{$else} {$else}
blocksize = 16; { at least size of freerecord } blocksize = 16; { at least size of freerecord }
blockshr = 4; { shr value for blocksize=2^blockshr} blockshift = 4; { shr value for blocksize=2^blockshift}
maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord } maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
{$endif} {$endif}
maxblockindex = maxblocksize div blocksize; { highest index in array of lists of memchunks } maxblockindex = maxblocksize div blocksize; { highest index in array of lists of memchunks }
maxreusebigger = 8; { max reuse bigger tries } maxreusebigger = 8; { max reuse bigger tries }
usedflag = 1; { flag if the block is used or not } { common flags }
lastblockflag = 2; { flag if the block is the last in os chunk } fixedsizeflag = 1; { flag if the block is of fixed size }
firstblockflag = 4; { flag if the block is the first in os chunk } { memchunk var flags }
fixedsizeflag = 8; { flag if the block is of fixed size } usedflag = 2; { flag if the block is used or not }
lastblockflag = 4; { flag if the block is the last in os chunk }
firstblockflag = 8; { flag if the block is the first in os chunk }
sizemask = not(blocksize-1); sizemask = not(blocksize-1);
fixedsizemask = sizemask and $ffff; fixedsizemask = sizemask and $ffff;
@ -81,21 +77,27 @@ const
); );
type type
poschunk = ^toschunk;
toschunk = record
size,
used,
chunkindex : ptrint;
next,
prev : poschunk;
end;
pmemchunk_fixed = ^tmemchunk_fixed; pmemchunk_fixed = ^tmemchunk_fixed;
tmemchunk_fixed = record tmemchunk_fixed = record
{$ifdef cpusparc} size : ptrint;
{ Sparc needs to alloc aligned on 8 bytes, to allow doubles } poc : poschunk;
_dummy : ptrint;
{$endif cpusparc}
size : ptrint;
next_fixed, next_fixed,
prev_fixed : pmemchunk_fixed; prev_fixed : pmemchunk_fixed;
end; end;
pmemchunk_var = ^tmemchunk_var; pmemchunk_var = ^tmemchunk_var;
tmemchunk_var = record tmemchunk_var = record
size : ptrint;
prevsize : ptrint; prevsize : ptrint;
size : ptrint;
next_var, next_var,
prev_var : pmemchunk_var; prev_var : pmemchunk_var;
end; end;
@ -103,25 +105,16 @@ type
{ ``header'', ie. size of structure valid when chunk is in use } { ``header'', ie. size of structure valid when chunk is in use }
{ should correspond to tmemchunk_var_hdr structure starting with the { should correspond to tmemchunk_var_hdr structure starting with the
last field. Reason is that the overlap is starting from the end of the last field. Reason is that the overlap is starting from the end of the
record. } record.
Alignment is 8 bytes for 32bit machines. This required
for x86 MMX/SSE and for sparc Double values }
tmemchunk_fixed_hdr = record tmemchunk_fixed_hdr = record
{$ifdef cpusparc} size : ptrint;
{ Sparc needs to alloc aligned on 8 bytes, to allow doubles } poschunk : pointer;
_dummy : ptrint;
{$endif cpusparc}
size : ptrint;
end; end;
tmemchunk_var_hdr = record tmemchunk_var_hdr = record
prevsize : ptrint; prevsize,
size : ptrint; size : ptrint;
end;
poschunk = ^toschunk;
toschunk = record
size : ptrint;
next,
prev : poschunk;
used : ptrint;
end; end;
tfreelists = array[1..maxblockindex] of pmemchunk_fixed; tfreelists = array[1..maxblockindex] of pmemchunk_fixed;
@ -136,11 +129,6 @@ var
freeoslist : poschunk; freeoslist : poschunk;
freeoslistcount : dword; freeoslistcount : dword;
{$ifdef TestFreeLists}
{ this can be turned on by debugger }
const
test_each : boolean = false;
{$endif TestFreeLists}
{***************************************************************************** {*****************************************************************************
Memory Manager Memory Manager
@ -505,41 +493,12 @@ end;
{$endif} {$endif}
{$ifdef TestFreeLists}
procedure TestFreeLists;
var
i,j : ptrint;
mc : pmemchunk_fixed;
begin
for i := 1 to maxblockindex do
begin
j := 0;
mc := freelists_fixed[i];
while assigned(mc) do
begin
inc(j);
if ((mc^.size and fixedsizemask) <> i * blocksize) then
RunError(204);
mc := mc^.next_fixed;
end;
end;
end;
{$endif TestFreeLists}
{***************************************************************************** {*****************************************************************************
List adding/removal List adding/removal
*****************************************************************************} *****************************************************************************}
procedure append_to_list_fixed(blockindex: ptrint; pmc: pmemchunk_fixed); procedure append_to_list_var(pmc: pmemchunk_var);inline;
begin
pmc^.prev_fixed := nil;
pmc^.next_fixed := freelists_fixed[blockindex];
if freelists_fixed[blockindex]<>nil then
freelists_fixed[blockindex]^.prev_fixed := pmc;
freelists_fixed[blockindex] := pmc;
end;
procedure append_to_list_var(pmc: pmemchunk_var);
begin begin
pmc^.prev_var := nil; pmc^.prev_var := nil;
pmc^.next_var := freelist_var; pmc^.next_var := freelist_var;
@ -548,17 +507,7 @@ begin
freelist_var := pmc; freelist_var := pmc;
end; end;
procedure remove_from_list_fixed(blockindex: ptrint; pmc: pmemchunk_fixed); procedure remove_from_list_var(pmc: pmemchunk_var);inline;
begin
if assigned(pmc^.next_fixed) then
pmc^.next_fixed^.prev_fixed := pmc^.prev_fixed;
if assigned(pmc^.prev_fixed) then
pmc^.prev_fixed^.next_fixed := pmc^.next_fixed
else
freelists_fixed[blockindex] := pmc^.next_fixed;
end;
procedure remove_from_list_var(pmc: pmemchunk_var);
begin begin
if assigned(pmc^.next_var) then if assigned(pmc^.next_var) then
pmc^.next_var^.prev_var := pmc^.prev_var; pmc^.next_var^.prev_var := pmc^.prev_var;
@ -572,8 +521,8 @@ procedure append_to_oslist(poc: poschunk);
begin 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 >= MaxKeptOSChunks) if (freeoslistcount >= MaxKeptOSChunks) or
or (poc^.size > growheapsize2) then (poc^.size > growheapsize2) then
begin begin
dec(internal_status.currheapsize, poc^.size); dec(internal_status.currheapsize, poc^.size);
SysOSFree(poc, poc^.size); SysOSFree(poc, poc^.size);
@ -613,16 +562,25 @@ begin
append_to_oslist(poc); append_to_oslist(poc);
end; end;
procedure append_to_oslist_fixed(blockindex, chunksize: ptrint; poc: poschunk); procedure append_to_oslist_fixed(poc: poschunk);
var var
pmc: pmemchunk_fixed; pmc: pmemchunk_fixed;
chunksize,
chunkindex,
i, count: ptrint; i, count: ptrint;
begin begin
count := (poc^.size - sizeof(toschunk)) div chunksize; chunkindex:=poc^.chunkindex;
chunksize:=chunkindex shl blockshift;
pmc := pmemchunk_fixed(pointer(poc)+sizeof(toschunk)); pmc := pmemchunk_fixed(pointer(poc)+sizeof(toschunk));
count := (poc^.size - sizeof(toschunk)) div chunksize;
for i := 0 to count - 1 do for i := 0 to count - 1 do
begin begin
remove_from_list_fixed(blockindex, pmc); if assigned(pmc^.next_fixed) then
pmc^.next_fixed^.prev_fixed := pmc^.prev_fixed;
if assigned(pmc^.prev_fixed) then
pmc^.prev_fixed^.next_fixed := pmc^.next_fixed
else
freelists_fixed[chunkindex] := pmc^.next_fixed;
pmc := pointer(pmc)+chunksize; pmc := pointer(pmc)+chunksize;
end; end;
append_to_oslist(poc); append_to_oslist(poc);
@ -655,6 +613,7 @@ begin
end; end;
end; end;
{***************************************************************************** {*****************************************************************************
Try concat freerecords Try concat freerecords
*****************************************************************************} *****************************************************************************}
@ -751,35 +710,40 @@ end;
Grow Heap Grow Heap
*****************************************************************************} *****************************************************************************}
function alloc_oschunk(blockindex, size: ptrint): pointer; function alloc_oschunk(chunkindex, size: ptrint):pointer;
var var
pmcfirst,
pmclast,
pmc : pmemchunk_fixed; pmc : pmemchunk_fixed;
pmcv : pmemchunk_var; pmcv : pmemchunk_var;
poc : poschunk;
chunksize,
minsize, minsize,
maxsize, maxsize,
i, count : ptrint; i, count : ptrint;
chunksize : ptrint;
begin begin
result:=nil;
chunksize:=chunkindex shl blockshift;
{ increase size by size needed for os block header } { increase size by size needed for os block header }
minsize := size + sizeof(toschunk); minsize := size + sizeof(toschunk);
if blockindex<>0 then if chunkindex<>0 then
maxsize := (size * $ffff) + sizeof(toschunk) maxsize := (chunksize * $ffff) + sizeof(toschunk)
else else
maxsize := high(ptrint); maxsize := high(ptrint);
{ blocks available in freelist? } { blocks available in freelist? }
result := freeoslist; poc := freeoslist;
while result <> nil do while poc <> nil do
begin begin
if (poschunk(result)^.size >= minsize) and if (poc^.size >= minsize) and
(poschunk(result)^.size <= maxsize) then (poc^.size <= maxsize) then
begin begin
size := poschunk(result)^.size; size := poc^.size;
remove_from_oslist(poschunk(result)); remove_from_oslist(poc);
break; break;
end; end;
result := poschunk(result)^.next; poc := poc^.next;
end; end;
if result = nil then if poc = nil then
begin begin
{$ifdef DUMPGROW} {$ifdef DUMPGROW}
writeln('growheap(',size,') allocating ',(size+sizeof(toschunk)+$ffff) and $ffff0000); writeln('growheap(',size,') allocating ',(size+sizeof(toschunk)+$ffff) and $ffff0000);
@ -788,135 +752,131 @@ begin
{ allocate by 64K size } { allocate by 64K size }
size := (size+sizeof(toschunk)+$ffff) and not $ffff; size := (size+sizeof(toschunk)+$ffff) and not $ffff;
{ allocate smaller blocks for fixed-size chunks } { allocate smaller blocks for fixed-size chunks }
if blockindex<>0 then if chunksize<>0 then
begin begin
result := SysOSAlloc(GrowHeapSizeSmall); poc := SysOSAlloc(GrowHeapSizeSmall);
if result<>nil then if poc<>nil then
size := GrowHeapSizeSmall; size := GrowHeapSizeSmall;
end end
{ first try 256K (default) } { first try 256K (default) }
else if size<=GrowHeapSize1 then else if size<=GrowHeapSize1 then
begin
result := SysOSAlloc(GrowHeapSize1);
if result<>nil then
size := GrowHeapSize1;
end
{ second try 1024K (default) }
else if size<=GrowHeapSize2 then
begin
result := SysOSAlloc(GrowHeapSize2);
if result<>nil then
size := GrowHeapSize2;
end
{ else allocate the needed bytes }
else
result := SysOSAlloc(size);
{ try again }
if result=nil then
begin
result := SysOSAlloc(size);
if (result=nil) then
begin begin
if ReturnNilIfGrowHeapFails then poc := SysOSAlloc(GrowHeapSize1);
exit if poc<>nil then
else size := GrowHeapSize1;
HandleError(203); end
{ second try 1024K (default) }
else if size<=GrowHeapSize2 then
begin
poc := SysOSAlloc(GrowHeapSize2);
if poc<>nil then
size := GrowHeapSize2;
end
{ else allocate the needed bytes }
else
poc := SysOSAlloc(size);
{ try again }
if poc=nil then
begin
poc := SysOSAlloc(size);
if (poc=nil) then
begin
if ReturnNilIfGrowHeapFails then
exit
else
HandleError(203);
end;
end; end;
{ set the total new heap size }
inc(internal_status.currheapsize,size);
if internal_status.currheapsize>internal_status.maxheapsize then
internal_status.maxheapsize:=internal_status.currheapsize;
end; end;
{ set the total new heap size }
inc(internal_status.currheapsize,size);
if internal_status.currheapsize>internal_status.maxheapsize then
internal_status.maxheapsize:=internal_status.currheapsize;
end;
{ initialize os-block } { initialize os-block }
poschunk(result)^.used := 0; poc^.used := 0;
poschunk(result)^.size := size; poc^.size := size;
inc(result, sizeof(toschunk)); poc^.chunkindex := chunkindex;
if blockindex<>0 then { initialized oschunck for fixed chunks }
if chunkindex<>0 then
begin begin
{ chop os chunk in fixedsize parts, { chop os chunk in fixedsize parts,
maximum of $ffff elements are allowed, otherwise maximum of $ffff elements are allowed, otherwise
there will be an overflow } there will be an overflow }
chunksize := blockindex shl blockshr;
count := (size-sizeof(toschunk)) div chunksize; count := (size-sizeof(toschunk)) div chunksize;
if count>$ffff then if count>$ffff then
HandleError(204); HandleError(204);
pmc := pmemchunk_fixed(result); { Initialize linkedlist of chunks, the first chunk
pmc^.prev_fixed := nil; is pmemchunk_fixed(poc) and the last chunk will be in pmc at
i := 0; the end of the loop }
repeat pmcfirst := pmemchunk_fixed(pointer(poc)+sizeof(toschunk));
pmc^.size := fixedsizeflag or chunksize or (i shl 16); pmc:=pmcfirst;
pmc^.next_fixed := pointer(pmc)+chunksize; for i:=1 to count do
inc(i); begin
if i < count then pmc^.poc:=poc;
begin pmc^.size:=chunksize or fixedsizeflag;
pmc := pmemchunk_fixed(pointer(pmc)+chunksize); pmc^.prev_fixed := pointer(pmc)-chunksize;
pmc^.prev_fixed := pointer(pmc)-chunksize; pmc^.next_fixed := pointer(pmc)+chunksize;
end pmc := pmemchunk_fixed(pointer(pmc)+chunksize);
else end;
begin { undo last increase to get last chunk }
break; pmclast := pmemchunk_fixed(pointer(pmc)-chunksize);
end; { Add to freelist and fixup first and last chunk }
until false; pmclast^.next_fixed := freelists_fixed[chunkindex];
append_to_list_fixed(blockindex, pmc); if freelists_fixed[chunkindex]<>nil then
pmc^.prev_fixed := pointer(pmc)-chunksize; freelists_fixed[chunkindex]^.prev_fixed := pmclast;
freelists_fixed[blockindex] := pmemchunk_fixed(result); freelists_fixed[chunkindex] := pmcfirst;
pmemchunk_fixed(poc)^.prev_fixed:=nil;
result:=pmcfirst;
end end
else else
begin begin
pmcv := pmemchunk_var(result); pmcv := pmemchunk_var(pointer(poc)+sizeof(toschunk));
append_to_list_var(pmcv); append_to_list_var(pmcv);
pmcv^.size := ((size-sizeof(toschunk)) and sizemask) or (firstblockflag or lastblockflag); pmcv^.size := ((size-sizeof(toschunk)) and sizemask) or (firstblockflag or lastblockflag);
pmcv^.prevsize := 0; pmcv^.prevsize := 0;
result:=pmcv;
end; end;
{$ifdef TestFreeLists}
TestFreeLists;
{$endif TestFreeLists}
end; end;
{***************************************************************************** {*****************************************************************************
SysGetMem SysGetMem
*****************************************************************************} *****************************************************************************}
function SysGetMem_Fixed(size: ptrint): pointer; function SysGetMem_Fixed(size: ptrint): pointer;
var var
pcurr: pmemchunk_fixed; pmc : pmemchunk_fixed;
poc: poschunk; poc : poschunk;
s: ptrint; chunkindex : ptrint;
begin begin
result:=nil; result:=nil;
{ try to find a block in one of the freelists per size } { try to find a block in one of the freelists per size }
s := size shr blockshr; chunkindex := size shr blockshift;
pcurr := freelists_fixed[s]; pmc := freelists_fixed[chunkindex];
{ no free blocks ? } { no free blocks ? }
if not assigned(pcurr) then if not assigned(pmc) then
begin begin
pcurr := alloc_oschunk(s, size); pmc:=alloc_oschunk(chunkindex, size);
if not assigned(pcurr) then if not assigned(pmc) then
exit; exit;
end; end;
{ get a pointer to the block we should return } { get a pointer to the block we should return }
result := pointer(pcurr)+sizeof(tmemchunk_fixed_hdr); result := pointer(pmc)+sizeof(tmemchunk_fixed_hdr);
{ flag as in-use }
pcurr^.size := pcurr^.size or usedflag;
{ update freelist } { update freelist }
freelists_fixed[s] := pcurr^.next_fixed; freelists_fixed[chunkindex] := pmc^.next_fixed;
if assigned(freelists_fixed[s]) then if assigned(freelists_fixed[chunkindex]) then
freelists_fixed[s]^.prev_fixed := nil; freelists_fixed[chunkindex]^.prev_fixed := nil;
poc := poschunk(pointer(pcurr)-((pcurr^.size shr 16)*(pcurr^.size and fixedsizemask)+sizeof(toschunk))); poc := pmc^.poc;
if (poc^.used = 0) then if (poc^.used = 0) then
freelists_free_chunk[s] := false; freelists_free_chunk[chunkindex] := false;
inc(poc^.used); inc(poc^.used);
{ statistics } { statistics }
inc(internal_status.currheapused,size); inc(internal_status.currheapused,size);
if internal_status.currheapused>internal_status.maxheapused then if internal_status.currheapused>internal_status.maxheapused then
internal_status.maxheapused:=internal_status.currheapused; internal_status.maxheapused:=internal_status.currheapused;
{$ifdef TestFreeLists}
if test_each then
TestFreeLists;
{$endif TestFreeLists}
end; end;
function SysGetMem_Var(size: ptrint): pointer; function SysGetMem_Var(size: ptrint): pointer;
var var
pcurr : pmemchunk_var; pcurr : pmemchunk_var;
@ -976,10 +936,6 @@ begin
inc(internal_status.currheapused,size); inc(internal_status.currheapused,size);
if internal_status.currheapused>internal_status.maxheapused then if internal_status.currheapused>internal_status.maxheapused then
internal_status.maxheapused:=internal_status.currheapused; internal_status.maxheapused:=internal_status.currheapused;
{$ifdef TestFreeLists}
if test_each then
TestFreeLists;
{$endif TestFreeLists}
end; end;
function SysGetMem(size : ptrint):pointer; function SysGetMem(size : ptrint):pointer;
@ -998,12 +954,12 @@ begin
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); result := sysgetmem_fixed(size);
end end
else else
begin begin
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask; size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
sysgetmem := sysgetmem_var(size); result := sysgetmem_var(size);
end; end;
end; end;
@ -1012,83 +968,70 @@ end;
SysFreeMem SysFreeMem
*****************************************************************************} *****************************************************************************}
function SysFreeMem_Fixed(pcurr: pmemchunk_fixed; size: ptrint): ptrint; function SysFreeMem_Fixed(pmc: pmemchunk_fixed): ptrint;
var var
pcurrsize: ptrint; chunksize,
blockindex: ptrint; chunkindex : ptrint;
poc: poschunk; poc : poschunk;
begin begin
pcurrsize := pcurr^.size and fixedsizemask; poc := pmc^.poc;
if size<>pcurrsize then chunkindex:=poc^.chunkindex;
HandleError(204); chunksize:=chunkindex shl blockshift;
dec(internal_status.currheapused,pcurrsize); { statistics }
dec(internal_status.currheapused,chunksize);
{ insert the block in it's freelist } { insert the block in it's freelist }
pcurr^.size := pcurr^.size and (not usedflag); pmc^.prev_fixed := nil;
blockindex := pcurrsize shr blockshr; pmc^.next_fixed := freelists_fixed[chunkindex];
append_to_list_fixed(blockindex, pcurr); if freelists_fixed[chunkindex]<>nil then
freelists_fixed[chunkindex]^.prev_fixed := pmc;
freelists_fixed[chunkindex] := pmc;
{ decrease used blocks count } { decrease used blocks count }
poc := poschunk(pointer(pcurr)-(pcurr^.size shr 16)*pcurrsize-sizeof(toschunk));
if poc^.used = 0 then if poc^.used = 0 then
HandleError(204); HandleError(204);
dec(poc^.used); dec(poc^.used);
if poc^.used = 0 then if poc^.used = 0 then
begin begin
if (freelists_free_chunk[blockindex]) then { osblock can be freed? }
// block eligable for freeing if freelists_free_chunk[chunkindex] then
append_to_oslist_fixed(blockindex, pcurrsize, poc) append_to_oslist_fixed(poc)
else else
freelists_free_chunk[blockindex] := true; freelists_free_chunk[chunkindex] := true;
end; end;
SysFreeMem_Fixed := pcurrsize; result := chunksize;
{$ifdef TestFreeLists}
if test_each then
TestFreeLists;
{$endif TestFreeLists}
end; end;
function SysFreeMem_Var(pcurr: pmemchunk_var; size: ptrint): ptrint;
function SysFreeMem_Var(pcurr: pmemchunk_var): ptrint;
var var
pcurrsize: ptrint; chunksize: ptrint;
begin begin
pcurrsize := pcurr^.size and sizemask; chunksize := pcurr^.size and sizemask;
if size<>pcurrsize then dec(internal_status.currheapused,chunksize);
HandleError(204);
dec(internal_status.currheapused,pcurrsize);
{ insert the block in it's freelist } { insert the block in it's freelist }
pcurr^.size := pcurr^.size and (not usedflag); pcurr^.size := pcurr^.size and (not usedflag);
append_to_list_var(pcurr); append_to_list_var(pcurr);
SysFreeMem_Var := pcurrsize; result := chunksize;
pcurr := try_concat_free_chunk(pcurr); pcurr := try_concat_free_chunk(pcurr);
if (pcurr^.size and (firstblockflag or lastblockflag)) = (firstblockflag or lastblockflag) then if (pcurr^.size and (firstblockflag or lastblockflag)) = (firstblockflag or lastblockflag) then
begin
append_to_oslist_var(pcurr); append_to_oslist_var(pcurr);
end;
{$ifdef TestFreeLists}
if test_each then
TestFreeLists;
{$endif TestFreeLists}
end; end;
function SysFreeMem(p: pointer): ptrint; function SysFreeMem(p: pointer): ptrint;
var var
pcurrsize: ptrint; size : ptrint;
begin begin
if p=nil then if p=nil then
begin begin
result:=0; result:=0;
exit; exit;
end; end;
pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size; size := 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 (size and fixedsizeflag) = 0 then
begin result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)))
result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)), pcurrsize and sizemask);
end
else else
begin result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)));
result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)), pcurrsize and fixedsizemask);
end;
end; end;
{***************************************************************************** {*****************************************************************************
@ -1097,7 +1040,7 @@ end;
Function SysFreeMemSize(p: pointer; size: ptrint):ptrint; Function SysFreeMemSize(p: pointer; size: ptrint):ptrint;
var var
pcurrsize: ptrint; chunksize: ptrint;
begin begin
SysFreeMemSize := 0; SysFreeMemSize := 0;
if p=nil then if p=nil then
@ -1109,18 +1052,14 @@ begin
exit; exit;
end; end;
pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size; chunksize := 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. We can't check the passed
if (pcurrsize and fixedsizeflag) = 0 then size parameter since the block can be resized (by reallocmem) to an
begin optimized value that the user doesn't know }
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask; if (chunksize and fixedsizeflag) = 0 then
result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)), size); result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)))
end
else else
begin result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)));
size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask;
result := sysfreemem_fixed(pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr)), size);
end;
end; end;
@ -1130,16 +1069,16 @@ end;
function SysMemSize(p: pointer): ptrint; function SysMemSize(p: pointer): ptrint;
begin begin
SysMemSize := pmemchunk_fixed(pointer(p)-sizeof(tmemchunk_fixed_hdr))^.size; result := pmemchunk_fixed(pointer(p)-sizeof(tmemchunk_fixed_hdr))^.size;
if (SysMemSize and fixedsizeflag) = 0 then if (result and fixedsizeflag) = 0 then
begin begin
SysMemSize := SysMemSize and sizemask; result := SysMemSize and sizemask;
dec(SysMemSize, sizeof(tmemchunk_var_hdr)); dec(result, sizeof(tmemchunk_var_hdr));
end end
else else
begin begin
SysMemSize := SysMemSize and fixedsizemask; result := SysMemSize and fixedsizemask;
dec(SysMemSize, sizeof(tmemchunk_fixed_hdr)); dec(result, sizeof(tmemchunk_fixed_hdr));
end; end;
end; end;
@ -1150,9 +1089,9 @@ end;
function SysAllocMem(size: ptrint): pointer; function SysAllocMem(size: ptrint): pointer;
begin begin
sysallocmem := MemoryManager.GetMem(size); result := MemoryManager.GetMem(size);
if sysallocmem<>nil then if result<>nil then
FillChar(sysallocmem^,MemoryManager.MemSize(sysallocmem),0); FillChar(result^,MemoryManager.MemSize(result),0);
end; end;
@ -1162,7 +1101,7 @@ end;
function SysTryResizeMem(var p: pointer; size: ptrint): boolean; function SysTryResizeMem(var p: pointer; size: ptrint): boolean;
var var
pcurrsize, chunksize,
oldsize, oldsize,
currsize : ptrint; currsize : ptrint;
pcurr : pmemchunk_var; pcurr : pmemchunk_var;
@ -1170,13 +1109,13 @@ begin
SysTryResizeMem := false; SysTryResizeMem := false;
{ fix p to point to the heaprecord } { fix p to point to the heaprecord }
pcurrsize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size; chunksize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size;
{ handle fixed memchuncks separate. Only allow resizes when the { handle fixed memchuncks separate. Only allow resizes when the
new size fits in the same block } new size fits in the same block }
if (pcurrsize and fixedsizeflag) <> 0 then if (chunksize and fixedsizeflag) <> 0 then
begin begin
currsize := pcurrsize and fixedsizemask; currsize := chunksize and fixedsizemask;
{ first check if the size fits in the fixed block range to prevent { first check if the size fits in the fixed block range to prevent
"truncating" the size by the fixedsizemask } "truncating" the size by the fixedsizemask }
@ -1186,24 +1125,19 @@ begin
systryresizemem:=true; systryresizemem:=true;
exit; exit;
end; end;
{ we need to allocate a new fixed or var memchunck } { we need to allocate a new fixed or var memchunck }
exit; exit;
end; end;
{ var memchunck } { var memchunck }
currsize := pcurrsize and sizemask; currsize := chunksize and sizemask;
size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask; size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
{ is the allocated block still correct? } { is the allocated block still correct? }
if (currsize>=size) and (size>(currsize-blocksize)) then if (currsize>=size) and (size>(currsize-blocksize)) then
begin begin
SysTryResizeMem := true; SysTryResizeMem := true;
{$ifdef TestFreeLists} exit;
if test_each then
TestFreeLists;
{$endif TestFreeLists}
exit;
end; end;
{ get pointer to block } { get pointer to block }
@ -1231,11 +1165,6 @@ begin
inc(internal_status.currheapused,size-oldsize); inc(internal_status.currheapused,size-oldsize);
SysTryResizeMem := true; SysTryResizeMem := true;
{$ifdef TestFreeLists}
if test_each then
TestFreeLists;
{$endif TestFreeLists}
end; end;
@ -1245,6 +1174,8 @@ end;
function SysReAllocMem(var p: pointer; size: ptrint):pointer; function SysReAllocMem(var p: pointer; size: ptrint):pointer;
var var
newsize,
oldsize,
minsize : ptrint; minsize : ptrint;
p2 : pointer; p2 : pointer;
begin begin
@ -1267,10 +1198,23 @@ begin
{ Resize block } { Resize block }
if not SysTryResizeMem(p,size) then if not SysTryResizeMem(p,size) then
begin begin
minsize := MemoryManager.MemSize(p); oldsize:=MemoryManager.MemSize(p);
if size < minsize then { Grow with bigger steps to prevent the need for
minsize := size; multiple getmem/freemem calls for fixed blocks. It might cost a bit
p2 := MemoryManager.GetMem(size); of extra memory, but in most cases a reallocmem is done multiple times. }
if oldsize<maxblocksize then
begin
newsize:=oldsize*2+blocksize;
if size>newsize then
newsize:=size;
end
else
newsize:=size;
{ calc size of data to move }
minsize:=oldsize;
if newsize < minsize then
minsize := newsize;
p2 := MemoryManager.GetMem(newsize);
if p2<>nil then if p2<>nil then
Move(p^,p2^,minsize); Move(p^,p2^,minsize);
MemoryManager.FreeMem(p); MemoryManager.FreeMem(p);
@ -1324,5 +1268,3 @@ begin
freeoslistcount := 0; freeoslistcount := 0;
fillchar(internal_status,sizeof(internal_status),0); fillchar(internal_status,sizeof(internal_status),0);
end; end;