Problem with threadprivate procedure pointers with gfortran 4.6

[Andrew Benson <abenson at its dot caltech dot edu>]

I'm finding what appears to be incorrect behavior when using threadprivate 
procedure pointers with gfortran 4.6. The problem is reminiscent of a previous 
problem that I had with gfortran 4.4:

http://gcc.gnu.org/ml/fortran/2010-02/msg00080.html

That problem was never tracked down because it didn't occur in 4.5. The new 
problem is similar, but different. I've modified the test case that Janus 
created for the previous problem:

module testMod
  use omp_lib
  private
  public :: Do_Inter_Go
  
  procedure(), pointer :: globalProc
  !$omp threadprivate(globalProc)

contains

  subroutine Do_Inter_Go
    globalProc => null()
    call Get_Proc(globalProc)
    write (0,*) omp_get_thread_num(),loc(globalProc)
    call globalProc()
  end subroutine Do_Inter_Go

  subroutine Get_Proc(assignedProc)
    procedure(), pointer, intent(out) :: assignedProc
    call Give_Me_A_Proc(assignedProc)
  end subroutine Get_Proc

  subroutine Give_Me_A_Proc(assignedProc)
    procedure(), pointer, intent(out) :: assignedProc

    if (omp_get_thread_num() == 0) assignedProc => Proc_To_Call0
    if (omp_get_thread_num() == 1) assignedProc => Proc_To_Call1
  end subroutine Give_Me_A_Proc

  subroutine Proc_To_Call0
    print *,'do task 0'
    if (omp_get_thread_num() /= 0) stop 'wrong thread in Proc_To_Call0'
  end subroutine Proc_To_Call0

  subroutine Proc_To_Call1
    print *,'do task 1'
    if (omp_get_thread_num() /= 1) stop 'wrong thread in Proc_To_Call1'
  end subroutine Proc_To_Call1

end module testMod

program test
  use OMP_Lib
  use testMod
  implicit none

  !$omp parallel
  do while (.true.)
     call Do_Inter_Go
  end do
  !$omp end parallel

end program test


The way this should work (assuming I constructed it correctly) is that the 
call to Give_Me_A_Proc() should return a pointer to Proc_To_CallX where X is 
the OpenMP thread number. That subroutine is then called and checks that it's 
being called from the expected thread - stopping if it isn't. Here's a typical 
result of running (with 2 threads):

$ gfortran -v
Using built-in specs.
COLLECT_GCC=gfortran
COLLECT_LTO_WRAPPER=/usr/libexec/gcc/i686-redhat-linux/4.6.0/lto-wrapper
Target: i686-redhat-linux
Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --
infodir=/usr/share/info --with-bugurl=http://bugzilla.redhat.com/bugzilla --
enable-bootstrap --enable-shared --enable-threads=posix --enable-
checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-
exceptions --enable-gnu-unique-object --enable-linker-build-id --enable-
languages=c,c++,objc,obj-c++,java,fortran,ada,go,lto --enable-plugin --enable-
java-awt=gtk --disable-dssi --with-java-home=/usr/lib/jvm/java-1.5.0-
gcj-1.5.0.0/jre --enable-libgcj-multifile --enable-java-maintainer-mode --
with-ecj-jar=/usr/share/java/eclipse-ecj.jar --disable-libjava-multilib --
with-ppl --with-cloog --with-tune=generic --with-arch=i686 --build=i686-
redhat-linux
Thread model: posix
gcc version 4.6.0 20110603 (Red Hat 4.6.0-10) (GCC)
$ gfortran test.F90 -fopenmp
$ ./a.out 
           0   134514452
 do task 1
           1   134514452
STOP  do task 1
wr           1   134514452
o do task 1
n           1   134514452
g do task 1
            1   134514452
t do task 1
h           1   134514452
r do task 1
e           1   134514452
a do task 1
d           1   134514452
  do task 1
i           1   134514452
n do task 1
            1   134514452
P do task 1
r           1   134514452
o do task 1
c           1   134514452
_ do task 1
T           1   134514452
o do task 1
_           1   134514452
C do task 1
a           1   134514452
l do task 1
l           1   134514452
1 do task 1

           1   134514452
 do task 1

(weird formatting due to the two threads writing simultaneously).

The output of the loc() of the returned procedure shows that it is always the 
same subroutine in each thread - although which subroutine (Proc_To_Call0 or 
Proc_To_Call1) can vary from run to run - presumably depending on which thread 
happens to execute first.

When I encountered the similar problem with 4.4 I wasn't entirely sure that a 
threadprivate procedure pointer was valid (or if it's just an undefined 
situation). Assuming that it is valid, this seems to be a bug. I haven't 
tested this in trunk yet, but I can try that tomorrow.

-Andrew.

-- 

* Andrew Benson: http://www.tapir.caltech.edu/~abenson/contact.html

* Galacticus: http://sites.google.com/site/galacticusmodel