diff --git a/docs/implementation-status.md b/docs/implementation-status.md index 2b137cbc..0c66ef8e 100644 --- a/docs/implementation-status.md +++ b/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 | | --> ---- \ No newline at end of file +--- diff --git a/install.sh b/install.sh index 871bc077..ff5a6373 100755 --- a/install.sh +++ b/install.sh @@ -1,4 +1,4 @@ -#!/bin/sh +#!/bin/bash set -e # exit on error diff --git a/src/caffeine/allocation_s.f90 b/src/caffeine/allocation_s.f90 index a108add9..466a46fd 100644 --- a/src/caffeine/allocation_s.f90 +++ b/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 diff --git a/src/caffeine/caffeine.c b/src/caffeine/caffeine.c index 367ebcc3..34d5ce9f 100644 --- a/src/caffeine/caffeine.c +++ b/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); diff --git a/src/caffeine/image_queries_s.f90 b/src/caffeine/image_queries_s.f90 index b8c4b072..b2594e8b 100644 --- a/src/caffeine/image_queries_s.f90 +++ b/src/caffeine/image_queries_s.f90 @@ -7,11 +7,11 @@ 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 @@ -19,8 +19,11 @@ 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 diff --git a/src/caffeine/prif_private_s.f90 b/src/caffeine/prif_private_s.f90 index 3f7880e9..75feb66e 100644 --- a/src/caffeine/prif_private_s.f90 +++ b/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, & diff --git a/src/caffeine/program_startup_s.F90 b/src/caffeine/program_startup_s.F90 index e5f8fbdc..230ee90b 100644 --- a/src/caffeine/program_startup_s.F90 +++ b/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 diff --git a/src/caffeine/teams_s.f90 b/src/caffeine/teams_s.f90 index f7594e8b..094608a9 100644 --- a/src/caffeine/teams_s.f90 +++ b/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 diff --git a/src/prif.F90 b/src/prif.F90 index 4d8240bf..47b4b376 100644 --- a/src/prif.F90 +++ b/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() diff --git a/test/caf_teams_test.f90 b/test/caf_teams_test.f90 index 7eb53043..9a636d62 100644 --- a/test/caf_teams_test.f90 +++ b/test/caf_teams_test.f90 @@ -1,16 +1,7 @@ module caf_teams_test - use iso_c_binding, only: c_size_t, c_ptr, c_null_funptr, c_int64_t - use prif, only: & - prif_coarray_handle, & - prif_allocate_coarray, & - prif_deallocate_coarray, & - prif_this_image_no_coarray, & - prif_num_images, & - prif_team_type, & - prif_form_team, & - prif_change_team, & - prif_end_team - use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed + use iso_c_binding, only: c_size_t, c_ptr, c_null_funptr, c_int64_t, c_int + use prif + use veggies, only: result_t, test_item_t, assert_equals, assert_that, describe, it, succeed, fail implicit none private @@ -29,25 +20,134 @@ function check_teams() result(result_) type(result_t) :: result_ ! TODO: use final_func to observe automatic deallocation of coarrays - integer :: dummy_element, initial_num_imgs, num_imgs, me, i + integer :: dummy_element, i + integer(c_int) :: initial_num_imgs, num_imgs, me, me_child, x integer(c_size_t) :: element_size - integer(c_int64_t) :: which_team + integer(c_int64_t) :: which_team, n integer, parameter :: num_coarrays = 4 type(prif_coarray_handle) :: coarrays(num_coarrays) type(c_ptr) :: allocated_memory - type(prif_team_type) :: team + type(prif_team_type) :: team, initial_team, t + + result_ = succeed("") - call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=initial_num_imgs) + result_ = result_ .and. & + assert_that(initial_num_imgs > 0, "prif_num_images is valid") + + call prif_this_image_no_coarray(this_image=me) + result_ = result_ .and. & + assert_that(me >= 1 .and. me <= initial_num_imgs, "prif_this_image is valid") + + n = 0 ! clear outputs + call prif_team_number(team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "Initial team number is -1") + + n = 0 ! clear outputs + call prif_get_team(team=initial_team) + call prif_team_number(team=initial_team, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_get_team retrieves current initial team") + + x = 0 ! clear outputs + call prif_num_images_with_team(team=initial_team, num_images=x) + result_ = result_ .and. & + assert_equals(x, initial_num_imgs, "prif_num_images works with initial team") + + x = 0 ! clear outputs + call prif_this_image_no_coarray(team=initial_team, this_image=x) + result_ = result_ .and. & + assert_equals(x, me, "prif_this_image_no_coarray works with initial team") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(level=PRIF_INITIAL_TEAM, team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_get_team(PRIF_INITIAL_TEAM) retrieves initial team") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(level=PRIF_CURRENT_TEAM, team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_get_team(PRIF_CURRENT_TEAM) retrieves initial team when current team is initial team") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(level=PRIF_PARENT_TEAM, team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_get_team(PRIF_PARENT_TEAM) retrieves initial team when parent team is initial team") + which_team = merge(1_c_int64_t, 2_c_int64_t, mod(me, 2) == 0) element_size = int(storage_size(dummy_element)/8, c_size_t) call prif_form_team(team_number = which_team, team = team) call prif_change_team(team) call prif_num_images(num_images=num_imgs) - result_ = assert_equals( & + result_ = result_ .and. & + assert_equals( & initial_num_imgs/2 + mod(initial_num_imgs,2)*(int(which_team)-1), & num_imgs, & "Team has correct number of images") + + x = 0 ! clear outputs + call prif_num_images_with_team(team=team, num_images=x) + result_ = result_ .and. & + assert_equals(x, num_imgs, "prif_num_images works with team") + + call prif_this_image_no_coarray(this_image=me_child) + result_ = result_ .and. & + assert_equals(me_child, (me - 1)/2 + 1, "prif_this_image is valid") + + x = 0 ! clear outputs + call prif_this_image_no_coarray(team=team, this_image=x) + result_ = result_ .and. & + assert_equals(x, me_child, "prif_this_image is valid") + + n = 0 ! clear outputs + call prif_team_number(team_number=n) + result_ = result_ .and. & + assert_equals(int(n), int(which_team), "Correct current team number") + + n = 0 ! clear outputs + call prif_team_number(team=team, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), int(which_team), "Correct current team number") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), int(which_team), "prif_get_team retrieves current team") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(level=PRIF_INITIAL_TEAM, team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_get_team(PRIF_INITIAL_TEAM) retrieves initial team") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(level=PRIF_CURRENT_TEAM, team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), int(which_team), "prif_get_team(PRIF_CURRENT_TEAM) retrieves current team") + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(level=PRIF_PARENT_TEAM, team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_get_team(PRIF_PARENT_TEAM) retrieves initial team when parent team is initial team") + + x = 0 ! clear outputs + call prif_num_images_with_team(team=initial_team, num_images=x) + result_ = result_ .and. & + assert_equals(x, initial_num_imgs, "prif_num_images works with initial team") + + x = 0 ! clear outputs + call prif_this_image_no_coarray(team=initial_team, this_image=x) + result_ = result_ .and. & + assert_equals(x, me, "prif_this_image_no_coarray works with initial team") + + do i = 1, num_coarrays call prif_allocate_coarray( & lcobounds = [1_c_int64_t], & @@ -59,7 +159,15 @@ function check_teams() result(result_) end do call prif_deallocate_coarray(coarrays(4:4)) call prif_deallocate_coarray(coarrays(2:2)) + call prif_end_team() + + t = prif_team_type() ; n = 0 ! clear outputs + call prif_get_team(team=t) + call prif_team_number(team=t, team_number=n) + result_ = result_ .and. & + assert_equals(int(n), -1, "prif_end_team restores initial team") + result_ = result_.and.succeed("Seems to have worked") end function end module