From 4058b2f4342d2c3ed3c85e7e91134ba9cfb092b3 Mon Sep 17 00:00:00 2001 From: Dan Bonachea Date: Mon, 29 Dec 2025 20:02:34 -0800 Subject: [PATCH 1/3] Implement final_func argument in prif_deallocate_coarray(s) Re-enable and fix code for final_func invocation, fix some errors This code remains disabled for gfortran < 16, which lacks the necessary F2018 support. --- include/language-support.F90 | 14 ++++++ src/caffeine/allocation_s.F90 | 81 ++++++++++++++++++++--------------- test/prif_allocate_test.F90 | 1 + 3 files changed, 61 insertions(+), 35 deletions(-) diff --git a/include/language-support.F90 b/include/language-support.F90 index d880a908..b2099b80 100644 --- a/include/language-support.F90 +++ b/include/language-support.F90 @@ -29,6 +29,20 @@ #endif #endif +#ifndef HAVE_FINAL_FUNC_SUPPORT +# if defined(__GFORTRAN__) && HAVE_GCC_VERSION < 160000 + ! gfortran 14-15 defect prevents declaration of the coarray_cleanup interface: + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=113338 + ! reportedly fixed in gfortran 16 +# define HAVE_FINAL_FUNC_SUPPORT 0 +# elif defined(__flang__) && __flang_major__ < 20 + ! also missing in flang before 20 +# define HAVE_FINAL_FUNC_SUPPORT 0 +# else +# define HAVE_FINAL_FUNC_SUPPORT 1 +# endif +#endif + ! ISO_FORTRAN_ENV constant value control: ! The following knobs influence Caffeine's choice of value for the named constants ! specified by PRIF for ISO_FORTRAN_ENV: diff --git a/src/caffeine/allocation_s.F90 b/src/caffeine/allocation_s.F90 index cb42bee8..df992978 100644 --- a/src/caffeine/allocation_s.F90 +++ b/src/caffeine/allocation_s.F90 @@ -81,22 +81,23 @@ end procedure module procedure prif_deallocate_coarrays #endif - ! gfortran is yelling that this isn't valid for bind(C) - ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=113338 - ! abstract interface - ! subroutine coarray_cleanup_i(handle, stat, errmsg) bind(C) - ! import c_int, prif_coarray_handle - ! implicit none - ! type(prif_coarray_handle), pointer, intent(in) :: handle - ! integer(c_int), intent(out) :: stat - ! character(len=:), intent(out), allocatable :: errmsg - ! end subroutine - ! end interface integer :: i, num_handles - !integer(c_int) :: local_stat - !character(len=:), allocatable :: local_errmsg - ! procedure(coarray_cleanup_i), pointer :: coarray_cleanup character(len=*), parameter :: unallocated_message = "Attempted to deallocate unallocated coarray" + type(prif_coarray_handle), target :: coarray_handle +# if HAVE_FINAL_FUNC_SUPPORT + abstract interface + subroutine coarray_cleanup_i(handle, stat, errmsg) bind(C) + import c_int, prif_coarray_handle + implicit none + type(prif_coarray_handle), pointer, intent(in) :: handle + integer(c_int), intent(out) :: stat + character(len=:), intent(out), allocatable :: errmsg + end subroutine + end interface + procedure(coarray_cleanup_i), pointer :: coarray_cleanup + integer(c_int) :: local_stat + character(len=:), allocatable :: local_errmsg +#endif call prif_sync_all ! Need to ensure we don't deallocate anything till everyone gets here num_handles = size(coarray_handles) @@ -115,27 +116,37 @@ end if call_assert(all(coarray_handle_check(coarray_handles))) - ! TODO: invoke finalizers from coarray_handles(:)%info%final_func - ! do i = 1, num_handles - ! if (coarray_handles(i)%info%final_func /= c_null_funptr) then - ! call c_f_procpointer(coarray_handles(i)%info%final_func, coarray_cleanup) - ! call coarray_cleanup(coarray_handles(i), local_stat, local_errmsg) - ! call prif_co_sum(local_stat) ! Need to be sure it didn't fail on any images - ! if (local_stat /= 0) then - ! if (present(stat)) then - ! stat = local_stat - ! if (present(errmsg)) then - ! errmsg = local_errmsg - ! else if (present(errmsg_alloc)) then - ! call move_alloc(local_errmsg, errmsg_alloc) - ! end if - ! return ! NOTE: We no longer have guarantees that coarrays are in consistent state - ! else - ! call prif_error_stop(.false._c_bool, stop_code_char=local_errmsg) - ! end if - ! end if - ! end if - ! end do + + ! invoke finalizers from coarray_handles(:)%info%final_func + do i = 1, num_handles + coarray_handle = coarray_handles(i) ! Add target attribute + if (c_associated(coarray_handle%info%final_func)) then +# if HAVE_FINAL_FUNC_SUPPORT + call c_f_procpointer(coarray_handle%info%final_func, coarray_cleanup) + call coarray_cleanup(coarray_handle, local_stat, local_errmsg) + call prif_co_sum(local_stat) ! Need to be sure it didn't fail on any images + if (local_stat /= 0) then + if (.not. allocated(local_errmsg)) then ! provide a default errmsg + local_errmsg = "coarray_cleanup finalization callback failed" + end if + if (present(stat)) then + stat = local_stat + if (present(errmsg)) then + errmsg = local_errmsg + else if (present(errmsg_alloc)) then + call move_alloc(local_errmsg, errmsg_alloc) + end if + return ! NOTE: We no longer have guarantees that coarrays are in consistent state + else + call prif_error_stop(.false._c_bool, stop_code_char=local_errmsg) + end if + end if +# else + ! TODO: issue a warning that we are ignoring the final_func? +# endif + end if + end do + do i = 1, num_handles call remove_from_team_list(coarray_handles(i)) if (current_team%info%this_image == 1) & diff --git a/test/prif_allocate_test.F90 b/test/prif_allocate_test.F90 index 0664e2ba..361b9002 100644 --- a/test/prif_allocate_test.F90 +++ b/test/prif_allocate_test.F90 @@ -1,4 +1,5 @@ #include "test-utils.F90" +#include "language-support.F90" module prif_allocate_test_m # include "test-uses-alloc.F90" From 314c8e371e3f7181a7dc24ef5f1eec270ef97404 Mon Sep 17 00:00:00 2001 From: Dan Bonachea Date: Mon, 29 Dec 2025 21:22:33 -0800 Subject: [PATCH 2/3] prif_allocate_test: add coverage for final_func Note finalizer functions currently cannot be internal procedures. This happens to work with flang-21 on Linux but fails at runtime with flang-21 on macOS. F23 15.5.1 note 3 seems to imply this should be valid, so it might represent a compiler defect. --- src/caffeine/allocation_s.F90 | 2 +- test/prif_allocate_test.F90 | 116 +++++++++++++++++++++++++++++++++- test/test-uses-alloc.F90 | 10 ++- 3 files changed, 123 insertions(+), 5 deletions(-) diff --git a/src/caffeine/allocation_s.F90 b/src/caffeine/allocation_s.F90 index df992978..3def11a3 100644 --- a/src/caffeine/allocation_s.F90 +++ b/src/caffeine/allocation_s.F90 @@ -124,7 +124,7 @@ subroutine coarray_cleanup_i(handle, stat, errmsg) bind(C) # if HAVE_FINAL_FUNC_SUPPORT call c_f_procpointer(coarray_handle%info%final_func, coarray_cleanup) call coarray_cleanup(coarray_handle, local_stat, local_errmsg) - call prif_co_sum(local_stat) ! Need to be sure it didn't fail on any images + call prif_co_max(local_stat) ! Need to be sure it didn't fail on any images if (local_stat /= 0) then if (.not. allocated(local_errmsg)) then ! provide a default errmsg local_errmsg = "coarray_cleanup finalization callback failed" diff --git a/test/prif_allocate_test.F90 b/test/prif_allocate_test.F90 index 361b9002..dcb34ae9 100644 --- a/test/prif_allocate_test.F90 +++ b/test/prif_allocate_test.F90 @@ -6,7 +6,7 @@ module prif_allocate_test_m use prif, only : & prif_num_images, prif_size_bytes, & prif_set_context_data, prif_get_context_data, prif_local_data_pointer, & - prif_alias_create, prif_alias_destroy + prif_alias_create, prif_alias_destroy, prif_this_image_no_coarray use julienne_m, only: test_description_t, test_diagnosis_t, test_result_t, test_t, string_t, usher & ,operator(.all.), operator(.also.), operator(.equalsExpected.), operator(//) @@ -21,6 +21,15 @@ module prif_allocate_test_m procedure, nopass, non_overridable :: results end type +#if HAVE_FINAL_FUNC_SUPPORT + ! Global state used to coordinate with finalizers + integer :: ff_count + type(prif_coarray_handle) :: ff_handle + type(test_diagnosis_t) :: ff_diag + logical :: ff_force_fail = .false. + character(len=*), parameter :: ff_err = "test error message" +#endif + contains pure function subject() @@ -39,6 +48,11 @@ function results() result(test_results) usher(check_allocate_integer_array_coarray_with_corank2)) & ,test_description_t("allocating, using and deallocating memory non-symmetrically", & usher(check_allocate_non_symmetric)) & + ,test_description_t("allocating and deallocating coarrays with finalizers" & +# if HAVE_FINAL_FUNC_SUPPORT + , usher(check_final_func) & +# endif + ) & ])) end function @@ -95,6 +109,106 @@ function check_allocate_integer_scalar_coarray_with_corank1() result(diag) end function +#if HAVE_FINAL_FUNC_SUPPORT + function check_final_func() result(retdiag) + type(test_diagnosis_t) retdiag + + ! this function shares several global vars with finalizers, see ff_* above + ! globalize diag for ALSO: +# define diag ff_diag + + integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds + integer :: num_imgs, me, dummy_element + type(c_ptr) :: allocated_memory + integer, pointer :: local_slice + integer(c_size_t) :: data_size, query_size + integer(c_int) :: stat + character(len=len(ff_err)) :: errmsg + character(len=:), allocatable :: errmsg_alloc + + diag = .true. + + call prif_num_images(num_images=num_imgs) + call prif_this_image_no_coarray(this_image=me) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + data_size = storage_size(dummy_element)/8 + + ! simple final_func case + ff_count = 0 + call prif_allocate_coarray( & + lcobounds, ucobounds, data_size, c_funloc(coarray_cleanup_simple), & + ff_handle, allocated_memory) + ALSO(ff_count .equalsExpected. 0) + + call prif_deallocate_coarray(ff_handle) + ALSO(ff_count .equalsExpected. 1) + + ! final_func that errors on first three deallocations + ff_count = 0 + call prif_allocate_coarray( & + lcobounds, ucobounds, data_size, c_funloc(coarray_cleanup_first_error), & + ff_handle, allocated_memory) + ALSO(ff_count .equalsExpected. 0) + + call prif_deallocate_coarray3(ff_handle, stat, errmsg=errmsg) + ALSO(ff_count .equalsExpected. 1) + ALSO(stat .equalsExpected. 10) + ALSO(errmsg .equalsExpected. ff_err) + + call prif_deallocate_coarrays3([ff_handle], stat, errmsg_alloc=errmsg_alloc) + ALSO(ff_count .equalsExpected. 2) + ALSO(stat .equalsExpected. 20) + ALSO(errmsg_alloc .equalsExpected. ff_err) + deallocate(errmsg_alloc) + + if (me == num_imgs) then ! test non-single-valued failure + ff_force_fail = .true. + end if + call prif_deallocate_coarray3(ff_handle, stat, errmsg_alloc=errmsg_alloc) + ALSO(ff_count .equalsExpected. 3) + ALSO(stat .equalsExpected. 30) + ALSO(errmsg_alloc .equalsExpected. ff_err) + deallocate(errmsg_alloc) + ff_force_fail = .false. + + call prif_deallocate_coarray3(ff_handle, stat, errmsg_alloc=errmsg_alloc) + ALSO(ff_count .equalsExpected. 4) + ALSO(stat .equalsExpected. 0) + ALSO(.not. allocated(errmsg_alloc)) + + retdiag = diag + end function + + subroutine coarray_cleanup_simple(handle , stat, errmsg) bind(C) + type(prif_coarray_handle), pointer , intent(in) :: handle + integer(c_int), intent(out) :: stat + character(len=:), intent(out), allocatable :: errmsg + + ALSO(assert_aliased(handle, ff_handle, 0)) + + ff_count = ff_count + 1 + stat = 0 + end subroutine + + subroutine coarray_cleanup_first_error(handle , stat, errmsg) bind(C) + type(prif_coarray_handle), pointer , intent(in) :: handle + integer(c_int), intent(out) :: stat + character(len=:), intent(out), allocatable :: errmsg + + ALSO(assert_aliased(handle, ff_handle, 0)) + + ff_count = ff_count + 1 + errmsg = ff_err + if (ff_count <= 2 .or. ff_force_fail) then + stat = 10 * ff_count + else + stat = 0 + end if + end subroutine +# undef diag +#endif + function check_allocate_non_symmetric() result(diag) type(test_diagnosis_t) diag diff --git a/test/test-uses-alloc.F90 b/test/test-uses-alloc.F90 index 6669cb0a..47378c8c 100644 --- a/test/test-uses-alloc.F90 +++ b/test/test-uses-alloc.F90 @@ -15,16 +15,20 @@ #if !defined(CAF_PRIF_VERSION) || CAF_PRIF_VERSION >= 7 ! PRIF 0.7+ deallocate use prif, only : prif_deallocate_coarray, prif_deallocate_coarrays +# define prif_deallocate_coarray3 prif_deallocate_coarray +# define prif_deallocate_coarrays3 prif_deallocate_coarrays #else ! emulate PRIF 0.7 deallocate with older interfaces use prif, only : prif_deallocate_coarray_ => prif_deallocate_coarray -# define prif_deallocate_coarray(h) prif_deallocate_coarray_([h]) -# define prif_deallocate_coarrays(arr) prif_deallocate_coarray_(arr) +# define prif_deallocate_coarray(h) prif_deallocate_coarray_([h]) +# define prif_deallocate_coarrays(arr) prif_deallocate_coarray_(arr) +# define prif_deallocate_coarray3(h,a2,a3) prif_deallocate_coarray_([h],a2,a3) +# define prif_deallocate_coarrays3(arr,a2,a3) prif_deallocate_coarray_(arr,a2,a3) #endif use iso_c_binding, only: & c_ptr, c_int, c_int64_t, c_size_t, c_intptr_t, & c_null_funptr, c_null_ptr, & - c_associated, c_f_pointer, c_loc, c_sizeof + c_associated, c_f_pointer, c_funloc, c_loc, c_sizeof #endif From af0ddf79c40da75a9dec9fe683ebdcb9fa3c8dd4 Mon Sep 17 00:00:00 2001 From: Dan Bonachea Date: Mon, 29 Dec 2025 23:32:57 -0800 Subject: [PATCH 3/3] Update implementation-status --- docs/implementation-status.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/implementation-status.md b/docs/implementation-status.md index b4542fc9..15e378ed 100644 --- a/docs/implementation-status.md +++ b/docs/implementation-status.md @@ -69,8 +69,8 @@ are accepted, but in some cases, the associated runtime behavior is not fully im |-----------|--------|-------| | `prif_allocate_coarray` | **YES** | | | `prif_allocate` | **YES** | | -| `prif_deallocate_coarray` | *partial* | no `final_func` arg support | -| `prif_deallocate_coarrays` | *partial* | no `final_func` arg support | +| `prif_deallocate_coarray` | **YES** | `final_func` support requires flang 20+ | +| `prif_deallocate_coarrays` | **YES** | `final_func` support requires flang 20+ | | `prif_deallocate` | **YES** | | | `prif_alias_create` | **YES** | | | `prif_alias_destroy` | **YES** | |