Fix/workraround for mock mpi testing

The use of link-time polymorphism to mock MPI has always been a bit risky. It looks lik recent changes in NAG and/or OpenMPI necessitate some changes. Some are generally good on their own. But there is some risk this is now less portable to other flavors of MPI. Since the hack only affects tests, we can restrict CI testing to only be OpenMPI in the worst case.
Goddard-Fortran-Ecosystem · Mar 7, 2024 · 4d06968 · 4d06968
1 parent 78ad950
commit 4d06968
Show file tree

Hide file tree

Showing 6 changed files with 93 additions and 85 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -7,6 +7,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+### Fixed
+
+- Recent changes in NAG and/or OpenMPI broke the kludge that allow use of a mock MPI layer for testing
+  locks within pFlogger.
+
 ## [1.13.0] - 2024-03-03
 
 ### Added

diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
@@ -80,7 +80,8 @@ if (MPI_FOUND)
   if (PFUNIT_FOUND)
     add_library (mock-mpi MockMpi.F90)
     set_target_properties(mock-mpi PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mock-mpi)
-    target_include_directories (mock-mpi PUBLIC ${MPI_Fortran_INCLUDE_DIRS} ${CMAKE_CURRENT_BINARY_DIR}/mock-mpi)
+    #    target_include_directories (mock-mpi PUBLIC ${MPI_Fortran_INCLUDE_DIRS} ${CMAKE_CURRENT_BINARY_DIR}/mock-mpi)
+    target_include_directories (mock-mpi PUBLIC ${CMAKE_CURRENT_BINARY_DIR}/mock-mpi)
     target_include_directories (mock-mpi PUBLIC ${CMAKE_CURRENT_BINARY_DIR})
     target_link_libraries (mock-mpi PUBLIC PFUNIT::funit)
     if (SUPPORT_FOR_C_LOC_ASSUMED_SIZE)

diff --git a/src/MockMpi.F90 b/src/MockMpi.F90
@@ -1,21 +1,72 @@
-module mpi_base
-   include 'mpif.h'
-end module mpi_base
-
-module MockMpi_mod
+module mpi
+   use, intrinsic :: iso_fortran_env, only: INT64
    use funit
    implicit none
    private
 
-   public :: MockMpi
    public :: mocker
 
    public :: set_mpi_rank
    public :: set_mpi_size
-   public :: set_mpi_get
-   public :: set_mpi_recv
-   public :: set_mpi_send
    public :: verify
+
+   public :: MPI_ADDRESS_KIND
+   public :: MPI_STATUS_SIZE
+   public :: MPI_STATUS_IGNORE
+   public :: MPI_LOGICAL
+   public :: MPI_SUCCESS
+   public :: MPI_INFO_NULL
+   public :: MPI_ANY_SOURCE
+
+   integer, parameter :: MPI_ADDRESS_KIND = INT64
+   integer, parameter :: MPI_STATUS_SIZE = 1
+   integer, parameter :: MPI_STATUS_IGNORE(MPI_STATUS_SIZE) = [0]
+   integer, parameter :: MPI_LOGICAL = 9
+   integer, parameter :: MPI_SUCCESS = 0
+   integer, parameter :: MPI_INFO_NULL = 0
+   integer, parameter :: MPI_ANY_SOURCE = -1
+
+
+   public :: MPI_Alloc_mem
+   public :: MPI_Type_indexed
+   public :: MPI_Type_Commit
+
+
+   ! Because this interface is overloaded (in theory), it cannot
+   ! be accessed through "include 'mpif.h'".
+   ! As such, we can include it in the mock implementation.
+
+   interface MPI_Alloc_mem
+      subroutine MPI_Alloc_mem_cptr(size, info, baseptr, ierror)
+         use iso_c_binding, only: c_ptr, c_loc
+         use iso_fortran_env, only: INT8
+         import MPI_ADDRESS_KIND
+         integer info, ierror
+         integer(kind=MPI_ADDRESS_KIND) size
+         type (c_ptr), intent(out) :: baseptr
+      end subroutine MPI_Alloc_mem_cptr
+   end interface
+
+   interface MPI_Type_indexed
+      subroutine MPI_Type_indexed(count, array_of_blocklengths, &
+         array_of_displacements, oldtype, newtype, ierror)
+         integer, intent(in) :: count, array_of_blocklengths(*)
+         integer, intent(in) :: array_of_displacements(*), oldtype
+         integer, intent(out) :: newtype
+         integer, intent(out) :: ierror
+      end subroutine MPI_TYPE_INDEXED
+   end interface MPI_Type_indexed
+
+   interface MPI_Type_Commit
+      subroutine MPI_Type_commit(datatype, ierror)
+         !   use mpi_base
+         integer, intent(in) :: datatype
+         integer, intent(out) :: ierror
+
+      end subroutine MPI_Type_commit
+   end interface MPI_Type_Commit
+
+
 
    type MockMpi
       integer :: rank
@@ -40,7 +91,6 @@ module MockMpi_mod
 contains
 
 
-
    subroutine reset(this)
       class (MockMpi), intent(inout) :: this
       this%call_count = 0
@@ -53,8 +103,8 @@ subroutine reset(this)
       this%mpi_get_call_count = 0
    end subroutine reset
 
-
-   subroutine set_mpi_rank(rank)
+ 
+subroutine set_mpi_rank(rank)
       integer, intent(in) :: rank
 
       mocker%rank = rank
@@ -109,36 +159,14 @@ subroutine verify()
       call mocker%reset()
    end subroutine verify
 
-end module MockMpi_mod
-
-
-
-module mpi
-   use mpi_base
-   use MockMpi_mod
-
-
-   ! Because this interface is overloaded (in theory), it cannot
-   ! be accessed through "include 'mpif.h'".
-   ! As such, we can include it in the mock implementation.
 
-   interface MPI_Alloc_mem
-      subroutine MPI_Alloc_mem_cptr(size, info, baseptr, ierror)
-         use mpi_base
-         use iso_c_binding, only: c_ptr, c_loc
-         use iso_fortran_env, only: INT8
-         integer info, ierror
-         integer(kind=MPI_ADDRESS_KIND) size
-         type (c_ptr), intent(out) :: baseptr
-      end subroutine MPI_Alloc_mem_cptr
-   end interface
+
 
 end module mpi
 
 ! Implicit interface for actual subroutines
 subroutine MPI_Comm_rank(comm, rank, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer, intent(in) :: comm
    integer, intent(out) :: rank
    integer, intent(inout) :: ierror
@@ -153,8 +181,7 @@ end subroutine MPI_Comm_rank
 
 ! Implicit interface for actual subroutines
 subroutine MPI_Comm_size(comm, size, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer, intent(in) :: comm
    integer, intent(out) :: size
    integer, intent(inout) :: ierror
@@ -167,16 +194,14 @@ subroutine MPI_Comm_size(comm, size, ierror)
 end subroutine MPI_Comm_size
 
 subroutine MPI_Win_free(win, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer win, ierror
    ierror = MPI_SUCCESS
    mocker%call_count = mocker%call_count + 1
 end subroutine MPI_Win_free
 
 subroutine MPI_Win_lock(lock_type, rank, assert, win, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer, intent(in) :: lock_type
    integer, intent(in) :: rank
    integer, intent(in) :: assert
@@ -191,8 +216,7 @@ end subroutine MPI_Win_lock
 
 
 subroutine MPI_Win_unlock(rank, win, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer, intent(in) :: rank
    integer, intent(in) :: win
    integer, intent(out) :: ierror
@@ -204,8 +228,7 @@ end subroutine MPI_Win_unlock
 
 subroutine MPI_Get(origin_addr, origin_count, origin_datatype, target_rank, &
      & target_disp, target_count, target_datatype, win, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    use iso_c_binding, only: c_ptr, c_loc, c_f_pointer
 #ifdef SUPPORT_FOR_ASSUMED_TYPE   
    type(*) :: origin_addr(*)
@@ -236,8 +259,7 @@ end subroutine MPI_Get
 
 subroutine MPI_Put(origin_addr, origin_count, origin_datatype, target_rank, &
      & target_disp, target_count, target_datatype, win, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
 #ifdef SUPPORT_FOR_ASSUMED_TYPE   
    type(*) :: origin_addr(*)
 #else
@@ -252,8 +274,7 @@ subroutine MPI_Put(origin_addr, origin_count, origin_datatype, target_rank, &
 end subroutine MPI_Put
 
 subroutine MPI_Recv(buf, count, datatype, source, tag, comm, status, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
 #ifdef SUPPORT_FOR_ASSUMED_TYPE   
    type(*) :: buf(*)
 #else
@@ -269,8 +290,7 @@ subroutine MPI_Recv(buf, count, datatype, source, tag, comm, status, ierror)
 end subroutine MPI_Recv
 
 subroutine MPI_Send(buf, count, datatype, dest, tag, comm, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
 #ifdef SUPPORT_FOR_ASSUMED_TYPE   
    type(*) :: buf(*)
 #else
@@ -284,8 +304,7 @@ subroutine MPI_Send(buf, count, datatype, dest, tag, comm, ierror)
 end subroutine MPI_Send
 
 subroutine MPI_Alloc_mem(size, info, baseptr, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi, only: MPI_ADDRESS_KIND
    use iso_c_binding, only: c_ptr, c_loc
    use iso_fortran_env, only: INT8
 
@@ -300,8 +319,7 @@ subroutine MPI_Alloc_mem(size, info, baseptr, ierror)
 end subroutine MPI_Alloc_mem
 
 subroutine MPI_Alloc_mem_cptr(size, info, baseptr, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi, only: mocker, MPI_ADDRESS_KIND
    use iso_c_binding, only: c_ptr, c_loc
    use iso_fortran_env, only: INT8
 
@@ -323,8 +341,7 @@ end subroutine MPI_Alloc_mem_cptr
 
 ! just a stub
 subroutine MPI_Comm_free(comm, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer, intent(in) :: comm
    integer ierror
 
@@ -333,8 +350,7 @@ subroutine MPI_Comm_free(comm, ierror)
 end subroutine MPI_Comm_free
 
 subroutine MPI_Free_mem(base, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
 #ifdef SUPPORT_FOR_ASSUMED_TYPE   
    type(*) :: base(*)
 #else
@@ -348,8 +364,7 @@ subroutine MPI_Free_mem(base, ierror)
 end subroutine MPI_Free_mem
 
 subroutine MPI_Win_create(base, size, disp_unit, info, comm, win, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
 #ifdef SUPPORT_FOR_ASSUMED_TYPE   
    type(*) :: base(*)
 #else
@@ -366,8 +381,7 @@ end subroutine MPI_Win_create
 
 ! This one is just a stub for now
 subroutine MPI_Comm_dup(comm, newcomm, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer, intent(in) :: comm
    integer, intent(out) :: newcomm
    integer, intent(out) :: ierror
@@ -380,8 +394,7 @@ end subroutine MPI_Comm_dup
 
 
 subroutine MPI_Type_indexed(count, array_of_blocklengths, array_of_displacements, oldtype, newtype, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi, only: mocker
    integer, intent(in) :: count
    integer, intent(in) :: array_of_blocklengths(*)
    integer, intent(in) :: array_of_displacements(*)
@@ -396,8 +409,7 @@ subroutine MPI_Type_indexed(count, array_of_blocklengths, array_of_displacements
 end subroutine MPI_Type_indexed
 
 subroutine MPI_Type_commit(datatype, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi, only: mocker
    integer, intent(in) :: datatype
    integer, intent(out) :: ierror
 
@@ -408,8 +420,7 @@ end subroutine MPI_Type_commit
 
 
 subroutine MPI_Type_extent(datatype, extent, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi, only: mocker
    integer, intent(in) :: datatype
    integer, intent(out) :: extent
    integer, intent(out) :: ierror
@@ -422,19 +433,10 @@ end subroutine MPI_Type_extent
 
 
 subroutine MPI_Type_free(datatype, ierror)
-   use MockMpi_mod
-   use mpi_base
+   use mpi
    integer    datatype, ierror
    ierror = MPI_SUCCESS
    mocker%call_count = mocker%call_count + 1
 end subroutine MPI_Type_free
 
 
-!!$subroutine mpi_init(ierror)
-!!$   use MockMpi_mod
-!!$   use mpi_base
-!!$   integer    datatype, ierror
-!!$   ierror = MPI_SUCCESS
-!!$   mocker%call_count = mocker%call_count + 1
-!!$end subroutine mpi_init
-
diff --git a/tests/Test_MpiCommConfig.pf b/tests/Test_MpiCommConfig.pf
@@ -1,5 +1,5 @@
 module Test_MpiCommConfig
-   use MockMpi_mod
+   use mpi
    use funit
    use PFL_MpiCommConfig
    use gftl2_StringUnlimitedMap, only: StringUnlimitedMap

diff --git a/tests/Test_MpiFilter.pf b/tests/Test_MpiFilter.pf
@@ -11,7 +11,7 @@ contains
 
    @test
    subroutine Test_MpiFilter_defaultRank()
-      use MockMpi_mod
+      use mpi
       integer :: comm
       type (MpiFilter) :: f
       type (LogRecord) :: record
@@ -31,7 +31,7 @@ contains
 
    @test
    subroutine Test_MpiFilter_withRank
-      use MockMpi_mod
+      use mpi
       integer :: comm
       type (MpiFilter) :: f
       type (LogRecord) :: record

diff --git a/tests/Test_MpiFormatter.pf b/tests/Test_MpiFormatter.pf
@@ -1,6 +1,6 @@
 module Test_MpiFormatter
    use funit
-   use MockMpi_mod
+   use mpi
    use PFL_MpiFormatter
    use PFL_LogRecord
    use PFL_SeverityLevels