paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 22:59:29 +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;
{$ifdef HASGETHEAPSTATUS}
var
status : THeapStatus;
status : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS}
begin
{$ifdef HASGETHEAPSTATUS}
GetHeapStatus(status);
status:=GetFPCHeapStatus;
startmem:=status.CurrHeapUsed;
{$else HASGETHEAPSTATUS}
startmem:=memavail;
@ -386,13 +386,13 @@ implementation
procedure tmemdebug.stop;
{$ifdef HASGETHEAPSTATUS}
var
status : THeapStatus;
status : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS}
begin
{$ifdef HASGETHEAPSTATUS}
if startmem<>0 then
begin
GetHeapStatus(status);
status:=GetFPCHeapStatus;
inc(TotalMem,startmem-status.CurrHeapUsed);
startmem:=0;
end;
@ -2367,7 +2367,10 @@ end;
end.
{
$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
}

9
compiler/comphook.pas
View File

@ -205,7 +205,7 @@ end;
function def_status:boolean;
{$ifdef HASGETHEAPSTATUS}
var
hstatus : THeapStatus;
hstatus : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS}
begin
def_status:=false; { never stop }
@ -218,7 +218,7 @@ begin
if status.currentline>0 then
Write(status.currentline,' ');
{$ifdef HASGETHEAPSTATUS}
GetHeapStatus(hstatus);
hstatus:=GetFPCHeapStatus;
WriteLn(DStr(hstatus.CurrHeapUsed shr 10),'/',DStr(hstatus.CurrHeapSize shr 10),' Kb Used');
{$else HASGETHEAPSTATUS}
WriteLn(DStr(memavail shr 10),'/',DStr(system.heapsize shr 10),' Kb Free');
@ -398,7 +398,10 @@ end;
end.
{
$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
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
starttime : real;
{$ifdef HASGETHEAPSTATUS}
hstatus : THeapStatus;
hstatus : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS}
begin
try
@ -424,7 +424,7 @@ begin
end;
{$ifdef SHOWUSEDMEM}
{$ifdef HASGETHEAPSTATUS}
GetHeapStatus(hstatus);
hstatus:=GetFPCHeapStatus;
Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb');
{$else HASGETHEAPSTATUS}
Writeln('Memory used (heapsize): ',DStr(system.Heapsize shr 10),' Kb');
@ -441,7 +441,10 @@ end;
end.
{
$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
Revision 1.56 2005/02/14 17:13:06 peter

9
fv/gadgets.pas
View File

@ -182,11 +182,11 @@ end;
PROCEDURE THeapView.Update;
{$ifdef HASGETHEAPSTATUS}
var
status : THeapStatus;
status : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS}
BEGIN
{$ifdef HASGETHEAPSTATUS}
GetHeapStatus(status);
status:=GetFPCHeapStatus;
If (OldMem <> status.CurrHeapUsed) Then Begin { Memory differs }
OldMem := status.CurrHeapUsed; { Hold memory avail }
DrawView; { Now redraw }
@ -316,7 +316,10 @@ END;
END.
{
$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
}

9
ide/fpcompil.pas
View File

@ -511,7 +511,7 @@ procedure TCompilerStatusDialog.Update;
var
StatusS,KeyS: string;
{$ifdef HASGETHEAPSTATUS}
hstatus : THeapStatus;
hstatus : TFPCHeapStatus;
{$endif HASGETHEAPSTATUS}
const
MaxFileNameSize = 46;
@ -572,7 +572,7 @@ begin
AddFormatParamInt(Status.CurrentLine);
AddFormatParamInt(Status.CompiledLines);
{$ifdef HASGETHEAPSTATUS}
GetHeapStatus(hstatus);
hstatus:=GetFPCHeapStatus;
AddFormatParamInt(hstatus.CurrHeapUsed div 1024);
AddFormatParamInt(hstatus.CurrHeapSize div 1024);
{$else}
@ -1277,7 +1277,10 @@ end;
end.
{
$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
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))^;
end;
Procedure CGetHeapStatus(var status:THeapStatus);
function CGetHeapStatus:THeapStatus;
var res: THeapStatus;
begin
fillchar(status,sizeof(status),0);
fillchar(res,sizeof(res),0);
CGetHeapStatus:=res;
end;
function CGetFPCHeapStatus:TFPCHeapStatus;
begin
fillchar(CGetFPCHeapStatus,sizeof(CGetFPCHeapStatus),0);
end;
@ -168,6 +177,7 @@ Const
ReallocMem : @CReAllocMem;
MemSize : @CMemSize;
GetHeapStatus : @CGetHeapStatus;
GetFPCHeapStatus: @CGetFPCHeapStatus;
);
Var
@ -183,7 +193,10 @@ end.
{
$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
}

52
rtl/inc/heap.inc
View File

@ -128,7 +128,7 @@ type
pfreelists = ^tfreelists;
var
internal_status : THeapStatus;
internal_status : TFPCHeapStatus;
freelists_fixed : tfreelists;
freelist_var : pmemchunk_var;
@ -259,24 +259,43 @@ begin
end;
procedure GetHeapStatus(var status:THeapStatus);
function GetHeapStatus:THeapStatus;
begin
if IsMultiThread and MemoryManager.NeedLock then
begin
try
MemoryMutexManager.MutexLock;
MemoryManager.GetHeapStatus(status);
result:=MemoryManager.GetHeapStatus();
finally
MemoryMutexManager.MutexUnlock;
end;
end
else
begin
MemoryManager.GetHeapStatus(status);
result:=MemoryManager.GetHeapStatus();
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;
begin
if IsMultiThread and MemoryManager.NeedLock then
@ -466,10 +485,26 @@ end;
GetHeapStatus
*****************************************************************************}
procedure SysGetHeapStatus(var status:THeapStatus);
function SysFPCGetHeapStatus:TFPCHeapStatus;
begin
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;
@ -1286,7 +1321,10 @@ end;
{
$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
Revision 1.42 2005/01/30 11:56:29 peter

45
rtl/inc/heaph.inc
View File

@ -16,30 +16,46 @@
{ Memorymanager }
type
THeapStatus = record
TFPCHeapStatus = record
MaxHeapSize,
MaxHeapUsed,
CurrHeapSize,
CurrHeapUsed,
CurrHeapFree : ptrint;
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;
TMemoryManager = record
NeedLock : boolean;
Getmem : Function(Size:ptrint):Pointer;
Freemem : Function(p:pointer):ptrint;
FreememSize : Function(p:pointer;Size:ptrint):ptrint;
AllocMem : Function(Size:ptrint):Pointer;
ReAllocMem : Function(var p:pointer;Size:ptrint):Pointer;
MemSize : function(p:pointer):ptrint;
GetHeapStatus : procedure(var status:THeapStatus);
NeedLock : boolean;
Getmem : Function(Size:ptrint):Pointer;
Freemem : Function(p:pointer):ptrint;
FreememSize : Function(p:pointer;Size:ptrint):ptrint;
AllocMem : Function(Size:ptrint):Pointer;
ReAllocMem : Function(var p:pointer;Size:ptrint):Pointer;
MemSize : function(p:pointer):ptrint;
GetHeapStatus : function :THeapStatus;
GetFPCHeapStatus : function :TFPCHeapStatus;
end;
TMemoryMutexManager = record
MutexInit : procedure;
MutexDone : procedure;
MutexLock : procedure;
MutexUnlock : procedure;
end;
procedure GetMemoryManager(var MemMgr: TMemoryManager);
procedure SetMemoryManager(const MemMgr: TMemoryManager);
function IsMemoryManagerSet: Boolean;
@ -61,7 +77,8 @@ Function SysMemSize(p:pointer):ptrint;
Function SysAllocMem(size:ptrint):Pointer;
function SysTryResizeMem(var p:pointer;size : ptrint):boolean;
Function SysReAllocMem(var p:pointer;size:ptrint):Pointer;
procedure SysGetHeapStatus(var status:THeapStatus);
function SysGetHeapStatus:THeapStatus;
function SysFPCGetHeapStatus:TFPCHeapStatus;
{ Tp7 functions }
Procedure Getmem(Var p:pointer;Size:ptrint);
@ -80,7 +97,8 @@ function Freememory(p:pointer):ptrint;
function AllocMem(Size:ptrint):pointer;
function ReAllocMem(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}
{ Needed to solve overloading problem with call from assembler (PFV) }
@ -99,7 +117,10 @@ Function Heapsize:ptrint;
{
$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
}

23
rtl/inc/heaptrc.pp
View File

@ -854,14 +854,14 @@ var
pp : pheap_mem_info;
i : ptrint;
ExpectedHeapFree : ptrint;
status : THeapStatus;
status : TFPCHeapStatus;
begin
pp:=heap_mem_root;
Writeln(ptext^,'Heap dump by heaptrc unit');
Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_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);
SysGetHeapStatus(status);
status:=SysFPCGetHeapStatus;
Write(ptext^,'True heap size : ',status.CurrHeapSize);
if EntryMemUsed > 0 then
Writeln(ptext^,' (',EntryMemUsed,' used in System startup)')
@ -938,9 +938,14 @@ end;
No specific tracing calls
*****************************************************************************}
procedure TraceGetHeapStatus(var status:THeapStatus);
function TraceGetHeapStatus:THeapStatus;
begin
SysGetHeapStatus(status);
TraceGetHeapStatus:=SysGetHeapStatus;
end;
function TraceGetFPCHeapStatus:TFPCHeapStatus;
begin
TraceGetFPCHeapStatus:=SysFPCGetHeapStatus;
end;
@ -993,14 +998,15 @@ const
ReAllocMem : @TraceReAllocMem;
MemSize : @TraceMemSize;
GetHeapStatus : @TraceGetHeapStatus;
GetFPCHeapStatus : @TraceGetFPCHeapStatus;
);
procedure TraceInit;
var
initheapstatus : THeapStatus;
initheapstatus : TFPCHeapStatus;
begin
SysGetHeapStatus(initheapstatus);
initheapstatus:=SysFPCGetHeapStatus;
EntryMemUsed:=initheapstatus.CurrHeapUsed;
MakeCRC32Tbl;
SetMemoryManager(TraceManager);
@ -1145,7 +1151,10 @@ finalization
end.
{
$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
Revision 1.38 2005/01/21 15:56:32 peter