From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from smtp.smtpout.orange.fr (smtp-19.smtpout.orange.fr [80.12.242.19]) by sourceware.org (Postfix) with ESMTPS id A9245385842B for ; Tue, 11 Jul 2023 10:33:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A9245385842B Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: sourceware.org; spf=fail smtp.mailfrom=gcc.gnu.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id JAfuqCdJWn02aJAg2qNA48; Tue, 11 Jul 2023 12:33:02 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=wanadoo.fr; s=t20230301; t=1689071582; bh=8WswCOgIPi+CHVCPV80kEyLjGgtnPDvmz1Ipjj17dFY=; h=From:To:Subject:Date:In-Reply-To:References; b=OHGtZKMcn6sVAqFfSYhja8FKWD46E48jTYCSNDEn/dcHBL7vF0z+FuuF4ooG4kMg/ FrXzmlf2l9ef+63ll6EJe7D9tN3k05qY5LdkXOojuA6ujvIgviKPTKGobez4cvT+vJ LNLk1QdVM7c30SGTzyceqEJGPCNDtWQD1XH0ewQ+uFcQUDNMHpHDFAtgTQSppB8K8S Yxv+s+wgDA5giKi6z288DIvzem8o0zf9hzM9dZpKz6dNsaiB2j/0GvrHicUwPLnuGv 2+B2PDhM3vhgc1pjCn0923eWwtO0kwf4OHOdEsBqBoS5HsrmKyPq1Xm/6uoFDXyX4G 7/qhp/LsBJUOg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Tue, 11 Jul 2023 12:33:02 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 2/3] fortran: Factor data references for scalar class argument wrapping [PR92178] Date: Tue, 11 Jul 2023 12:32:52 +0200 Message-Id: <20230711103253.1589353-3-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.40.1 In-Reply-To: <20230711103253.1589353-1-mikael@gcc.gnu.org> References: <20230711103253.1589353-1-mikael@gcc.gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-10.1 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,FORGED_SPF_HELO,GIT_PATCH_0,JMQ_SPF_NEUTRAL,RCVD_IN_DNSWL_NONE,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,SPF_NEUTRAL,TXREP,T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: In the case of a scalar actual arg passed to a polymorphic assumed-rank dummy with INTENT(OUT) attribute, avoid repeatedly evaluating the actual argument reference by saving a pointer to it. This is non-optimal, but may also be invalid, because the data reference may depend on its own content. In that case the expression can't be evaluated after the data has been deallocated. There are two ways redundant expressions are generated: - parmse.expr, which contains the actual argument expression, is reused to get or set subfields in gfc_conv_class_to_class. - gfc_conv_class_to_class, to get the virtual table pointer associated with the argument, generates a new expression from scratch starting with the frontend expression. The first part is fixed by saving parmse.expr to a pointer and using the pointer instead of the original expression. The second part is fixed by adding a separate field to gfc_se that is set to the class container expression when the expression to evaluate is polymorphic. This needs the same field in gfc_ss_info so that its value can be propagated to gfc_conv_class_to_class which is modified to use that value. Finally gfc_conv_procedure saves the expression in that field to a pointer in between to avoid the same problem as for the first part. PR fortran/92178 gcc/fortran/ChangeLog: * trans.h (struct gfc_se): New field class_container. (struct gfc_ss_info): Ditto. (gfc_evaluate_data_ref_now): New prototype. * trans.cc (gfc_evaluate_data_ref_now): Implement it. * trans-array.cc (gfc_conv_ss_descriptor): Copy class_container field from gfc_se struct to gfc_ss_info struct. (gfc_conv_expr_descriptor): Copy class_container field from gfc_ss_info struct to gfc_se struct. * trans-expr.cc (gfc_conv_class_to_class): Use class container set in class_container field if available. (gfc_conv_variable): Set class_container field on encountering class variables or components, clear it on encountering non-class components. (gfc_conv_procedure_call): Evaluate data ref to a pointer now, and replace later references by usage of the pointer. gcc/testsuite/ChangeLog: * gfortran.dg/intent_out_20.f90: New test. --- gcc/fortran/trans-array.cc | 3 ++ gcc/fortran/trans-expr.cc | 26 ++++++++++++++++ gcc/fortran/trans.cc | 28 +++++++++++++++++ gcc/fortran/trans.h | 6 ++++ gcc/testsuite/gfortran.dg/intent_out_20.f90 | 33 +++++++++++++++++++++ 5 files changed, 96 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/intent_out_20.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e7c51bae052..1c2af55d436 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3271,6 +3271,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) gfc_add_block_to_block (block, &se.pre); info->descriptor = se.expr; ss_info->string_length = se.string_length; + ss_info->class_container = se.class_container; if (base) { @@ -7687,6 +7688,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else if (deferred_array_component) se->string_length = ss_info->string_length; + se->class_container = ss_info->class_container; + gfc_free_ss_chain (ss); return; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index b7e95e6d04d..5169fbcd974 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1266,6 +1266,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, slen = build_zero_cst (size_type_node); } + else if (parmse->class_container != NULL_TREE) + /* Don't redundantly evaluate the expression if the required information + is already available. */ + tmp = parmse->class_container; else { /* Remove everything after the last class reference, convert the @@ -3078,6 +3082,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) return; } + if (sym->ts.type == BT_CLASS + && sym->attr.class_ok + && sym->ts.u.derived->attr.is_class) + se->class_container = se->expr; + /* Dereference the expression, where needed. */ se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, is_classarray); @@ -3135,6 +3144,15 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + + if (ref->u.c.component->ts.type == BT_CLASS + && ref->u.c.component->attr.class_ok + && ref->u.c.component->ts.u.derived->attr.is_class) + se->class_container = se->expr; + else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED + && ref->u.c.sym->attr.is_class)) + se->class_container = NULL_TREE; + if (!ref->next && ref->u.c.sym->attr.codimension && se->want_pointer && se->descriptor_only) return; @@ -6664,6 +6682,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, defer_to_dealloc_blk = true; + parmse.expr = gfc_evaluate_data_ref_now (parmse.expr, + &parmse.pre); + + if (parmse.class_container != NULL_TREE) + parmse.class_container + = gfc_evaluate_data_ref_now (parmse.class_container, + &parmse.pre); + gfc_init_block (&block); ptr = parmse.expr; if (e->ts.type == BT_CLASS) diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 7ad85aee9e7..f1a3aacd850 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -174,6 +174,34 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock) return gfc_evaluate_now_loc (input_location, expr, pblock); } + +/* Returns a fresh pointer variable pointing to the same data as EXPR, adding + in BLOCK the initialization code that makes it point to EXPR. */ + +tree +gfc_evaluate_data_ref_now (tree expr, stmtblock_t *block) +{ + tree t = expr; + + STRIP_NOPS (t); + + /* If EXPR can be used as lhs of an assignment, we have to take the address + of EXPR. Otherwise, reassigning the pointer would retarget it to some + other data without EXPR being retargetted as well. */ + bool lvalue_p = DECL_P (t) || REFERENCE_CLASS_P (t) || INDIRECT_REF_P (t); + + tree value; + if (lvalue_p) + { + value = gfc_build_addr_expr (NULL_TREE, expr); + value = gfc_evaluate_now (value, block); + return build_fold_indirect_ref_loc (input_location, value); + } + else + return gfc_evaluate_now (expr, block); +} + + /* Like gfc_evaluate_now, but add the created variable to the function scope. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0c8d004736d..82cdd694073 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -57,6 +57,10 @@ typedef struct gfc_se here. */ tree class_vptr; + /* When expr is a reference to a direct subobject of a class, store + the reference to the class object here. */ + tree class_container; + /* Whether expr is a reference to an unlimited polymorphic object. */ unsigned unlimited_polymorphic:1; @@ -263,6 +267,7 @@ typedef struct gfc_ss_info gfc_ss_type type; gfc_expr *expr; tree string_length; + tree class_container; union { @@ -525,6 +530,7 @@ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); /* If the value is not constant, Create a temporary and copy the value. */ tree gfc_evaluate_now_loc (location_t, tree, stmtblock_t *); tree gfc_evaluate_now (tree, stmtblock_t *); +tree gfc_evaluate_data_ref_now (tree, stmtblock_t *); tree gfc_evaluate_now_function_scope (tree, stmtblock_t *); /* Find the appropriate variant of a math intrinsic. */ diff --git a/gcc/testsuite/gfortran.dg/intent_out_20.f90 b/gcc/testsuite/gfortran.dg/intent_out_20.f90 new file mode 100644 index 00000000000..8e5d8c6909e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_20.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that if a data reference passed is as actual argument whose dummy +! has INTENT(OUT) attribute, any other argument depending on the +! same data reference is evaluated before the data reference deallocation. + +program p + implicit none + type t + integer :: i + end type t + type u + class(t), allocatable :: ta + end type u + type(u), allocatable :: c(:) + allocate(c, source = [u(t(1)), u(t(4))]) + call bar ( & + allocated (c(c(1)%ta%i)%ta), & + c(c(1)%ta%i)%ta, & + allocated (c(c(1)%ta%i)%ta) & + ) + if (allocated (c(1)%ta)) stop 11 + if (.not. allocated (c(2)%ta)) stop 12 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(..) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end -- 2.40.1