Found another issue – applied to OG11 as attached. Will include it in the mainline patch once Stage1.
(However, I intent to split the original patch (+ follow ups) into smaller pieces for mainline incorporation.) Tobias On 02.03.22 23:20, Tobias Burnus wrote:
Some testing found an issue in class.cc (in the new _callback function) – updated patch attached (long version + interdiff). Tobias (PS: OG11 - original patch was committed as https://gcc.gnu.org/g:98961d3a0ccb02d7d54d2d4dd07cca75473d685a ; follow-up version to be committed in a moment) On 01.03.22 16:34, Tobias Burnus wrote:Hi all, this patch adds support for mapping something like type t type(t2), allocatable :: a, b(:) integer, allocatable :: c, c(:) end type t type(t), allocatable :: var, var2(:,:) !$omp target enter data map(var, var) which does a deep walk of the components at runtime. On the ME side, the static addr/size/kinds arrays are replaced (only if need) by allocatable arrays – which are then filled by trans-openmp.c. All deep-mapping handling happens via the hooks called late in omp-low.c such that removing mappings or implicitly added one are handled. In principle, there is also code to handle polymorphic variables (new callback function in vtable + two on-the-fly generated functions to be used for walking the vtable). Issues: None known, but I am sure with experimenting, more can be found - especially with arrays/array sections and polymorphism, I expect issues. I did find some on the way and fixed them - but (see PR refs in testcase -7.f90), I also found unrelated bugs, which I did not fix ;-) Comments? OK for mainline (GCC 13)? Tobias PS: I will commit this patch to OG11 for further testing. PPS: Previously discussed at https://gcc.gnu.org/pipermail/gcc-patches/2021-December/586237.html
----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
commit c6daf2090d48bc794c6809a5d98e8d9a583346bd Author: Tobias Burnus <[email protected]> Date: Mon Apr 25 15:12:01 2022 +0200 Fortran: Fix finalization resolution with deep copy Follow-up patch to "Fortran/OpenMP: Support mapping of DT with allocatable components" https://gcc.gnu.org/pipermail/gcc-patches/2022-March/591144.html gcc/fortran/ChangeLog: * resolve.c (gfc_resolve_finalizers): Also resolve allocatable comps. gcc/testsuite/ChangeLog: * gfortran.dg/finalize_38.f90: New test. --- gcc/fortran/resolve.c | 11 ++- gcc/testsuite/gfortran.dg/finalize_38.f90 | 135 ++++++++++++++++++++++++++++++ 2 files changed, 143 insertions(+), 3 deletions(-) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 59faa4c119d..10c89de0eaa 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13578,11 +13578,16 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) if (parent) gfc_resolve_finalizers (parent, finalizable); - /* Ensure that derived-type components have a their finalizers resolved. */ + /* Ensure that derived-type components have a their finalizers resolved; + handle allocatables but avoid issues with (in)direct allocatable types. */ bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers; for (c = derived->components; c; c = c->next) - if (c->ts.type == BT_DERIVED - && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable) + if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.proc_pointer + && (!c->attr.allocatable + || (c->ts.u.derived != derived + && c->ts.u.derived->f2k_derived + && c->ts.u.derived->f2k_derived->finalizers + && !c->ts.u.derived->f2k_derived->finalizers->proc_tree))) { bool has_final2 = false; if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2)) diff --git a/gcc/testsuite/gfortran.dg/finalize_38.f90 b/gcc/testsuite/gfortran.dg/finalize_38.f90 new file mode 100644 index 00000000000..442e1753311 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_38.f90 @@ -0,0 +1,135 @@ +! { dg-do compile } +! +! Check finalization +! +module Real_2D__Form + + implicit none + private + + integer, parameter :: & + KDR = kind ( 1.0d0 ), & + KDI = kind ( 1 ), & + KDL = kind ( .true. ) + + type, public :: Real_2D_Form + real ( KDR ), dimension ( :, : ), allocatable :: & + Value + contains + procedure, private, pass :: & + Initialize_R_2D + procedure, private, pass :: & + Initialize_R_2D_FromValue + procedure, private, pass :: & + Initialize_R_2D_Copy + generic :: & + Initialize & + => Initialize_R_2D, Initialize_R_2D_FromValue, Initialize_R_2D_Copy + final :: & + Finalize_R_2D + end type Real_2D_Form + + type, public :: Real_2D_2D_Form + type ( Real_2D_Form ), dimension ( :, : ), allocatable :: & + Value + contains + final :: & + Finalize_R_2D_2D + end type Real_2D_2D_Form + +contains + + subroutine Initialize_R_2D ( A, nValues, ClearOption, iaLowerBoundOption ) + class ( Real_2D_Form ), intent ( inout ) :: & + A + integer ( KDI ), dimension ( 2 ), intent ( in ) :: & + nValues + logical ( KDL ), intent ( in ), optional :: & + ClearOption + integer ( KDI ), dimension ( 2 ), intent ( in ), optional :: & + iaLowerBoundOption + + integer ( KDI ), dimension ( 2 ) :: & + iaLB + logical ( KDL ) :: & + ClearRequested + + if ( any ( nValues < 0 ) ) return + + if ( all ( nValues == 0 ) ) then + allocate ( A % Value ( 0, 0 ) ) + return + end if + + ClearRequested = .false. + if ( present ( ClearOption ) ) ClearRequested = ClearOption + + iaLB = 1 + if ( present ( iaLowerBoundOption ) ) iaLB = iaLowerBoundOption + + allocate & + ( A % Value & + ( iaLB ( 1 ) : iaLB ( 1 ) + nValues ( 1 ) - 1, & + iaLB ( 2 ) : iaLB ( 2 ) + nValues ( 2 ) - 1 ) ) + + !if ( ClearRequested ) call Clear ( A % Value ) + + end subroutine Initialize_R_2D + + + subroutine Initialize_R_2D_FromValue ( A, Value, iaLowerBoundOption ) + + class ( Real_2D_Form ), intent ( inout ) :: & + A + real ( KDR ), dimension ( :, : ), intent ( in ) :: & + Value + integer ( KDI ), dimension ( 2 ), intent ( in ), optional :: & + iaLowerBoundOption + + call A % Initialize_R_2D & + ( shape ( Value ), iaLowerBoundOption = iaLowerBoundOption ) + A % Value = Value + + end subroutine Initialize_R_2D_FromValue + + + subroutine Initialize_R_2D_Copy ( A, B, iaLowerBoundOption ) + + class ( Real_2D_Form ), intent ( inout ) :: & + A + type ( Real_2D_Form ), intent ( in ) :: & + B + integer ( KDI ), intent ( in ), optional :: & + iaLowerBoundOption + + integer ( KDI ), dimension ( 2 ) :: & + iaLB + + iaLB = lbound ( B % Value ) + if ( present ( iaLowerBoundOption ) ) iaLB = iaLowerBoundOption + + call A % Initialize_R_2D_FromValue ( B % Value, iaLowerBoundOption = iaLB ) + + end subroutine Initialize_R_2D_Copy + + + elemental subroutine Finalize_R_2D ( A ) + + type ( Real_2D_Form ), intent ( inout ) :: & + A + + if ( allocated ( A % Value ) ) deallocate ( A % Value ) + + end subroutine Finalize_R_2D + + + elemental subroutine Finalize_R_2D_2D ( A ) + + type ( Real_2D_2D_Form ), intent ( inout ) :: & + A + + if ( allocated ( A % Value ) ) deallocate ( A % Value ) + + end subroutine Finalize_R_2D_2D + +end module Real_2D__Form
