diff --git a/docs/implementation-status.md b/docs/implementation-status.md index 777d234a..47dc3a6a 100644 --- a/docs/implementation-status.md +++ b/docs/implementation-status.md @@ -188,6 +188,7 @@ selected constant values from `ISO_FORTRAN_ENV` of the hosting compiler. | Procedure | Status | Notes | |-----------|--------|-------| | `prif_co_broadcast` | **YES** | | +| `prif_co_broadcast_cptr`| **YES** | expected in PRIF 0.8 | | `prif_co_max` | **YES** | | | `prif_co_max_character` | **YES** | | | `prif_co_min` | **YES** | | diff --git a/src/caffeine/caffeine.c b/src/caffeine/caffeine.c index a3968a1b..2f76ad35 100644 --- a/src/caffeine/caffeine.c +++ b/src/caffeine/caffeine.c @@ -548,19 +548,24 @@ void caf_co_reduce( CFI_cdesc_t* a_desc, int result_image, size_t num_elements, op_wrapper, client_data, team); } -void caf_co_broadcast(CFI_cdesc_t * a_desc, int source_image, int num_elements, gex_TM_t team) -{ - char* c_loc_a = (char*) a_desc->base_addr; - size_t c_sizeof_a = a_desc->elem_len; - int nbytes = num_elements * c_sizeof_a; - - int data_type = a_desc->type; +void caf_co_broadcast_cptr(void *a_ptr, int source_image, size_t nbytes, gex_TM_t team) { + assert(a_ptr); + assert(source_image >= 0); + assert(nbytes > 0); gex_Event_t ev - = gex_Coll_BroadcastNB(team, source_image-1, c_loc_a, c_loc_a, nbytes, 0); + = gex_Coll_BroadcastNB(team, source_image-1, a_ptr, a_ptr, nbytes, 0); gex_Event_Wait(ev); } +void caf_co_broadcast(CFI_cdesc_t * a_desc, int source_image, int num_elements, gex_TM_t team) { + assert(a_desc); + char* a_ptr = (char*) a_desc->base_addr; + size_t element_size = a_desc->elem_len; + int nbytes = num_elements * element_size; + caf_co_broadcast_cptr(a_ptr, source_image, nbytes, team); +} + //------------------------------------------------------------------- // Typed computational collective subroutines //------------------------------------------------------------------- diff --git a/src/caffeine/co_broadcast_s.F90 b/src/caffeine/co_broadcast_s.F90 index 5173a30d..a4ec6913 100644 --- a/src/caffeine/co_broadcast_s.F90 +++ b/src/caffeine/co_broadcast_s.F90 @@ -28,4 +28,9 @@ subroutine contiguous_co_broadcast(a, source_image, stat, errmsg, errmsg_alloc) ! and eliminate the calculation of num_elements*sizeof(a) in caffeine.c. end subroutine + module procedure prif_co_broadcast_cptr + call_assert(source_image >= 1 .and. source_image <= current_team%info%num_images) + if (present(stat)) stat=0 + call caf_co_broadcast_cptr(a_ptr, source_image, size_in_bytes, current_team%info%gex_team) + end procedure end submodule co_broadcast_s diff --git a/src/caffeine/prif_private_s.F90 b/src/caffeine/prif_private_s.F90 index dd8fc4d7..be239f1a 100644 --- a/src/caffeine/prif_private_s.F90 +++ b/src/caffeine/prif_private_s.F90 @@ -301,6 +301,16 @@ subroutine caf_co_broadcast(a, source_image, Nelem, team) bind(C) type(c_ptr), value :: team end subroutine + subroutine caf_co_broadcast_cptr(a_ptr, source_image, nbytes, team) bind(C) + !! void caf_co_broadcast_cptr(void *a_ptr, int source_image, size_t nbytes, gex_TM_t team) + import c_int, c_ptr, c_size_t + implicit none + type(c_ptr), value :: a_ptr + integer(c_int), value :: source_image + integer(c_size_t), value :: nbytes + type(c_ptr), value :: team + end subroutine + subroutine caf_co_reduce(a, result_image, num_elements, op_wrapper, client_data, team) bind(C) !! void caf_co_reduce(CFI_cdesc_t* a_desc, int result_image, size_t num_elements, gex_Coll_ReduceFn_t op_wrapper, void* client_data, gex_TM_t team) import c_int, c_ptr, c_size_t, c_funptr diff --git a/src/prif.F90 b/src/prif.F90 index 4fa08065..ccdb5ff9 100644 --- a/src/prif.F90 +++ b/src/prif.F90 @@ -50,7 +50,7 @@ module prif public :: prif_num_images, prif_num_images_with_team, prif_num_images_with_team_number public :: prif_failed_images, prif_stopped_images, prif_image_status public :: prif_local_data_pointer, prif_set_context_data, prif_get_context_data, prif_size_bytes - public :: prif_co_sum, prif_co_max, prif_co_min, prif_co_reduce, prif_co_reduce_cptr, prif_co_broadcast + public :: prif_co_sum, prif_co_max, prif_co_min, prif_co_reduce, prif_co_reduce_cptr, prif_co_broadcast, prif_co_broadcast_cptr public :: prif_co_min_character, prif_co_max_character public :: prif_operation_wrapper_interface public :: prif_form_team, prif_change_team, prif_end_team, prif_get_team, prif_team_number @@ -764,6 +764,16 @@ module subroutine prif_co_broadcast(a, source_image, stat, errmsg, errmsg_alloc) character(len=:), intent(inout), allocatable, optional :: errmsg_alloc end subroutine + module subroutine prif_co_broadcast_cptr(a_ptr, size_in_bytes, source_image, stat, errmsg, errmsg_alloc) + implicit none + type(c_ptr), intent(in) :: a_ptr + integer(c_size_t), intent(in) :: size_in_bytes + integer(c_int), intent(in) :: source_image + integer(c_int), intent(out), optional :: stat + character(len=*), intent(inout), optional :: errmsg + character(len=:), intent(inout), allocatable, optional :: errmsg_alloc + end subroutine + module subroutine prif_form_team(team_number, team, new_index, stat, errmsg, errmsg_alloc) implicit none integer(c_int64_t), intent(in) :: team_number diff --git a/test/prif_allocate_test.F90 b/test/prif_allocate_test.F90 index 64432850..b932be6a 100644 --- a/test/prif_allocate_test.F90 +++ b/test/prif_allocate_test.F90 @@ -183,7 +183,7 @@ subroutine coarray_cleanup_simple(handle , stat, errmsg) bind(C) integer(c_int), intent(out) :: stat character(len=:), intent(out), allocatable :: errmsg - ALSO(assert_aliased(handle, ff_handle, 0)) + ALSO(assert_aliased(handle, ff_handle)) ff_count = ff_count + 1 stat = 0 @@ -194,7 +194,7 @@ subroutine coarray_cleanup_first_error(handle , stat, errmsg) bind(C) integer(c_int), intent(out) :: stat character(len=:), intent(out), allocatable :: errmsg - ALSO(assert_aliased(handle, ff_handle, 0)) + ALSO(assert_aliased(handle, ff_handle)) ff_count = ff_count + 1 errmsg = ff_err diff --git a/test/prif_co_broadcast_test.F90 b/test/prif_co_broadcast_test.F90 index 3a93da58..a4541608 100644 --- a/test/prif_co_broadcast_test.F90 +++ b/test/prif_co_broadcast_test.F90 @@ -1,12 +1,17 @@ +#include "test-utils.F90" + module prif_co_broadcast_test_m - use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray + use iso_c_binding, only: c_loc, c_size_t + use prif, only : prif_co_broadcast, prif_co_broadcast_cptr, prif_num_images, prif_this_image_no_coarray use julienne_m, only : & usher & + ,string_t & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,test_t & ,operator(//) & + ,operator(.also.) & ,operator(.expect.) & ,operator(.equalsExpected.) @@ -21,6 +26,7 @@ module prif_co_broadcast_test_m end type type object_t + sequence ! guarantee components reside in flat linear storage integer i logical fallacy character(len=len("fooey")) actor @@ -44,7 +50,14 @@ function results() result(test_results) allocate(test_results, source = prif_co_broadcast_test%run([ & test_description_t("broadcasting a default integer scalar with no optional arguments present", usher(broadcast_default_integer_scalar)) & - ,test_description_t("broadcasting a derived type scalar with no allocatable components", usher(broadcast_derived_type)) & + ,test_description_t("prif_co_broadcast of a derived type scalar with no allocatable components", usher(broadcast_derived_type)) & + ,test_description_t("prif_co_broadcast_cptr of a derived type scalar with no allocatable components" & +# if __LFORTRAN__ && __LFORTRAN_MAJOR__ == 0 && __LFORTRAN_MINOR__ <= 63 + ! test disabled for LFortran issue 11191 +# else + , usher(broadcast_derived_type_cptr) & +# endif + ) & ])) end function @@ -60,26 +73,53 @@ logical pure function equals(lhs, rhs) function broadcast_default_integer_scalar() result(diag) type(test_diagnosis_t) :: diag - integer iPhone, me + integer, target :: a, me integer, parameter :: source_value = 7779311, junk = -99 + diag = .true. + call prif_this_image_no_coarray(this_image=me) - iPhone = merge(source_value, junk, me==1) - call prif_co_broadcast(iPhone, source_image=1) - diag = iPhone .equalsExpected. source_value + + a = merge(source_value, junk, me==1) + call prif_co_broadcast(a, source_image=1) + ALSO(a .equalsExpected. source_value) + + a = merge(source_value*7, junk, me==1) + call prif_co_broadcast_cptr(c_loc(a), size_in_bytes=storage_size(a,c_size_t)/8, source_image=1) + ALSO(a .equalsExpected. source_value*7) end function function broadcast_derived_type() result(diag) type(test_diagnosis_t) :: diag - type(object_t) object + type(object_t) :: object integer me, ni + diag = .true. + call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=ni) + object = object_t(me, .false., "gooey", me*(1.,0.)) call prif_co_broadcast(object, source_image=ni) associate(expected_object => object_t(ni, .false., "gooey", ni*(1.,0.))) - diag = .expect. (object == expected_object) // "co_broadcast derived type" + ALSO2(object == expected_object, "co_broadcast derived type") + end associate + end function + + function broadcast_derived_type_cptr() result(diag) + type(test_diagnosis_t) :: diag + type(object_t), target :: object + integer me, ni + + diag = .true. + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=ni) + + object = object_t(me, .true., "hooey", me*(10.,0.)) + call prif_co_broadcast_cptr(c_loc(object), storage_size(object,c_size_t)/8, source_image=ni) + associate(expected_object => object_t(ni, .true., "hooey", ni*(10.,0.))) + ALSO2(object == expected_object, "co_broadcast_cptr derived type") end associate end function diff --git a/test/prif_co_reduce_test.F90 b/test/prif_co_reduce_test.F90 index 3e419c0f..322374c9 100644 --- a/test/prif_co_reduce_test.F90 +++ b/test/prif_co_reduce_test.F90 @@ -30,12 +30,14 @@ module prif_co_reduce_test_m end type type :: pair + sequence ! guarantee components reside in flat linear storage integer :: fst real :: snd end type #if HAVE_PARAM_DERIVED type :: array(length) + sequence integer, len :: length = 2 integer :: elements(length) end type