* heaptrc should be multi threading safe now

git-svn-id: trunk@3582 -

.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

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;
+       useownfile:=false;
-        close(ownfile);
+       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),' ');
+     write(ownfile,paramstr(i),' ');
-   writeln(ptext^);
+   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');
+       if useownfile then
-       Writeln(ptext^,'Exitcode = ',exitcode);
-       if ptext<>@stderr then
          begin
-            ptext:=@stderr;
+           Writeln(ownfile,'No heap dump by heaptrc unit');
-            close(ownfile);
+           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;
+       useownfile:=false;
-        close(ownfile);
+       close(ownfile);
      end;
 end;
 

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.

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.