diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index b5250a0..0cdf659 100644 --- a/lib/CMakeLists.txt +++ b/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) diff --git a/lib/meson.build b/lib/meson.build index db50325..c590372 100644 --- a/lib/meson.build +++ b/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 diff --git a/lib/module.fpp b/lib/module.fpp index a121129..a605e24 100644 --- a/lib/module.fpp +++ b/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 diff --git a/lib/mpifx_win.fpp b/lib/mpifx_win.fpp new file mode 100644 index 0000000..1d96892 --- /dev/null +++ b/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 diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 29760dd..0b6785c 100644 --- a/test/CMakeLists.txt +++ b/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) diff --git a/test/meson.build b/test/meson.build index cbfc239..fd98ff5 100644 --- a/test/meson.build +++ b/test/meson.build @@ -12,6 +12,7 @@ tests = [ 'reduce', 'scatter', 'scatterv', + 'win_shared_mem', ] foreach t : tests diff --git a/test/test_win_shared_mem.f90 b/test/test_win_shared_mem.f90 new file mode 100644 index 0000000..048fda8 --- /dev/null +++ b/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