From patchwork Thu May 7 13:11:41 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1285252 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 49Hv4t73g9z9sSg for ; Thu, 7 May 2020 23:12:12 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1CE38395B079; Thu, 7 May 2020 13:12:08 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id 3F10A386F46B; Thu, 7 May 2020 13:11:56 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 3F10A386F46B Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=Tobias_Burnus@mentor.com IronPort-SDR: V5GrgG4FNGYibcf9TqE5Vfn4D9ibiSZP6BRFZf6Mru2+BcbFYFhb0yllvie0dNrymviANHO2Zg x+gkwLuzn/5aqUyH459M1qnbKQqVklyRmQTNuuac+2wiYJa3lagfzL06JnB8M1xZlHu61iWRJA 2pFim0FMhJA77+yWOlr8aGK8z0BESXmWuOr+U3TQ77CAdFgJHD67sB+Zjv3CLOCUE3TPyj0tP8 FV7iSyK9LhOCn8kPUp7UG6VZ5PMPpbTzLyjpoO9PA21eXq0/zoRa6/SlA621sODIhHwOwOVEub ol0= X-IronPort-AV: E=Sophos;i="5.73,363,1583222400"; d="diff'?scan'208";a="48558946" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 07 May 2020 05:11:53 -0800 IronPort-SDR: CmNXFGSHkkRadHY3wBGoRDWK/kUZCk7bjgBXuTgtDkTCPMM8DFftEKsLzEq5gFhi5bY/+D47CW 4S+9bYnpn2caM9yP7AP3skvIf+aq+diZKpaZPqI8h+xrU3LDZMknbznASYhhGDUJQVYVRcUh2m lG22Dth/FD4tMlx3LXijmy16Tkldg1ywxwtHnVCLTUErRer/aPthYzJVhvwxBPcLz9A1QNKsAF CiLlheafFZOPFVfbMd7NHZ/ywx+ght0oMNo4xaGxYkHkIm2m2se499XaetJtGS58bE3iSzpnYp S/Q= To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] (general Fortran + OpenMP) [Fortran] Fix/modify present() handling for assumed-shape optional (PR 94672) Message-ID: <248b8834-b830-9130-c80f-64a81dd95a59@codesourcery.com> Date: Thu, 7 May 2020 15:11:41 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.7.0 MIME-Version: 1.0 Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-16.1 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" The main purpose of this patch is to fix OpenMP, but it modifies the general Fortran handling of assumed-shape optional arguments. For assumed shape, gfortran generates an "arg.0 = arg->data" artificial variable – and with optional one has something like if (arg != NULL && arg->data != NULL) { arg.0 = arg->data; lbound.0 = ... } And an "if (present(arg))" becomes "if (arg != NULL && arg->data != NULL)". The proposed change changes the init to: if (arg != NULL && arg->data != NULL) { arg.0 = arg->data; lbound.0 = ... } else arg.0 = NULL; // <-- new Such that an "if (present(arg))" becomes "if (arg.0 != NULL)". I think for Fortran code itself, it does not really make any difference. However, for OpenMP (and OpenACC) it does. Currently, !$omp … if (present(arg)) stop 1 !$omp end … has decl = "arg.0" and SAVED_DESCRIPTOR(decl) == "arg" such that inside the omp block everything is "arg.0" – except for "if (present(arg))" which is converted to the "!arg && !arg->data". This causes the problems shown in the PR (PR94672). For optional & 'omp target' where one has to map the variable and has to check it inside the target function, I even ended up setting "arg.0 = NULL" explicitly as this was much simpler than adding more checking in gcc/omp-low.c. Thus: I think either variant (checking arg directly vs. checking arg.0 plus setting it to NULL) works equally well with normal Fortran code; one can probably design code where one or the other is slightly faster, but at the end it should not matter. And for OpenMP/OpenACC, the new variant avoids several problems. Hence: OK for the trunk – and GCC 10 (regression, rejects valid code)? Tobias ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter [Fortran] Fix/modify present() handling for assumed-shape optional (PR 94672) gcc/fortran/ 2020-05-07 Tobias Burnus PR fortran/94672 * trans.h (gfc_conv_expr_present): Add use_saved_decl=false argument. * trans-expr.c (gfc_conv_expr_present): Likewise; use DECL directly and only if use_saved_decl is true, use the actual PARAM_DECL arg (saved descriptor). * trans-array.c (gfc_trans_dummy_array_bias): Set local 'arg.0' variable to NULL if 'arg' is not present. * trans-openmp.c (gfc_omp_check_optional_argument): Simplify by checking 'arg.0' instead of the true PARM_DECL. (gfc_omp_finish_clause): Remove setting 'arg.0' to NULL. gcc/testsuite/ 2020-05-07 Jakub Jelinek Tobias Burnus PR fortran/94672 * gfortran.dg/gomp/pr94672.f90: New. * gfortran.dg/missing_optional_dummy_6a.f90: Update scan-tree. gcc/fortran/trans-array.c | 8 +- gcc/fortran/trans-expr.c | 22 ++-- gcc/fortran/trans-openmp.c | 42 +------ gcc/fortran/trans.h | 2 +- gcc/testsuite/gfortran.dg/gomp/pr94672.f90 | 127 +++++++++++++++++++++ .../gfortran.dg/missing_optional_dummy_6a.f90 | 3 +- 6 files changed, 152 insertions(+), 52 deletions(-) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 9c928d04e0a..434960c5bc7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6787,9 +6787,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, && sym->attr.dummy)); if (optional_arg) { - tmp = gfc_conv_expr_present (sym); - stmtInit = build3_v (COND_EXPR, tmp, stmtInit, - build_empty_stmt (input_location)); + tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node); + zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + tmpdesc, zero_init); + tmp = gfc_conv_expr_present (sym, true); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init); } /* Cleanup code. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 030edc1e5ce..33fc061d89b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1712,12 +1712,12 @@ gfc_make_safe_expr (gfc_se * se) Also used for arguments to procedures with multiple entry points. */ tree -gfc_conv_expr_present (gfc_symbol * sym) +gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc) { - tree decl, cond; + tree decl, orig_decl, cond; gcc_assert (sym->attr.dummy); - decl = gfc_get_symbol_decl (sym); + orig_decl = decl = gfc_get_symbol_decl (sym); /* Intrinsic scalars with VALUE attribute which are passed by value use a hidden argument to denote the present status. */ @@ -1744,10 +1744,13 @@ gfc_conv_expr_present (gfc_symbol * sym) return cond; } - if (TREE_CODE (decl) != PARM_DECL) + /* Assumed-shape arrays use a local variable for the array data; + the actual PARAM_DECL is in a saved decl. As the local variable + is NULL, it can be checked instead, unless use_saved_desc is + requested. */ + + if (use_saved_desc && TREE_CODE (decl) != PARM_DECL) { - /* Array parameters use a temporary descriptor, we want the real - parameter. */ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); decl = GFC_DECL_SAVED_DESCRIPTOR (decl); @@ -1761,9 +1764,12 @@ gfc_conv_expr_present (gfc_symbol * sym) we thus also need to check the array descriptor. For BT_CLASS, it can also occur for scalars and F2003 due to type->class wrapping and class->class wrapping. Note further that BT_CLASS always uses an - array descriptor for arrays, also for explicit-shape/assumed-size. */ + array descriptor for arrays, also for explicit-shape/assumed-size. + For assumed-rank arrays, no local variable is generated, hence, + the following also applies with !use_saved_desc. */ - if (!sym->attr.allocatable + if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL) + && !sym->attr.allocatable && ((sym->ts.type != BT_CLASS && !sym->attr.pointer) || (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)->attr.allocatable diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 66669550499..42ecd0a9cbb 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -90,16 +90,13 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check) if (!DECL_LANG_SPECIFIC (decl)) return NULL_TREE; - bool is_array_type = false; + tree orig_decl = decl; /* For assumed-shape arrays, a local decl with arg->data is used. */ if (TREE_CODE (decl) != PARM_DECL && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) - { - is_array_type = true; - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - } + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (decl == NULL_TREE || TREE_CODE (decl) != PARM_DECL @@ -132,23 +129,8 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check) return decl; } - tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - decl, null_pointer_node); - - /* Fortran regards unallocated allocatables/disassociated pointer which - are passed to a nonallocatable, nonpointer argument as not associated; - cf. F2018, 15.5.2.12, Paragraph 1. */ - if (is_array_type) - { - tree cond2 = build_fold_indirect_ref_loc (input_location, decl); - cond2 = gfc_conv_array_data (cond2); - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - cond2, null_pointer_node); - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond, cond2); - } - - return cond; + return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + orig_decl, null_pointer_node); } @@ -1287,22 +1269,6 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) return; tree orig_decl = decl; - /* For nonallocatable, nonpointer arrays, a temporary variable is - generated, but this one is only defined if the variable is present; - hence, we now set it to NULL to avoid accessing undefined variables. - We cannot use a temporary variable here as otherwise the replacement - of the variables in omp-low.c will not work. */ - if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) - { - tree tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, decl, null_pointer_node); - tree cond = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - boolean_type_node, present); - tmp = build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, NULL_TREE); - gimplify_and_add (tmp, pre_p); - } - c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); OMP_CLAUSE_DECL (c4) = decl; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 69171f3d0f2..bd96cdf86fc 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -561,7 +561,7 @@ void gfc_trans_common (gfc_namespace *); void gfc_conv_structure (gfc_se *, gfc_expr *, int); /* Return an expression which determines if a dummy parameter is present. */ -tree gfc_conv_expr_present (gfc_symbol *); +tree gfc_conv_expr_present (gfc_symbol *, bool use_saved_decl = false); /* Convert a missing, dummy argument into a null or zero. */ void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int); diff --git a/gcc/testsuite/gfortran.dg/gomp/pr94672.f90 b/gcc/testsuite/gfortran.dg/gomp/pr94672.f90 new file mode 100644 index 00000000000..7b89c5df249 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr94672.f90 @@ -0,0 +1,127 @@ +! { dg-do compile } + +SUBROUTINE foo(n,array) + IMPLICIT NONE + INTEGER, INTENT (IN) :: n + REAL, INTENT(INOUT),OPTIONAL:: array(:) + INTEGER:: i + + !$OMP PARALLEL DO DEFAULT(none) SHARED(array,n) PRIVATE(i) + DO i = 1,n + IF (PRESENT(array)) THEN + array(i) = array(i) + i + ENDIF + ENDDO + !$OMP END PARALLEL DO +END SUBROUTINE foo + +subroutine s1 (array) + real, optional :: array(:) + !$omp parallel default(none) firstprivate (array) + if (present (array)) array(:) = 3 + !$omp end parallel +end subroutine + +subroutine s2 (array) + real, optional :: array(:) + !$omp parallel default(none) shared (array) + !$omp master + if (present (array)) array(:) = 3 + !$omp end master + !$omp end parallel +end subroutine + +subroutine s3 (array) + real, optional :: array(:) + !$omp parallel default(none) private (array) + if (present (array)) array(:) = 3 + !$omp end parallel +end subroutine + +subroutine s4 (arg) + real, optional :: arg + !$omp parallel default(none) firstprivate (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s5 (arg) + real, optional :: arg + !$omp parallel default(none) shared (arg) + !$omp master + if (present (arg)) arg = 3 + !$omp end master + !$omp end parallel +end subroutine + +subroutine s6 (arg) + real, optional :: arg + !$omp parallel default(none) private (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s7 (arg) + real, value, optional :: arg + !$omp parallel default(none) firstprivate (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s8 (arg) + real, value, optional :: arg + !$omp parallel default(none) shared (arg) + !$omp master + if (present (arg)) arg = 3 + !$omp end master + !$omp end parallel +end subroutine + +subroutine s9 (arg) + real, value, optional :: arg + !$omp parallel default(none) private (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s10 (arg) + real, optional :: arg(..) + !$omp parallel default(none) private (arg) + if (present (arg)) stop 10 + !$omp end parallel +end subroutine + +subroutine w1 (array) + real, optional :: array(:) + !$omp parallel default(none) ! { dg-error "enclosing 'parallel'" } + if (.not.present (array)) stop 1 ! { dg-error "'array' not specified in enclosing 'parallel'" } + !$omp end parallel +end subroutine + +subroutine w2 (array2) + real, optional :: array2(*) + !$omp parallel default(none) ! { dg-error "enclosing 'parallel'" "TODO" { xfail *-*-* } } + if (.not.present (array2)) stop 2 ! { dg-error "'array2' not specified in enclosing 'parallel'" "TODO" { xfail *-*-* } } + !$omp end parallel +end subroutine + +subroutine w3 (arg) + real, optional :: arg + !$omp parallel default(none) ! { dg-error "enclosing 'parallel'" } + if (.not.present (arg)) stop 3 ! { dg-error "'arg' not specified in enclosing 'parallel'" } + !$omp end parallel +end subroutine + +subroutine w4 (arg2) + real, value, optional :: arg2 + !$omp parallel default(none) ! { dg-error "enclosing 'parallel" "TODO" { xfail *-*-* } } + if (.not.present (arg2)) stop 4 ! { dg-error "'arg2' not specified in enclosing 'parallel'" "TODO" { xfail *-*-*} } + !$omp end parallel +end subroutine + +subroutine w5 (array3) + real, optional :: array3(..) + !$omp parallel default(none) ! { dg-error "enclosing 'parallel'" } + if (.not.present (array3)) stop 5 ! { dg-error "'array3' not specified in enclosing 'parallel'" } + !$omp end parallel +end subroutine diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90 index 0e08ed3aa0c..c08c97a2c7e 100644 --- a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90 +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90 @@ -53,7 +53,6 @@ end program test ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } } ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } } -! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } } +! { dg-final { scan-tree-dump-times "= as1.0 != 0B" 2 "original" } } ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } } ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } } -