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 C93C13857704 for ; Tue, 11 Jul 2023 10:33:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org C93C13857704 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 JAfuqCdJWn02aJAg2qNA4B; 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=DhNaFWv6kslI3Z9RlmbIRMPCZUUqOh/BCamlo+JbMBU=; h=From:To:Subject:Date:In-Reply-To:References; b=X3i9DUpzCl61tnLCvpaJVo09ftqJ88zZnkuAKpLIPPdJKHH5XmPELxkQh3Duvhtl1 3V8XN7VW97LTghuCOgNKZ2/LO1yddV2fb8WsLwXRUjqqfRluXn/s99XwSh7XqCFbGn ELtpfA/B74sRkf35sY0/9C8ijekwQ9hnc7eCb+Bxs512DdAbeJGwBpY60WRub57HzH 9Y+vbOfz9I8LiVid2uxpE1Uy88PrdSRMZi0bn0/QxDTaBlGn9sktrmmNBpVZN+SkvC cKXczRA/TduYOxkYfvPvGzysdajbPQY9Z98xotLudeLb2yg/WJLgtp+cxu28DnvAvf PuldPsUtpfCSw== 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 3/3] fortran: Reorder array argument evaluation parts [PR92178] Date: Tue, 11 Jul 2023 12:32:53 +0200 Message-Id: <20230711103253.1589353-4-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.4 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 an array actual arg passed to a polymorphic array dummy with INTENT(OUT) attribute, reorder the argument evaluation code to the following: - first evaluate arguments' values, and data references, - deallocate data references associated with an allocatable, intent(out) dummy, - create a class container using the freed data references. The ordering used to be incorrect between the first two items, when one argument was deallocated before a later argument evaluated its expression depending on the former argument. r14-2395-gb1079fc88f082d3c5b583c8822c08c5647810259 fixed it by treating arguments associated with an allocatable, intent(out) dummy in a separate, later block. This, however, wasn't working either if the data reference of such an argument was depending on its own content, as the class container initialization was trying to use deallocated content. This change generates class container initialization code in a separate block, so that it is moved after the deallocation block without moving the rest of the argument evaluation code. This alone is not sufficient to fix the problem, because the class container generation code repeatedly uses the full expression of the argument at a place where deallocation might have happened already. 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. As in the scalar case previously treated, this is fixed by saving the data reference to a pointer before any deallocation happens, and then only refering to the pointer. gfc_reset_vptr is updated to take into account the already evaluated class container if it's available. Contrary to the scalar case, one hunk is needed to wrap the parameter evaluation in a conditional, to avoid regressing in optional_class_2.f90. This used to be handled by the class wrapper construction which wrapped the whole code in a conditional. With this change the class wrapper construction can't see the parameter evaluation code, so the latter is updated with an additional handling for optional arguments. PR fortran/92178 gcc/fortran/ChangeLog: * trans.h (gfc_reset_vptr): Add class_container argument. * trans-expr.cc (gfc_reset_vptr): Ditto. If a valid vptr can be obtained through class_container argument, bypass evaluation of e. (gfc_conv_procedure_call): Wrap the argument evaluation code in a conditional if the associated dummy is optional. Evaluate the data reference to a pointer now, and replace later references with usage of the pointer. gcc/testsuite/ChangeLog: * gfortran.dg/intent_out_21.f90: New test. --- gcc/fortran/trans-expr.cc | 86 ++++++++++++++++----- gcc/fortran/trans.h | 2 +- gcc/testsuite/gfortran.dg/intent_out_21.f90 | 33 ++++++++ 3 files changed, 101 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/intent_out_21.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 5169fbcd974..dbb04f8c434 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -529,24 +529,32 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, } -/* Reset the vptr to the declared type, e.g. after deallocation. */ +/* Reset the vptr to the declared type, e.g. after deallocation. + Use the variable in CLASS_CONTAINER if available. Otherwise, recreate + one with E. The generated assignment code is added at the end of BLOCK. */ void -gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) +gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container) { - gfc_symbol *vtab; - tree vptr; - tree vtable; - gfc_se se; + tree vptr = NULL_TREE; - /* Evaluate the expression and obtain the vptr from it. */ - gfc_init_se (&se, NULL); - if (e->rank) - gfc_conv_expr_descriptor (&se, e); - else - gfc_conv_expr (&se, e); - gfc_add_block_to_block (block, &se.pre); - vptr = gfc_get_vptr_from_expr (se.expr); + if (class_container != NULL_TREE) + vptr = gfc_get_vptr_from_expr (class_container); + + if (vptr == NULL_TREE) + { + gfc_se se; + + /* Evaluate the expression and obtain the vptr from it. */ + gfc_init_se (&se, NULL); + if (e->rank) + gfc_conv_expr_descriptor (&se, e); + else + gfc_conv_expr (&se, e); + gfc_add_block_to_block (block, &se.pre); + + vptr = gfc_get_vptr_from_expr (se.expr); + } /* If a vptr is not found, we can do nothing more. */ if (vptr == NULL_TREE) @@ -556,6 +564,9 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); else { + gfc_symbol *vtab; + tree vtable; + /* Return the vptr to the address of the declared type. */ vtab = gfc_find_derived_vtab (e->ts.u.derived); vtable = vtab->backend_decl; @@ -6847,6 +6858,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr_descriptor (&parmse, e); bool defer_to_dealloc_blk = false; + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + stmtblock_t block; + + gfc_init_block (&block); + gfc_add_block_to_block (&block, &parmse.pre); + + tree t = fold_build3_loc (input_location, COND_EXPR, + void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&parmse.pre, t); + } + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym->attr.intent == INTENT_OUT @@ -6855,6 +6884,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t block; tree ptr; + /* In case the data reference to deallocate is dependent on + its own content, save the resulting pointer to a variable + and only use that variable from now on, before the + expression becomes invalid. */ + 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; ptr = gfc_class_data_get (ptr); @@ -6868,7 +6909,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, void_type_node, ptr, null_pointer_node); gfc_add_expr_to_block (&block, tmp); - gfc_reset_vptr (&block, e); + gfc_reset_vptr (&block, e, parmse.class_container); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE @@ -6890,9 +6931,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, defer_to_dealloc_blk = true; } + gfc_se class_se = parmse; + gfc_init_block (&class_se.pre); + gfc_init_block (&class_se.post); + /* The conversion does not repackage the reference to a class array - _data descriptor. */ - gfc_conv_class_to_class (&parmse, e, fsym->ts, false, + gfc_conv_class_to_class (&class_se, e, fsym->ts, false, fsym->attr.intent != INTENT_IN && (CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable), @@ -6902,9 +6947,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); - /* Defer repackaging after deallocation. */ - if (defer_to_dealloc_blk) - gfc_add_block_to_block (&dealloc_blk, &parmse.pre); + parmse.expr = class_se.expr; + stmtblock_t *class_pre_block = defer_to_dealloc_blk + ? &dealloc_blk + : &parmse.pre; + gfc_add_block_to_block (class_pre_block, &class_se.pre); + gfc_add_block_to_block (&parmse.post, &class_se.post); } else { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 82cdd694073..7b41e8912b4 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -451,7 +451,7 @@ tree gfc_vptr_def_init_get (tree); tree gfc_vptr_copy_get (tree); tree gfc_vptr_final_get (tree); tree gfc_vptr_deallocate_get (tree); -void gfc_reset_vptr (stmtblock_t *, gfc_expr *); +void gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE); void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_class_from_gfc_expr (gfc_expr *); tree gfc_get_class_from_expr (tree); diff --git a/gcc/testsuite/gfortran.dg/intent_out_21.f90 b/gcc/testsuite/gfortran.dg/intent_out_21.f90 new file mode 100644 index 00000000000..5f61a547471 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_21.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that in the case of a data reference depending on its own content +! passed as actual argument to an INTENT(OUT) dummy, no reference to the +! content happens after the 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(:) + c = [u([t(1), t(3)]), u([t(4), t(9)])] + call bar ( & + allocated (c(c(1)%ta(1)%i)%ta), & + c(c(1)%ta(1)%i)%ta, & + allocated (c(c(1)%ta(1)%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