Add more team support

docs/implementation-status.md

@@ -55,8 +55,9 @@ in the following sections.
 | Procedure | Status | Notes |
 |-----------|--------|-------|
 | `prif_num_images`    | **YES** |  |
-| `prif_num_images_with_team`, `prif_num_images_with_team_number`  | no |  |
-| `prif_this_image_no_coarray` | *partial* | team argument is ignored |
+| `prif_num_images_with_team` | **YES** |  |
+| `prif_num_images_with_team_number`  | no |  |
+| `prif_this_image_no_coarray` | **YES** |  |
 | `prif_this_image_with_coarray`, `prif_this_image_with_dim`  | no |  |
 | `prif_failed_images` | no |  |
 | `prif_stopped_images` | no |  |
@@ -183,13 +184,13 @@ in the following sections.
 ---
 
 ## Teams
-### Support = partial (No support for `prif_get_team` and `prif_team_number`)
+### Support = **YES** 
 
 | Procedure | Status | Notes |
 |-----------|--------|-------|
 | `prif_form_team`   | **YES**   |  |
-| `prif_get_team`    | no        |  |
-| `prif_team_number` | no        |  |
+| `prif_get_team`    | **YES**   |  |
+| `prif_team_number` | **YES**   |  |
 | `prif_change_team` | **YES**   |  |
 | `prif_end_team`    | **YES**   |  |
 
@@ -246,4 +247,4 @@ in the following sections.
 | `prif_atomic_ref_logical_indirect`    | no  |  |
 -->
 
----
+---

install.sh

@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/bin/bash
 
 set -e # exit on error
 

src/caffeine/allocation_s.f90

@@ -24,7 +24,7 @@
     type(prif_coarray_descriptor) :: unused
     type(prif_coarray_descriptor), pointer :: unused2(:)
 
-    me = caf_this_image(current_team%info%gex_team)
+    me = current_team%info%this_image
     if (caf_have_child_teams()) then
       ! Free the child team space to make sure we have space to allocate the coarray
       if (me == 1) then
@@ -119,13 +119,13 @@
     ! end do
     do i = 1, num_handles
       call remove_from_team_list(coarray_handles(i))
-      if (caf_this_image(current_team%info%gex_team) == 1) &
+      if (current_team%info%this_image == 1) &
         call caf_deallocate(current_team%info%heap_mspace, c_loc(coarray_handles(i)%info))
     end do
     if (present(stat)) stat = 0
     if (caf_have_child_teams()) then
       ! reclaim any free space possible for the child teams to use
-      if (caf_this_image(current_team%info%gex_team) == 1) then
+      if (current_team%info%this_image == 1) then
         call caf_deallocate(current_team%info%heap_mspace, current_team%info%child_heap_info%allocated_memory)
       end if
       call caf_establish_child_heap

src/caffeine/caffeine.c

@@ -28,18 +28,23 @@ typedef void(*final_func_ptr)(void*, size_t) ;
 typedef uint8_t byte;
 
 #if __GNUC__ >= 12
-  const int float_Complex_workaround = CFI_type_float_Complex;
-  const int double_Complex_workaround = CFI_type_double_Complex;
+  #define float_Complex_workaround  CFI_type_float_Complex
+  #define double_Complex_workaround CFI_type_double_Complex
 #else
-  const int float_Complex_workaround = 2052;
-  const int double_Complex_workaround =4100;
+  #define float_Complex_workaround  2052
+  #define double_Complex_workaround 4100
 #endif
 
-int caf_this_image(gex_TM_t team)
+// ---------------------------------------------------
+int caf_this_image(gex_TM_t gex_team)
 {
-  return gex_TM_QueryRank(team) + 1;
+  return gex_TM_QueryRank(gex_team) + 1;
 }
-
+int caf_num_images(gex_TM_t gex_team)
+{
+  return gex_TM_QuerySize(gex_team);
+}
+// ---------------------------------------------------
 // NOTE: gex_TM_T is a typedef to a C pointer, so the `gex_TM_t* initial_team` arg in the C signature matches the BIND(C) interface of an `intent(out)` arg of type `c_ptr` for the same argument
 void caf_caffeinate(
   mspace* symmetric_heap,
@@ -94,11 +99,6 @@ void caf_decaffeinate(int exit_code)
   gasnet_exit(exit_code);
 }
 
-int caf_num_images(gex_TM_t team)
-{
-  return gex_TM_QuerySize(team);
-}
-
 void* caf_allocate(mspace heap, size_t bytes)
 {
    void* allocated_space = mspace_memalign(heap, 8, bytes);

src/caffeine/image_queries_s.f90

@@ -7,20 +7,23 @@
 contains
 
   module procedure prif_num_images
-    num_images = caf_num_images(current_team%info%gex_team)
+    num_images = current_team%info%num_images
   end procedure
 
   module procedure prif_num_images_with_team
-    call unimplemented("prif_num_images_with_team")
+    num_images = team%info%num_images
   end procedure
 
   module procedure prif_num_images_with_team_number
     call unimplemented("prif_num_images_with_team_number")
   end procedure
 
   module procedure prif_this_image_no_coarray
-    ! TODO: handle optional arg `team`
-    this_image = caf_this_image(current_team%info%gex_team)
+    if (present(team)) then
+      this_image = team%info%this_image
+    else
+      this_image = current_team%info%this_image
+    endif
   end procedure
 
   module procedure prif_this_image_with_coarray

src/caffeine/prif_private_s.f90

@@ -42,19 +42,19 @@ subroutine caf_decaffeinate(exit_code) bind(C)
 
     ! _________________ Image enumeration ____________________
 
-    function caf_this_image(team) bind(C)
-      !! int caf_this_image();
+    function caf_this_image(gex_team) bind(C)
+      !! int caf_this_image(gex_TM_t gex_team);
       import c_ptr, c_int
       implicit none
-      type(c_ptr), value :: team
+      type(c_ptr), value :: gex_team
       integer(c_int) caf_this_image
     end function
 
-    pure function caf_num_images(team) bind(C)
-      !! int caf_num_images();
+    pure function caf_num_images(gex_team) bind(C)
+      !! int caf_num_images(gex_TM_t gex_team);
       import c_ptr, c_int
       implicit none
-      type(c_ptr), value :: team
+      type(c_ptr), value :: gex_team
       integer(c_int) caf_num_images
     end function
 
@@ -270,7 +270,7 @@ pure function optional_value(var) result(c_val)
   end function
 
   subroutine caf_establish_child_heap
-    if (caf_this_image(current_team%info%gex_team) == 1) then
+    if (current_team%info%this_image == 1) then
       call caf_allocate_remaining( &
           current_team%info%heap_mspace, &
           current_team%info%child_heap_info%allocated_memory, &

src/caffeine/program_startup_s.F90

@@ -17,6 +17,10 @@
           non_symmetric_heap_mspace, &
           initial_team%gex_team)
        current_team%info => initial_team
+       initial_team%parent_team => initial_team
+       initial_team%team_number = -1
+       initial_team%this_image = caf_this_image(initial_team%gex_team)
+       initial_team%num_images = caf_num_images(initial_team%gex_team)
        prif_init_called_previously = .true.
        stat = 0
     end if

src/caffeine/teams_s.f90

@@ -73,15 +73,30 @@
       allocate(team%info)
       team%info%parent_team => current_team%info
       call caf_form_team(current_team%info%gex_team, team%info%gex_team, team_number, new_index_)
+      team%info%team_number = team_number
+      team%info%this_image = caf_this_image(team%info%gex_team)
+      team%info%num_images = caf_num_images(team%info%gex_team)
     end block
   end procedure
 
   module procedure prif_get_team
-    call unimplemented("prif_get_team")
+    if (.not. present(level) .or. level == PRIF_CURRENT_TEAM) then
+      team = current_team
+    else if (level == PRIF_PARENT_TEAM) then
+      team = prif_team_type(current_team%info%parent_team)
+    else if (level == PRIF_INITIAL_TEAM) then
+      team = prif_team_type(initial_team)
+    else
+      call prif_error_stop(.false._c_bool, stop_code_char="prif_get_team: invalid level")
+    endif
   end procedure
 
   module procedure prif_team_number
-    call unimplemented("prif_team_number")
+    if (present(team)) then
+      team_number = team%info%team_number
+    else
+      team_number = current_team%info%team_number
+    endif
   end procedure
 
 end submodule

src/prif.F90

@@ -1056,6 +1056,8 @@ module subroutine prif_atomic_ref_logical_indirect(image_num, atom_remote_ptr, v
     type(c_ptr) :: heap_mspace
     integer(c_intptr_t) :: heap_start
     integer(c_size_t) :: heap_size
+    integer(c_int64_t) :: team_number
+    integer(c_int) :: this_image, num_images
     type(team_data), pointer :: parent_team => null()
     type(prif_coarray_descriptor), pointer :: coarrays => null()
     type(child_team_info), pointer :: child_heap_info => null()