paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-24 12:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)

Browse Source
This commit is contained in:
marco 2005-02-28 15:38:38 +00:00
parent a8f2c6e5f7
commit daf59fbd7e
9 changed files with 142 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
compiler/cclasses.pas
View File

@ -371,11 +371,11 @@ implementation
procedure tmemdebug.start; procedure tmemdebug.start;
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
var var
status : THeapStatus; status : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS} {$endif HASGETHEAPSTATUS}
begin begin
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
GetHeapStatus(status); status:=GetFPCHeapStatus;
startmem:=status.CurrHeapUsed; startmem:=status.CurrHeapUsed;
{$else HASGETHEAPSTATUS} {$else HASGETHEAPSTATUS}
startmem:=memavail; startmem:=memavail;
@ -386,13 +386,13 @@ implementation
procedure tmemdebug.stop; procedure tmemdebug.stop;
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
var var
status : THeapStatus; status : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS} {$endif HASGETHEAPSTATUS}
begin begin
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
if startmem<>0 then if startmem<>0 then
begin begin
GetHeapStatus(status); status:=GetFPCHeapStatus;
inc(TotalMem,startmem-status.CurrHeapUsed); inc(TotalMem,startmem-status.CurrHeapUsed);
startmem:=0; startmem:=0;
end; end;
@ -2367,7 +2367,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.41 2005-02-14 17:13:06 peter Revision 1.42 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.41 2005/02/14 17:13:06 peter
* truncate log * truncate log
} }

9
compiler/comphook.pas
View File

@ -205,7 +205,7 @@ end;
function def_status:boolean; function def_status:boolean;
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
var var
hstatus : THeapStatus; hstatus : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS} {$endif HASGETHEAPSTATUS}
begin begin
def_status:=false; { never stop } def_status:=false; { never stop }
@ -218,7 +218,7 @@ begin
if status.currentline>0 then if status.currentline>0 then
Write(status.currentline,' '); Write(status.currentline,' ');
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
GetHeapStatus(hstatus); hstatus:=GetFPCHeapStatus;
WriteLn(DStr(hstatus.CurrHeapUsed shr 10),'/',DStr(hstatus.CurrHeapSize shr 10),' Kb Used'); WriteLn(DStr(hstatus.CurrHeapUsed shr 10),'/',DStr(hstatus.CurrHeapSize shr 10),' Kb Used');
{$else HASGETHEAPSTATUS} {$else HASGETHEAPSTATUS}
WriteLn(DStr(memavail shr 10),'/',DStr(system.heapsize shr 10),' Kb Free'); WriteLn(DStr(memavail shr 10),'/',DStr(system.heapsize shr 10),' Kb Free');
@ -398,7 +398,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.36 2005-02-14 17:13:06 peter Revision 1.37 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.36 2005/02/14 17:13:06 peter
* truncate log * truncate log
Revision 1.35 2005/01/24 18:12:17 olle Revision 1.35 2005/01/24 18:12:17 olle

9
compiler/compiler.pas
View File

@ -367,7 +367,7 @@ function Compile(const cmd:string):longint;
var var
starttime : real; starttime : real;
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
hstatus : THeapStatus; hstatus : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS} {$endif HASGETHEAPSTATUS}
begin begin
try try
@ -424,7 +424,7 @@ begin
end; end;
{$ifdef SHOWUSEDMEM} {$ifdef SHOWUSEDMEM}
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
GetHeapStatus(hstatus); hstatus:=GetFPCHeapStatus;
Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb'); Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb');
{$else HASGETHEAPSTATUS} {$else HASGETHEAPSTATUS}
Writeln('Memory used (heapsize): ',DStr(system.Heapsize shr 10),' Kb'); Writeln('Memory used (heapsize): ',DStr(system.Heapsize shr 10),' Kb');
@ -441,7 +441,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.57 2005-02-15 19:15:45 peter Revision 1.58 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.57 2005/02/15 19:15:45 peter
* Handle Control-C exception more cleanly * Handle Control-C exception more cleanly
Revision 1.56 2005/02/14 17:13:06 peter Revision 1.56 2005/02/14 17:13:06 peter

9
fv/gadgets.pas
View File

@ -182,11 +182,11 @@ end;
PROCEDURE THeapView.Update; PROCEDURE THeapView.Update;
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
var var
status : THeapStatus; status : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS} {$endif HASGETHEAPSTATUS}
BEGIN BEGIN
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
GetHeapStatus(status); status:=GetFPCHeapStatus;
If (OldMem <> status.CurrHeapUsed) Then Begin { Memory differs } If (OldMem <> status.CurrHeapUsed) Then Begin { Memory differs }
OldMem := status.CurrHeapUsed; { Hold memory avail } OldMem := status.CurrHeapUsed; { Hold memory avail }
DrawView; { Now redraw } DrawView; { Now redraw }
@ -316,7 +316,10 @@ END;
END. END.
{ {
$Log$ $Log$
Revision 1.10 2005-02-14 17:13:18 peter Revision 1.11 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.10 2005/02/14 17:13:18 peter
* truncate log * truncate log
} }

9
ide/fpcompil.pas
View File

@ -511,7 +511,7 @@ procedure TCompilerStatusDialog.Update;
var var
StatusS,KeyS: string; StatusS,KeyS: string;
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
hstatus : THeapStatus; hstatus : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS} {$endif HASGETHEAPSTATUS}
const const
MaxFileNameSize = 46; MaxFileNameSize = 46;
@ -572,7 +572,7 @@ begin
AddFormatParamInt(Status.CurrentLine); AddFormatParamInt(Status.CurrentLine);
AddFormatParamInt(Status.CompiledLines); AddFormatParamInt(Status.CompiledLines);
{$ifdef HASGETHEAPSTATUS} {$ifdef HASGETHEAPSTATUS}
GetHeapStatus(hstatus); hstatus:=GetFPCHeapStatus;
AddFormatParamInt(hstatus.CurrHeapUsed div 1024); AddFormatParamInt(hstatus.CurrHeapUsed div 1024);
AddFormatParamInt(hstatus.CurrHeapSize div 1024); AddFormatParamInt(hstatus.CurrHeapSize div 1024);
{$else} {$else}
@ -1277,7 +1277,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.36 2005-02-14 17:13:18 peter Revision 1.37 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.36 2005/02/14 17:13:18 peter
* truncate log * truncate log
Revision 1.35 2005/02/10 20:57:02 peter Revision 1.35 2005/02/10 20:57:02 peter

19
rtl/inc/cmem.pp
View File

@ -150,10 +150,19 @@ begin
CMemSize:=pptrint(p-sizeof(ptrint))^; CMemSize:=pptrint(p-sizeof(ptrint))^;
end; end;
Procedure CGetHeapStatus(var status:THeapStatus); function CGetHeapStatus:THeapStatus;
var res: THeapStatus;
begin begin
fillchar(status,sizeof(status),0); fillchar(res,sizeof(res),0);
CGetHeapStatus:=res;
end;
function CGetFPCHeapStatus:TFPCHeapStatus;
begin
fillchar(CGetFPCHeapStatus,sizeof(CGetFPCHeapStatus),0);
end; end;
@ -168,6 +177,7 @@ Const
ReallocMem : @CReAllocMem; ReallocMem : @CReAllocMem;
MemSize : @CMemSize; MemSize : @CMemSize;
GetHeapStatus : @CGetHeapStatus; GetHeapStatus : @CGetHeapStatus;
GetFPCHeapStatus: @CGetFPCHeapStatus;
); );
Var Var
@ -183,7 +193,10 @@ end.
{ {
$Log$ $Log$
Revision 1.12 2005-02-14 17:13:22 peter Revision 1.13 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.12 2005/02/14 17:13:22 peter
* truncate log * truncate log
} }

52
rtl/inc/heap.inc
View File

@ -128,7 +128,7 @@ type
pfreelists = ^tfreelists; pfreelists = ^tfreelists;
var var
internal_status : THeapStatus; internal_status : TFPCHeapStatus;
freelists_fixed : tfreelists; freelists_fixed : tfreelists;
freelist_var : pmemchunk_var; freelist_var : pmemchunk_var;
@ -259,24 +259,43 @@ begin
end; end;
procedure GetHeapStatus(var status:THeapStatus); function GetHeapStatus:THeapStatus;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
try try
MemoryMutexManager.MutexLock; MemoryMutexManager.MutexLock;
MemoryManager.GetHeapStatus(status); result:=MemoryManager.GetHeapStatus();
finally finally
MemoryMutexManager.MutexUnlock; MemoryMutexManager.MutexUnlock;
end; end;
end end
else else
begin begin
MemoryManager.GetHeapStatus(status); result:=MemoryManager.GetHeapStatus();
end; end;
end; end;
function GetFPCHeapStatus:TFPCHeapStatus;
begin
if IsMultiThread and MemoryManager.NeedLock then
begin
try
MemoryMutexManager.MutexLock;
result:=MemoryManager.GetFPCHeapStatus();
finally
MemoryMutexManager.MutexUnlock;
end;
end
else
begin
Result:=MemoryManager.GetFPCHeapStatus();
end;
end;
function MemSize(p:pointer):ptrint; function MemSize(p:pointer):ptrint;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
@ -466,10 +485,26 @@ end;
GetHeapStatus GetHeapStatus
*****************************************************************************} *****************************************************************************}
procedure SysGetHeapStatus(var status:THeapStatus); function SysFPCGetHeapStatus:TFPCHeapStatus;
begin begin
internal_status.CurrHeapFree:=internal_status.CurrHeapSize-internal_status.CurrHeapUsed; internal_status.CurrHeapFree:=internal_status.CurrHeapSize-internal_status.CurrHeapUsed;
status:=internal_status; result:=internal_status;
end;
function SysGetHeapStatus :THeapStatus;
begin
internal_status.CurrHeapFree:=internal_status.CurrHeapSize-internal_status.CurrHeapUsed;
result.TotalAllocated :=internal_status.CurrHeapUsed;
result.TotalFree :=internal_status.CurrHeapFree;
result.TotalAddrSpace :=0;
result.TotalUncommitted :=0;
result.TotalCommitted :=0;
result.FreeSmall :=0;
result.FreeBig :=0;
result.Unused :=0;
result.Overhead :=0;
result.HeapErrorCode :=0;
end; end;
@ -1286,7 +1321,10 @@ end;
{ {
$Log$ $Log$
Revision 1.43 2005-02-14 17:13:22 peter Revision 1.44 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.43 2005/02/14 17:13:22 peter
* truncate log * truncate log
Revision 1.42 2005/01/30 11:56:29 peter Revision 1.42 2005/01/30 11:56:29 peter

45
rtl/inc/heaph.inc
View File

@ -16,30 +16,46 @@
{ Memorymanager } { Memorymanager }
type type
THeapStatus = record TFPCHeapStatus = record
MaxHeapSize, MaxHeapSize,
MaxHeapUsed, MaxHeapUsed,
CurrHeapSize, CurrHeapSize,
CurrHeapUsed, CurrHeapUsed,
CurrHeapFree : ptrint; CurrHeapFree : ptrint;
end; end;
THeapStatus = record
TotalAddrSpace: Cardinal;
TotalUncommitted: Cardinal;
TotalCommitted: Cardinal;
TotalAllocated: Cardinal;
TotalFree: Cardinal;
FreeSmall: Cardinal;
FreeBig: Cardinal;
Unused: Cardinal;
Overhead: Cardinal;
HeapErrorCode: Cardinal;
end;
PMemoryManager = ^TMemoryManager; PMemoryManager = ^TMemoryManager;
TMemoryManager = record TMemoryManager = record
NeedLock : boolean; NeedLock : boolean;
Getmem : Function(Size:ptrint):Pointer; Getmem : Function(Size:ptrint):Pointer;
Freemem : Function(p:pointer):ptrint; Freemem : Function(p:pointer):ptrint;
FreememSize : Function(p:pointer;Size:ptrint):ptrint; FreememSize : Function(p:pointer;Size:ptrint):ptrint;
AllocMem : Function(Size:ptrint):Pointer; AllocMem : Function(Size:ptrint):Pointer;
ReAllocMem : Function(var p:pointer;Size:ptrint):Pointer; ReAllocMem : Function(var p:pointer;Size:ptrint):Pointer;
MemSize : function(p:pointer):ptrint; MemSize : function(p:pointer):ptrint;
GetHeapStatus : procedure(var status:THeapStatus); GetHeapStatus : function :THeapStatus;
GetFPCHeapStatus : function :TFPCHeapStatus;
end; end;
TMemoryMutexManager = record TMemoryMutexManager = record
MutexInit : procedure; MutexInit : procedure;
MutexDone : procedure; MutexDone : procedure;
MutexLock : procedure; MutexLock : procedure;
MutexUnlock : procedure; MutexUnlock : procedure;
end; end;
procedure GetMemoryManager(var MemMgr: TMemoryManager); procedure GetMemoryManager(var MemMgr: TMemoryManager);
procedure SetMemoryManager(const MemMgr: TMemoryManager); procedure SetMemoryManager(const MemMgr: TMemoryManager);
function IsMemoryManagerSet: Boolean; function IsMemoryManagerSet: Boolean;
@ -61,7 +77,8 @@ Function SysMemSize(p:pointer):ptrint;
Function SysAllocMem(size:ptrint):Pointer; Function SysAllocMem(size:ptrint):Pointer;
function SysTryResizeMem(var p:pointer;size : ptrint):boolean; function SysTryResizeMem(var p:pointer;size : ptrint):boolean;
Function SysReAllocMem(var p:pointer;size:ptrint):Pointer; Function SysReAllocMem(var p:pointer;size:ptrint):Pointer;
procedure SysGetHeapStatus(var status:THeapStatus); function SysGetHeapStatus:THeapStatus;
function SysFPCGetHeapStatus:TFPCHeapStatus;
{ Tp7 functions } { Tp7 functions }
Procedure Getmem(Var p:pointer;Size:ptrint); Procedure Getmem(Var p:pointer;Size:ptrint);
@ -80,7 +97,8 @@ function Freememory(p:pointer):ptrint;
function AllocMem(Size:ptrint):pointer; function AllocMem(Size:ptrint):pointer;
function ReAllocMem(var p:pointer;Size:ptrint):pointer; function ReAllocMem(var p:pointer;Size:ptrint):pointer;
function ReAllocMemory(var p:pointer;Size:ptrint):pointer; function ReAllocMemory(var p:pointer;Size:ptrint):pointer;
procedure GetHeapStatus(var status:THeapStatus); function GetHeapStatus:THeapStatus;
function GetFPCHeapStatus:TFPCHeapStatus;
{$ifndef ValueGetmem} {$ifndef ValueGetmem}
{ Needed to solve overloading problem with call from assembler (PFV) } { Needed to solve overloading problem with call from assembler (PFV) }
@ -99,7 +117,10 @@ Function Heapsize:ptrint;
{ {
$Log$ $Log$
Revision 1.13 2005-02-14 17:13:22 peter Revision 1.14 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.13 2005/02/14 17:13:22 peter
* truncate log * truncate log
} }

23
rtl/inc/heaptrc.pp
View File

@ -854,14 +854,14 @@ var
pp : pheap_mem_info; pp : pheap_mem_info;
i : ptrint; i : ptrint;
ExpectedHeapFree : ptrint; ExpectedHeapFree : ptrint;
status : THeapStatus; status : TFPCHeapStatus;
begin begin
pp:=heap_mem_root; pp:=heap_mem_root;
Writeln(ptext^,'Heap dump by heaptrc unit'); Writeln(ptext^,'Heap dump by heaptrc unit');
Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size); Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size);
Writeln(ptext^,freemem_cnt,' memory blocks freed : ',freemem_size,'/',freemem8_size); Writeln(ptext^,freemem_cnt,' memory blocks freed : ',freemem_size,'/',freemem8_size);
Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size); Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size);
SysGetHeapStatus(status); status:=SysFPCGetHeapStatus;
Write(ptext^,'True heap size : ',status.CurrHeapSize); Write(ptext^,'True heap size : ',status.CurrHeapSize);
if EntryMemUsed > 0 then if EntryMemUsed > 0 then
Writeln(ptext^,' (',EntryMemUsed,' used in System startup)') Writeln(ptext^,' (',EntryMemUsed,' used in System startup)')
@ -938,9 +938,14 @@ end;
No specific tracing calls No specific tracing calls
*****************************************************************************} *****************************************************************************}
procedure TraceGetHeapStatus(var status:THeapStatus); function TraceGetHeapStatus:THeapStatus;
begin begin
SysGetHeapStatus(status); TraceGetHeapStatus:=SysGetHeapStatus;
end;
function TraceGetFPCHeapStatus:TFPCHeapStatus;
begin
TraceGetFPCHeapStatus:=SysFPCGetHeapStatus;
end; end;
@ -993,14 +998,15 @@ const
ReAllocMem : @TraceReAllocMem; ReAllocMem : @TraceReAllocMem;
MemSize : @TraceMemSize; MemSize : @TraceMemSize;
GetHeapStatus : @TraceGetHeapStatus; GetHeapStatus : @TraceGetHeapStatus;
GetFPCHeapStatus : @TraceGetFPCHeapStatus;
); );
procedure TraceInit; procedure TraceInit;
var var
initheapstatus : THeapStatus; initheapstatus : TFPCHeapStatus;
begin begin
SysGetHeapStatus(initheapstatus); initheapstatus:=SysFPCGetHeapStatus;
EntryMemUsed:=initheapstatus.CurrHeapUsed; EntryMemUsed:=initheapstatus.CurrHeapUsed;
MakeCRC32Tbl; MakeCRC32Tbl;
SetMemoryManager(TraceManager); SetMemoryManager(TraceManager);
@ -1145,7 +1151,10 @@ finalization
end. end.
{ {
$Log$ $Log$
Revision 1.39 2005-02-14 17:13:22 peter Revision 1.40 2005-02-28 15:38:38 marco
* getFPCheapstatus (no, FPC HEAP, not FP CHEAP!)
Revision 1.39 2005/02/14 17:13:22 peter
* truncate log * truncate log
Revision 1.38 2005/01/21 15:56:32 peter Revision 1.38 2005/01/21 15:56:32 peter