Merge branch 'mpi_shared_memory' into main

lib/CMakeLists.txt

@@ -19,7 +19,8 @@ set(sources-fpp
   mpifx_reduce.fpp
   mpifx_scatter.fpp
   mpifx_scatterv.fpp
-  mpifx_send.fpp)
+  mpifx_send.fpp
+  mpifx_win.fpp)
 
 fypp_preprocess("${sources-fpp}" sources-f90)
 

lib/meson.build

@@ -22,6 +22,7 @@ sources_fpp = files(
   'mpifx_scatter.fpp',
   'mpifx_scatterv.fpp',
   'mpifx_send.fpp',
+  'mpifx_win.fpp',
 )
 sources_f90 = []
 foreach src : sources_fpp

lib/module.fpp

@@ -30,6 +30,7 @@ module libmpifx_module
   use mpifx_allgatherv_module
   use mpifx_scatter_module
   use mpifx_scatterv_module
+  use mpifx_win_module
   implicit none
   public
 

lib/mpifx_win.fpp

@@ -0,0 +1,171 @@
+#:include 'mpifx.fypp'
+#:set TYPES = NUMERIC_TYPES
+
+!> Contains routined for MPI shared memory.
+module mpifx_win_module
+  use mpifx_common_module
+  use iso_c_binding, only : c_ptr, c_f_pointer
+  implicit none
+  private
+
+  public :: mpifx_win
+
+  !> MPI shared memory window with some additional information.
+  type mpifx_win
+    private
+    integer, public :: id       !< Window id.
+    integer :: comm_id  !< Communicator id.
+  contains
+    !> Initializes an MPI shared memory window.
+#:for TYPE in TYPES
+    generic :: allocate_shared => mpifx_win_allocate_shared_${TYPE_ABBREVS[TYPE]}$
+#:endfor
+
+#:for TYPE in TYPES
+    procedure, private :: mpifx_win_allocate_shared_${TYPE_ABBREVS[TYPE]}$
+#:endfor
+
+    !> Locks a shared memory segment.
+    procedure :: lock => mpifx_win_lock
+
+    !> Unlocks a shared memory segment.
+    procedure :: unlock => mpifx_win_unlock
+
+    !> Synchronizes shared memory across MPI ranks.
+    procedure :: sync => mpifx_win_sync
+
+    !> Deallocates memory associated with a shared memory segment.
+    procedure :: free => mpifx_win_free
+
+  end type mpifx_win
+
+contains
+
+#:def mpifx_win_allocate_shared_template(SUFFIX, TYPE)
+
+  !> Initialized a window handle and returns a pointer to the address associated with a shared memory segment.
+  !!
+  !! \param self  Handle of the shared memory window on return.
+  !! \param mycomm  MPI communicator.
+  !! \param length  Number of elements of type ${TYPE}$ in the shared memory window.
+  !! \param shared_data  Pointer to the shared data array of length 'length' on return.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_ALLOCATE_SHARED)
+  !!
+  subroutine mpifx_win_allocate_shared_${SUFFIX}$(self, mycomm, length, shared_data, error)
+    class(mpifx_win), intent(out) :: self
+    class(mpifx_comm), intent(in) :: mycomm
+    integer, intent(in) :: length
+    ${TYPE}$, pointer, intent(out) :: shared_data(:)
+    integer, intent(out), optional :: error
+
+    integer :: disp_unit, error0, error1
+    integer(MPI_ADDRESS_KIND) :: local_length
+    type(c_ptr) :: baseptr
+
+    disp_unit = storage_size(shared_data) / 8
+
+    local_length = 0
+    if (mycomm%lead) then
+      local_length = int(length, kind=MPI_ADDRESS_KIND) * disp_unit
+    end if
+
+    call mpi_win_allocate_shared(local_length, disp_unit, MPI_INFO_NULL, mycomm%id, baseptr, self%id, error0)
+    call handle_errorflag(error0, "MPI_WIN_ALLOCATE_SHARED in mpifx_win_allocate_shared_${SUFFIX}$", error)
+
+    call mpi_win_shared_query(self%id, 0, local_length, disp_unit, baseptr, error1)
+    call handle_errorflag(error1, "MPI_WIN_SHARED_QUERY in mpifx_win_allocate_shared_${SUFFIX}$", error)
+
+    self%comm_id = mycomm%id
+    call c_f_pointer(baseptr, shared_data, [length])
+
+  end subroutine mpifx_win_allocate_shared_${SUFFIX}$
+
+#:enddef mpifx_win_allocate_shared_template
+
+  !> Locks a shared memory segment.
+  !!
+  !! \param self  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_LOCK_ALL)
+  !!
+  subroutine mpifx_win_lock(self, error)
+    class(mpifx_win), intent(inout) :: self
+    integer, intent(out), optional :: error
+
+    integer :: error0
+
+    call mpi_win_lock_all(MPI_MODE_NOCHECK, self%id, error0)
+    call handle_errorflag(error0, "MPI_WIN_LOCK_ALL in mpifx_win_lock", error)
+
+  end subroutine mpifx_win_lock
+
+  !> Unlocks a shared memory segment.
+  !!
+  !! \param self  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_UNLOCK_ALL)
+  !!
+  subroutine mpifx_win_unlock(self, error)
+    class(mpifx_win), intent(inout) :: self
+    integer, intent(out), optional :: error
+
+    integer :: error0
+
+    call mpi_win_unlock_all(self%id, error0)
+    call handle_errorflag(error0, "MPI_WIN_UNLOCK_ALL in mpifx_win_unlock", error)
+
+  end subroutine mpifx_win_unlock
+
+  !> Synchronizes shared memory across MPI ranks.
+  !!
+  !! \param self  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_SYNC)
+  !!
+  subroutine mpifx_win_sync(self, error)
+    class(mpifx_win), intent(inout) :: self
+    integer, intent(out), optional :: error
+
+    integer :: error0, error1
+
+    call mpi_win_sync(self%id, error0)
+    call handle_errorflag(error0, "MPI_WIN_SYNC in mpifx_win_sync", error)
+
+    call mpi_barrier(self%comm_id, error1)
+    call handle_errorflag(error1, "MPI_BARRIER in mpifx_win_sync", error)
+
+  end subroutine mpifx_win_sync
+
+  !> Deallocates memory associated with a shared memory segment.
+  !!
+  !! \param self  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_FREE)
+  !!
+  subroutine mpifx_win_free(self, error)
+    class(mpifx_win), intent(inout) :: self
+    integer, intent(out), optional :: error
+
+    integer :: error0
+
+    call mpi_win_free(self%id, error0)
+    call handle_errorflag(error0, "MPI_WIN_FREE in mpifx_win_free", error)
+
+  end subroutine mpifx_win_free
+
+
+#:for TYPE in TYPES
+  #:set FTYPE = FORTRAN_TYPES[TYPE]
+  #:set SUFFIX = TYPE_ABBREVS[TYPE]
+
+  $:mpifx_win_allocate_shared_template(SUFFIX, FTYPE)
+
+#:endfor
+
+end module mpifx_win_module

test/CMakeLists.txt

@@ -9,7 +9,8 @@ set(targets
   test_gatherv
   test_reduce
   test_scatter
-  test_scatterv)
+  test_scatterv
+  test_win_shared_mem)
 
 foreach(target IN LISTS targets)
   add_executable(${target} ${target}.f90)

test/meson.build

@@ -12,6 +12,7 @@ tests = [
   'reduce',
   'scatter',
   'scatterv',
+  'win_shared_mem',
 ]
 
 foreach t : tests

test/test_win_shared_mem.f90

@@ -0,0 +1,34 @@
+program test_win_shared_mem
+  use libmpifx_module
+  implicit none
+
+  type(mpifx_comm) :: globalcomm, nodecomm
+  type(mpifx_win) :: win
+  integer, parameter :: length = 7
+  integer, pointer :: data_pointer(:)
+
+  call mpifx_init()
+  call globalcomm%init()
+
+  ! Create a new communicator for all ranks on a node first
+  call globalcomm%split_type(MPI_COMM_TYPE_SHARED, globalcomm%rank, nodecomm)
+
+  call win%allocate_shared(nodecomm, length, data_pointer)
+
+  call win%lock()
+
+  ! Only rank 0 writes data into the array
+  if (nodecomm%lead) then
+    data_pointer(:) = 42
+  end if
+
+  call win%sync()
+  call win%unlock()
+
+  ! All ranks on the node will read the same value
+  write(*, "(2(A,1X,I0,1X))") "ID:", nodecomm%rank, "VALUE:", data_pointer(1)
+
+  call win%free()
+  call mpifx_finalize()
+
+end program test_win_shared_mem