issue #192 : implement final_func argument of prif_allocate_coarray

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** |  |

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:

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_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"
+          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) &

test/prif_allocate_test.F90

@@ -1,11 +1,12 @@
 #include "test-utils.F90"
+#include "language-support.F90"
 
 module prif_allocate_test_m
 # include "test-uses-alloc.F90"
   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(//)
@@ -20,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()
@@ -38,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
 
@@ -94,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 
 

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