Merge pull request #474 from sourceryinstitute/opencoarrays-teams

Merge opencoarrays-teams into master

Author: zbeekman

CMakeLists.txt

@@ -245,6 +245,8 @@ if (NOT MPIEXEC)
 report this bug to the OpenCoarrays developers at
 https://github.com/sourceryinstitute/opencoarrays/issues, otherwise point CMake
 to the desired MPI runtime.")
+else()
+  add_definitions(-DHAVE_MPI)
 endif()
 
 get_filename_component(MPIEXEC_RELATIVE_LOC "${MPIEXEC}"
@@ -656,6 +658,10 @@ if(opencoarrays_aware_compiler)
     add_caf_test(comp_allocated_1 2 comp_allocated_1)
     add_caf_test(comp_allocated_2 2 comp_allocated_2)
     add_caf_test(alloc_comp_get_convert_nums 2 alloc_comp_get_convert_nums)
+    if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 8)
+      add_caf_test(team_number 2 ${tests_root}/unit/teams/team_number)
+      add_caf_test(get_communicator 3 ${tests_root}/unit/teams/get_communicator)
+    endif()
   endif()
 
 
@@ -730,6 +736,7 @@ if(opencoarrays_aware_compiler)
   add_caf_test(co_heat 2 co_heat)
   add_caf_test(asynchronous_hello_world 3 asynchronous_hello_world)
 
+
   # Regression tests based on reported issues
   if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
     if( CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0 )

src/extensions/opencoarrays.F90

@@ -46,6 +46,10 @@ module opencoarrays
   public :: num_images
   public :: error_stop
   public :: sync_all
+  public :: team_number
+#ifdef HAVE_MPI
+  public :: get_communicator
+#endif
 #ifdef COMPILER_SUPPORTS_ATOMICS
   public :: event_type
   public :: event_post
@@ -102,6 +106,31 @@ pure function logical_operator(lhs,rhs) result(lhs_op_rhs)
      end function
   end interface
 
+  interface
+#ifdef COMPILER_SUPPORTS_CAF_INTRINSICS
+    function team_number(team_type_ptr) result(my_team_number) bind(C,name="_caf_extensions_team_number")
+#else
+    function team_number(team_type_ptr) result(my_team_number) bind(C,name="_gfortran_caf_team_number")
+#endif
+       use iso_c_binding, only : c_int,c_ptr
+       implicit none
+       type(c_ptr), optional :: team_type_ptr
+       integer(c_int) :: my_team_number
+    end function
+
+#ifdef COMPILER_SUPPORTS_CAF_INTRINSICS
+    function get_communicator(team_type_ptr) result(my_team) bind(C,name="_caf_extensions_get_communicator")
+#else
+    function get_communicator(team_type_ptr) result(my_team) bind(C,name="_gfortran_caf_get_communicator")
+#endif
+       use iso_c_binding, only : c_int,c_ptr
+       implicit none
+       type(c_ptr), optional :: team_type_ptr
+       integer(c_int) :: my_team
+    end function
+  end interface
+
+
   ! __________ End Public Interface _____________
 
 

src/libcaf.h

@@ -34,6 +34,8 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  */
 
 #include "libcaf-gfortran-descriptor.h"
 
+#include <mpi.h>
+
 #ifndef __GNUC__
 #define __attribute__(x)
 #define likely(x)       (x)
@@ -89,10 +91,23 @@ typedef enum caf_deregister_t {
 caf_deregister_t;
 
 typedef void* caf_token_t;
-#ifdef GCC_GE_7
 /** Add a dummy type representing teams in coarrays. */
+
 typedef void * caf_team_t;
-#endif
+
+typedef struct caf_teams_list {
+  caf_team_t team;
+  int team_id;
+  struct caf_teams_list *prev;
+}
+caf_teams_list;
+
+typedef struct caf_used_teams_list {
+  struct caf_teams_list *team_list_elem;
+  struct caf_used_teams_list *prev;
+}
+caf_used_teams_list;
+
 
 /* When there is a vector subscript in this dimension, nvec == 0, otherwise,
    lower_bound, upper_bound, stride contains the bounds relative to the declared
@@ -269,6 +284,12 @@ void PREFIX (error_stop_str) (const char *, int32_t)
 void PREFIX (error_stop) (int32_t) __attribute__ ((noreturn));
 void PREFIX (fail_image) (void) __attribute__ ((noreturn));
 
+void PREFIX (form_team) (int, caf_team_t *, int);
+void PREFIX (change_team) (caf_team_t *, int);
+void PREFIX (end_team) (caf_team_t *);
+void PREFIX (sync_team) (caf_team_t *, int);
+int PREFIX (team_number) (caf_team_t *);
+
 int PREFIX (image_status) (int);
 void PREFIX (failed_images) (gfc_descriptor_t *, int, int *);
 void PREFIX (stopped_images) (gfc_descriptor_t *, int, int *);
@@ -285,4 +306,10 @@ void PREFIX (unlock) (caf_token_t, size_t, int, int *, char *, int);
 void PREFIX (event_post) (caf_token_t, size_t, int, int *, char *, int);
 void PREFIX (event_wait) (caf_token_t, size_t, int, int *, char *, int);
 void PREFIX (event_query) (caf_token_t, size_t, int, int *, int *);
+
+/* Language extension */
+#ifdef HAVE_MPI
+MPI_Fint PREFIX (get_communicator) (caf_team_t *);
+#endif
+
 #endif  /* LIBCAF_H  */

src/mpi/CMakeLists.txt

@@ -186,7 +186,6 @@ install(TARGETS caf_mpi_static EXPORT OpenCoarraysTargets
   LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}"
   )
 
-
 ##############################################
 # Configure `caf` and `cafrun` wrapper scripts
 ##############################################

src/mpi/mpi_caf.c

@@ -216,6 +216,9 @@ char err_buffer[MPI_MAX_ERROR_STRING];
    MPI_COMM_WORLD for interoperability purposes. */
 MPI_Comm CAF_COMM_WORLD;
 
+static caf_teams_list *teams_list = NULL;
+static caf_used_teams_list *used_teams = NULL;
+
 /* Emitted when a theorectically unreachable part is reached.  */
 const char unreachable[] = "Fatal error: unreachable alternative found.\n";
 
@@ -801,6 +804,16 @@ PREFIX (init) (int *argc, char ***argv)
 
       stat_tok = malloc (sizeof (MPI_Win));
 
+      teams_list = (caf_teams_list *)calloc(1,sizeof(caf_teams_list));
+      teams_list->team_id = -1;
+      MPI_Comm *tmp_comm = (MPI_Comm *)calloc(1,sizeof(MPI_Comm));
+      *tmp_comm = CAF_COMM_WORLD;
+      teams_list->team = tmp_comm;
+      teams_list->prev = NULL;
+      used_teams = (caf_used_teams_list *)calloc(1,sizeof(caf_used_teams_list));
+      used_teams->team_list_elem = teams_list;
+      used_teams->prev = NULL;
+
 #ifdef WITH_FAILED_IMAGES
       MPI_Comm_dup (MPI_COMM_WORLD, &alive_comm);
       /* Handling of failed/stopped images is done by setting an error handler
@@ -7142,7 +7155,6 @@ PREFIX(atomic_ref) (caf_token_t token, size_t offset,
   return;
 }
 
-
 void
 PREFIX(atomic_cas) (caf_token_t token, size_t offset,
                     int image_index, void *old, void *compare,
@@ -7634,3 +7646,140 @@ unimplemented_alloc_comps_message (const char * functionname)
   exit (EXIT_FAILURE);
 #endif
 }
+
+void PREFIX (form_team) (int team_id, caf_team_t *team, int index __attribute__ ((unused)))
+{
+  struct caf_teams_list *tmp;
+  void * tmp_team;
+  MPI_Comm *newcomm;
+  MPI_Comm *current_comm = &CAF_COMM_WORLD;
+
+  MPI_Barrier(CAF_COMM_WORLD);
+  newcomm = (MPI_Comm *)calloc(1,sizeof(MPI_Comm));
+  MPI_Comm_split(*current_comm, team_id, caf_this_image, newcomm);
+
+  tmp = calloc(1,sizeof(struct caf_teams_list));
+  tmp->prev = teams_list;
+  teams_list = tmp;
+  teams_list->team_id = team_id;
+  teams_list->team = newcomm;
+  *team = tmp;
+}
+
+void PREFIX (change_team) (caf_team_t *team, int coselector __attribute__ ((unused)))
+{
+  caf_used_teams_list *tmp_used = NULL;
+  caf_teams_list * tmp_list = NULL;
+  void *tmp_team;
+  MPI_Comm *tmp_comm;
+
+  MPI_Barrier(CAF_COMM_WORLD);
+  tmp_list = (struct caf_teams_list *)*team;
+  tmp_team = (void *)tmp_list->team;
+  tmp_comm = (MPI_Comm *)tmp_team;
+
+  tmp_used = (caf_used_teams_list *)calloc(1,sizeof(caf_used_teams_list));
+  tmp_used->prev = used_teams;
+
+  /* /\* We need to look in the teams_list and find the appropriate element. */
+  /*  * This is not efficient but can be easily fixed in the future.  */
+  /*  * Instead of keeping track of the communicator in the compiler  */
+  /*  * we should keep track of the caf_teams_list element associated with it. *\/ */
+
+  /* tmp_list = teams_list; */
+
+  /* while(tmp_list) */
+  /*   { */
+  /*     if(tmp_list->team == tmp_team) */
+  /* 	break; */
+  /*     tmp_list = tmp_list->prev; */
+  /*   } */
+
+  if(tmp_list == NULL)
+    caf_runtime_error("CHANGE TEAM called on a non-existing team");
+
+  tmp_used->team_list_elem = tmp_list;
+  used_teams = tmp_used;
+  tmp_team = tmp_used->team_list_elem->team;
+  tmp_comm = (MPI_Comm *)tmp_team;
+  CAF_COMM_WORLD = *tmp_comm;
+  MPI_Comm_rank(*tmp_comm,&caf_this_image);
+  caf_this_image++;
+  MPI_Comm_size(*tmp_comm,&caf_num_images);
+}
+
+MPI_Fint
+PREFIX (get_communicator) (caf_team_t *team)
+{
+  if(team != NULL) caf_runtime_error("get_communicator does not yet support the optional team argument");
+
+  MPI_Comm* comm_ptr = teams_list->team;
+
+  MPI_Fint ret = MPI_Comm_c2f(*comm_ptr);
+
+  return ret;
+
+  //  return  *(int*)comm_ptr;
+}
+
+int
+PREFIX (team_number) (caf_team_t *team)
+{
+  if(team != NULL) caf_runtime_error("team_number does not yet support the optional team argument");
+
+  /* if(used_teams->prev == NULL) */
+  /*   return -1; */
+  return used_teams->team_list_elem->team_id;
+}
+
+void PREFIX (end_team) (caf_team_t *team __attribute__ ((unused)))
+{
+  caf_used_teams_list *tmp_used = NULL;
+  void *tmp_team;
+  MPI_Comm *tmp_comm;
+
+  MPI_Barrier(CAF_COMM_WORLD);
+  if(used_teams->prev == NULL)
+    caf_runtime_error("END TEAM called on initial team");
+
+  tmp_used = used_teams;
+  used_teams = used_teams->prev;
+  free(tmp_used);
+  tmp_used = used_teams;
+  tmp_team = tmp_used->team_list_elem->team;
+  tmp_comm = (MPI_Comm *)tmp_team;
+  CAF_COMM_WORLD = *tmp_comm;
+  MPI_Barrier(CAF_COMM_WORLD);
+  /* CAF_COMM_WORLD = (MPI_Comm)*tmp_used->team_list_elem->team; */
+  MPI_Comm_rank(CAF_COMM_WORLD,&caf_this_image);
+  caf_this_image++;
+  MPI_Comm_size(CAF_COMM_WORLD,&caf_num_images);
+}
+
+void PREFIX (sync_team) (caf_team_t *team , int unused __attribute__ ((unused)))
+{
+  caf_teams_list *tmp_list = NULL;
+  caf_used_teams_list *tmp_used = NULL;
+  void *tmp_team;
+  MPI_Comm *tmp_comm;
+
+  /* Check if the team is the current, and ancestor or a descendant. To be implemented. */
+
+  tmp_used = used_teams;
+  tmp_list = (struct caf_teams_list *)*team;
+  tmp_team = (void *)tmp_list->team;
+  tmp_comm = (MPI_Comm *)tmp_team;
+
+  while(tmp_used)
+    {
+      if(tmp_used->team_list_elem == tmp_list)
+	break;
+      tmp_used = tmp_used->prev;
+    }
+
+  if(tmp_used == NULL)
+    caf_runtime_error("SYNC TEAM called on team different from current or ancestor or descendant");
+
+  MPI_Barrier(*tmp_comm);
+
+}

src/tests/unit/CMakeLists.txt

@@ -5,8 +5,13 @@ if (${opencoarrays_aware_compiler})
   add_subdirectory(collectives)
   add_subdirectory(sync)
   add_subdirectory(events)
-  if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7)
-    add_subdirectory(fail_images)
+  if (gfortran_compiler)
+    if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7)
+      add_subdirectory(fail_images)
+      if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 8)
+        add_subdirectory(teams)
+      endif()
+    endif()
   endif()
 else()
   add_subdirectory(extensions)

src/tests/unit/teams/CMakeLists.txt

@@ -0,0 +1,9 @@
+add_executable(team_number team-number.f90)
+target_link_libraries(team_number OpenCoarrays)
+#TODO: Remove when gfortran supports team_number()
+target_include_directories(team_number PRIVATE ${CMAKE_BINARY_DIR}/include)
+
+#add_executable(get_communicator get-communicator.f90)
+#target_link_libraries(get_communicator OpenCoarrays)
+#TODO: Remove when gfortran supports team_number()
+#target_include_directories(get_communicator PRIVATE ${CMAKE_BINARY_DIR}/include)