The attached patch fixes this regression. I would like further review on this.
It looks OK and regression tests on x86_64. I also confirmed the segfault when
running before the patch.
OK for mainline and later backports.
Regards,
Jerry
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.
gcc/testsuite/ChangeLog:
PR fortran/120286
* gfortran.dg/pr120286.f90: New test.
Signed-off-by: Christopher Albert <[email protected]>
From 985517a4dcc92c4d8996b9530b6e1beb2333b8fc Mon Sep 17 00:00:00 2001
From: Christopher Albert <[email protected]>
Date: Tue, 10 Mar 2026 20:59:48 +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.
gcc/testsuite/ChangeLog:
PR fortran/120286
* gfortran.dg/pr120286.f90: New test.
Signed-off-by: Christopher Albert <[email protected]>
---
gcc/fortran/trans-openmp.cc | 75 +++++++++++++++++++-------
gcc/testsuite/gfortran.dg/pr120286.f90 | 50 +++++++++++++++++
2 files changed, 105 insertions(+), 20 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/pr120286.f90
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 3dd4cf272e5..1224df47b26 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -466,8 +466,6 @@ gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok)
}
-/* Return true if TYPE is polymorphic but not with pointer attribute. */
-
static bool
gfc_is_polymorphic_nonptr (tree type)
{
@@ -476,6 +474,30 @@ gfc_is_polymorphic_nonptr (tree type)
return GFC_CLASS_TYPE_P (type);
}
+/* 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 unlimited polymorphic but not with pointer attribute;
unlimited means also intrinsic types are handled and _len is used. */
@@ -905,22 +927,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))
{
@@ -1428,17 +1457,23 @@ 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);
- /* 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)))
- return NULL_TREE;
+ 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)));
+ /* Only pointer association was privatized; cf. gfc_omp_clause_copy_ctor.
+ 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 (gfc_is_polymorphic_nonptr (decl_type))
{
if (POINTER_TYPE_P (decl_type))
diff --git a/gcc/testsuite/gfortran.dg/pr120286.f90 b/gcc/testsuite/gfortran.dg/pr120286.f90
new file mode 100644
index 00000000000..99c02a78c9c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120286.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+! { dg-additional-options "-fopenmp" }
+!
+! 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
--
2.53.0
