Allow SYNC TEAM team-value to be a child team

CMakeLists.txt

@@ -744,6 +744,7 @@ if(opencoarrays_aware_compiler)
       add_caf_test(teams_coarray_send 5 teams_coarray_send)
       add_caf_test(teams_coarray_send_by_ref 5 teams_coarray_send_by_ref)
       add_caf_test(teams_coarray_sendget 5 teams_coarray_sendget)
+      add_caf_test(sync_team 8 sync_team)
       add_caf_test(alloc_comp_multidim_shape 2 alloc_comp_multidim_shape)
     endif()
   endif()

src/mpi/mpi_caf.c

@@ -8324,24 +8324,25 @@ void PREFIX(sync_team) (caf_team_t *team , int unused __attribute__((unused)))
   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 the team is not a child */
+  if (tmp_used->team_list_elem != tmp_list->prev)
+  /* then search backwards through the team list, first checking if it's the
+   * current team, then if it is an ancestor 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");
+                      "or ancestor, or child");
 
   int ierr = MPI_Barrier(*tmp_comm); chk_err(ierr);
 }

src/tests/unit/teams/CMakeLists.txt

@@ -6,3 +6,4 @@ caf_compile_executable(teams_coarray_get_by_ref teams_coarray_get.f90)
 caf_compile_executable(teams_coarray_send teams_coarray_send.f90)
 caf_compile_executable(teams_coarray_send_by_ref teams_coarray_send.f90)
 caf_compile_executable(teams_coarray_sendget teams_coarray_sendget.f90)
+caf_compile_executable(sync_team sync-team.f90)

src/tests/unit/teams/sync-team.f90

@@ -0,0 +1,32 @@
+program main
+  use, intrinsic :: iso_fortran_env, only: team_type
+  implicit none
+  integer, parameter :: PARENT_TEAM = 1, CURRENT_TEAM = 2, CHILD_TEAM = 3
+  type(team_type) :: team(3)
+
+  if (num_images() < 8) error stop "I need at least 8 images to function."
+
+  form team (1, team(PARENT_TEAM))
+  change team (team(PARENT_TEAM))
+    form team (mod(this_image(),2)+1, team(CURRENT_TEAM))
+    change team (team(CURRENT_TEAM))
+      form team(mod(this_image(),2)+1, team(CHILD_TEAM))
+      sync team(team(PARENT_TEAM))
+      ! change order / number of syncs between teams to try to expose deadlocks
+      if (team_number() == 1) then
+         sync team(team(CURRENT_TEAM))
+         sync team(team(CHILD_TEAM))
+      else
+         sync team(team(CHILD_TEAM))
+         sync team(team(CURRENT_TEAM))
+         sync team(team(CHILD_TEAM))
+         sync team(team(CURRENT_TEAM))
+      end if
+    end team
+  end team
+
+  sync all
+
+  if (this_image() == 1) write(*,*) "Test passed."
+
+end program