See the attached patch. I ran into this bug while testing for another unrelated
PR.
Regression tested on x86_64 at -m64 and -m32
OK for mainline?
Regards,
Jerry
---
[PATCH] fortran: [PR128678] Fix OpenMP ctor/dtor for SIMD body-local decls
Gimplify gives an addressable decl local to a SIMD body an implicit
private clause. The Fortran clause hooks treated it like a user's
private variable: the default constructor hit gcc_assert (outer) for a
decl with allocatable components, and the destructor freed the data of
a CLASS temporary, which for a non-polymorphic actual argument is the
actual itself. The body initializes and finalizes such decls, so both
hooks now do nothing for a private clause without an outer reference on
a decl that gfc_omp_private_outer_ref accepts. The destructor also no
longer frees the data of a nonallocatable CLASS copy that
gfc_omp_clause_copy_ctor did not allocate.
Assisted-by: Claude Opus 5.5
PR fortran/128678
gcc/fortran/ChangeLog:
* trans-openmp.cc (gfc_is_class_pointer_type): Rename to ...
(gfc_class_container_kind): ... this. Return the kind suffix of
the class container type name.
(gfc_omp_body_local_private_p): New function.
(gfc_omp_clause_default_ctor): Return NULL_TREE for a body-local
private clause.
(gfc_omp_clause_copy_ctor): Use gfc_class_container_kind.
(gfc_omp_clause_dtor): Likewise. Return NULL_TREE for a body-local
private clause and for a nonallocatable CLASS copy not made by
gfc_omp_clause_copy_ctor.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/simd-body-local-1.f90: New test.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/simd-body-local-1.f90: New test.
---From c297c3861a7cb39c2923dc0d5378deb6a1ff8862 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Thu, 12 Nov 2026 10:28:47 -0800
Subject: [PATCH] fortran: [PR128678] Fix OpenMP ctor/dtor for SIMD body-local
decls
Gimplify gives an addressable decl local to a SIMD body an implicit
private clause. The Fortran clause hooks treated it like a user's
private variable: the default constructor hit gcc_assert (outer) for a
decl with allocatable components, and the destructor freed the data of
a CLASS temporary, which for a non-polymorphic actual argument is the
actual itself. The body initializes and finalizes such decls, so both
hooks now do nothing for a private clause without an outer reference on
a decl that gfc_omp_private_outer_ref accepts. The destructor also no
longer frees the data of a nonallocatable CLASS copy that
gfc_omp_clause_copy_ctor did not allocate.
Assisted-by: Claude Opus 5.5
PR fortran/128678
gcc/fortran/ChangeLog:
* trans-openmp.cc (gfc_is_class_pointer_type): Rename to ...
(gfc_class_container_kind): ... this. Return the kind suffix of
the class container type name.
(gfc_omp_body_local_private_p): New function.
(gfc_omp_clause_default_ctor): Return NULL_TREE for a body-local
private clause.
(gfc_omp_clause_copy_ctor): Use gfc_class_container_kind.
(gfc_omp_clause_dtor): Likewise. Return NULL_TREE for a body-local
private clause and for a nonallocatable CLASS copy not made by
gfc_omp_clause_copy_ctor.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/simd-body-local-1.f90: New test.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/simd-body-local-1.f90: New test.
---
gcc/fortran/trans-openmp.cc | 41 +++++++++---
.../gfortran.dg/gomp/simd-body-local-1.f90 | 66 +++++++++++++++++++
.../libgomp.fortran/simd-body-local-1.f90 | 60 +++++++++++++++++
3 files changed, 159 insertions(+), 8 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/gomp/simd-body-local-1.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/simd-body-local-1.f90
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index d511c267de9..13b17e573db 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -494,10 +494,11 @@ gfc_is_polymorphic_nonptr (tree type)
return GFC_CLASS_TYPE_P (type);
}
-/* Return true if TYPE is a class container for a POINTER entity. */
+/* If TYPE is a class container, return 'p', 'a' or 't' for a POINTER,
+ ALLOCATABLE or other entity (cf. gfc_build_class_symbol), else 0. */
-static bool
-gfc_is_class_pointer_type (tree type)
+static char
+gfc_class_container_kind (tree type)
{
tree name;
const char *s;
@@ -506,16 +507,16 @@ gfc_is_class_pointer_type (tree type)
type = TREE_TYPE (type);
if (!GFC_CLASS_TYPE_P (type))
- return false;
+ return 0;
name = TYPE_NAME (type);
if (name && TREE_CODE (name) == TYPE_DECL)
name = DECL_NAME (name);
if (!name)
- return false;
+ return 0;
s = IDENTIFIER_POINTER (name);
- return startswith (s, "__class_") && s[strlen (s) - 1] == 'p';
+ return startswith (s, "__class_") ? s[strlen (s) - 1] : 0;
}
/* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
@@ -586,6 +587,19 @@ gfc_omp_private_outer_ref (tree decl)
return false;
}
+/* Return true if CLAUSE privatizes a decl that gfc_omp_private_outer_ref
+ accepts, but without an outer reference: gimplify adds such a clause for
+ an addressable decl local to a SIMD body, which the body itself
+ initializes and finalizes. */
+
+static bool
+gfc_omp_body_local_private_p (tree clause)
+{
+ return (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
+ && !OMP_CLAUSE_PRIVATE_OUTER_REF (clause)
+ && gfc_omp_private_outer_ref (OMP_CLAUSE_DECL (clause)));
+}
+
/* Callback for gfc_omp_unshare_expr. */
static tree
@@ -839,6 +853,9 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
gcc_unreachable ();
}
+ if (gfc_omp_body_local_private_p (clause))
+ return NULL_TREE;
+
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
@@ -971,7 +988,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
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)))
+ || gfc_class_container_kind (decl_type) == 'p'))
return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
if (gfc_is_polymorphic_nonptr (decl_type))
@@ -1495,7 +1512,15 @@ gfc_omp_clause_dtor (tree clause, tree decl)
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)))
+ || gfc_class_container_kind (decl_type) == 'p'))
+ return NULL_TREE;
+ if (gfc_omp_body_local_private_p (clause))
+ return NULL_TREE;
+ /* Only gfc_omp_clause_copy_ctor gives a nonallocatable CLASS copy data of
+ its own. */
+ if (gfc_class_container_kind (decl_type) == 't'
+ && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_FIRSTPRIVATE
+ && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_LINEAR)
return NULL_TREE;
if (gfc_is_polymorphic_nonptr (decl_type))
{
diff --git a/gcc/testsuite/gfortran.dg/gomp/simd-body-local-1.f90 b/gcc/testsuite/gfortran.dg/gomp/simd-body-local-1.f90
new file mode 100644
index 00000000000..69f0438cfa1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/simd-body-local-1.f90
@@ -0,0 +1,66 @@
+! { dg-do compile }
+! PR 128678
+!
+! Addressable decls local to a SIMD body get an implicit private clause;
+! the body initializes and finalizes them, so the OpenMP constructor hook
+! must not. This used to ICE in gfc_omp_clause_default_ctor.
+
+module m
+ implicit none
+ type t
+ real, allocatable :: v(:)
+ end type
+ type pair
+ type(t) :: i, o
+ end type
+ type batch
+ type(pair), allocatable :: p(:)
+ end type
+contains
+ elemental function mkpair (i, o) result (r)
+ type(t), intent(in) :: i, o
+ type(pair) :: r
+ r%i = i
+ r%o = o
+ end function
+ pure function mkbatch (p) result (r)
+ type(pair), intent(in) :: p(:)
+ type(batch) :: r
+ r%p = p
+ end function
+end module
+
+subroutine temps (a, b)
+ use m
+ implicit none
+ type(t) :: a(4, 3)
+ type(batch) :: b(3)
+ integer :: j
+ !$omp parallel do simd
+ do j = 1, 3
+ b(j) = mkbatch (mkpair (a(:,j), a(:,j)))
+ end do
+end subroutine
+
+subroutine block_locals (r)
+ use m
+ implicit none
+ real :: r(100)
+ integer :: j
+ !$omp simd
+ do j = 1, 100
+ block
+ real, allocatable :: w(:)
+ type(t) :: x
+ allocate (w(j))
+ w = 1.0
+ x%v = w
+ call use_it (x%v, w)
+ r(j) = sum (x%v)
+ end block
+ end do
+contains
+ subroutine use_it (a, b)
+ real :: a(:), b(:)
+ end subroutine
+end subroutine
diff --git a/libgomp/testsuite/libgomp.fortran/simd-body-local-1.f90 b/libgomp/testsuite/libgomp.fortran/simd-body-local-1.f90
new file mode 100644
index 00000000000..94ed5500090
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/simd-body-local-1.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+! PR 128678
+!
+! Decls local to a SIMD body that own allocated memory, and CLASS
+! temporaries there, must not be freed by the OpenMP destructor hook: a
+! CLASS temporary for a non-polymorphic actual points to that actual.
+
+module m
+ implicit none
+ type t
+ real, allocatable :: v(:)
+ end type
+ type acc
+ integer :: base = 10
+ end type
+ type, extends(acc) :: acc2
+ integer :: extra = 1
+ end type
+contains
+ pure integer function bump (this, k)
+ class(acc), intent(in) :: this
+ integer, intent(in) :: k
+ bump = this%base + k
+ end function
+end module
+
+program p
+ use m
+ implicit none
+ type(acc) :: o
+ type(acc2) :: o2
+ integer :: r(50), s(50), i
+ real :: x(50)
+
+ !$omp parallel do simd
+ do i = 1, 50
+ r(i) = bump (o, i)
+ s(i) = bump (o2, -i)
+ end do
+
+ !$omp parallel do simd
+ do i = 1, 50
+ block
+ real, allocatable :: w(:)
+ type(t) :: y
+ class(acc), allocatable :: c
+ allocate (w(i))
+ w = 1.0
+ y%v = w
+ allocate (acc2 :: c)
+ c%base = i
+ x(i) = sum (y%v) + c%base
+ end block
+ end do
+
+ do i = 1, 50
+ if (r(i) /= 10 + i .or. s(i) /= 10 - i) stop 1
+ if (x(i) /= 2 * i) stop 2
+ end do
+end program
--
2.56.0
