Merged revisions 7429,7551,7588,7617-7618,7678-7680,7771,7789 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r7429 | jonas | 2007-05-23 15:38:20 +0200 (Wed, 23 May 2007) | 2 lines

  * implement CThreadSwitch using sched_yield()

........
r7551 | jonas | 2007-06-02 13:39:59 +0200 (Sat, 02 Jun 2007) | 3 lines

  * disable thread suspension from another thread under *nix, see added
    comments in cthreads.pp why

........
r7588 | jonas | 2007-06-06 17:18:48 +0200 (Wed, 06 Jun 2007) | 7 lines

  * return thread function result via pthread_exit() from CBeginThread
    (Vinzent Hoefler)
  * simplified CWaitForThreadTerminate based on comments from Vinzent
    Hoefler
  * fixed resource leaks where in some cases a pthread would not be
    reaped based on comments from Vinzent Hoefler (resolves #9016)

........
r7617 | jonas | 2007-06-09 22:36:35 +0200 (Sat, 09 Jun 2007) | 2 lines

  * fixed FFreeOnTerminate handing in destructor + better comments

........
r7618 | jonas | 2007-06-09 22:37:26 +0200 (Sat, 09 Jun 2007) | 2 lines

  * fixed important typo in better comments :)

........
r7678 | jonas | 2007-06-16 10:48:13 +0200 (Sat, 16 Jun 2007) | 2 lines

  * ifdef linux -> ifdef unix for cthreads

........
r7679 | jonas | 2007-06-16 11:13:01 +0200 (Sat, 16 Jun 2007) | 2 lines

  + added cwstring unit for unix

........
r7680 | jonas | 2007-06-16 12:02:22 +0200 (Sat, 16 Jun 2007) | 2 lines

  * removed svn:executable property

........
r7771 | jonas | 2007-06-22 16:38:35 +0200 (Fri, 22 Jun 2007) | 2 lines

  + added test (already works)

........
r7789 | jonas | 2007-06-24 14:11:08 +0200 (Sun, 24 Jun 2007) | 2 lines

  * fixed loading the address of class methods (mantis #9139)

........

git-svn-id: branches/fixes_2_2@8430 -

.gitattributes

@@ -8158,6 +8158,9 @@ tests/webtbs/tw9076a.pp svneol=native#text/plain
 tests/webtbs/tw9085.pp svneol=native#text/plain
 tests/webtbs/tw9098.pp svneol=native#text/plain
 tests/webtbs/tw9107.pp svneol=native#text/plain
+tests/webtbs/tw9128.pp svneol=native#text/plain
+tests/webtbs/tw9139.pp svneol=native#text/plain
+tests/webtbs/tw9139a.pp svneol=native#text/plain
 tests/webtbs/tw9174.pp svneol=native#text/plain
 tests/webtbs/tw9179.pp svneol=native#text/plain
 tests/webtbs/tw9187.pp svneol=native#text/plain

compiler/ncgld.pas

@@ -283,7 +283,7 @@ implementation
                       tg.GetTemp(current_asmdata.CurrAsmList,2*sizeof(aint),tt_normal,location.reference);
                       secondpass(left);
 
-                      { load class instance address }
+                      { load class instance/classrefdef address }
                       if left.location.loc=LOC_CONSTANT then
                         location_force_reg(current_asmdata.CurrAsmList,left.location,OS_ADDR,false);
                       case left.location.loc of
@@ -299,7 +299,7 @@ implementation
                          LOC_REFERENCE:
                            begin
                               hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                              if is_class_or_interface(left.resultdef) then
+                              if not is_object(left.resultdef) then
                                 cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,left.location.reference,hregister)
                               else
                                 cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,hregister);
@@ -309,7 +309,7 @@ implementation
                            internalerror(200610311);
                       end;
 
-                      { store the class instance address }
+                      { store the class instance or classredef address }
                       href:=location.reference;
                       inc(href.offset,sizeof(aint));
                       cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,hregister,href);
@@ -318,10 +318,14 @@ implementation
                       if (po_virtualmethod in procdef.procoptions) and
                          not(nf_inherited in flags) then
                         begin
-                          { load vmt pointer }
-                          reference_reset_base(href,hregister,0);
-                          hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                          cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister);
+                          { a classrefdef already points to the VMT }
+                          if (left.resultdef.typ<>classrefdef) then
+                            begin
+                              { load vmt pointer }
+                              reference_reset_base(href,hregister,0);
+                              hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                              cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister);
+                            end;
                           { load method address }
                           reference_reset_base(href,hregister,procdef._class.vmtmethodoffset(procdef.extnumber));
                           hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);

rtl/unix/cthreads.pp

@@ -216,7 +216,7 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
 {$endif DEBUG_MT}
         ThreadMain:=pointer(ti.f(ti.p));
         DoneThread;
-        pthread_exit(nil);
+        pthread_exit(ThreadMain);
       end;
 
 
@@ -282,20 +282,33 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
 
   function  CSuspendThread (threadHandle : TThreadID) : dword;
     begin
-      result := pthread_kill(threadHandle,SIGSTOP);
+    {  pthread_kill(SIGSTOP) cannot be used, because posix-compliant
+       implementations then freeze the entire process instead of only
+       the target thread. Suspending a particular thread is not
+       supported by posix nor by most *nix implementations, presumably
+       because of concerns mentioned in E.4 at
+       http://pauillac.inria.fr/~xleroy/linuxthreads/faq.html#E and in
+       http://java.sun.com/j2se/1.4.2/docs/guide/misc/threadPrimitiveDeprecation.html
+    }
+//      result := pthread_kill(threadHandle,SIGSTOP);
     end;
 
 
   function  CResumeThread  (threadHandle : TThreadID) : dword;
     begin
-      result := pthread_kill(threadHandle,SIGCONT);
+//      result := pthread_kill(threadHandle,SIGCONT);
     end;
 
 
+  procedure sched_yield; cdecl; external 'c' name 'sched_yield';
+
   procedure CThreadSwitch;  {give time to other threads}
     begin
-      {extern int pthread_yield (void) __THROW;}
-      {$Warning ThreadSwitch needs to be implemented}
+      { At least on Mac OS X, the pthread_yield_np calls through to this. }
+      { Further, sched_yield is in POSIX and supported on FreeBSD 4+,     }
+      { Linux, Mac OS X and Solaris, while the thread-specific yield      }
+      { routines are called differently everywhere and non-standard.      }
+      sched_yield;
     end;
 
 
@@ -309,12 +322,9 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
   function  CWaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint) : dword;  {0=no timeout}
     var
       LResultP: Pointer;
-      LResult: DWord;
     begin
-      LResult := 0;
-      LResultP := @LResult;
       pthread_join(pthread_t(threadHandle), @LResultP);
-      CWaitForThreadTerminate := LResult;
+      CWaitForThreadTerminate := dword(LResultP);
     end;
 
 {$warning threadhandle can be larger than a dword}

rtl/unix/tthread.inc

@@ -121,9 +121,11 @@ begin
       WRITE_DEBUG('Thread ',ptrint(lthread),' should be freed');
       LThread.Free;
       WRITE_DEBUG('Thread freed');
-//    tthread.destroy already frees all things and terminates the thread
-//    WRITE_DEBUG('thread func calling EndThread');
-//    EndThread(Result);
+      WRITE_DEBUG('thread func calling EndThread');
+      // we can never come here if the thread has already been joined, because
+      // this function is the thread's main function (so it would have terminated
+      // already in case it was joined)
+      EndThread(Result);
     end
   else
     begin
@@ -144,6 +146,7 @@ begin
     raise EThread.create('Semaphore init failed (possibly too many concurrent threads)');
   FSuspended := CreateSuspended;
   FSuspendedExternal := false;
+  FThreadReaped := false;
   FInitialSuspended := CreateSuspended;
   FFatalException := nil;
   WRITE_DEBUG('creating thread, self = ',longint(self));
@@ -169,22 +172,35 @@ begin
       inherited destroy;
       exit;
     end;
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not FFinished then
-    raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
-  // if someone calls .Free on a thread with
-  // FreeOnTerminate, then don't crash!
-  FFreeOnTerminate := false;
-  if not FFinished then
+  if (FThreadID = GetCurrentThreadID) then
     begin
-      Terminate;
-      if (FInitialSuspended) then
-        Resume;
-      WaitFor;
+      if not(FFreeOnTerminate) and not FFinished then
+        raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
+      FFreeOnTerminate := false;
+    end
+  else
+    begin
+      // if someone calls .Free on a thread with not(FreeOnTerminate), there
+      // is no problem. Otherwise, FreeOnTerminate must be set to false so
+      // when ThreadFunc exits the main runloop, it does not try to Free
+      // itself again
+      FFreeOnTerminate := false;
+      { you can't join yourself, so only for FThreadID<>GetCurrentThreadID }
+      { and you can't join twice -> make sure we didn't join already       }
+      if not FThreadReaped then
+        begin
+          Terminate;
+          if (FInitialSuspended) then
+            Resume;
+          WaitFor;
+        end;
     end;
   CurrentTM.SemaphoreDestroy(FSem);
   FFatalException.Free;
   FFatalException := nil;
-  { threadvars have been released by cthreads.ThreadMain -> DoneThread }
+  { threadvars have been released by cthreads.ThreadMain -> DoneThread, or  }
+  { or will be released (in case of FFreeOnTerminate) after this destructor }
+  { has exited by ThreadFunc->EndThread->cthreads.CEndThread->DoneThread)   }
   inherited Destroy;
 end;
 
@@ -199,34 +215,38 @@ end;
 
 procedure TThread.Suspend;
 begin
-  if not FSuspended and
-     (InterLockedExchange(longint(FSuspended),ord(true)) = ord(false)) then
+  if FThreadID = GetCurrentThreadID then
     begin
-      if FThreadID = GetCurrentThreadID then
+      if not FSuspended and
+         (InterLockedExchange(longint(FSuspended),ord(true)) = ord(false)) then
         CurrentTM.SemaphoreWait(FSem)
-      else
-        begin
-          FSuspendedExternal := true;
-          SuspendThread(FHandle);
-        end;
+    end
+  else
+    begin
+      Raise EThread.create('Suspending one thread from inside another one is unsupported (because it is unsafe and deadlock prone) by *nix and posix operating systems');
+//      FSuspendedExternal := true;
+//      SuspendThread(FHandle);
     end;
 end;
 
 
 procedure TThread.Resume;
 begin
-  if FSuspended and
-     (InterLockedExchange(longint(FSuspended),ord(false)) = ord(true)) then
-    if (not FSuspendedExternal) then
-      begin
-        WRITE_DEBUG('resuming ',ptrint(self));
-        CurrentTM.SemaphorePost(FSem);
-      end
-    else
-      begin
-        FSuspendedExternal := false;
-        ResumeThread(FHandle);
-      end;
+  if (not FSuspendedExternal) then
+    begin
+      if FSuspended and
+         (InterLockedExchange(longint(FSuspended),ord(false)) = ord(true)) then
+        begin
+          WRITE_DEBUG('resuming ',ptrint(self));
+          CurrentTM.SemaphorePost(FSem);
+        end
+    end
+  else
+    begin
+      raise EThread.create('External suspending is not supported under *nix/posix, so trying to resume from from an external suspension should never happen');
+//      FSuspendedExternal := false;
+//      ResumeThread(FHandle);
+    end;
 end;
 
 
@@ -239,6 +259,9 @@ function TThread.WaitFor: Integer;
 begin
   WRITE_DEBUG('waiting for thread ',ptrint(FHandle));
   WaitFor := WaitForThreadTerminate(FHandle, 0);
+  { should actually check for errors in WaitForThreadTerminate, but no }
+  { error api is defined for that function                             }
+  FThreadReaped:=true;
   WRITE_DEBUG('thread terminated');
 end;
 

rtl/win/winsock2.pp

@@ -1,4 +1,12 @@
 { %version=1.1 }
+
+{$ifdef fpc}
+{$ifdef unix}
+uses
+  cwstring;
+{$endif}
+{$endif}
+
 type
   RR = record
     RA : WideString;

tests/test/talign2.pp

@@ -11,15 +11,20 @@ program talign2;
 
 {$ifdef fpc}
 {$mode objfpc}
-  {$ifndef ver1_0}
-    {$define haswidestring}
-  {$endif}
+{$define haswidestring}
 {$else}
   {$ifndef ver70}
     {$define haswidestring}
   {$endif}
 {$endif}
 
+{$ifdef fpc}
+{$ifdef unix}
+uses
+  cwstring;
+{$endif}
+{$endif}
+
 
 procedure test(b : boolean);
 begin

tests/webtbs/tw7006.pp

@@ -2,7 +2,7 @@ program av;
 {$ifdef FPC}{$mode objfpc}{$h+}{$INTERFACES CORBA}{$endif}
 {$ifdef mswindows}{$apptype console}{$endif}
 uses
- {$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}sysutils;
+ {$ifdef FPC}{$ifdef unix}cthreads,cwstring,{$endif}{$endif}sysutils;
 type
  testrecty = record
   str: widestring;

tests/webtbs/tw9128.pp

@@ -0,0 +1,49 @@
+program BUGGY;
+
+{$MODE delphi}
+
+type
+  TImageFormat = (ifIndex8, ifA8R8G8B8);
+
+  TImageData = packed record
+    Width: Integer;
+    Height: Integer;
+    Format: TImageFormat;
+    Size: Integer;
+    Bits: Pointer;
+    Palette: Pointer;
+  end;
+
+  TDynArray = array of TImageData;
+
+procedure ModImage(var Img: TImageData);
+begin
+  Img.Width := 128;
+  Img.Height := 128;
+end;
+
+procedure ArrayStuff(const Arr: TDynArray);
+var
+  I: Integer;
+begin
+  for I := 0 to High(Arr) do
+    ModImage(Arr[I]);
+end;
+
+var
+  MyArr: TDynArray;
+begin
+  SetLength(MyArr, 5);
+  ArrayStuff(MyArr);
+end.
+
+{
+  bug-interror.pas(30,5) Fatal: Internal error 200106041
+  bug-interror.pas(30,5) Fatal: Compilation aborted
+  
+  Error is caused by const parameter in procedure ArrayStuff(const Arr: TDynArray);
+  Doesn't occur when array is var parameter.
+  Only crashed in $MODE DELPHI.
+  Delphi lets you change elements of array even though
+  array is passed as const parameter.
+}

tests/webtbs/tw9139.pp

@@ -0,0 +1,72 @@
+{$mode objfpc}{$H+}
+{.$define second_test}
+
+type
+  TTestClass = class of TTestBase;
+
+  TTestBase = class(TObject)
+  public
+    class function ClassMetadataStr: string;
+    class function InternalMetadataStr: string; virtual;
+  end;
+
+  TTestImpl = class(TTestBase)
+  public
+    class function InternalMetadataStr: string; override;
+  end;
+
+class function TTestBase.ClassMetadataStr: string;
+var
+  VMetadataMethod, VParentMetadataMethod: function: string of object;
+{$ifdef second_test}
+  VClass: TTestClass;
+{$endif}
+begin
+  if Self <> TTestBase then
+  begin
+    writeln('pass 1');
+    VMetadataMethod := @InternalMetadataStr;
+    writeln('pass 2');
+{$ifndef second_test}
+    VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
+{$else}
+    VClass := TTestClass(ClassParent);
+    writeln('pass 2.1');
+    VParentMetadataMethod := @VClass.InternalMetadataStr;
+{$endif}
+    writeln('pass 3');
+    if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
+      begin
+        Result := VParentMetadataMethod();
+        writeln('result: ',result);
+        if Result<>'parent meth' then
+          halt(1);
+      end
+    else
+      halt(2);
+    writeln('pass 4');
+  end else
+    Result := 'base result';
+end;
+
+class function TTestBase.InternalMetadataStr: string;
+begin
+  Result := 'parent meth';
+end;
+
+class function TTestImpl.InternalMetadataStr: string;
+begin
+  Result := 'some stuff';
+end;
+
+var
+  VTestClass: TTestClass;
+begin
+  VTestClass := TTestBase;
+  writeln('TTestBase result:');
+  writeln(VTestClass.ClassMetadataStr);
+  writeln;
+  VTestClass := TTestImpl;
+  writeln('TTestImpl result:');
+  writeln(VTestClass.ClassMetadataStr);
+end.

tests/webtbs/tw9139a.pp

@@ -0,0 +1,72 @@
+{$mode objfpc}{$H+}
+{$define second_test}
+
+type
+  TTestClass = class of TTestBase;
+
+  TTestBase = class(TObject)
+  public
+    class function ClassMetadataStr: string;
+    class function InternalMetadataStr: string; virtual;
+  end;
+
+  TTestImpl = class(TTestBase)
+  public
+    class function InternalMetadataStr: string; override;
+  end;
+
+class function TTestBase.ClassMetadataStr: string;
+var
+  VMetadataMethod, VParentMetadataMethod: function: string of object;
+{$ifdef second_test}
+  VClass: TTestClass;
+{$endif}
+begin
+  if Self <> TTestBase then
+  begin
+    writeln('pass 1');
+    VMetadataMethod := @InternalMetadataStr;
+    writeln('pass 2');
+{$ifndef second_test}
+    VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
+{$else}
+    VClass := TTestClass(ClassParent);
+    writeln('pass 2.1');
+    VParentMetadataMethod := @VClass.InternalMetadataStr;
+{$endif}
+    writeln('pass 3');
+    if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
+      begin
+        Result := VParentMetadataMethod();
+        writeln('result: ',result);
+        if Result<>'parent meth' then
+          halt(1);
+      end
+    else
+      halt(2);
+    writeln('pass 4');
+  end else
+    Result := 'base result';
+end;
+
+class function TTestBase.InternalMetadataStr: string;
+begin
+  Result := 'parent meth';
+end;
+
+class function TTestImpl.InternalMetadataStr: string;
+begin
+  Result := 'some stuff';
+end;
+
+var
+  VTestClass: TTestClass;
+begin
+  VTestClass := TTestBase;
+  writeln('TTestBase result:');
+  writeln(VTestClass.ClassMetadataStr);
+  writeln;
+  VTestClass := TTestImpl;
+  writeln('TTestImpl result:');
+  writeln(VTestClass.ClassMetadataStr);
+end.