fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-09 15:41:45 +00:00
Code Issues Packages Projects Releases Wiki Activity

[FIX] Fixed RMA windows create using memory pool to attach and detach

Browse Source
This commit is contained in:
Stack-1
2026-08-11 10:43:59 +02:00
parent 2a767a4097
commit a3249c509a
2 changed files with 166 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/comm/internals/psi_dswapdata.F90
+50 -41
View File
@@ -86,7 +86,8 @@ submodule (psi_d_comm_v_mod) psi_d_swapdata_impl
use psb_comm_schemes_mod, only: psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, &
& psb_comm_persistent_ineighbor_alltoallv_, psb_comm_rma_pull_, psb_comm_rma_push_, &
& psb_comm_handle_type
use psb_comm_rma_mod, only: psb_comm_rma_handle
use psb_comm_rma_mod, only: psb_comm_rma_handle, psb_comm_rma_get_window
use, intrinsic :: iso_c_binding, only: c_loc
use psb_comm_factory_mod
contains
@@ -997,7 +998,7 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: swap_status
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_d_base_vect_type), intent(inout), target :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv
class(psb_comm_handle_type), intent(inout) :: comm_handle
@@ -1106,15 +1107,13 @@ contains
element_bytes = storage_size(y%combuf(1))/8
if (.not. rma_handle%window_ready) then
! Created once and kept for the life of the handle. On a dynamic
! window buffers come and go through local attach/detach, so this
! collective is paid a single time instead of on every buffer change.
call mpi_win_create_dynamic(mpi_info_null, ctxt%get_mpic(), &
& rma_handle%win, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
! The window comes from the module pool, keyed by communicator: it is
! created on the first request of the run and reused by every handle
! afterwards. Creating it per handle, as before, meant paying a
! communicator-wide collective (~0.9 s at 448 ranks) each time.
call psb_comm_rma_get_window(ctxt%get_mpic(), rma_handle%win, info)
if (info /= psb_success_) then
call psb_errpush(info,name); goto 9999
end if
rma_handle%window_ready = .true.
end if
@@ -1128,6 +1127,10 @@ contains
goto 9999
end if
call mpi_get_address(y%combuf, rma_handle%my_buf_addr, iret)
! Kept so that the handle can detach on free, when the buffer is no
! longer reachable from here.
rma_handle%win_base = c_loc(y%combuf(1))
rma_handle%win_nelem = size(y%combuf)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
@@ -1252,7 +1255,7 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: swap_status
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_d_base_vect_type), intent(inout), target :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv
class(psb_comm_handle_type), intent(inout) :: comm_handle
@@ -1359,15 +1362,13 @@ contains
element_bytes = storage_size(y%combuf(1))/8
if (.not. rma_handle%window_ready) then
! Created once and kept for the life of the handle. On a dynamic
! window buffers come and go through local attach/detach, so this
! collective is paid a single time instead of on every buffer change.
call mpi_win_create_dynamic(mpi_info_null, ctxt%get_mpic(), &
& rma_handle%win, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
! The window comes from the module pool, keyed by communicator: it is
! created on the first request of the run and reused by every handle
! afterwards. Creating it per handle, as before, meant paying a
! communicator-wide collective (~0.9 s at 448 ranks) each time.
call psb_comm_rma_get_window(ctxt%get_mpic(), rma_handle%win, info)
if (info /= psb_success_) then
call psb_errpush(info,name); goto 9999
end if
rma_handle%window_ready = .true.
end if
@@ -1381,6 +1382,10 @@ contains
goto 9999
end if
call mpi_get_address(y%combuf, rma_handle%my_buf_addr, iret)
! Kept so that the handle can detach on free, when the buffer is no
! longer reachable from here.
rma_handle%win_base = c_loc(y%combuf(1))
rma_handle%win_nelem = size(y%combuf)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
@@ -2334,7 +2339,7 @@ end subroutine psi_dswap_neighbor_topology_multivect_persistent
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: swap_status
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
class(psb_d_base_multivect_type), intent(inout), target :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv
class(psb_comm_handle_type), intent(inout) :: comm_handle
@@ -2440,15 +2445,13 @@ end subroutine psi_dswap_neighbor_topology_multivect_persistent
element_bytes = storage_size(y%combuf(1))/8
if (.not. rma_handle%window_ready) then
! Created once and kept for the life of the handle. On a dynamic
! window buffers come and go through local attach/detach, so this
! collective is paid a single time instead of on every buffer change.
call mpi_win_create_dynamic(mpi_info_null, ctxt%get_mpic(), &
& rma_handle%win, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
! The window comes from the module pool, keyed by communicator: it is
! created on the first request of the run and reused by every handle
! afterwards. Creating it per handle, as before, meant paying a
! communicator-wide collective (~0.9 s at 448 ranks) each time.
call psb_comm_rma_get_window(ctxt%get_mpic(), rma_handle%win, info)
if (info /= psb_success_) then
call psb_errpush(info,name); goto 9999
end if
rma_handle%window_ready = .true.
end if
@@ -2462,6 +2465,10 @@ end subroutine psi_dswap_neighbor_topology_multivect_persistent
goto 9999
end if
call mpi_get_address(y%combuf, rma_handle%my_buf_addr, iret)
! Kept so that the handle can detach on free, when the buffer is no
! longer reachable from here.
rma_handle%win_base = c_loc(y%combuf(1))
rma_handle%win_nelem = size(y%combuf)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
@@ -2577,7 +2584,7 @@ end subroutine psi_dswap_neighbor_topology_multivect_persistent
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: swap_status
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
class(psb_d_base_multivect_type), intent(inout), target :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv
class(psb_comm_handle_type), intent(inout) :: comm_handle
@@ -2683,15 +2690,13 @@ end subroutine psi_dswap_neighbor_topology_multivect_persistent
element_bytes = storage_size(y%combuf(1))/8
if (.not. rma_handle%window_ready) then
! Created once and kept for the life of the handle. On a dynamic
! window buffers come and go through local attach/detach, so this
! collective is paid a single time instead of on every buffer change.
call mpi_win_create_dynamic(mpi_info_null, ctxt%get_mpic(), &
& rma_handle%win, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
! The window comes from the module pool, keyed by communicator: it is
! created on the first request of the run and reused by every handle
! afterwards. Creating it per handle, as before, meant paying a
! communicator-wide collective (~0.9 s at 448 ranks) each time.
call psb_comm_rma_get_window(ctxt%get_mpic(), rma_handle%win, info)
if (info /= psb_success_) then
call psb_errpush(info,name); goto 9999
end if
rma_handle%window_ready = .true.
end if
@@ -2705,6 +2710,10 @@ end subroutine psi_dswap_neighbor_topology_multivect_persistent
goto 9999
end if
call mpi_get_address(y%combuf, rma_handle%my_buf_addr, iret)
! Kept so that the handle can detach on free, when the buffer is no
! longer reachable from here.
rma_handle%win_base = c_loc(y%combuf(1))
rma_handle%win_nelem = size(y%combuf)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
base/modules/comm/comm_schemes/psb_comm_rma_mod.F90
+116 -4
View File
@@ -3,7 +3,7 @@ module psb_comm_rma_mod
use psb_desc_const_mod, only: psb_proc_id_, psb_n_elem_recv_, psb_elem_recv_, &
& psb_n_elem_send_, psb_elem_send_
use psb_error_mod
use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_associated, c_f_pointer
#ifdef PSB_MPI_MOD
use mpi
#endif
@@ -11,6 +11,26 @@ module psb_comm_rma_mod
& psb_comm_unknown_
implicit none
integer(psb_mpk_), parameter :: psb_rma_meta_tag = 913
!
! Window pool.
!
! MPI_Win_create and MPI_Win_create_dynamic are both collective over the whole
! communicator, and profiling at 448 ranks put either at ~0.9 s per call: with
! the window owned by the communication handle, every handle that came and
! went paid one. Measured, that was ~1400-1700 s aggregated, against ~3.5 s for
! the MPI_Get that actually moves the data.
!
! So the window is owned by the module and keyed by communicator: created once
! on first use and kept for the run. Handles attach and detach their own
! buffers to it, which are local operations. This is the reuse policy PETSc
! applies to its window flavors; the flavor alone buys nothing without it.
!
integer(psb_ipk_), parameter :: psb_rma_max_wins = 16
integer(psb_mpk_), private, save :: rma_pool_comm(psb_rma_max_wins) = mpi_comm_null
integer(psb_mpk_), private, save :: rma_pool_win(psb_rma_max_wins) = mpi_win_null
integer(psb_ipk_), private, save :: rma_pool_n = 0
public :: psb_comm_rma_get_window, psb_comm_rma_free_windows
#ifdef PSB_MPI_H
include 'mpif.h'
#endif
@@ -69,6 +89,83 @@ module psb_comm_rma_mod
contains
!
! Hand back the dynamic window for this communicator, creating it if this is
! the first request. The collective is paid here, once per communicator per
! run, instead of once per handle.
!
subroutine psb_comm_rma_get_window(icomm, win, info)
#ifdef PSB_MPI_MOD
use mpi
#endif
implicit none
#ifdef PSB_MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(out) :: win
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: k
integer(psb_mpk_) :: iret
info = psb_success_
win = mpi_win_null
do k = 1, rma_pool_n
if (rma_pool_comm(k) == icomm) then
win = rma_pool_win(k)
return
end if
end do
if (rma_pool_n >= psb_rma_max_wins) then
! More distinct communicators than the pool can hold. Raising the bound is
! the fix; silently creating an unpooled window would reintroduce the very
! per-handle collective this exists to remove.
info = psb_err_internal_error_
return
end if
call mpi_win_create_dynamic(mpi_info_null, icomm, win, iret)
if (iret /= mpi_success) then
info = psb_err_mpi_error_
win = mpi_win_null
return
end if
rma_pool_n = rma_pool_n + 1
rma_pool_comm(rma_pool_n) = icomm
rma_pool_win(rma_pool_n) = win
end subroutine psb_comm_rma_get_window
!
! Release every pooled window. Collective on each communicator involved, so it
! belongs at teardown, before MPI_Finalize.
!
subroutine psb_comm_rma_free_windows(info)
#ifdef PSB_MPI_MOD
use mpi
#endif
implicit none
#ifdef PSB_MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: k
integer(psb_mpk_) :: iret
info = psb_success_
do k = 1, rma_pool_n
if (rma_pool_win(k) /= mpi_win_null) then
call mpi_win_free(rma_pool_win(k), iret)
if (iret /= mpi_success) info = psb_err_mpi_error_
end if
rma_pool_win(k) = mpi_win_null
rma_pool_comm(k) = mpi_comm_null
end do
rma_pool_n = 0
end subroutine psb_comm_rma_free_windows
subroutine psb_comm_rma_init(this, info)
class(psb_comm_rma_handle), intent(inout) :: this
integer(psb_ipk_), intent(out) :: info
@@ -287,16 +384,31 @@ contains
class(psb_comm_rma_handle), intent(inout) :: this
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: iret
real(psb_dpk_), pointer :: detach_p(:)
info = 0
if (this%window_open) then
call mpi_win_unlock_all(this%win, iret)
this%window_open = .false.
end if
if (this%win /= mpi_win_null) then
call mpi_win_free(this%win, iret)
this%win = mpi_win_null
!
! The window belongs to the module pool, not to this handle: it is not freed
! here. What must go is the attachment, because the buffer behind it is about
! to be deallocated with the vector, and leaving a dangling region attached
! would also make the next attach of the same address overlap.
!
! MPI_Win_detach wants the buffer, not its address, and this module is
! type-generic; c_f_pointer on the stored c_ptr gives an array at the right
! address, which is all detach looks at.
!
if (this%buf_attached .and. c_associated(this%win_base) &
& .and. (this%win /= mpi_win_null)) then
call c_f_pointer(this%win_base, detach_p, [1])
call mpi_win_detach(this%win, detach_p, iret)
if (iret /= mpi_success) info = psb_err_mpi_error_
end if
this%buf_attached = .false.
this%win = mpi_win_null
this%win_base = c_null_ptr
this%win_nelem = 0
! Freeing the window drops whatever is attached to it, so the attachment