Misc fixes

src/caffeine/caffeine.c

@@ -63,14 +63,14 @@ int caf_num_images(gex_TM_t tm) {
 // Given team and corresponding image_num, return image number in the initial team
 int caf_image_to_initial(gex_TM_t tm, int image_num) {
   assert(image_num >= 1);
-  assert(image_num <= gex_TM_QuerySize(tm));
+  assert(image_num <= (int)gex_TM_QuerySize(tm));
   gex_Rank_t proc = gex_TM_TranslateRankToJobrank(tm, image_num-1);
   return proc + 1;
 }
 // Given image number in the initial team, return image number corresponding to given team
 int caf_image_from_initial(gex_TM_t tm, int image_num) {
   assert(image_num >= 1);
-  assert(image_num <= numprocs);
+  assert(image_num <= (int)numprocs);
   gex_Rank_t proc = gex_TM_TranslateJobrankToRank(tm, image_num-1);
   // GEX_RANK_INVALID indicates the provided image_num in initial team is not part of tm
   assert(proc != GEX_RANK_INVALID); 
@@ -405,7 +405,7 @@ static void atomic_init(void) {
 void caf_atomic_int(int opcode, int image, void* addr, int64_t *result, int64_t op1, int64_t op2) {
   assert(atomic_AD != GEX_AD_INVALID);
   assert(addr);
-  assert(opcode >= 0 && opcode < sizeof(op_map)/sizeof(op_map[0]));
+  assert(opcode >= 0 && opcode < (int)(sizeof(op_map)/sizeof(op_map[0])));
 
   gex_OP_t op = op_map[opcode];
   gex_Event_Wait(
@@ -428,6 +428,13 @@ void caf_atomic_logical(int opcode, int image, void* addr, int64_t *result, int6
 }
 
 //-------------------------------------------------------------------
+// gfortran 13.2 .. 15 : c_funloc is non-compliant
+// it erroneously generates a non-callable pointer to a pointer to the subroutine
+// This helper is used to undo that incorrect extra level of indirection
+typedef void (*funloc_t)(void);
+funloc_t caf_c_funloc_deref(funloc_t funloc) {
+  return *(funloc_t *)funloc;
+}
 
 void caf_co_reduce(
   CFI_cdesc_t* a_desc, int result_image, size_t num_elements, gex_Coll_ReduceFn_t user_op, void* client_data, gex_TM_t team
@@ -436,12 +443,7 @@ void caf_co_reduce(
   assert(result_image >= 0);
   assert(num_elements > 0);
   assert(user_op);
-#if PLATFORM_COMPILER_GNU
-  // gfortran 13.2 & 14 - c_funloc is non-compliant
-  // it erroneously generates a non-callable pointer to a pointer to the subroutine
-  // Here we undo that incorrect extra level of indirection
-  user_op = *(gex_Coll_ReduceFn_t *)user_op; 
-#endif
+
   char* a_address = (char*) a_desc->base_addr;
   size_t c_sizeof_a = a_desc->elem_len;
   gex_Event_t ev;
@@ -550,7 +552,7 @@ static int64_t *widen_from_array(CFI_cdesc_t* a_desc, size_t num_elements) {
   } else if (a_desc->elem_len == 2) {
     int16_t *src = a_desc->base_addr;
     for (size_t i=0; i < num_elements; i++) res[i] = src[i];
-  } else gasnett_fatalerror("Logic error in widen_from_array: %i", a_desc->elem_len);
+  } else gasnett_fatalerror("Logic error in widen_from_array: %i", (int)a_desc->elem_len);
   return res;
 }
 
@@ -564,7 +566,7 @@ static void narrow_to_array(CFI_cdesc_t* a_desc, int64_t *src, size_t num_elemen
   } else if (a_desc->elem_len == 2) {
     int16_t *dst = a_desc->base_addr;
     for (size_t i=0; i < num_elements; i++) dst[i] = src[i];
-  } else gasnett_fatalerror("Logic error in narrow_to_array: %i", a_desc->elem_len);
+  } else gasnett_fatalerror("Logic error in narrow_to_array: %i", (int)a_desc->elem_len);
   free(src);
 }
 

src/caffeine/co_reduce_s.F90

@@ -36,7 +36,13 @@ subroutine contiguous_co_reduce(a, operation_wrapper, cdata, result_image, stat,
 
     if (present(stat)) stat=0
 
-    funptr = c_funloc(operation_wrapper)
+#   if __GFORTRAN__
+      ! Gfortran 13..15 bug workaround
+      funptr = caf_c_funloc_deref(c_funloc(operation_wrapper))
+#   else
+      funptr = c_funloc(operation_wrapper)
+#   endif
+
     call_assert(c_associated(funptr))
 
     call caf_co_reduce( &

src/caffeine/coarray_queries_s.F90

@@ -26,6 +26,7 @@
 
   module procedure prif_ucobound_with_dim
     call_assert(coarray_handle_check(coarray_handle))
+    call_assert(team_check(current_team))
 
     associate (info => coarray_handle%info, corank => coarray_handle%info%corank) 
       call_assert(dim >= 1 .and. dim <= corank)
@@ -58,10 +59,9 @@
   end procedure
 
   module procedure prif_coshape
-    integer(c_int64_t) :: trailing_ucobound
-
     call_assert(coarray_handle_check(coarray_handle))
     call_assert(size(sizes) == coarray_handle%info%corank)
+    call_assert(team_check(current_team))
 
     associate(info => coarray_handle%info, corank => coarray_handle%info%corank)
       if (corank == 1) then ! common-case optimization
@@ -79,16 +79,17 @@
     end associate
   end procedure
 
-  subroutine image_index_helper(coarray_handle, sub, num_images, image_index)
+  subroutine image_index_helper(coarray_handle, sub, team, image_index)
     implicit none
     type(prif_coarray_handle), intent(in) :: coarray_handle
     integer(c_int64_t), intent(in) :: sub(:)
-    integer(c_int), intent(in) :: num_images
+    type(prif_team_type), intent(in) :: team
     integer(c_int), intent(out) :: image_index
 
     integer :: dim
 
     call_assert(coarray_handle_check(coarray_handle))
+    call_assert(team_check(team))
 
     associate (info => coarray_handle%info, corank => coarray_handle%info%corank) 
       call_assert(size(sub) == corank)
@@ -108,24 +109,25 @@ subroutine image_index_helper(coarray_handle, sub, num_images, image_index)
        end do
     end associate
 
-    if (image_index .gt. num_images) then
+    if (image_index .gt. team%info%num_images) then
        image_index = 0
     end if
   end subroutine
 
   module procedure prif_image_index
-    call image_index_helper(coarray_handle, sub, current_team%info%num_images, image_index)
+    call image_index_helper(coarray_handle, sub, current_team, image_index)
   end procedure
 
   module procedure prif_image_index_with_team
-    call image_index_helper(coarray_handle, sub, team%info%num_images, image_index)
+    call image_index_helper(coarray_handle, sub, team, image_index)
   end procedure
 
   module procedure prif_image_index_with_team_number
+    call_assert(team_check(current_team))
     if (team_number == -1) then
-      call image_index_helper(coarray_handle, sub, initial_team%num_images, image_index)
+      call image_index_helper(coarray_handle, sub, prif_team_type(initial_team), image_index)
     else if (team_number == current_team%info%team_number) then
-      call image_index_helper(coarray_handle, sub, current_team%info%num_images, image_index)
+      call image_index_helper(coarray_handle, sub, current_team, image_index)
     else
       call unimplemented("prif_image_index_with_team_number: no support for sibling teams")
     end if 
@@ -143,6 +145,7 @@ subroutine initial_index_helper(coarray_handle, sub, team, initial_team_index)
     integer :: dim
     integer(c_int) :: image_index
 
+    call_assert(team_check(team))
     call_assert(coarray_handle_check(coarray_handle))
 
     associate (info => coarray_handle%info, corank => coarray_handle%info%corank)

src/caffeine/image_queries_s.F90

@@ -11,14 +11,17 @@
 contains
 
   module procedure prif_num_images
+    call_assert(team_check(current_team))
     num_images = current_team%info%num_images
   end procedure
 
   module procedure prif_num_images_with_team
+    call_assert(team_check(team))
     num_images = team%info%num_images
   end procedure
 
   module procedure prif_num_images_with_team_number
+    call_assert(team_check(current_team))
     if (team_number == -1) then
       num_images = initial_team%num_images 
     else if (team_number == current_team%info%team_number) then
@@ -30,8 +33,10 @@
 
   module procedure prif_this_image_no_coarray
     if (present(team)) then
+      call_assert(team_check(team))
       this_image = team%info%this_image
     else
+      call_assert(team_check(current_team))
       this_image = current_team%info%this_image
     endif
   end procedure
@@ -44,8 +49,10 @@
     call_assert(size(cosubscripts) == coarray_handle%info%corank)
 
     if (present(team)) then
+      call_assert(team_check(team))
       offset = team%info%this_image - 1
     else
+      call_assert(team_check(current_team))
       offset = current_team%info%this_image - 1
     endif
 
@@ -90,16 +97,34 @@
   end procedure
 
   module procedure prif_failed_images
+    if (present(team)) then
+      call_assert(team_check(team))
+    else
+      call_assert(team_check(current_team))
+    endif
+
     ! no current support for detecting image failure
     allocate(failed_images(0))
   end procedure
 
   module procedure prif_stopped_images
+    if (present(team)) then
+      call_assert(team_check(team))
+    else
+      call_assert(team_check(current_team))
+    endif
+
     ! no current support for detecting image stops
     allocate(stopped_images(0))
   end procedure
 
   module procedure prif_image_status
+    if (present(team)) then
+      call_assert(team_check(team))
+    else
+      call_assert(team_check(current_team))
+    endif
+
     ! no current support for detecting image failure/stops
     image_status = 0
   end procedure

src/caffeine/prif_private_s.F90

@@ -338,6 +338,15 @@ subroutine caf_form_team(current_team, new_team, team_number, new_index) bind(C)
       integer(c_int), intent(in), value :: new_index
      end subroutine
 
+    ! ______________ Misc helpers  __________________
+     function caf_c_funloc_deref(funloc) result(res) bind(C)
+       !! funloc_t caf_c_funloc_deref(funloc_t funloc)
+       import c_funptr
+       implicit none
+       type(c_funptr), value :: funloc
+       type(c_funptr) :: res
+     end function
+
   end interface
 
   interface num_to_str
@@ -500,6 +509,89 @@ elemental impure function coarray_handle_check(coarray_handle) result(result_)
     result_ = .true.
   end function
 
+  ! verify state invariants for a team
+  ! Note this function validates invariants with deliberately UNconditional assertions
+  ! Suggested caller usage for conditional validation is: 
+  !   call_assert(team_check(current_team))
+  recursive function team_check(team, known_active, cycle_check) result(result_)
+    implicit none
+    type(prif_team_type), intent(in) :: team
+    logical, optional, intent(in) :: known_active ! is this known to be the current team or an ancestor team?
+    type(prif_team_type), optional, intent(in) :: cycle_check(:)
+    type(prif_team_type), allocatable :: cycle_check_(:)
+    logical :: result_, known_active_
+    integer :: i
+
+    call assert_always(associated(team%info), "unassociated info pointer in prif_team_type")
+
+    ! check for invalid cycles in the team hierarchy
+    if (.not. present(cycle_check)) then ! initial call
+      cycle_check_ = [ team ]
+    else ! recursive call should never encounter a matching team as an ancestor
+      call assert_always(.not. any( [(associated(team%info, cycle_check(i)%info), i = 1, size(cycle_check))] ), &
+           "Invalid cycle detected in team ancestor hierarchy")
+      cycle_check_ = [ cycle_check, team ]
+    end if
+
+    associate(info => team%info, ch_info => team%info%child_heap_info)
+      call assert_always(c_associated(info%gex_team), "invalid gex_team in team descriptor")
+
+      if (associated(team%info, initial_team)) then ! initial team
+        call assert_always(info%team_number == -1, "invalid team_number in initial team descriptor")
+        call assert_always(.not. associated(info%parent_team), "invalid parent_team in initial team descriptor")
+      else ! non-initial team, have parent team
+        call assert_always(info%team_number > 0, "invalid team_number in initial team descriptor")
+        call assert_always(associated(info%parent_team), "invalid parent_team in team descriptor")
+      end if
+
+      call assert_always(info%this_image == caf_this_image(info%gex_team), "invalid this_image in team descriptor")
+      call assert_always(info%num_images == caf_num_images(info%gex_team), "invalid num_images in team descriptor")
+
+      ! determine activity of this team (is it the current team or an ancestor of current)
+      if (present(known_active)) then 
+        known_active_ = known_active
+      else
+        known_active_ = .false.
+      end if
+      if (.not. known_active_) then
+        if (associated(team%info, initial_team)) then
+          known_active_ = .true.
+        else if (associated(current_team%info)) then
+          if (associated(team%info, current_team%info) .or. &
+              associated(team%info, current_team%info%parent_team)) then
+            known_active_ = .true.
+          end if
+        end if
+      end if 
+
+      if (known_active_) then
+        call assert_always(info%heap_start /= 0, "invalid heap_start in an active team descriptor")
+        call assert_always(info%heap_size > 0, "invalid heap_size in an active team descriptor")
+        if (info%this_image == 1) then
+          call assert_always(c_associated(info%heap_mspace), "invalid heap_mspace in an active team descriptor")
+        end if
+      end if
+
+      if (associated(info%child_heap_info)) then ! have child teams
+        if (info%this_image == 1) then
+          call assert_always(c_associated(ch_info%allocated_memory), &
+                            "invalid child_heap_info%allocated_memory in team descriptor")
+          call assert_always(ch_info%offset == as_int(ch_info%allocated_memory) - info%heap_start, &
+                            "invalid child_heap_info%offset in team descriptor")
+        end if
+        call assert_always(ch_info%size > 0, "invalid child_heap_info%size in team descriptor")
+        call assert_always(ch_info%offset + ch_info%size <= info%heap_size, &
+                          "invalid child_heap_info bounds in team descriptor")
+      end if
+
+      if (associated(info%parent_team)) then ! recurse up the team tree
+        result_ = team_check(prif_team_type(info%parent_team), known_active_, cycle_check_)
+      end if
+    end associate
+
+    result_ = .true.
+  end function
+
   subroutine caf_establish_child_heap
     if (current_team%info%this_image == 1) then
       call caf_allocate_remaining( &

src/caffeine/program_startup_s.F90

@@ -1,5 +1,8 @@
 ! Copyright (c), The Regents of the University of California
 ! Terms of use are as specified in LICENSE.txt
+
+#include "assert_macros.h"
+
 submodule(prif:prif_private_s) program_startup_s
   ! DO NOT ADD USE STATEMENTS HERE
   ! All use statements belong in prif_private_s.F90
@@ -22,12 +25,14 @@
           initial_team%gex_team)
        call assert_init()
        current_team%info => initial_team
-       initial_team%parent_team => initial_team
+       nullify(initial_team%parent_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)
        non_symmetric_heap_size = total_heap_size - initial_team%heap_size
 
+       call_assert(team_check(current_team))
+
        call sync_init()
 
        ! issue #259: Ensure we clear any IEEE FP exceptions potentially

src/caffeine/sync_stmt_s.F90

@@ -16,11 +16,13 @@
 contains
 
   module procedure prif_sync_all
+    call_assert(team_check(current_team))
     call caf_sync_team(current_team%info%gex_team)
     if (present(stat)) stat = 0
   end procedure
 
   module procedure prif_sync_team
+    call_assert(team_check(team))
     call caf_sync_team(team%info%gex_team)
     if (present(stat)) stat = 0
   end procedure
@@ -61,6 +63,7 @@
     integer(c_intptr_t) :: evt_ptr
 
     call_assert(coarray_handle_check(si_coarray_handle))
+    call_assert(team_check(current_team))
 
     call caf_sync_memory ! end segment and amortize release fence