From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1534) id 9158C385782B; Mon, 24 May 2021 14:59:03 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9158C385782B MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Tobias Burnus To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-1016] OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470] X-Act-Checkin: gcc X-Git-Author: Tobias Burnus X-Git-Refname: refs/heads/master X-Git-Oldrev: b326f495218a213079f572bd9960903b3425da74 X-Git-Newrev: 0e3b3b77e13cac764a135a7118613c47686e0a62 Message-Id: <20210524145903.9158C385782B@sourceware.org> Date: Mon, 24 May 2021 14:59:03 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 24 May 2021 14:59:03 -0000 https://gcc.gnu.org/g:0e3b3b77e13cac764a135a7118613c47686e0a62 commit r12-1016-g0e3b3b77e13cac764a135a7118613c47686e0a62 Author: Tobias Burnus Date: Mon May 24 16:50:51 2021 +0200 OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470] gcc/fortran/ChangeLog: PR fortran/86470 * trans-expr.c (gfc_copy_class_to_class): Add unshare_expr. * trans-openmp.c (gfc_is_polymorphic_nonptr, gfc_is_unlimited_polymorphic_nonptr): New. (gfc_omp_clause_copy_ctor, gfc_omp_clause_dtor): Handle polymorphic scalars. libgomp/ChangeLog: PR fortran/86470 * testsuite/libgomp.fortran/class-firstprivate-1.f90: New test. * testsuite/libgomp.fortran/class-firstprivate-2.f90: New test. * testsuite/libgomp.fortran/class-firstprivate-3.f90: New test. gcc/testsuite/ChangeLog: PR fortran/86470 * gfortran.dg/gomp/class-firstprivate-1.f90: New test. * gfortran.dg/gomp/class-firstprivate-2.f90: New test. * gfortran.dg/gomp/class-firstprivate-3.f90: New test. * gfortran.dg/gomp/class-firstprivate-4.f90: New test. Diff: --- gcc/fortran/trans-expr.c | 2 +- gcc/fortran/trans-openmp.c | 162 +++++++++- .../gfortran.dg/gomp/class-firstprivate-1.f90 | 62 ++++ .../gfortran.dg/gomp/class-firstprivate-2.f90 | 54 ++++ .../gfortran.dg/gomp/class-firstprivate-3.f90 | 61 ++++ .../gfortran.dg/gomp/class-firstprivate-4.f90 | 44 +++ .../libgomp.fortran/class-firstprivate-1.f90 | 323 ++++++++++++++++++++ .../libgomp.fortran/class-firstprivate-2.f90 | 334 +++++++++++++++++++++ .../libgomp.fortran/class-firstprivate-3.f90 | 334 +++++++++++++++++++++ 9 files changed, 1374 insertions(+), 2 deletions(-) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3432cd4fdfd..00690fe9ed4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1561,7 +1561,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) { vec_safe_push (args, from_len); vec_safe_push (args, to_len); - extcopy = build_call_vec (fcn_type, fcn, args); + extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args); tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, from_len, build_zero_cst (TREE_TYPE (from_len))); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 5666cd68c7e..44542d9ab1a 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -360,6 +360,39 @@ gfc_has_alloc_comps (tree type, tree decl) return false; } +/* Return true if TYPE is polymorphic but not with pointer attribute. */ + +static bool +gfc_is_polymorphic_nonptr (tree type) +{ + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + return GFC_CLASS_TYPE_P (type); +} + +/* Return true if TYPE is unlimited polymorphic but not with pointer attribute; + unlimited means also intrinsic types are handled and _len is used. */ + +static bool +gfc_is_unlimited_polymorphic_nonptr (tree type) +{ + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (!GFC_CLASS_TYPE_P (type)) + return false; + + tree field = TYPE_FIELDS (type); /* _data */ + gcc_assert (field); + field = DECL_CHAIN (field); /* _vptr */ + gcc_assert (field); + field = DECL_CHAIN (field); + if (!field) + return false; + gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0); + return true; +} + + /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ bool @@ -743,12 +776,88 @@ tree 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 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); + 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)) + decl_type = TREE_TYPE (decl_type); + decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); + if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) + fatal_error (input_location, + "Sorry, polymorphic arrays not yet supported for " + "firstprivate"); + tree src_len; + tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */ + tree src_data = gfc_class_data_get (unshare_expr (src)); + tree dest_data = gfc_class_data_get (unshare_expr (dest)); + bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type); + + gfc_start_block (&block); + gfc_add_modify (&block, gfc_class_vptr_get (dest), + gfc_class_vptr_get (src)); + gfc_init_block (&cond_block); + + if (unlimited) + { + src_len = gfc_class_len_get (src); + gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len); + } + + /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */ + size = fold_convert (size_type_node, gfc_class_vtab_size_get (src)); + if (unlimited) + { + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + unshare_expr (src_len), + build_zero_cst (TREE_TYPE (src_len))); + cond = build3_loc (input_location, COND_EXPR, size_type_node, cond, + fold_convert (size_type_node, + unshare_expr (src_len)), + build_int_cst (size_type_node, 1)); + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + size, cond); + } + + /* Malloc memory + call class->_vpt->_copy. */ + call = builtin_decl_explicit (BUILT_IN_MALLOC); + call = build_call_expr_loc (input_location, call, 1, size); + gfc_add_modify (&cond_block, dest_data, + fold_convert (TREE_TYPE (dest_data), call)); + gfc_add_expr_to_block (&cond_block, + gfc_copy_class_to_class (src, dest, nelems, + unlimited)); + + gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF); + if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1))) + { + gfc_add_block_to_block (&block, &cond_block); + } + else + { + /* Create: if (class._data != 0) else class._data = NULL; */ + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + src_data, null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), + fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + unshare_expr (dest_data), null_pointer_node))); + } + return gfc_finish_block (&block); + } + if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) @@ -773,7 +882,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) gfc_init_block (&cond_block); - gfc_add_modify (&cond_block, dest, src); + gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src)); if (GFC_DESCRIPTOR_TYPE_P (type)) { tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; @@ -1185,6 +1294,57 @@ tree gfc_omp_clause_dtor (tree clause, tree decl) { tree type = TREE_TYPE (decl), tem; + tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + + 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)) + decl_type = TREE_TYPE (decl_type); + decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); + if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) + fatal_error (input_location, + "Sorry, polymorphic arrays not yet supported for " + "firstprivate"); + stmtblock_t block, cond_block; + gfc_start_block (&block); + gfc_init_block (&cond_block); + tree final = gfc_class_vtab_final_get (decl); + tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl)); + gfc_se se; + gfc_init_se (&se, NULL); + symbol_attribute attr = {}; + tree data = gfc_class_data_get (decl); + tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr); + + /* Call class->_vpt->_finalize + free. */ + tree call = build_fold_indirect_ref (final); + call = build_call_expr_loc (input_location, call, 3, + gfc_build_addr_expr (NULL, desc), + size, boolean_false_node); + gfc_add_block_to_block (&cond_block, &se.pre); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + gfc_add_block_to_block (&cond_block, &se.post); + /* Create: if (_vtab && _final) */ + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_class_vptr_get (decl), + null_pointer_node); + tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + final, null_pointer_node); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), NULL_TREE)); + call = builtin_decl_explicit (BUILT_IN_FREE); + call = build_call_expr_loc (input_location, call, 1, data); + gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); + return gfc_finish_block (&block); + } if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90 new file mode 100644 index 00000000000..0ff851db390 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + use iso_c_binding + !use omp_lib + implicit none + integer :: i + integer :: A(4) + type(c_ptr) :: B(4) + + B = [(c_null_ptr, i=1,4)] + A = [1,2,3,4] + call sub(A, B) +contains + subroutine sub(val1, val2) + class(*) :: val1(4) + type(c_ptr) :: val2(2:5) + + !$OMP PARALLEL firstprivate(val2) + do i = 2, 5 + if (c_associated (val2(i))) stop 123 + end do + !$OMP END PARALLEL + + !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 4549 + val1 = [32,6,48,28] + class default + stop 99 + end select + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [32,6,48,28])) stop 4512 + class default + stop 99 + end select + !$OMP END PARALLEL + + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 454 + class default + stop 99 + end select + print *, "PASS!" + end subroutine +end program select_type_openmp diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90 new file mode 100644 index 00000000000..354223741f7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + !use omp_lib + implicit none + class(*), allocatable :: B(:) + + allocate(B, source=["abcdef","cdefi2"]) + allocate(B, source=[1,2,3]) + call sub(B) +contains + subroutine sub(val2) + class(*), allocatable :: val2(:) + + !$OMP PARALLEL firstprivate(val2) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + if (.not.allocated(val2)) stop 3 + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 4545 + val2 = ["123456", "789ABC"] + class default + stop 991 + end select + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2(1) /= "123456" .or. val2(2) /= "789ABC") stop 453 + class default + stop 991 + end select + !$OMP END PARALLEL + + if (.not.allocated(val2)) stop 3 + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 456 + class default + stop 991 + end select + print *, "PASS!" + end subroutine +end program select_type_openmp diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90 new file mode 100644 index 00000000000..c83bf297511 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + use iso_c_binding + !use omp_lib + implicit none + call sub +contains + subroutine sub + integer :: i + class(*), allocatable :: val1(:) + type(c_ptr), allocatable :: val2(:) + + allocate(val1, source=[1, 2, 3, 4]) + allocate(val2(2:5)) + val2 = c_null_ptr + + !$OMP PARALLEL firstprivate(val2) + do i = 2, 5 + if (c_associated (val2(i))) stop 123 + end do + !$OMP END PARALLEL + + !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 4549 + val1 = [32,6,48,28] + class default + stop 99 + end select + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [32,6,48,28])) stop 4512 + class default + stop 99 + end select + !$OMP END PARALLEL + + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 454 + class default + stop 99 + end select + print *, "PASS!" + end subroutine +end program select_type_openmp diff --git a/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90 new file mode 100644 index 00000000000..237c6c535f7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + use iso_c_binding + !use omp_lib + implicit none + integer x(4) + x = [1, 2, 3, 4] + call sub(x) + if (any (x /= [1,2,3,4])) stop 3 +contains + subroutine sub(val1) + integer :: i + class(*) :: val1(4) + + !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 4549 + val1 = [32,6,48,28] + class default + stop 99 + end select + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 34 + if (any (val1 /= [32,6,48,28])) stop 4512 + class default + stop 98 + end select + !$OMP END PARALLEL + end +end diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90 new file mode 100644 index 00000000000..b77117ec611 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90 @@ -0,0 +1,323 @@ +! FIRSTPRIVATE: CLASS(*) + intrinsic types +program select_type_openmp + implicit none + class(*), allocatable :: val1, val1a, val2, val3 + + call sub() ! local var + + call sub2(val1, val1a, val2, val3) ! allocatable args + + allocate(val1, source=7) + allocate(val1a, source=7) + allocate(val2, source="abcdef") + allocate(val3, source=4_"zyx4") + call sub3(val1, val1a, val2, val3) ! nonallocatable vars + deallocate(val1, val1a, val2, val3) +contains +subroutine sub() + class(*), allocatable :: val1, val1a, val2, val3 + allocate(val1a, source=7) + allocate(val2, source="abcdef") + allocate(val3, source=4_"zyx4") + + if (allocated(val1)) stop 1 + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + if (allocated(val1)) stop 2 + if (.not.allocated(val1a)) stop 3 + if (.not.allocated(val2)) stop 4 + if (.not.allocated(val3)) stop 5 + + allocate(val1, source=7) + + select type (val1) + type is (integer) + if (val1 /= 7) stop 6 + val1 = 8 + class default + stop 7 + end select + + select type (val1a) + type is (integer) + if (val1a /= 7) stop 8 + val1a = 8 + class default + stop 9 + end select + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 10 + if (val2 /= "abcdef") stop 11 + val2 = "123456" + class default + stop 12 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 13 + if (val3 /= 4_"zyx4") stop 14 + val3 = 4_"AbCd" + class default + stop 15 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 16 + if (val3 /= 4_"AbCd") stop 17 + val3 = 4_"1ab2" + class default + stop 18 + end select + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 19 + if (val2 /= "123456") stop 20 + val2 = "A2C4E6" + class default + stop 21 + end select + + select type (val1) + type is (integer) + if (val1 /= 8) stop 22 + val1 = 9 + class default + stop 23 + end select + + select type (val1a) + type is (integer) + if (val1a /= 8) stop 24 + val1a = 9 + class default + stop 25 + end select + !$OMP END PARALLEL + + if (allocated(val1)) stop 26 + if (.not. allocated(val1a)) stop 27 + if (.not. allocated(val2)) stop 28 + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 29 + if (val2 /= "abcdef") stop 30 + class default + stop 31 + end select + select type (val3) + type is (character(len=*,kind=4)) + if (len(val3) /= 4) stop 32 + if (val3 /= 4_"zyx4") stop 33 + class default + stop 34 + end select + deallocate(val1a, val2, val3) +end subroutine sub + +subroutine sub2(val1, val1a, val2, val3) + class(*), allocatable :: val1, val1a, val2, val3 + optional :: val1a + allocate(val1a, source=7) + allocate(val2, source="abcdef") + allocate(val3, source=4_"zyx4") + + if (allocated(val1)) stop 35 + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + if (allocated(val1)) stop 36 + if (.not.allocated(val1a)) stop 37 + if (.not.allocated(val2)) stop 38 + if (.not.allocated(val3)) stop 39 + + allocate(val1, source=7) + + select type (val1) + type is (integer) + if (val1 /= 7) stop 40 + val1 = 8 + class default + stop 41 + end select + + select type (val1a) + type is (integer) + if (val1a /= 7) stop 42 + val1a = 8 + class default + stop 43 + end select + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2 /= "abcdef") stop 45 + val2 = "123456" + class default + stop 46 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 47 + if (val3 /= 4_"zyx4") stop 48 + val3 = "AbCd" + class default + stop 49 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 50 + if (val3 /= 4_"AbCd") stop 51 + val3 = 4_"1ab2" + class default + stop 52 + end select + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 53 + if (val2 /= "123456") stop 54 + val2 = "A2C4E6" + class default + stop 55 + end select + + select type (val1) + type is (integer) + if (val1 /= 8) stop 56 + val1 = 9 + class default + stop 57 + end select + + select type (val1a) + type is (integer) + if (val1a /= 8) stop 58 + val1a = 9 + class default + stop 59 + end select + !$OMP END PARALLEL + + if (allocated(val1)) stop 60 + if (.not. allocated(val1a)) stop 61 + if (.not. allocated(val2)) stop 62 + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 63 + if (val2 /= "abcdef") stop 64 + class default + stop 65 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 66 + if (val3 /= 4_"zyx4") stop 67 + val3 = 4_"AbCd" + class default + stop 68 + end select + deallocate(val1a, val2, val3) +end subroutine sub2 + +subroutine sub3(val1, val1a, val2, val3) + class(*) :: val1, val1a, val2, val3 + optional :: val1a + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + select type (val1) + type is (integer) + if (val1 /= 7) stop 69 + val1 = 8 + class default + stop 70 + end select + + select type (val1a) + type is (integer) + if (val1a /= 7) stop 71 + val1a = 8 + class default + stop 72 + end select + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 73 + if (val2 /= "abcdef") stop 74 + val2 = "123456" + class default + stop 75 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 76 + if (val3 /= 4_"zyx4") stop 77 + val3 = 4_"AbCd" + class default + stop 78 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 79 + if (val3 /= 4_"AbCd") stop 80 + val3 = 4_"1ab2" + class default + stop 81 + end select + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 82 + if (val2 /= "123456") stop 83 + val2 = "A2C4E6" + class default + stop 84 + end select + + select type (val1) + type is (integer) + if (val1 /= 8) stop 85 + val1 = 9 + class default + stop 86 + end select + + select type (val1a) + type is (integer) + if (val1a /= 8) stop 87 + val1a = 9 + class default + stop 88 + end select + !$OMP END PARALLEL + + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 89 + if (val2 /= "abcdef") stop 90 + class default + stop 91 + end select + + select type (val3) + type is (character(len=*, kind=4)) + if (len(val3) /= 4) stop 92 + if (val3 /= 4_"zyx4") stop 93 + val3 = 4_"AbCd" + class default + stop 94 + end select +end subroutine sub3 +end program select_type_openmp diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90 new file mode 100644 index 00000000000..7528d32e8db --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90 @@ -0,0 +1,334 @@ +! FIRSTPRIVATE: CLASS(t) + derived types +program select_type_openmp + implicit none + type t + end type t + type, extends(t) :: t_int + integer :: i + end type + type, extends(t) :: t_char1 + character(len=:, kind=1), allocatable :: str + end type + type, extends(t) :: t_char4 + character(len=:, kind=4), allocatable :: str + end type + class(t), allocatable :: val1, val1a, val2, val3 + + call sub() ! local var + + call sub2(val1, val1a, val2, val3) ! allocatable args + + allocate(val1, source=t_int(7)) + allocate(val1a, source=t_int(7)) + allocate(val2, source=t_char1("abcdef")) + allocate(val3, source=t_char4(4_"zyx4")) + call sub3(val1, val1a, val2, val3) ! nonallocatable vars + deallocate(val1, val1a, val2, val3) +contains +subroutine sub() + class(t), allocatable :: val1, val1a, val2, val3 + allocate(val1a, source=t_int(7)) + allocate(val2, source=t_char1("abcdef")) + allocate(val3, source=t_char4(4_"zyx4")) + + if (allocated(val1)) stop 1 + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + if (allocated(val1)) stop 2 + if (.not.allocated(val1a)) stop 3 + if (.not.allocated(val2)) stop 4 + if (.not.allocated(val3)) stop 5 + + allocate(val1, source=t_int(7)) + + select type (val1) + type is (t_int) + if (val1%i /= 7) stop 6 + val1%i = 8 + class default + stop 7 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 7) stop 8 + val1a%i = 8 + class default + stop 9 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 10 + if (val2%str /= "abcdef") stop 11 + val2%str = "123456" + class default + stop 12 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 13 + if (val3%str /= 4_"zyx4") stop 14 + val3%str = 4_"AbCd" + class default + stop 15 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 16 + if (val3%str /= 4_"AbCd") stop 17 + val3%str = 4_"1ab2" + class default + stop 18 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 19 + if (val2%str /= "123456") stop 20 + val2%str = "A2C4E6" + class default + stop 21 + end select + + select type (val1) + type is (t_int) + if (val1%i /= 8) stop 22 + val1%i = 9 + class default + stop 23 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 8) stop 24 + val1a%i = 9 + class default + stop 25 + end select + !$OMP END PARALLEL + + if (allocated(val1)) stop 26 + if (.not. allocated(val1a)) stop 27 + if (.not. allocated(val2)) stop 28 + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 29 + if (val2%str /= "abcdef") stop 30 + class default + stop 31 + end select + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 32 + if (val3%str /= 4_"zyx4") stop 33 + class default + stop 34 + end select + deallocate(val1a,val2, val3) +end subroutine sub + +subroutine sub2(val1, val1a, val2, val3) + class(t), allocatable :: val1, val1a, val2, val3 + optional :: val1a + allocate(val1a, source=t_int(7)) + allocate(val2, source=t_char1("abcdef")) + allocate(val3, source=t_char4(4_"zyx4")) + + if (allocated(val1)) stop 35 + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + if (allocated(val1)) stop 36 + if (.not.allocated(val1a)) stop 37 + if (.not.allocated(val2)) stop 38 + if (.not.allocated(val3)) stop 39 + + allocate(val1, source=t_int(7)) + + select type (val1) + type is (t_int) + if (val1%i /= 7) stop 40 + val1%i = 8 + class default + stop 41 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 7) stop 42 + val1a%i = 8 + class default + stop 43 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 44 + if (val2%str /= "abcdef") stop 45 + val2%str = "123456" + class default + stop 46 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 47 + if (val3%str /= 4_"zyx4") stop 48 + val3%str = "AbCd" + class default + stop 49 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 50 + if (val3%str /= 4_"AbCd") stop 51 + val3%str = 4_"1ab2" + class default + stop 52 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 53 + if (val2%str /= "123456") stop 54 + val2%str = "A2C4E6" + class default + stop 55 + end select + + select type (val1) + type is (t_int) + if (val1%i /= 8) stop 56 + val1%i = 9 + class default + stop 57 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 8) stop 58 + val1a%i = 9 + class default + stop 59 + end select + !$OMP END PARALLEL + + if (allocated(val1)) stop 60 + if (.not. allocated(val1a)) stop 61 + if (.not. allocated(val2)) stop 62 + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 63 + if (val2%str /= "abcdef") stop 64 + class default + stop 65 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 66 + if (val3%str /= 4_"zyx4") stop 67 + val3%str = 4_"AbCd" + class default + stop 68 + end select + deallocate(val1a, val2, val3) +end subroutine sub2 + +subroutine sub3(val1, val1a, val2, val3) + class(t) :: val1, val1a, val2, val3 + optional :: val1a + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + select type (val1) + type is (t_int) + if (val1%i /= 7) stop 69 + val1%i = 8 + class default + stop 70 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 7) stop 71 + val1a%i = 8 + class default + stop 72 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 73 + if (val2%str /= "abcdef") stop 74 + val2%str = "123456" + class default + stop 75 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 76 + if (val3%str /= 4_"zyx4") stop 77 + val3%str = 4_"AbCd" + class default + stop 78 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 79 + if (val3%str /= 4_"AbCd") stop 80 + val3%str = 4_"1ab2" + class default + stop 81 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 82 + if (val2%str /= "123456") stop 83 + val2%str = "A2C4E6" + class default + stop 84 + end select + + select type (val1) + type is (t_int) + if (val1%i /= 8) stop 85 + val1%i = 9 + class default + stop 86 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 8) stop 87 + val1a%i = 9 + class default + stop 88 + end select + !$OMP END PARALLEL + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 89 + if (val2%str /= "abcdef") stop 90 + class default + stop 91 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 92 + if (val3%str /= 4_"zyx4") stop 93 + val3%str = 4_"AbCd" + class default + stop 94 + end select +end subroutine sub3 +end program select_type_openmp diff --git a/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90 b/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90 new file mode 100644 index 00000000000..a450fdee1ac --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90 @@ -0,0 +1,334 @@ +! FIRSTPRIVATE: CLASS(*) + derived types +program select_type_openmp + implicit none + type t + end type t + type, extends(t) :: t_int + integer :: i + end type + type, extends(t) :: t_char1 + character(len=:, kind=1), allocatable :: str + end type + type, extends(t) :: t_char4 + character(len=:, kind=4), allocatable :: str + end type + class(*), allocatable :: val1, val1a, val2, val3 + + call sub() ! local var + + call sub2(val1, val1a, val2, val3) ! allocatable args + + allocate(val1, source=t_int(7)) + allocate(val1a, source=t_int(7)) + allocate(val2, source=t_char1("abcdef")) + allocate(val3, source=t_char4(4_"zyx4")) + call sub3(val1, val1a, val2, val3) ! nonallocatable vars + deallocate(val1, val1a, val2, val3) +contains +subroutine sub() + class(*), allocatable :: val1, val1a, val2, val3 + allocate(val1a, source=t_int(7)) + allocate(val2, source=t_char1("abcdef")) + allocate(val3, source=t_char4(4_"zyx4")) + + if (allocated(val1)) stop 1 + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + if (allocated(val1)) stop 2 + if (.not.allocated(val1a)) stop 3 + if (.not.allocated(val2)) stop 4 + if (.not.allocated(val3)) stop 5 + + allocate(val1, source=t_int(7)) + + select type (val1) + type is (t_int) + if (val1%i /= 7) stop 6 + val1%i = 8 + class default + stop 7 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 7) stop 8 + val1a%i = 8 + class default + stop 9 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 10 + if (val2%str /= "abcdef") stop 11 + val2%str = "123456" + class default + stop 12 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 13 + if (val3%str /= 4_"zyx4") stop 14 + val3%str = 4_"AbCd" + class default + stop 15 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 16 + if (val3%str /= 4_"AbCd") stop 17 + val3%str = 4_"1ab2" + class default + stop 18 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 19 + if (val2%str /= "123456") stop 20 + val2%str = "A2C4E6" + class default + stop 21 + end select + + select type (val1) + type is (t_int) + if (val1%i /= 8) stop 22 + val1%i = 9 + class default + stop 23 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 8) stop 24 + val1a%i = 9 + class default + stop 25 + end select + !$OMP END PARALLEL + + if (allocated(val1)) stop 26 + if (.not. allocated(val1a)) stop 27 + if (.not. allocated(val2)) stop 28 + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 29 + if (val2%str /= "abcdef") stop 30 + class default + stop 31 + end select + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 32 + if (val3%str /= 4_"zyx4") stop 33 + class default + stop 34 + end select + deallocate(val1a,val2, val3) +end subroutine sub + +subroutine sub2(val1, val1a, val2, val3) + class(*), allocatable :: val1, val1a, val2, val3 + optional :: val1a + allocate(val1a, source=t_int(7)) + allocate(val2, source=t_char1("abcdef")) + allocate(val3, source=t_char4(4_"zyx4")) + + if (allocated(val1)) stop 35 + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + if (allocated(val1)) stop 36 + if (.not.allocated(val1a)) stop 37 + if (.not.allocated(val2)) stop 38 + if (.not.allocated(val3)) stop 39 + + allocate(val1, source=t_int(7)) + + select type (val1) + type is (t_int) + if (val1%i /= 7) stop 40 + val1%i = 8 + class default + stop 41 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 7) stop 42 + val1a%i = 8 + class default + stop 43 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 44 + if (val2%str /= "abcdef") stop 45 + val2%str = "123456" + class default + stop 46 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 47 + if (val3%str /= 4_"zyx4") stop 48 + val3%str = "AbCd" + class default + stop 49 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 50 + if (val3%str /= 4_"AbCd") stop 51 + val3%str = 4_"1ab2" + class default + stop 52 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 53 + if (val2%str /= "123456") stop 54 + val2%str = "A2C4E6" + class default + stop 55 + end select + + select type (val1) + type is (t_int) + if (val1%i /= 8) stop 56 + val1%i = 9 + class default + stop 57 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 8) stop 58 + val1a%i = 9 + class default + stop 59 + end select + !$OMP END PARALLEL + + if (allocated(val1)) stop 60 + if (.not. allocated(val1a)) stop 61 + if (.not. allocated(val2)) stop 62 + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 63 + if (val2%str /= "abcdef") stop 64 + class default + stop 65 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 66 + if (val3%str /= 4_"zyx4") stop 67 + val3%str = 4_"AbCd" + class default + stop 68 + end select + deallocate(val1a, val2, val3) +end subroutine sub2 + +subroutine sub3(val1, val1a, val2, val3) + class(*) :: val1, val1a, val2, val3 + optional :: val1a + + !$OMP PARALLEL firstprivate(val1, val1a, val2, val3) + select type (val1) + type is (t_int) + if (val1%i /= 7) stop 69 + val1%i = 8 + class default + stop 70 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 7) stop 71 + val1a%i = 8 + class default + stop 72 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 73 + if (val2%str /= "abcdef") stop 74 + val2%str = "123456" + class default + stop 75 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 76 + if (val3%str /= 4_"zyx4") stop 77 + val3%str = 4_"AbCd" + class default + stop 78 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 79 + if (val3%str /= 4_"AbCd") stop 80 + val3%str = 4_"1ab2" + class default + stop 81 + end select + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 82 + if (val2%str /= "123456") stop 83 + val2%str = "A2C4E6" + class default + stop 84 + end select + + select type (val1) + type is (t_int) + if (val1%i /= 8) stop 85 + val1%i = 9 + class default + stop 86 + end select + + select type (val1a) + type is (t_int) + if (val1a%i /= 8) stop 87 + val1a%i = 9 + class default + stop 88 + end select + !$OMP END PARALLEL + + select type (val2) + type is (t_char1) + if (len(val2%str) /= 6) stop 89 + if (val2%str /= "abcdef") stop 90 + class default + stop 91 + end select + + select type (val3) + type is (t_char4) + if (len(val3%str) /= 4) stop 92 + if (val3%str /= 4_"zyx4") stop 93 + val3%str = 4_"AbCd" + class default + stop 94 + end select +end subroutine sub3 +end program select_type_openmp