https://gcc.gnu.org/g:fb12014c4ea9967aab463524f283454ce16d9785
commit r13-10241-gfb12014c4ea9967aab463524f283454ce16d9785 Author: Paul Thomas <[email protected]> Date: Thu Apr 2 15:51:01 2026 +0100 Subject: [PATCH] fortran: Preserve scalar class pointers in OpenMP privatization [PR120286] OpenMP privatization currently treats scalar class pointers like owned polymorphic class objects. In the worker cleanup for private/firstprivate class pointers, the generated code finalizes and frees ptr._data even though the clause only copied pointer association status from a shared target. Fix this in gfc_omp_clause_copy_ctor and gfc_omp_clause_dtor by unwrapping saved descriptors first and by recognizing class-pointer container types locally in those hooks. That keeps scalar class pointers on the association-only path without changing the broader polymorphic mapping classification used for OpenMP warnings and deep mapping. Add a runtime regression test for the original private(ptr) crash plus a firstprivate(ptr) association check. gcc/fortran/ChangeLog: PR fortran/120286 * trans-openmp.cc (gfc_is_class_pointer_type): New helper. (gfc_omp_clause_copy_ctor): Unwrap saved descriptors before deciding whether privatization should preserve only pointer association. Handle scalar class pointers on that path too. (gfc_omp_clause_dtor): Likewise. libgomp/ChangeLog: * testsuite/libgomp.fortran/pr120286.f90: New test. Signed-off-by: Christopher Albert <[email protected]> (cherry picked from commit 86960a3ffbd7d87b6b1d18d7cc02bf5078526bca) Diff: --- gcc/fortran/trans-openmp.cc | 72 ++++++++++++++++++++------ libgomp/testsuite/libgomp.fortran/pr120286.f90 | 49 ++++++++++++++++++ 2 files changed, 104 insertions(+), 17 deletions(-) diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index d542f52761f3..8dd5903ea665 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -405,6 +405,30 @@ gfc_has_alloc_comps (tree type, tree decl) return false; } +/* Return true if TYPE is a class container for a POINTER entity. */ + +static bool +gfc_is_class_pointer_type (tree type) +{ + tree name; + const char *s; + + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (!GFC_CLASS_TYPE_P (type)) + return false; + + name = TYPE_NAME (type); + if (name && TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + if (!name) + return false; + + s = IDENTIFIER_POINTER (name); + return startswith (s, "__class_") && s[strlen (s) - 1] == 'p'; +} + /* Return true if TYPE is polymorphic but not with pointer attribute. */ static bool @@ -844,22 +868,29 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) { tree type = TREE_TYPE (dest), ptr, size, call; tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + tree orig_decl = OMP_CLAUSE_DECL (clause); tree cond, then_b, else_b; stmtblock_t block, cond_block; gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); - /* Privatize pointer, only; cf. gfc_omp_predetermined_sharing. */ - if (DECL_P (OMP_CLAUSE_DECL (clause)) - && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause))) - return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src); + if (DECL_ARTIFICIAL (orig_decl) + && DECL_LANG_SPECIFIC (orig_decl) + && GFC_DECL_SAVED_DESCRIPTOR (orig_decl)) + { + orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl); + decl_type = TREE_TYPE (orig_decl); + } - if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) - && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) - && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) - decl_type - = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); + /* Privatize pointer association only; cf. gfc_omp_predetermined_sharing. + This includes scalar class pointers, whose tree type is still the class + record even though the Fortran entity has POINTER semantics. */ + if (DECL_P (orig_decl) + && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl) + || GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || gfc_is_class_pointer_type (decl_type))) + return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src); if (gfc_is_polymorphic_nonptr (decl_type)) { @@ -1367,17 +1398,24 @@ gfc_omp_clause_dtor (tree clause, tree decl) { tree type = TREE_TYPE (decl), tem; tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + tree orig_decl = OMP_CLAUSE_DECL (clause); + + if (DECL_ARTIFICIAL (orig_decl) + && DECL_LANG_SPECIFIC (orig_decl) + && GFC_DECL_SAVED_DESCRIPTOR (orig_decl)) + { + orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl); + decl_type = TREE_TYPE (orig_decl); + } - /* Only pointer was privatized; cf. gfc_omp_clause_copy_ctor. */ - if (DECL_P (OMP_CLAUSE_DECL (clause)) - && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause))) + /* Only pointer association was privatized; cf. gfc_omp_clause_copy_ctr. + Scalar class pointers must not finalize or free their targets here. */ + if (DECL_P (orig_decl) + && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl) + || GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || gfc_is_class_pointer_type (decl_type))) return NULL_TREE; - if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) - && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) - && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) - decl_type - = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); if (gfc_is_polymorphic_nonptr (decl_type)) { if (POINTER_TYPE_P (decl_type)) diff --git a/libgomp/testsuite/libgomp.fortran/pr120286.f90 b/libgomp/testsuite/libgomp.fortran/pr120286.f90 new file mode 100644 index 000000000000..e45ed5539a62 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/pr120286.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! PR fortran/120286 - scalar class pointers in OpenMP private/firstprivate +! clauses must preserve association status without taking ownership. + +program main + implicit none + + type foo_t + integer :: dummy + end type foo_t + + type fooPtr_t + class(foo_t), pointer :: p + end type fooPtr_t + + type fooPtrStack_t + class(fooPtr_t), allocatable :: list(:) + end type fooPtrStack_t + + type(fooPtrStack_t) :: x + class(foo_t), pointer :: ptr + integer :: it, n + logical :: ok + + allocate (x%list(1)) + allocate (x%list(1)%p) + x%list(1)%p%dummy = 7 + + do it = 1, 16 +!$omp parallel do default(none) num_threads(2) private(n, ptr) shared(x) + do n = 1, 1 + ptr => x%list(n)%p + end do +!$omp end parallel do + end do + + if (.not. associated (x%list(1)%p)) stop 1 + if (x%list(1)%p%dummy /= 7) stop 2 + + ptr => x%list(1)%p + ok = .false. + +!$omp parallel default(none) num_threads(1) firstprivate(ptr) shared(x, ok) + ok = associated (ptr, x%list(1)%p) .and. ptr%dummy == 7 +!$omp end parallel + + if (.not. ok) stop 3 +end program main
