Merge branch 'co_broadcast-derived-type' of github.com:sourceryinstitute/OpenCoarrays

Author: zbeekman

CMakeLists.txt

@@ -797,6 +797,7 @@ if(opencoarrays_aware_compiler)
 
   add_caf_test(co_sum 4 co_sum_test)
   add_caf_test(co_broadcast 4 co_broadcast_test)
+  add_caf_test(co_broadcast_derived_type 4 co_broadcast_derived_type_test)
   add_caf_test(co_min 4 co_min_test)
   add_caf_test(co_max 4 co_max_test)
   add_caf_test(syncall 8 syncall)

src/mpi/mpi_caf.c

@@ -7253,9 +7253,10 @@ get_MPI_datatype(gfc_descriptor_t *desc, int char_len)
     return string;
   }
 
-  caf_runtime_error("Unsupported data type in collective: %zd\n",
-                    GFC_DTYPE_TYPE_SIZE(desc));
-  return 0;
+  return MPI_BYTE;
+  /* caf_runtime_error("Unsupported data type in collective: %zd\n", */
+  /*                   GFC_DTYPE_TYPE_SIZE(desc)); */
+  /* return 0; */
 }
 
 
@@ -7379,9 +7380,17 @@ PREFIX(co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat,
     size *= dimextent;
   }
 
+  printf("DTYPE Size: %d\n",GFC_DESCRIPTOR_SIZE(a));
+
   if (rank == 0)
   {
-    if (datatype != MPI_CHARACTER)
+    if( datatype == MPI_BYTE)
+      {
+	ierr = MPI_Bcast(a->base_addr, size*GFC_DESCRIPTOR_SIZE(a),
+			 datatype, source_image - 1,
+			 CAF_COMM_WORLD); chk_err(ierr);
+      }
+    else if (datatype != MPI_CHARACTER)
     {
       ierr = MPI_Bcast(a->base_addr, size, datatype, source_image - 1,
                        CAF_COMM_WORLD); chk_err(ierr);

src/tests/unit/collectives/CMakeLists.txt

@@ -1,5 +1,6 @@
 caf_compile_executable(co_sum_test co_sum.F90)
 caf_compile_executable(co_broadcast_test co_broadcast.F90)
+caf_compile_executable(co_broadcast_derived_type_test co_broadcast_derived_type.f90)
 caf_compile_executable(co_min_test co_min.F90)
 caf_compile_executable(co_max_test co_max.F90)
 caf_compile_executable(co_reduce_test co_reduce.F90)

src/tests/unit/collectives/co_broadcast_derived_type.f90

@@ -0,0 +1,95 @@
+module object_interface
+  implicit none
+  private
+  public :: object
+
+  type object
+    private
+    integer :: foo=0
+    logical :: bar=.false.
+  contains
+    procedure :: initialize
+    procedure :: co_broadcast_me
+    procedure :: not_equal
+    procedure :: copy
+    generic :: operator(/=)=>not_equal
+    generic :: assignment(=)=>copy
+  end type
+
+  interface
+    elemental impure module subroutine initialize(this,foo_,bar_)
+      implicit none
+      class(object), intent(out) :: this
+      integer, intent(in) :: foo_
+      logical, intent(in) :: bar_
+    end subroutine
+
+    elemental impure module subroutine co_broadcast_me(this,source_image)
+      implicit none
+      class(object), intent(inout) :: this
+      integer, intent(in) :: source_image
+    end subroutine
+
+    elemental module function not_equal(lhs,rhs) result(lhs_ne_rhs)
+      implicit none
+      class(object), intent(in) :: lhs,rhs
+      logical lhs_ne_rhs
+    end function
+
+    elemental impure module subroutine copy(lhs,rhs)
+      implicit none
+      class(object), intent(inout) :: lhs
+      class(object), intent(in) :: rhs
+    end subroutine
+  end interface
+
+end module
+
+submodule(object_interface) object_implementation
+  implicit none
+contains
+    module procedure co_broadcast_me
+      call co_broadcast(this%foo,source_image)
+      call co_broadcast(this%bar,source_image)
+    end procedure
+
+    module procedure initialize
+      this%foo = foo_
+      this%bar = bar_
+    end procedure
+
+    module procedure not_equal
+      lhs_ne_rhs = (lhs%foo /= rhs%foo) .or. (lhs%bar .neqv. rhs%bar)
+    end procedure
+
+    module procedure copy
+       lhs%foo = rhs%foo
+       lhs%bar = rhs%bar
+    end procedure
+end submodule
+
+program main
+  use object_interface, only : object
+  implicit none
+  type(object) message
+
+  call message%initialize(foo_=1,bar_=.true.)
+
+  emulate_co_broadcast: block
+    type(object) foobar
+    if (this_image()==1) foobar = message
+    call foobar%co_broadcast_me(source_image=1)
+    if ( foobar /= message ) error stop "Test failed."
+  end block emulate_co_broadcast
+
+  desired_co_broadcast: block
+    type(object) barfoo
+    if (this_image()==1) barfoo = message
+    call co_broadcast(barfoo,source_image=1)  ! OpenCoarrays terminates here with the message "Unsupported data type"
+    if ( barfoo /= message ) error stop "Test failed."
+  end block desired_co_broadcast
+
+  sync all  ! Wait for each image to pass the test
+  if (this_image()==1) print *,"Test passed."
+
+end program main