From 80ea45c78a8242f2bef1fd9638c58906d7c1f639 Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Thu, 19 Dec 2024 17:05:50 -0600 Subject: [PATCH] feat: create implementation of co_reduce --- src/caffeine/caffeine.c | 2 +- .../collective_subroutines/co_reduce_s.f90 | 25 ++- test/caf_co_reduce_test.f90 | 165 +++++++++++++++++- 3 files changed, 184 insertions(+), 8 deletions(-) diff --git a/src/caffeine/caffeine.c b/src/caffeine/caffeine.c index ad6c51d4..e07d340e 100644 --- a/src/caffeine/caffeine.c +++ b/src/caffeine/caffeine.c @@ -158,7 +158,7 @@ void caf_sync_all() } void caf_co_reduce( - CFI_cdesc_t* a_desc, int result_image, int num_elements, gex_Coll_ReduceFn_t user_op, void* client_data, gex_TM_t team + CFI_cdesc_t* a_desc, int result_image, size_t num_elements, gex_Coll_ReduceFn_t user_op, void* client_data, gex_TM_t team ) { char* a_address = (char*) a_desc->base_addr; diff --git a/src/caffeine/collective_subroutines/co_reduce_s.f90 b/src/caffeine/collective_subroutines/co_reduce_s.f90 index e36a19eb..bd77528b 100644 --- a/src/caffeine/collective_subroutines/co_reduce_s.f90 +++ b/src/caffeine/collective_subroutines/co_reduce_s.f90 @@ -1,8 +1,8 @@ ! Copyright (c), The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(prif:prif_private_s) co_reduce_s + use iso_c_binding, only: c_funloc implicit none - contains module subroutine prif_co_reduce(a, operation_wrapper, cdata, result_image, stat, errmsg, errmsg_alloc) @@ -13,7 +13,28 @@ module subroutine prif_co_reduce(a, operation_wrapper, cdata, result_image, stat integer(c_int), intent(out), optional :: stat character(len=*), intent(inout), optional :: errmsg character(len=:), intent(inout), allocatable, optional :: errmsg_alloc - call unimplemented("prif_co_reduce") + call contiguous_co_reduce(a, operation_wrapper, cdata, result_image, stat, errmsg, errmsg_alloc) + end subroutine + + subroutine contiguous_co_reduce(a, operation_wrapper, cdata, result_image, stat, errmsg, errmsg_alloc) + type(*), intent(inout), target, contiguous :: a(..) + procedure(prif_operation_wrapper_interface), pointer, intent(in) :: operation_wrapper + type(c_ptr), intent(in), value :: cdata + integer(c_int), intent(in), optional :: result_image + integer(c_int), intent(out), optional :: stat + character(len=*), intent(inout), optional :: errmsg + character(len=:), intent(inout), allocatable, optional :: errmsg_alloc + + if (present(stat)) stat=0 + call assert(associated(operation_wrapper), "caf_co_reduce: associated(operation)") + + call caf_co_reduce( & + a, & + optional_value(result_image), & + int(product(shape(a)), c_size_t), & + c_funloc(operation_wrapper), & + cdata, & + current_team%info%gex_team) end subroutine end submodule co_reduce_s diff --git a/test/caf_co_reduce_test.f90 b/test/caf_co_reduce_test.f90 index c148dbe5..fd727866 100644 --- a/test/caf_co_reduce_test.f90 +++ b/test/caf_co_reduce_test.f90 @@ -1,11 +1,27 @@ module caf_co_reduce_test - use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray - use veggies, only : result_t, test_item_t, assert_equals, describe, it, succeed + use iso_c_binding, only: c_ptr, c_funptr, c_size_t, c_f_pointer, c_f_procpointer, c_funloc, c_loc, c_null_ptr + use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_operation_wrapper_interface + use veggies, only : result_t, test_item_t, assert_equals, assert_not, assert_that, describe, it, succeed implicit none private public :: test_prif_co_reduce + ! type :: pair + ! integer :: fst + ! real :: snd + ! end type + + ! type :: array(length) + ! integer, len :: length = 2 + ! integer :: elements(length) + ! end type + + ! type :: reduction_context_data + ! type(c_funptr) :: user_op + ! integer :: length + ! end type + contains function test_prif_co_reduce() result(tests) @@ -21,17 +37,156 @@ function test_prif_co_reduce() result(tests) function check_logical() result(result_) type(result_t) :: result_ - result_ = succeed("temporarily") + result_ = succeed("skip for now") + + ! logical :: val + ! procedure(prif_operation_wrapper_interface), pointer :: op + ! op => and_wrapper + + ! val = .true. + ! call prif_co_reduce(val, op, c_null_ptr) + ! result_ = assert_that(val) + + ! val = .false. + ! call prif_co_reduce(val, op, c_null_ptr) + ! result_ = result_.and.assert_not(val) end function + ! subroutine and_wrapper(arg1, arg2_and_out, count, cdata) bind(C) + ! type(c_ptr), intent(in), value :: arg1, arg2_and_out + ! integer(c_size_t), intent(in), value :: count + ! type(c_ptr), intent(in), value :: cdata + + ! logical, pointer :: lhs(:), rhs_and_result(:) + ! integer(c_size_t) :: i + + ! if (count == 0) return + ! call c_f_pointer(arg1, lhs, [count]) + ! call c_f_pointer(arg2_and_out, rhs_and_result, [count]) + ! do i = 1, count + ! rhs_and_result(i) = lhs(i).and.rhs_and_result(i) + ! end do + ! end subroutine + function check_derived_type_reduction() result(result_) type(result_t) :: result_ - result_ = succeed("temporarily") + result_ = succeed("skip for now") + + ! type(pair), parameter :: values(*,*) = reshape( & + ! [ pair(1, 53.), pair(3, 47.) & + ! , pair(5, 43.), pair(7, 41.) & + ! , pair(11, 37.), pair(13, 31.) & + ! , pair(17, 29.), pair(19, 23.) & + ! ], & + ! [2, 4]) + ! integer :: me, ni, i + ! type(pair), dimension(size(values,1)) :: my_val, expected + ! procedure(prif_operation_wrapper_interface), pointer :: op + + ! op => pair_adder + ! call prif_this_image_no_coarray(this_image=me) + ! call prif_num_images(ni) + + ! my_val = values(:, mod(me-1, size(values,2))+1) + ! call prif_co_reduce(my_val, op, c_null_ptr) + + ! expected = reduce(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), add_pair, dim=2) + ! result_ = & + ! assert_equals(expected%fst, my_val%fst) & + ! .and. assert_equals(real(expected%snd, kind=kind(0.d0)), real(my_val%snd, kind=kind(0.d0))) end function + ! pure function add_pair(lhs, rhs) result(total) + ! type(pair), intent(in) :: lhs, rhs + ! type(pair) :: total + + ! total%fst = lhs%fst + rhs%fst + ! total%snd = lhs%snd + rhs%snd + ! end function + + ! subroutine pair_adder(arg1, arg2_and_out, count, cdata) bind(C) + ! type(c_ptr), intent(in), value :: arg1, arg2_and_out + ! integer(c_size_t), intent(in), value :: count + ! type(c_ptr), intent(in), value :: cdata + + ! type(pair), pointer :: lhs(:), rhs_and_result(:) + ! integer(c_size_t) :: i + + ! if (count == 0) return + ! call c_f_pointer(arg1, lhs, [count]) + ! call c_f_pointer(arg2_and_out, rhs_and_result, [count]) + ! do i = 1, count + ! rhs_and_result(i) = add_pair(lhs(i), rhs_and_result(i)) + ! end do + ! end subroutine + function check_type_parameter_reduction() result(result_) type(result_t) :: result_ - result_ = succeed("temporarily") + result_ = succeed("skip for now") + + ! type(array), parameter :: values(*,*) = reshape( & + ! [ array([1, 53]), array([3, 47]) & + ! , array([5, 43]), array([7, 41]) & + ! , array([11, 37]), array([13, 31]) & + ! , array([17, 29]), array([19, 23]) & + ! ], & + ! [2, 4]) + ! integer :: me, ni, i + ! type(array(values%length)), dimension(size(values,1)) :: my_val, expected + ! procedure(prif_operation_wrapper_interface), pointer :: op + ! type(reduction_context_data), target :: context + + ! op => array_wrapper + ! context%user_op = c_funloc(add_array) + ! context%length = values%length + ! call prif_this_image_no_coarray(this_image=me) + ! call prif_num_images(ni) + + ! my_val = values(:, mod(me-1, size(values,2))+1) + ! call prif_co_reduce(my_val, op, c_loc(context)) + + ! expected = reduce(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), add_array, dim=2) + ! do i = 1, size(expected) + ! result_ = result_.and.assert_equals(expected(i)%elements, my_val(i)%elements) + ! end do end function + ! pure function add_array(lhs, rhs) result(total) + ! type(array), intent(in) :: lhs, rhs + ! type(array) :: total + + ! total%elements = lhs%elements + rhs%elements + ! end function + + ! subroutine array_wrapper(arg1, arg2_and_out, count, cdata) bind(C) + ! type(c_ptr), intent(in), value :: arg1, arg2_and_out + ! integer(c_size_t), intent(in), value :: count + ! type(c_ptr), intent(in), value :: cdata + + ! type(reduction_context_data), pointer :: context + + ! if (count == 0) return + ! call c_f_pointer(cdata, context) + ! block + ! abstract interface + ! pure function op_interface(lhs, rhs) result(res) + ! import :: array, context + ! implicit none + ! type(array(context%length)), intent(in) :: lhs, rhs + ! type(array(context%length)) :: res + ! end function + ! end interface + ! procedure(op_interface), pointer :: op + ! type(array(context%length)), pointer :: lhs(:), rhs_and_result(:) + ! integer(c_size_t) :: i + + ! call c_f_procpointer(context%user_op, op) + ! call c_f_pointer(arg1, lhs, [count]) + ! call c_f_pointer(arg2_and_out, rhs_and_result, [count]) + ! do i = 1, count + ! rhs_and_result(i) = op(lhs(i), rhs_and_result(i)) + ! end do + ! end block + ! end subroutine + end module caf_co_reduce_test