From 203db768c92947eb9c726ee29aaeed1e72505a54 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Thu, 3 Apr 2025 15:48:43 +0530 Subject: [PATCH 1/5] Remove C-wrapper for MPI_Waitall --- src/mpi.f90 | 69 ++++++++++++++++++++++++++++++++++-------- src/mpi_c_bindings.f90 | 21 ++++++++----- src/mpi_wrapper.c | 27 ----------------- 3 files changed, 70 insertions(+), 47 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index 4532477..d16ad01 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -594,7 +594,7 @@ subroutine MPI_Comm_split_type_proc(comm, split_type, key, info, newcomm, ierror end if end if - end subroutine MPI_Comm_split_type_proc + end subroutine MPI_Comm_split_type_proc subroutine MPI_Recv_StatusArray_proc(buf, count, datatype, source, tag, comm, status, ierror) use iso_c_binding, only: c_int, c_ptr, c_loc @@ -624,14 +624,14 @@ subroutine MPI_Recv_StatusArray_proc(buf, count, datatype, source, tag, comm, st end if if (present(ierror)) then - ierror = local_ierr + ierror = local_ierr else if (local_ierr /= MPI_SUCCESS) then - print *, "MPI_Recv failed with error code: ", local_ierr + print *, "MPI_Recv failed with error code: ", local_ierr end if - end subroutine MPI_Recv_StatusArray_proc + end subroutine MPI_Recv_StatusArray_proc - subroutine MPI_Recv_StatusIgnore_proc(buf, count, datatype, source, tag, comm, status, ierror) + subroutine MPI_Recv_StatusIgnore_proc(buf, count, datatype, source, tag, comm, status, ierror) use iso_c_binding, only: c_int, c_ptr, c_loc use mpi_c_bindings, only: c_mpi_recv, c_mpi_comm_f2c, c_mpi_datatype_f2c, c_mpi_status_c2f real(8), dimension(*), intent(inout) :: buf @@ -659,21 +659,64 @@ subroutine MPI_Recv_StatusIgnore_proc(buf, count, datatype, source, tag, comm, s end if if (present(ierror)) then - ierror = local_ierr + ierror = local_ierr else if (local_ierr /= MPI_SUCCESS) then - print *, "MPI_Recv failed with error code: ", local_ierr + print *, "MPI_Recv failed with error code: ", local_ierr end if - end subroutine MPI_Recv_StatusIgnore_proc + end subroutine MPI_Recv_StatusIgnore_proc subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) - use mpi_c_bindings, only: c_mpi_waitall + use iso_c_binding, only: c_int, c_ptr + use mpi_c_bindings, only: c_mpi_waitall, c_mpi_request_f2c, c_mpi_request_c2f, c_mpi_status_c2f integer, intent(in) :: count - integer, intent(inout) :: array_of_requests(count) - integer, intent(out) :: array_of_statuses(*) + integer, dimension(count), intent(inout) :: array_of_requests + integer, dimension(*), intent(out) :: array_of_statuses integer, optional, intent(out) :: ierror - call c_mpi_waitall(count, array_of_requests, array_of_statuses, ierror) - end subroutine + + integer(c_int) :: local_ierr, status_ierr + integer :: i + + ! Allocate temporary arrays for the C representations. + type(c_ptr), allocatable :: c_requests(:) + type(c_ptr), allocatable :: c_statuses(:) + allocate(c_requests(count)) + allocate(c_statuses(count*MPI_STATUS_SIZE)) + + ! Convert Fortran requests to C requests. + do i = 1, count + c_requests(i) = c_mpi_request_f2c(array_of_requests(i)) + end do + + ! Call the native MPI_Waitall. + local_ierr = c_mpi_waitall(count, c_requests, c_statuses) + + ! Convert the C requests back to Fortran handles. + do i = 1, count + array_of_requests(i) = c_mpi_request_c2f(c_requests(i)) + end do + + ! For each status, convert the C status to Fortran status. + if(array_of_statuses(1) == MPI_STATUS_IGNORE) then + ! If the status is ignored, we don't need to convert. + array_of_statuses(1) = 0 + ! print *, "Status is ignored, no conversion needed." + else + ! Convert the C status to Fortran status. + do i = 1, count + status_ierr = c_mpi_status_c2f(c_statuses(i), array_of_statuses((i-1)*MPI_STATUS_SIZE+1)) + end do + end if + + if (present(ierror)) then + ierror = local_ierr + else if (local_ierr /= MPI_SUCCESS) then + print *, "MPI_Waitall failed with error code: ", local_ierr + end if + + deallocate(c_requests) + deallocate(c_statuses) + end subroutine MPI_Waitall_proc subroutine MPI_Ssend_proc(buf, count, datatype, dest, tag, comm, ierror) use iso_c_binding, only: c_int, c_ptr diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index 1fc55c2..bc00f76 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -20,6 +20,12 @@ function c_mpi_request_c2f(request) bind(C, name="MPI_Request_c2f") integer(c_int) :: c_mpi_request_c2f end function + function c_mpi_request_f2c(request) bind(C, name="MPI_Request_f2c") + use iso_c_binding, only: c_int, c_ptr + integer(c_int), value :: request + type(c_ptr) :: c_mpi_request_f2c + end function c_mpi_request_f2c + function c_mpi_datatype_f2c(datatype) bind(C, name="get_c_datatype_from_fortran") use iso_c_binding, only: c_int, c_ptr integer(c_int), value :: datatype @@ -38,6 +44,7 @@ function c_mpi_status_c2f(c_status, f_status) bind(C, name="MPI_Status_c2f") integer(c_int) :: f_status(*) ! assumed-size array integer(c_int) :: c_mpi_status_c2f end function c_mpi_status_c2f + function c_mpi_info_f2c(info_f) bind(C, name="get_c_info_from_fortran") use iso_c_binding, only: c_int, c_ptr integer(c_int), value :: info_f @@ -182,13 +189,13 @@ function c_mpi_recv(buf, count, c_dtype, source, tag, c_comm, status) bind(C, na integer(c_int) :: c_mpi_recv end function c_mpi_recv - subroutine c_mpi_waitall(count, array_of_requests, array_of_statuses, ierror) bind(C, name="mpi_waitall_wrapper") - use iso_c_binding, only: c_int - integer(c_int), intent(in) :: count - integer(c_int), intent(inout) :: array_of_requests(count) - integer(c_int) :: array_of_statuses(*) - integer(c_int), optional, intent(out) :: ierror - end subroutine + function c_mpi_waitall(count, requests, statuses) bind(C, name="MPI_Waitall") + use iso_c_binding, only: c_int, c_ptr + integer(c_int), value :: count + type(c_ptr), dimension(*), intent(inout) :: requests + type(c_ptr), dimension(*), intent(out) :: statuses + integer(c_int) :: c_mpi_waitall + end function c_mpi_waitall function c_mpi_ssend(buf, count, datatype, dest, tag, comm) bind(C, name="MPI_Ssend") use iso_c_binding, only: c_int, c_double, c_ptr diff --git a/src/mpi_wrapper.c b/src/mpi_wrapper.c index e8fbe87..bf30f77 100644 --- a/src/mpi_wrapper.c +++ b/src/mpi_wrapper.c @@ -60,30 +60,3 @@ MPI_Comm get_c_comm_from_fortran(int comm_f) { void* get_c_mpi_inplace_from_fortran(double sendbuf) { return MPI_IN_PLACE; } - -void mpi_waitall_wrapper(int *count, int *array_of_requests_f, - int *array_of_statuses_f, int *ierror) { - MPI_Request *array_of_requests; - MPI_Status *array_of_statuses; - array_of_requests = (MPI_Request *)malloc((*count) * sizeof(MPI_Request)); - array_of_statuses = (MPI_Status *)malloc((*count) * sizeof(MPI_Status)); - if (array_of_requests == NULL || array_of_statuses == NULL) { - *ierror = MPI_ERR_NO_MEM; - return; - } - for (int i = 0; i < *count; i++) { - array_of_requests[i] = MPI_Request_f2c(array_of_requests_f[i]); - } - - *ierror = MPI_Waitall(*count, array_of_requests, array_of_statuses); - for (int i = 0; i < *count; i++) { - array_of_requests_f[i] = MPI_Request_c2f(array_of_requests[i]); - } - - for (int i = 0; i < *count; i++) { - MPI_Status_c2f(&array_of_statuses[i], &array_of_statuses_f[i * MPI_STATUS_SIZE]); - } - - free(array_of_requests); - free(array_of_statuses); -} From b4eb1e7e2b3be8a3760552543217d096917da6f6 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Thu, 10 Apr 2025 15:30:52 +0530 Subject: [PATCH 2/5] use INTEGER(kind=MPI_HANDLE_KIND) for requests --- src/mpi.f90 | 2 +- src/mpi_c_bindings.f90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index 7cb470e..5e4144f 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -691,7 +691,7 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) integer :: i ! Allocate temporary arrays for the C representations. - type(c_ptr), allocatable :: c_requests(:) + integer(kind=MPI_HANDLE_KIND), allocatable :: c_requests(:) type(c_ptr), allocatable :: c_statuses(:) allocate(c_requests(count)) allocate(c_statuses(count*MPI_STATUS_SIZE)) diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index 1293a43..de65e0c 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -29,7 +29,7 @@ function c_mpi_request_c2f(request) bind(C, name="MPI_Request_c2f") function c_mpi_request_f2c(request) bind(C, name="MPI_Request_f2c") use iso_c_binding, only: c_int, c_ptr integer(c_int), value :: request - type(c_ptr) :: c_mpi_request_f2c + integer(kind=MPI_HANDLE_KIND) :: c_mpi_request_f2c end function c_mpi_request_f2c function c_mpi_datatype_f2c(datatype) bind(C, name="get_c_datatype_from_fortran") @@ -198,7 +198,7 @@ end function c_mpi_recv function c_mpi_waitall(count, requests, statuses) bind(C, name="MPI_Waitall") use iso_c_binding, only: c_int, c_ptr integer(c_int), value :: count - type(c_ptr), dimension(*), intent(inout) :: requests + integer(kind=MPI_HANDLE_KIND), dimension(*), intent(inout) :: requests type(c_ptr), dimension(*), intent(out) :: statuses integer(c_int) :: c_mpi_waitall end function c_mpi_waitall From 233e89830a5e67a918238f9653f6702c89e1a7d2 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Thu, 10 Apr 2025 16:19:35 +0530 Subject: [PATCH 3/5] Add C-wrapper to get MPI_STATUSES_IGNORE C-object --- src/mpi.f90 | 26 ++++++-------------------- src/mpi_c_bindings.f90 | 7 ++++++- src/mpi_wrapper.c | 4 ++++ 3 files changed, 16 insertions(+), 21 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index 5e4144f..b447624 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -681,7 +681,7 @@ end subroutine MPI_Recv_StatusIgnore_proc subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) use iso_c_binding, only: c_int, c_ptr - use mpi_c_bindings, only: c_mpi_waitall, c_mpi_request_f2c, c_mpi_request_c2f, c_mpi_status_c2f + use mpi_c_bindings, only: c_mpi_waitall, c_mpi_request_f2c, c_mpi_request_c2f, c_mpi_status_c2f, c_mpi_statuses_ignore integer, intent(in) :: count integer, dimension(count), intent(inout) :: array_of_requests integer, dimension(*), intent(out) :: array_of_statuses @@ -691,10 +691,10 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) integer :: i ! Allocate temporary arrays for the C representations. - integer(kind=MPI_HANDLE_KIND), allocatable :: c_requests(:) - type(c_ptr), allocatable :: c_statuses(:) - allocate(c_requests(count)) - allocate(c_statuses(count*MPI_STATUS_SIZE)) + integer(kind=MPI_HANDLE_KIND), dimension(count) :: c_requests + type(c_ptr) :: MPI_STATUSES_IGNORE_from_c + + MPI_STATUSES_IGNORE_from_c = c_mpi_statuses_ignore() ! Convert Fortran requests to C requests. do i = 1, count @@ -702,33 +702,19 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) end do ! Call the native MPI_Waitall. - local_ierr = c_mpi_waitall(count, c_requests, c_statuses) + local_ierr = c_mpi_waitall(count, c_requests, MPI_STATUSES_IGNORE_from_c) ! Convert the C requests back to Fortran handles. do i = 1, count array_of_requests(i) = c_mpi_request_c2f(c_requests(i)) end do - ! For each status, convert the C status to Fortran status. - if(array_of_statuses(1) == MPI_STATUS_IGNORE) then - ! If the status is ignored, we don't need to convert. - array_of_statuses(1) = 0 - ! print *, "Status is ignored, no conversion needed." - else - ! Convert the C status to Fortran status. - do i = 1, count - status_ierr = c_mpi_status_c2f(c_statuses(i), array_of_statuses((i-1)*MPI_STATUS_SIZE+1)) - end do - end if - if (present(ierror)) then ierror = local_ierr else if (local_ierr /= MPI_SUCCESS) then print *, "MPI_Waitall failed with error code: ", local_ierr end if - deallocate(c_requests) - deallocate(c_statuses) end subroutine MPI_Waitall_proc subroutine MPI_Ssend_proc(buf, count, datatype, dest, tag, comm, ierror) diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index de65e0c..7738aab 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -57,6 +57,11 @@ function c_mpi_info_f2c(info_f) bind(C, name="get_c_info_from_fortran") integer(kind=MPI_HANDLE_KIND) :: c_mpi_info_f2c end function c_mpi_info_f2c + function c_mpi_statuses_ignore() bind(C, name="get_c_MPI_STATUSES_IGNORE") + use iso_c_binding, only: c_ptr + type(c_ptr) :: c_mpi_statuses_ignore + end function c_mpi_statuses_ignore + function c_mpi_in_place_f2c(in_place_f) bind(C,name="get_c_mpi_inplace_from_fortran") use iso_c_binding, only: c_double, c_ptr real(c_double), value :: in_place_f @@ -199,7 +204,7 @@ function c_mpi_waitall(count, requests, statuses) bind(C, name="MPI_Waitall") use iso_c_binding, only: c_int, c_ptr integer(c_int), value :: count integer(kind=MPI_HANDLE_KIND), dimension(*), intent(inout) :: requests - type(c_ptr), dimension(*), intent(out) :: statuses + type(c_ptr), value :: statuses integer(c_int) :: c_mpi_waitall end function c_mpi_waitall diff --git a/src/mpi_wrapper.c b/src/mpi_wrapper.c index bf30f77..7e29380 100644 --- a/src/mpi_wrapper.c +++ b/src/mpi_wrapper.c @@ -60,3 +60,7 @@ MPI_Comm get_c_comm_from_fortran(int comm_f) { void* get_c_mpi_inplace_from_fortran(double sendbuf) { return MPI_IN_PLACE; } + +MPI_Status* get_c_MPI_STATUSES_IGNORE(){ + return MPI_STATUSES_IGNORE; +} \ No newline at end of file From d4ce896a128a2d338ff0d2251b529b5812741d85 Mon Sep 17 00:00:00 2001 From: Gaurav Dhingra Date: Thu, 10 Apr 2025 19:33:06 +0530 Subject: [PATCH 4/5] use a workaround for now --- src/mpi.f90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index b447624..21a0b5f 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -686,6 +686,7 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) integer, dimension(count), intent(inout) :: array_of_requests integer, dimension(*), intent(out) :: array_of_statuses integer, optional, intent(out) :: ierror + integer :: arr_request_item integer(c_int) :: local_ierr, status_ierr integer :: i @@ -698,7 +699,8 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) ! Convert Fortran requests to C requests. do i = 1, count - c_requests(i) = c_mpi_request_f2c(array_of_requests(i)) + arr_request_item = array_of_requests(i) + c_requests(i) = c_mpi_request_f2c(arr_request_item) end do ! Call the native MPI_Waitall. @@ -706,7 +708,8 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) ! Convert the C requests back to Fortran handles. do i = 1, count - array_of_requests(i) = c_mpi_request_c2f(c_requests(i)) + arr_request_item = c_requests(i) + array_of_requests(i) = c_mpi_request_c2f(arr_request_item) end do if (present(ierror)) then From 8d5a0f7cb95b6092dfe704109d676f7093c4ae55 Mon Sep 17 00:00:00 2001 From: Gaurav Dhingra Date: Thu, 10 Apr 2025 19:39:57 +0530 Subject: [PATCH 5/5] fix the workaround --- src/mpi.f90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index 21a0b5f..81a5bcc 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -686,7 +686,8 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) integer, dimension(count), intent(inout) :: array_of_requests integer, dimension(*), intent(out) :: array_of_statuses integer, optional, intent(out) :: ierror - integer :: arr_request_item + integer :: arr_request_item_kind_4 + integer(kind=MPI_HANDLE_KIND) :: arr_request_item_kind_mpi_handle_kind integer(c_int) :: local_ierr, status_ierr integer :: i @@ -699,8 +700,8 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) ! Convert Fortran requests to C requests. do i = 1, count - arr_request_item = array_of_requests(i) - c_requests(i) = c_mpi_request_f2c(arr_request_item) + arr_request_item_kind_4 = array_of_requests(i) + c_requests(i) = c_mpi_request_f2c(arr_request_item_kind_4) end do ! Call the native MPI_Waitall. @@ -708,8 +709,8 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) ! Convert the C requests back to Fortran handles. do i = 1, count - arr_request_item = c_requests(i) - array_of_requests(i) = c_mpi_request_c2f(arr_request_item) + arr_request_item_kind_mpi_handle_kind = c_requests(i) + array_of_requests(i) = c_mpi_request_c2f(arr_request_item_kind_mpi_handle_kind) end do if (present(ierror)) then