From f9df108e03154a56a8400124ef2f372ca724c933 Mon Sep 17 00:00:00 2001 From: florian Date: Fri, 19 May 2006 19:38:37 +0000 Subject: [PATCH] * heaptrc should be multi threading safe now git-svn-id: trunk@3582 - --- .gitattributes | 2 ++ rtl/inc/heaptrc.pp | 77 +++++++++++++++++++++++++++++++----------- tests/webtbs/tw6767.pp | 14 ++++++++ tests/webtbs/uw6767.pp | 48 ++++++++++++++++++++++++++ 4 files changed, 121 insertions(+), 20 deletions(-) create mode 100644 tests/webtbs/tw6767.pp create mode 100644 tests/webtbs/uw6767.pp diff --git a/.gitattributes b/.gitattributes index 298afa9c86..ae9bcb2eac 100644 --- a/.gitattributes +++ b/.gitattributes @@ -6823,6 +6823,7 @@ tests/webtbs/tw6491.pp svneol=native#text/plain tests/webtbs/tw6684.pp svneol=native#text/plain tests/webtbs/tw6735.pp svneol=native#text/plain tests/webtbs/tw6742.pp svneol=native#text/plain +tests/webtbs/tw6767.pp svneol=native#text/plain tests/webtbs/ub1873.pp svneol=native#text/plain tests/webtbs/ub1883.pp svneol=native#text/plain tests/webtbs/uw0555.pp svneol=native#text/plain @@ -6868,6 +6869,7 @@ tests/webtbs/uw4352c.pp svneol=native#text/plain tests/webtbs/uw4352d.pp svneol=native#text/plain tests/webtbs/uw4352e.pp svneol=native#text/plain tests/webtbs/uw4541.pp svneol=native#text/plain +tests/webtbs/uw6767.pp svneol=native#text/plain utils/Makefile svneol=native#text/plain utils/Makefile.fpc svneol=native#text/plain utils/README -text diff --git a/rtl/inc/heaptrc.pp b/rtl/inc/heaptrc.pp index a21bad4b03..9ef063672d 100644 --- a/rtl/inc/heaptrc.pp +++ b/rtl/inc/heaptrc.pp @@ -122,7 +122,7 @@ type end; var - ptext : ^text; + useownfile : boolean; ownfile : text; {$ifdef EXTRA} error_file : text; @@ -321,7 +321,10 @@ begin ((pp^.sig<>calculate_sig(pp)) or not usecrc) and (pp^.sig <>$AAAAAAAA) then begin - writeln(ptext^,'error in linked list of heap_mem_info'); + if useownfile then + writeln(ownfile,'error in linked list of heap_mem_info') + else + writeln(stderr,'error in linked list of heap_mem_info'); RunError(204); end; if pp=p then @@ -329,7 +332,10 @@ begin pp:=pp^.previous; inc(i); if i>getmem_cnt-freemem_cnt then - writeln(ptext^,'error in linked list of heap_mem_info'); + if useownfile then + writeln(ownfile,'error in linked list of heap_mem_info') + else + writeln(stderr,'error in linked list of heap_mem_info'); end; end; @@ -439,7 +445,12 @@ var pp2 : pheap_mem_info; {$endif} extra_size : ptrint; + ptext : ^text; begin + if useownfile then + ptext:=@ownfile + else + ptext:=@stderr; if p=nil then begin TraceFreeMemSize:=0; @@ -579,7 +590,11 @@ begin { this can never happend normaly } if pp^.size>l then begin - dump_wrong_size(pp,l,ptext^); + if useownfile then + dump_wrong_size(pp,l,ownfile) + else + dump_wrong_size(pp,l,stderr); + {$ifdef EXTRA} dump_wrong_size(pp,l,error_file); {$endif EXTRA} @@ -630,7 +645,10 @@ begin ((pp^.sig<>calculate_sig(pp)) or not usecrc) then begin error_in_heap:=true; - dump_error(pp,ptext^); + if useownfile then + dump_error(pp,ownfile) + else + dump_error(pp,stderr); {$ifdef EXTRA} dump_error(pp,error_file); {$endif EXTRA} @@ -771,6 +789,7 @@ var get_ebp,stack_top : longword; data_end : longword; {$endif go32v2} + ptext : ^text; label _exit; begin @@ -779,6 +798,11 @@ begin i:=0; + if useownfile then + ptext:=@ownfile + else + ptext:=@stderr; + {$ifdef go32v2} if ptruint(p)<$1000 then runerror(216); @@ -907,7 +931,12 @@ var i : ptrint; ExpectedHeapFree : ptrint; status : TFPCHeapStatus; + ptext : ^text; begin + if useownfile then + ptext:=@ownfile + else + ptext:=@stderr; pp:=heap_mem_root; Writeln(ptext^,'Heap dump by heaptrc unit'); Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size); @@ -995,10 +1024,10 @@ end; Procedure SetHeapTraceOutput(const name : string); var i : ptrint; begin - if ptext<>@stderr then + if useownfile then begin - ptext:=@stderr; - close(ownfile); + useownfile:=false; + close(ownfile); end; assign(ownfile,name); {$I-} @@ -1006,10 +1035,10 @@ begin if IOResult<>0 then Rewrite(ownfile); {$I+} - ptext:=@ownfile; + useownfile:=true; for i:=0 to Paramcount do - write(ptext^,paramstr(i),' '); - writeln(ptext^); + write(ownfile,paramstr(i),' '); + writeln(ownfile); end; procedure SetHeapExtraInfo( size : ptrint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); @@ -1049,7 +1078,7 @@ begin EntryMemUsed:=initheapstatus.CurrHeapUsed; MakeCRC32Tbl; SetMemoryManager(TraceManager); - ptext:=@stderr; + useownfile:=false; if outputstr <> '' then SetHeapTraceOutput(outputstr); {$ifdef EXTRA} @@ -1067,12 +1096,20 @@ begin ioresult; if (exitcode<>0) and (erroraddr<>nil) then begin - Writeln(ptext^,'No heap dump by heaptrc unit'); - Writeln(ptext^,'Exitcode = ',exitcode); - if ptext<>@stderr then + if useownfile then begin - ptext:=@stderr; - close(ownfile); + Writeln(ownfile,'No heap dump by heaptrc unit'); + Writeln(ownfile,'Exitcode = ',exitcode); + end + else + begin + Writeln(stderr,'No heap dump by heaptrc unit'); + Writeln(stderr,'Exitcode = ',exitcode); + end; + if useownfile then + begin + useownfile:=false; + close(ownfile); end; exit; end; @@ -1083,10 +1120,10 @@ begin {$ifdef EXTRA} Close(error_file); {$endif EXTRA} - if ptext<>@stderr then + if useownfile then begin - ptext:=@stderr; - close(ownfile); + useownfile:=false; + close(ownfile); end; end; diff --git a/tests/webtbs/tw6767.pp b/tests/webtbs/tw6767.pp new file mode 100644 index 0000000000..bc3c962e51 --- /dev/null +++ b/tests/webtbs/tw6767.pp @@ -0,0 +1,14 @@ +{ %OPT=-gl -gh } +program t3; + +uses + Sysutils,uw6767; + + +var + CheckThread : TCheckConnThread; +begin + CheckThread := TCheckConnThread.Create(false); + CheckThread.Terminate; + CheckThread.Waitfor; +end. diff --git a/tests/webtbs/uw6767.pp b/tests/webtbs/uw6767.pp new file mode 100644 index 0000000000..6b8133759c --- /dev/null +++ b/tests/webtbs/uw6767.pp @@ -0,0 +1,48 @@ +Unit uw6767; + +{$mode objfpc}{$H+} + +Interface + +Uses +Classes,Sysutils; + + +Type + TCheckConnThread = Class(TThread) + Private + Protected + Procedure Execute;override; + Public + Constructor Create(CreateSuspended : boolean); + End; + + + + Implementation + + +constructor TCheckConnThread.Create(CreateSuspended : boolean); +Begin + FreeOnTerminate := True; + inherited Create(CreateSuspended); +End; + + + + +Procedure TCheckConnThread.Execute; + +Var + i : Integer; +Begin + While (Not Terminated) Do + Begin + For i:=1 To 100 Do + Begin + If Terminated Then break; + End; + End; +End; + +End.