Implement PRIF 0.8 prif_co_broadcast_cptr

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** |  |

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
 //-------------------------------------------------------------------

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

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

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

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

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
 

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