From bbb08436c54fbef9b86f0071076239f839bd92aa Mon Sep 17 00:00:00 2001 From: peter Date: Mon, 22 Nov 2004 22:29:26 +0000 Subject: [PATCH] * memavail fixes --- tests/test/tclass5.pp | 2 -- tests/test/texception3.pp | 9 ++++---- tests/test/theap.pp | 21 +++++------------- tests/test/tobject1.pp | 19 +++++++++++------ tests/test/tobject2.pp | 3 --- tests/test/tstring4.pp | 40 +++++++++++----------------------- tests/test/tstring6.pp | 33 +++++++++++----------------- tests/units/erroru.pp | 45 +++++++++++++++++++++++++++++++++++++++ 8 files changed, 94 insertions(+), 78 deletions(-) diff --git a/tests/test/tclass5.pp b/tests/test/tclass5.pp index 1755fbe5d9..785d1e4545 100644 --- a/tests/test/tclass5.pp +++ b/tests/test/tclass5.pp @@ -22,7 +22,6 @@ program test_fail; end; var ta1, ta2 : tarraycla; - availmem : longint; constructor tarraycla.create(do_fail : boolean); begin @@ -63,7 +62,6 @@ program test_fail; end; begin - availmem:=memavail; ta1:=tarraycla.create(false); writeln('Call to ta1.test after successful init'); ta1.test; diff --git a/tests/test/texception3.pp b/tests/test/texception3.pp index 96b3d7a815..fda61cf6a2 100644 --- a/tests/test/texception3.pp +++ b/tests/test/texception3.pp @@ -600,11 +600,11 @@ procedure test119; end; var - startmemavail : longint; - + hstatusstart, + hstatusend : theapstatus; begin writeln('Testing exception handling'); - startmemavail:=memavail; + getheapstatus(hstatusstart); i:=-1; try test1; @@ -769,7 +769,8 @@ begin if i<>2 then do_error(1119); - if memavailhstatusend.Currheapused then begin writeln('exception generates memory holes'); do_error(99999); diff --git a/tests/test/theap.pp b/tests/test/theap.pp index 95d05cec12..871f27d0fe 100644 --- a/tests/test/theap.pp +++ b/tests/test/theap.pp @@ -5,6 +5,8 @@ } PROGRAM TestHeap; +uses + erroru; const {$ifdef cpusparc} @@ -27,8 +29,10 @@ end; procedure ShowHeap; +var + hstatus : THeapstatus; begin - WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail,' Heapsize: ',Heapsize); + WriteLn ('Used: ', hstatus.CurrHeapUsed, ' Free: ', hstatus.CurrHeapFree,' Size: ',hstatus.CurrHeapSize); end; @@ -143,21 +147,6 @@ BEGIN Inc (TotalTime, Delta); WriteLn (Delta:5, ' ms'); ShowHeap; - Start := MSTimer; - FOR L := 1 TO Blocks DO BEGIN - MaxAvail; - END; - Delta := MSTimer-Start; - Inc (TotalTime, (Delta + 5) DIV 10); - WriteLn (Blocks,' calls to MaxAvail: ', Delta:5, ' ms'); - Start := MSTimer; - FOR L := 1 TO Blocks DO BEGIN - MemAvail; - END; - Delta := MSTimer - Start; - Inc (TotalTime, (Delta + 5) DIV 10); - WriteLn (Blocks,' calls to MemAvail: ', Delta:5, ' ms'); - ShowHeap; Write ('Reallocating deallocated ',(Blocks div 2 + 1),' blocks at random: '); Start := MSTimer; FOR L := (Blocks div 2+1) TO Blocks DO BEGIN diff --git a/tests/test/tobject1.pp b/tests/test/tobject1.pp index cc91cb065e..d90e29bd4a 100644 --- a/tests/test/tobject1.pp +++ b/tests/test/tobject1.pp @@ -3,6 +3,9 @@ program test_fail; + uses + erroru; + type parrayobj = ^tarrayobj; tarrayobj = object @@ -64,20 +67,24 @@ program test_fail; end; begin - availmem:=memavail; new(pa1,init(false)); - writeln('After successful new(pa1,init), memory used = ',availmem - memavail); + getheapstatus(hstatus); + writeln('After successful new(pa1,init), memory used = ',hstatus.CurrHeapUsed); new(pa2,init(true)); - writeln('After unsuccessful new(pa2,init), memory used = ',availmem - memavail); + getheapstatus(hstatus); + writeln('After unsuccessful new(pa2,init), memory used = ',hstatus.CurrHeapUsed); writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2)); writeln('Call to pa1^.test after successful init'); pa1^.test; dispose(pa1,done); - writeln('After release of pa1, memory used = ',availmem - memavail); + getheapstatus(hstatus); + writeln('After release of pa1, memory used = ',hstatus.CurrHeapUsed); pa1:=new(pbigarrayobj,good_init); - writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',availmem - memavail); + getheapstatus(hstatus); + writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',hstatus.CurrHeapUsed); pa2:=new(pbigarrayobj,wrong_init); - writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',availmem - memavail); + getheapstatus(hstatus); + writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',hstatus.CurrHeapUsed); writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2)); writeln('Call to pa1^.test after successful init'); pa1^.test; diff --git a/tests/test/tobject2.pp b/tests/test/tobject2.pp index c29e9b4a92..b7b52472a4 100644 --- a/tests/test/tobject2.pp +++ b/tests/test/tobject2.pp @@ -94,10 +94,7 @@ var obj: pbase; devobj: tderived; Begin - WriteLn(MemAvail); obj:=new(pbase,init(10)); obj^.showit; - WriteLn(MemAvail); dispose(obj,done); - WriteLn(MemAvail); end. diff --git a/tests/test/tstring4.pp b/tests/test/tstring4.pp index f062f46612..37ea385659 100644 --- a/tests/test/tstring4.pp +++ b/tests/test/tstring4.pp @@ -1,5 +1,8 @@ Program ansitest; +uses + erroru; + {$ifdef cpu68k} {$define COMP_IS_INT64} {$endif cpu68k} @@ -10,33 +13,11 @@ Program ansitest; {$define COMP_IS_INT64} {$endif FPC_COMP_IS_INT64} -{$ifdef ver1_0} -type - ptrint=longint; - sizeint=longint; -{$endif} - -{$ifndef fpc} -type - ptrint=longint; - sizeint=longint; -Function Memavail : ptrint; -begin - Result:=0; -end; -{$endif} { ------------------------------------------------------------------- General stuff ------------------------------------------------------------------- } -Procedure DoMem (Var StartMem : sizeint); - -begin - Writeln ('Lost ',StartMem-Memavail,' Bytes.'); - StartMem:=MemAvail; -end; - Procedure DoRef (P : Pointer); Type Psizeint = ^sizeint; @@ -142,7 +123,8 @@ Var S : AnsiString; Mem : sizeint; begin - Mem:=MemAvail; + Mem:=0; + DoMem(Mem); S :='This is another ansistring'; Writeln ('Calling testvalparam with "',s,'"'); testvalparam (s); @@ -338,7 +320,8 @@ Var I : Integer; mem : sizeint; begin - mem:=memavail; + mem:=0; + DoMem(mem); S3 := 'ABCDEF'; Write ('S1+S2=S3 :'); If S1+S2=S3 then writeln (ok) else writeln (nok); @@ -381,7 +364,8 @@ Var S,T : AnsiString; Co : Comp; TempMem:sizeint; begin - TempMem:=Memavail; + TempMem:=0; + DoMem(TempMem); S:='ABCDEF'; Write ('S = "',S,'"');Doref(Pointer(S)); T:=Copy(S,1,3); @@ -468,8 +452,10 @@ end; Var GlobalStartMem,StartMem : PtrInt; begin - GlobalStartMem:=MemAvail; - StartMem:=MemAvail; + GlobalStartMem:=0; + StartMem:=0; + DoMem(GlobalStartMem); + DoMem(StartMem); Writeln ('Testing Initialize/Finalize.'); TestInitFinal; Write ('End of Initialize/finalize test : ');DoMem(StartMem); diff --git a/tests/test/tstring6.pp b/tests/test/tstring6.pp index e963af6bdd..133230b55d 100644 --- a/tests/test/tstring6.pp +++ b/tests/test/tstring6.pp @@ -1,25 +1,13 @@ { %VERSION=1.1 } Program widetest; -Function MemUsed : Longint; -begin -{$ifdef fpc} - MemUsed:=Heapsize-Memavail; -{$else} - MemUsed:=0; -{$endif} -end; - +uses + erroru; + { ------------------------------------------------------------------- General stuff ------------------------------------------------------------------- } -Procedure DoMem (Var StartMem : Longint); - -begin - Writeln ('Lost ',StartMem-MemUsed,' Bytes.'); - StartMem:=MemUsed; -end; Procedure DoRef (P : Pointer); @@ -132,7 +120,8 @@ Var S : WideString; Mem : Longint; begin - Mem:=MemUsed; + Mem:=0; + DoMem(Mem); S :='This is another WideString'; Writeln ('Calling testvalparam with "',s,'"'); testvalparam (s); @@ -329,7 +318,8 @@ Var I : Integer; mem : Longint; begin - mem:=MemUsed; + mem:=0; + DoMem(Mem); S3 := 'ABCDEF'; Write ('S1+S2=S3 :'); If S1+S2=S3 then writeln (ok) else writeln (nok); @@ -372,7 +362,8 @@ Var S,T : WideString; Co : Comp; TempMem:Longint; begin - TempMem:=MemUsed; + TempMem:=0; + DoMem(TempMem); S:='ABCDEF'; Write ('S = "',S,'"');Doref(Pointer(S)); T:=Copy(S,1,3); @@ -459,8 +450,10 @@ end; Var GlobalStartMem,StartMem : Longint; begin - GlobalStartMem:=MemUsed; - StartMem:=MemUsed; + GlobalStartMem:=0; + StartMem:=0; + DoMem(GlobalStartMem); + DoMem(StartMem); Writeln ('Testing Initialize/Finalize.'); TestInitFinal; Write ('End of Initialize/finalize test : ');DoMem(StartMem); diff --git a/tests/units/erroru.pp b/tests/units/erroru.pp index 5786b2368b..20068fdc69 100644 --- a/tests/units/erroru.pp +++ b/tests/units/erroru.pp @@ -2,6 +2,13 @@ unit erroru; interface +{$ifdef ver1_0} +type + ptrint=longint; + sizeint=longint; +{$endif} + + procedure do_error(l : longint); procedure error; @@ -10,6 +17,21 @@ interface procedure require_error(num : longint); +{$ifndef HASGETHEAPSTATUS} +type + THeapStatus = record + MaxHeapSize, + MaxHeapUsed, + CurrHeapSize, + CurrHeapUsed, + CurrHeapFree : ptrint; + end; + + procedure getheapstatus(var status:THeapStatus); +{$endif HASGETHEAPSTATUS} + +Procedure DoMem (Var StartMem : sizeint); + implementation @@ -80,6 +102,29 @@ begin end; end; +{$ifndef HASGETHEAPSTATUS} + procedure getheapstatus(var status:THeapStatus); + begin + fillchar(status,sizeof(status),0); + status.MaxHeapSize:=HeapSize; + status.MaxHeapUsed:=HeapSize-MemAvail; + status.CurrHeapSize:=HeapSize; + status.CurrHeapUsed:=HeapSize-MemAvail; + status.CurrHeapFree:=MemAvail; + end; +{$endif HASGETHEAPSTATUS} + + +Procedure DoMem (Var StartMem : sizeint); +var + hstatus : THeapstatus; +begin + GetHeapStatus(hstatus); + if StartMem<>0 then + Writeln ('Used: ',hstatus.CUrrHeapUsed shr 10,'Kb, Lost ',hstatus.CurrHeapUsed-StartMem,' Bytes.'); + StartMem:=hstatus.CurrHeapUsed; +end; + initialization finalization