From d104cd863338f753824f8c2e774c4aac58271625 Mon Sep 17 00:00:00 2001 From: Tobias Melson Date: Wed, 23 Feb 2022 14:09:54 +0100 Subject: [PATCH] Created win type with shared memory functionality The new type mpifx_win can now be used to handle MPI shared memory conveniently. --- lib/CMakeLists.txt | 2 +- lib/meson.build | 1 + lib/module.fpp | 2 +- lib/mpifx_shared_memory.fpp | 150 --------------- lib/mpifx_win.fpp | 172 ++++++++++++++++++ test/CMakeLists.txt | 2 +- test/meson.build | 2 +- ...red_memory.f90 => test_win_shared_mem.f90} | 16 +- 8 files changed, 185 insertions(+), 162 deletions(-) delete mode 100644 lib/mpifx_shared_memory.fpp create mode 100644 lib/mpifx_win.fpp rename test/{test_shared_memory.f90 => test_win_shared_mem.f90} (68%) diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index 43c83aa..0cdf659 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -20,7 +20,7 @@ set(sources-fpp mpifx_scatter.fpp mpifx_scatterv.fpp mpifx_send.fpp - mpifx_shared_memory.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 7e4cec4..a605e24 100644 --- a/lib/module.fpp +++ b/lib/module.fpp @@ -30,7 +30,7 @@ module libmpifx_module use mpifx_allgatherv_module use mpifx_scatter_module use mpifx_scatterv_module - use mpifx_shared_memory_module + use mpifx_win_module implicit none public diff --git a/lib/mpifx_shared_memory.fpp b/lib/mpifx_shared_memory.fpp deleted file mode 100644 index 2948669..0000000 --- a/lib/mpifx_shared_memory.fpp +++ /dev/null @@ -1,150 +0,0 @@ -#:include 'mpifx.fypp' -#:set TYPES = NUMERIC_TYPES - -!> Contains utilities for handling MPI shared memory -module mpifx_shared_memory_module - use mpifx_common_module - use iso_c_binding, only : c_ptr, c_f_pointer - implicit none - private - - public :: mpifx_allocate_shared, mpifx_free_shared, mpifx_lock_shared, mpifx_unlock_shared, mpifx_sync_shared - - interface mpifx_allocate_shared -#:for TYPE in TYPES - #:set TYPEABBREV = TYPE_ABBREVS[TYPE] - module procedure mpifx_allocate_shared_${TYPEABBREV}$ -#:endfor - end interface mpifx_allocate_shared - -contains - -#:def mpifx_allocate_shared_template(SUFFIX, TYPE) - - !> Returns a window handle and a pointer to the address associated with a shared memory segment. - !! - !! \param mycomm MPI communicator. - !! \param length Number of elements of type ${TYPE}$ in the shared memory window. - !! \param win Handle of the shared memory window on return. - !! \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_allocate_shared_${SUFFIX}$(mycomm, length, win, shared_data, error) - type(mpifx_comm), intent(in) :: mycomm - integer, intent(in) :: length - integer, intent(out) :: win - ${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 = kind(shared_data) - - local_length = 0 - if (mycomm%lead) then - local_length = length * disp_unit - end if - - call mpi_win_allocate_shared(local_length, disp_unit, MPI_INFO_NULL, mycomm%id, baseptr, win, error0) - call handle_errorflag(error0, "MPI_WIN_ALLOCATE_SHARED in mpifx_allocate_shared_${SUFFIX}$", error) - - call mpi_win_shared_query(win, 0, local_length, disp_unit, baseptr, error1) - call handle_errorflag(error1, "MPI_WIN_SHARED_QUERY in mpifx_allocate_shared_${SUFFIX}$", error) - - call c_f_pointer(baseptr, shared_data, [length]) - - end subroutine mpifx_allocate_shared_${SUFFIX}$ - -#:enddef mpifx_allocate_shared_template - - !> Deallocates a memory associated with a shared memory segment. - !! - !! \param win Handle of the shared memory window. - !! \param error Optional error code on return. - !! - !! \see MPI documentation (\c MPI_WIN_FREE) - !! - subroutine mpifx_free_shared(win, error) - integer, intent(inout) :: win - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_win_free(win, error0) - call handle_errorflag(error0, "MPI_WIN_FREE in mpifx_free_shared", error) - - end subroutine mpifx_free_shared - - !> Locks a shared memory segment. - !! - !! \param win Handle of the shared memory window. - !! \param error Optional error code on return. - !! - !! \see MPI documentation (\c MPI_WIN_LOCK_ALL) - !! - subroutine mpifx_lock_shared(win, error) - integer, intent(inout) :: win - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_win_lock_all(MPI_MODE_NOCHECK, win, error0) - call handle_errorflag(error0, "MPI_WIN_LOCK_ALL in mpifx_lock_shared", error) - - end subroutine mpifx_lock_shared - - !> Unlocks a shared memory segment. - !! - !! \param win Handle of the shared memory window. - !! \param error Optional error code on return. - !! - !! \see MPI documentation (\c MPI_WIN_UNLOCK_ALL) - !! - subroutine mpifx_unlock_shared(win, error) - integer, intent(inout) :: win - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_win_unlock_all(win, error0) - call handle_errorflag(error0, "MPI_WIN_UNLOCK_ALL in mpifx_unlock_shared", error) - - end subroutine mpifx_unlock_shared - - !> Synchronizes shared memory across MPI ranks. - !! - !! \param mycomm MPI communicator. - !! \param win Handle of the shared memory window. - !! \param error Optional error code on return. - !! - !! \see MPI documentation (\c MPI_WIN_SYNC) - !! - subroutine mpifx_sync_shared(mycomm, win, error) - type(mpifx_comm), intent(in) :: mycomm - integer, intent(inout) :: win - integer, intent(out), optional :: error - - integer :: error0, error1 - - call mpi_win_sync(win, error0) - call handle_errorflag(error0, "MPI_WIN_SYNC in mpifx_sync_shared", error) - - call mpi_barrier(mycomm%id, error1) - call handle_errorflag(error1, "MPI_BARRIER in mpifx_sync_shared", error) - - end subroutine mpifx_sync_shared - - -#:for TYPE in TYPES - #:set FTYPE = FORTRAN_TYPES[TYPE] - #:set SUFFIX = TYPE_ABBREVS[TYPE] - - $:mpifx_allocate_shared_template(SUFFIX, FTYPE) - -#:endfor - -end module mpifx_shared_memory_module diff --git a/lib/mpifx_win.fpp b/lib/mpifx_win.fpp new file mode 100644 index 0000000..2d9ece3 --- /dev/null +++ b/lib/mpifx_win.fpp @@ -0,0 +1,172 @@ +#: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 + integer :: id !< Window id. + integer :: comm_id !< Communicator id. + contains + !> Initializes an MPI shared memory window. + generic :: allocate_shared => & +#:for TYPE in TYPES[:-1] + & mpifx_win_allocate_shared_${TYPE_ABBREVS[TYPE]}$,& +#:endfor + & mpifx_win_allocate_shared_${TYPE_ABBREVS[TYPES[-1]]}$ + +#: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 = kind(shared_data) + + local_length = 0 + if (mycomm%lead) then + local_length = length * 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 0be19fc..0b6785c 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -10,7 +10,7 @@ set(targets test_reduce test_scatter test_scatterv - test_shared_memory) + 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 04fc3bb..fd98ff5 100644 --- a/test/meson.build +++ b/test/meson.build @@ -12,7 +12,7 @@ tests = [ 'reduce', 'scatter', 'scatterv', - 'shared_memory', + 'win_shared_mem', ] foreach t : tests diff --git a/test/test_shared_memory.f90 b/test/test_win_shared_mem.f90 similarity index 68% rename from test/test_shared_memory.f90 rename to test/test_win_shared_mem.f90 index ebce3cc..048fda8 100644 --- a/test/test_shared_memory.f90 +++ b/test/test_win_shared_mem.f90 @@ -1,10 +1,10 @@ -program test_shared_memory +program test_win_shared_mem use libmpifx_module implicit none type(mpifx_comm) :: globalcomm, nodecomm + type(mpifx_win) :: win integer, parameter :: length = 7 - integer :: win integer, pointer :: data_pointer(:) call mpifx_init() @@ -13,22 +13,22 @@ program test_shared_memory ! Create a new communicator for all ranks on a node first call globalcomm%split_type(MPI_COMM_TYPE_SHARED, globalcomm%rank, nodecomm) - call mpifx_allocate_shared(nodecomm, length, win, data_pointer) + call win%allocate_shared(nodecomm, length, data_pointer) - call mpifx_lock_shared(win) + call win%lock() ! Only rank 0 writes data into the array if (nodecomm%lead) then data_pointer(:) = 42 end if - call mpifx_sync_shared(nodecomm, win) - call mpifx_unlock_shared(win) + 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 mpifx_free_shared(win) + call win%free() call mpifx_finalize() -end program test_shared_memory +end program test_win_shared_mem