From patchwork Mon Jan 17 11:57:38 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1580739 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: bilbo.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=QkaghRqP; dkim-atps=neutral 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+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) 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 bilbo.ozlabs.org (Postfix) with ESMTPS id 4Jcr5q11ycz9ssD for ; Mon, 17 Jan 2022 22:58:38 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 76AEE3858020 for ; Mon, 17 Jan 2022 11:58:35 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 76AEE3858020 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1642420715; bh=uvWq85uNP634UvyMR9Hpamid1JXI2EVgSJMsXKjd5ro=; h=Date:Subject:To:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=QkaghRqPPMhHoJjsFlpA6aPwD/vTkAbo1YpgbVAMlDjWw6WkLH7WvVrrgfGckLF7M FKvn/TfJjCM2b++p1+iH8vrCcQzZdzAp3E41bDT+Gd6mt21mR4ZYAHQcCY+DJYCgMq BIAs9IY8YLtQ6Dvw8OV+xqGhHypUdmziAyZiiISY= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-qv1-xf2b.google.com (mail-qv1-xf2b.google.com [IPv6:2607:f8b0:4864:20::f2b]) by sourceware.org (Postfix) with ESMTPS id E9D183858D3C; Mon, 17 Jan 2022 11:57:49 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org E9D183858D3C Received: by mail-qv1-xf2b.google.com with SMTP id a8so18201035qvx.2; Mon, 17 Jan 2022 03:57:49 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:mime-version:from:date:message-id:subject:to; bh=l6JtmOl3rzNyG9H1McRlhoXY/QDH2Kj4SqFmj306kxU=; b=tZLgivCHMmsFbCrY4tnHz08RCGzO2X7mkApuKrJL0n22O0no1ESBARbSAD+SVMuAFs 8xHW+Hxyyg3XWUQOQZuRJxTKiwPnQNG8ubCzskNgRZTo9kcrTASjsj8T8gdZ8MOgl4fe /atDsa3vMuvhylMWpHv+mW6TwdWH/bwO1ybF1edtZyPBlPf4G0g7VTEZ2LiDjheRT4xI 6rYcQlgWrDLRh3TEHfcfyBa67uWmQ08KmKu/TXZFCh8h85KCQzOF6aBs4ITzb6uAYipx mk3BrnP4muDZTN6e3v54oZb+jVz9gXKVLWfwQUenT6s0+8DDS+W0/tVOE3KLye8665sU /Wdg== X-Gm-Message-State: AOAM530FjfOO9AzDLRIsd4GHolKZ0u2fXDvuS5KUJ8BjzBrZdufAwnvM b49NyVNoFLovOY6wEQkP9can9Jkddz3o0ZF28U/ZgoVvYT8= X-Google-Smtp-Source: ABdhPJyK/ngtjKxEGB5YIXV9uHLWVzlrzunq3/bADj91HRUk3h60liS7D+grb2TtWax7QQAksabPmNj3GD6Q6Tz/EIo= X-Received: by 2002:a05:6214:262a:: with SMTP id gv10mr17715840qvb.102.1642420669388; Mon, 17 Jan 2022 03:57:49 -0800 (PST) MIME-Version: 1.0 Date: Mon, 17 Jan 2022 11:57:38 +0000 Message-ID: Subject: [Patch, fortran] PR64290 - [F03] No finalization at deallocation of LHS To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-7.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-Content-Filtered-By: Mailman/MimeDel 2.1.29 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: , X-Patchwork-Original-From: Paul Richard Thomas via Gcc-patches From: Paul Richard Thomas Reply-To: Paul Richard Thomas Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Hi All, Strictly speaking, the attached patch is branching out into a more generalised attack on PR37336(Finalization) - [F03] Finish derived-type finalization but most of it fixes PR64290. I started work on this patch almost a year ago but had to drop it due daytime work pressure and only picked it up again a couple of weeks back. It is not, as yet, complete but I thought to post it in its present form because stage 3 ended yesterday. The main thrusts of the patch are: (i) To correct the order taken by finalization and deallocation of components for the lhs of assignments. This is done instead by a call to Tobias' finalization wrapper, rather than performing finalization component by component in structure_alloc_comps; (ii) To add finalization of scalar derived type function results, again by use of the finalization wrapper. This points to a problem that I haven't yet managed to fix, F2018(7.5.6.3 para 5) "If an executable construct references a nonpointer function, the result is finalized after execution of the innermost executable construct containing the reference." I have been struggling to avoid implementing this by introducing a finalization block into gfc_se but have run out of ideas as to how to do it otherwise. (eg. Try using a finalizable function as the actual argument of another procedure.); and (iii) Once (ii) is added, a segfault occurs if the derived type has allocatable, finalizable components. (PR96122) This occurred because the call to the component finalization wrapper was missing two arguments in the call; most particularly 'byte_stride'. There is still quite a lot to do to bring together common code chunks, fix the ordering requirement of F2018 (7.5.6.3 para 5), add more testcases. It's certainly not ready to be committed yet :-( Regards Paul Fortran:Implement missing finalization features [PR64290] 2022-01-17 Paul Thomas gcc/fortran PR fortran/103854 * class.c (has_finalizer_component): Do not return true for procedure pointer components. PR fortran/96087 * class.c (finalize_component): Include the missing arguments in the call to the component's finalizer wrapper. PR fortran/64290 * resolve.c (resolve_where, gfc_resolve_where_code_in_forall, gfc_resolve_forall_body, gfc_resolve_code): Check that the op code is still EXEC_ASSIGN. If it is set lhs to must finalize. * trans-array.c (structure_alloc_comps): Add boolean argument to suppress finalization and use it for calls from gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to false. (gfc_alloc_allocatable_for_assignment): Suppress finalization by setting new arg in call to gfc_deallocate_alloc_comp_no_caf. * trans-array.h : Add the new boolean argument to the prototype of gfc_deallocate_alloc_comp_no_caf with a default of false. * trans-expr.c (gfc_conv_procedure_call): Call finalizer for finalizable scalar function results. (gfc_trans_scalar_assign): Suppress finalization by setting new argument in call to gfc_deallocate_alloc_comp_no_caf. (gfc_assignment_finalizer_call): New function to provide finalization on intrinsic assignment. (trans_class_assignment, gfc_trans_assignment_1): Call it and add the block between the rhs evaluation and any reallocation on assignment that there might be. gcc/testsuite/ PR fortran/64290 * gfortran.dg/finalize_38.f90 : New test. * gfortran.dg/allocate_with_source_25.f90 : The number of final calls goes down from 6 to 4. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 2cb0c6572bd..18289eaffe8 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived) gfc_component *c; for (c = derived->components; c; c = c->next) - if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable) + if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable + && c->attr.flavor != FL_PROCEDURE) { if (c->ts.u.derived->f2k_derived && c->ts.u.derived->f2k_derived->finalizers) @@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, { /* Call FINAL_WRAPPER (comp); */ gfc_code *final_wrap; - gfc_symbol *vtab; + gfc_symbol *vtab, *byte_stride; + gfc_expr *scalar, *size_expr, *fini_coarray_expr; gfc_component *c; vtab = gfc_find_derived_vtab (comp->ts.u.derived); @@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, break; gcc_assert (c); + + /* Set scalar argument for storage_size. */ + gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride); + byte_stride->ts = e->ts; + byte_stride->attr.flavor = FL_VARIABLE; + byte_stride->attr.value = 1; + byte_stride->attr.artificial = 1; + gfc_set_sym_referenced (byte_stride); + gfc_commit_symbol (byte_stride); + scalar = gfc_lval_expr_from_sym (byte_stride); + final_wrap = gfc_get_code (EXEC_CALL); final_wrap->symtree = c->initializer->symtree; final_wrap->resolved_sym = c->initializer->symtree->n.sym; final_wrap->ext.actual = gfc_get_actual_arglist (); final_wrap->ext.actual->expr = e; + /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ + size_expr = gfc_get_expr (); + size_expr->where = gfc_current_locus; + size_expr->expr_type = EXPR_OP; + size_expr->value.op.op = INTRINSIC_DIVIDE; + + /* STORAGE_SIZE (array,kind=c_intptr_t). */ + size_expr->value.op.op1 + = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE, + "storage_size", gfc_current_locus, 2, + scalar, + gfc_get_int_expr (gfc_index_integer_kind, + NULL, 0)); + + /* NUMERIC_STORAGE_SIZE. */ + size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, + gfc_character_storage_size); + size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; + size_expr->ts = size_expr->value.op.op1->ts; + + /* Which provides the argument 'byte_stride'..... */ + final_wrap->ext.actual->next = gfc_get_actual_arglist (); + final_wrap->ext.actual->next->expr = size_expr; + + /* ...and last of all the 'fini_coarray' argument. */ + fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray); + final_wrap->ext.actual->next->next = gfc_get_actual_arglist (); + final_wrap->ext.actual->next->next->expr = fini_coarray_expr; + + + if (*code) { (*code)->next = final_wrap; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 43eeefee07f..e4b60a44a59 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10512,6 +10512,10 @@ resolve_where (gfc_code *code, gfc_expr *mask) if (e && !resolve_where_shape (cnext->expr1, e)) gfc_error ("WHERE assignment target at %L has " "inconsistent shape", &cnext->expr1->where); + + if (cnext->op == EXEC_ASSIGN) + cnext->expr1->must_finalize = 1; + break; @@ -10599,6 +10603,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, /* WHERE assignment statement */ case EXEC_ASSIGN: gfc_resolve_assign_in_forall (cnext, nvar, var_expr); + + if (cnext->op == EXEC_ASSIGN) + cnext->expr1->must_finalize = 1; + break; /* WHERE operator assignment statement */ @@ -10645,6 +10653,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) case EXEC_ASSIGN: case EXEC_POINTER_ASSIGN: gfc_resolve_assign_in_forall (c, nvar, var_expr); + + if (c->op == EXEC_ASSIGN) + c->expr1->must_finalize = 1; + break; case EXEC_ASSIGN_CALL: @@ -12069,6 +12081,9 @@ start: && code->expr1->ts.u.derived->attr.defined_assign_comp) generate_component_assignments (&code, ns); + if (code->op == EXEC_ASSIGN) + code->expr1->must_finalize = 1; + break; case EXEC_LABEL_ASSIGN: diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a77f3318846..e06b8ba4eb2 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr) if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) { gcc_assert (expr->ts.type == BT_CHARACTER); - + tmp = gfc_get_character_len_in_bytes (tmp); - + if (tmp == NULL_TREE || integer_zerop (tmp)) { tree bs; @@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr) tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, tmp, bs); } - + tmp = (tmp && !integer_zerop (tmp)) ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); } @@ -5657,7 +5657,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_se se; int n; - type = TREE_TYPE (descriptor); + if (expr->ts.type == BT_CLASS + && expr3_desc != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc))) + type = TREE_TYPE (expr3_desc); + else + type = TREE_TYPE (descriptor); stride = gfc_index_one_node; offset = gfc_index_zero_node; @@ -7478,7 +7483,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (!se->direct_byref) se->unlimited_polymorphic = UNLIMITED_POLY (expr); - + /* Special case things we know we can pass easily. */ switch (expr->expr_type) { @@ -8922,7 +8927,7 @@ static gfc_actual_arglist *pdt_param_list; static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, int rank, int purpose, int caf_mode, - gfc_co_subroutines_args *args) + gfc_co_subroutines_args *args, bool no_finalization) { gfc_component *c; gfc_loopinfo loop; @@ -9010,11 +9015,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_conv_array_data (dest)); dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP, caf_mode, args); + COPY_ALLOC_COMP, caf_mode, args, + no_finalization); } else tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, no_finalization); gfc_add_expr_to_block (&loopbody, tmp); @@ -9048,13 +9054,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) { tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, args); + DEALLOCATE_PDT_COMP, 0, args, + no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) { tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, 0, args); + NULLIFY_ALLOC_COMP, 0, args, + no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } @@ -9112,7 +9120,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, no_finalization); } else { @@ -9120,7 +9128,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, + no_finalization); } } @@ -9216,8 +9225,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } - if ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) + if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer) + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))) /* Call the finalizer, which will free the memory and nullify the pointer of an array. */ deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, @@ -9245,7 +9254,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, no_finalization); } else { @@ -9253,7 +9262,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, + no_finalization); } } @@ -9551,7 +9561,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode, args); + rank, purpose, caf_mode, args, + no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } break; @@ -9587,7 +9598,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose, caf_mode | GFC_STRUCTURE_CAF_MODE_IN_COARRAY, - args); + args, no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } } @@ -9695,7 +9706,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose, - caf_mode, args); + caf_mode, args, + no_finalization); } else add_when_allocated = NULL_TREE; @@ -10068,7 +10080,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, NULLIFY_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, + NULL, false); } @@ -10081,7 +10094,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, DEALLOCATE_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, + NULL, false); } tree @@ -10119,7 +10133,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, tmp = structure_alloc_comps (derived, array, NULL_TREE, rank, BCAST_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, + &args, false); return tmp; } @@ -10129,10 +10144,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, status of coarrays. */ tree -gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) +gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank, + bool no_finalization) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, 0, NULL); + DEALLOCATE_ALLOC_COMP, 0, NULL, + no_finalization); } @@ -10140,7 +10157,8 @@ tree gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) { return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, + NULL, false); } @@ -10152,7 +10170,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, int caf_mode) { return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, - caf_mode, NULL); + caf_mode, NULL, false); } @@ -10163,7 +10181,7 @@ tree gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) { return structure_alloc_comps (der_type, decl, dest, rank, - COPY_ONLY_ALLOC_COMP, 0, NULL); + COPY_ONLY_ALLOC_COMP, 0, NULL, false); } @@ -10178,7 +10196,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, gfc_actual_arglist *old_param_list = pdt_param_list; pdt_param_list = param_list; res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - ALLOCATE_PDT_COMP, 0, NULL); + ALLOCATE_PDT_COMP, 0, NULL, false); pdt_param_list = old_param_list; return res; } @@ -10190,7 +10208,7 @@ tree gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, NULL); + DEALLOCATE_PDT_COMP, 0, NULL, false); } @@ -10205,7 +10223,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, gfc_actual_arglist *old_param_list = pdt_param_list; pdt_param_list = param_list; res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - CHECK_PDT_DUMMY, 0, NULL); + CHECK_PDT_DUMMY, 0, NULL, false); pdt_param_list = old_param_list; return res; } @@ -10926,7 +10944,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, && expr1->ts.u.derived->attr.alloc_comp) { tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc, - expr1->rank); + expr1->rank, true); gfc_add_expr_to_block (&realloc_block, tmp); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 04fee617590..3aae4d2c4eb 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -56,7 +56,8 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0); tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0); tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree, tree, tree, tree); -tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int); +tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int, + bool no_finalization = false); tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree); tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2e15a7e874c..e666c41517b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -7675,9 +7675,58 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Allocatable scalar function results must be freed and nullified after use. This necessitates the creation of a temporary to hold the result to prevent duplicate calls. */ + bool allocatable = comp ? comp->attr.allocatable + && !comp->attr.dimension + : sym->attr.allocatable + && !sym->attr.dimension; + bool finalizable = comp ? comp->ts.type == BT_DERIVED + && gfc_is_finalizable (comp->ts.u.derived, NULL) + : sym->ts.type == BT_DERIVED + && gfc_is_finalizable (sym->ts.u.derived, NULL); + if (!byref && finalizable) + { + tree vptr, final_fndecl, desc; + gfc_symbol *vtab; + gfc_se post_se; + tmp = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify (&se->pre, tmp, se->expr); + se->expr = tmp; + tmp = gfc_evaluate_now (se->expr, &se->pre); + gfc_add_expr_to_block (&se->pre, + gfc_copy_alloc_comp (comp ? comp->ts.u.derived + : sym->ts.u.derived, + se->expr, tmp, 0, 0)); + vtab = comp ? gfc_find_derived_vtab (comp->ts.u.derived) + : gfc_find_derived_vtab (sym->ts.u.derived); + if (vtab->backend_decl == NULL_TREE) + vptr = gfc_get_symbol_decl (vtab); + else + vptr = vtab->backend_decl; + vptr = gfc_build_addr_expr (NULL, vptr); + + final_fndecl = gfc_vptr_final_get (vptr); + final_fndecl = build_fold_indirect_ref_loc (input_location, + final_fndecl); + gfc_init_se (&post_se, NULL); + desc = gfc_conv_scalar_to_descriptor (&post_se, tmp, + comp ? comp->attr + : sym->attr); + gfc_add_expr_to_block (&post, gfc_finish_block (&post_se.pre)); + desc = build_call_expr_loc (input_location, + final_fndecl, 3, + gfc_build_addr_expr (NULL, desc), + gfc_vptr_size_get (vptr), + boolean_false_node); + gfc_add_expr_to_block (&post, desc); + if (allocatable) + { + tmp = gfc_call_free (tmp); + gfc_add_expr_to_block (&post, tmp); + } + } + if (!byref && sym->ts.type != BT_CHARACTER - && ((sym->attr.allocatable && !sym->attr.dimension && !comp) - || (comp && comp->attr.allocatable && !comp->attr.dimension))) + && allocatable && !finalizable) { tmp = gfc_create_var (TREE_TYPE (se->expr), NULL); gfc_add_modify (&se->pre, tmp, se->expr); @@ -10430,7 +10479,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, if (dealloc) { tmp_var = gfc_evaluate_now (lse->expr, &lse->pre); - tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0); + tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, + 0, true); if (deep_copy) tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); @@ -11387,6 +11437,89 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) } + /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed + (10.2.1.3), if the variable is not an unallocated allocatable variable, + it is finalized after evaluation of expr and before the definition of + the variable. If the variable is an allocated allocatable variable, or + has an allocated allocatable subobject, that would be deallocated by + intrinsic assignment, the finalization occurs before the deallocation */ + +static tree +gfc_assignment_finalizer_call (gfc_expr *expr1, bool init_flag) +{ + stmtblock_t final_block; + gfc_init_block (&final_block); + symbol_attribute lhs_attr; + tree final_expr; + tree ptr; + tree cond; + gfc_se se; + + /* We have to exclude vtable procedures (_copy and _final especially), uses + of gfc_trans_assignment_1 in initialization and allocation before trying + to build a final call. */ + if (!expr1->must_finalize + || expr1->symtree->n.sym->attr.artificial + || expr1->symtree->n.sym->ns->proc_name->attr.artificial + || init_flag) + return NULL_TREE; + + if (!(expr1->ts.type == BT_CLASS + || (expr1->ts.type == BT_DERIVED + && gfc_is_finalizable (expr1->ts.u.derived, NULL))) + || !gfc_add_finalizer_call (&final_block, expr1)) + return NULL_TREE; + + lhs_attr = gfc_expr_attr (expr1); + + /* Check allocatable/pointer is allocated/associated. */ + if (lhs_attr.allocatable || lhs_attr.pointer) + { + if (expr1->ts.type == BT_CLASS) + { + ptr = gfc_get_class_from_gfc_expr (expr1); + gcc_assert (ptr != NULL_TREE); + ptr = gfc_class_data_get (ptr); + if (lhs_attr.dimension) + ptr = gfc_conv_descriptor_data_get (ptr); + } + else + { + gfc_init_se (&se, NULL); + if (expr1->rank) + { + gfc_conv_expr_descriptor (&se, expr1); + ptr = gfc_conv_descriptor_data_get (se.expr); + } + else + { + gfc_conv_expr (&se, expr1); + ptr = gfc_build_addr_expr (NULL_TREE, se.expr); + } + } + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + ptr, build_zero_cst (TREE_TYPE (ptr))); + final_expr = build3_loc (input_location, COND_EXPR, void_type_node, + cond, gfc_finish_block (&final_block), + build_empty_stmt (input_location)); + } + else + final_expr = gfc_finish_block (&final_block); + + /* Check optional present. */ + if (expr1->symtree->n.sym->attr.optional) + { + cond = gfc_conv_expr_present (expr1->symtree->n.sym); + final_expr = build3_loc (input_location, COND_EXPR, void_type_node, + cond, final_expr, + build_empty_stmt (input_location)); + } + + return final_expr; +} + + static tree trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_se *lse, gfc_se *rse, bool use_vptr_copy, @@ -11394,6 +11527,16 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, { tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr; vec *args = NULL; + tree final_expr; + + final_expr = gfc_assignment_finalizer_call (lhs, false); + if (final_expr != NULL_TREE) + { + if (rse->loop) + gfc_prepend_expr_to_block (&rse->loop->pre, final_expr); + else + gfc_add_expr_to_block (block, final_expr); + } /* Store the old vptr so that dynamic types can be compared for reallocation to occur or not. */ @@ -11519,6 +11662,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, } } + /* Subroutine of gfc_trans_assignment that actually scalarizes the assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. init_flag indicates initialization expressions and dealloc that no @@ -11542,6 +11686,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tree tmp; stmtblock_t block; stmtblock_t body; + tree final_expr; bool l_is_temp; bool scalar_to_array; tree string_length; @@ -11582,6 +11727,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, needed at two locations, so do it once only before the information is needed. */ lhs_attr = gfc_expr_attr (expr1); + is_poly_assign = (use_vptr_copy || lhs_attr.pointer || (lhs_attr.allocatable && !lhs_attr.dimension)) && (expr1->ts.type == BT_CLASS @@ -11855,6 +12001,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, else gfc_add_expr_to_block (&loop.post, tmp2); } + + expr1->must_finalize = 0; } else if (flag_coarray == GFC_FCOARRAY_LIB && lhs_caf_attr.codimension && rhs_caf_attr.codimension @@ -11909,8 +12057,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, !(l_is_temp || init_flag) && dealloc, expr1->symtree->n.sym->attr.codimension); - /* Add the pre blocks to the body. */ - gfc_add_block_to_block (&body, &rse.pre); + /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added + after evaluation of the rhs and before reallocation. */ + final_expr = gfc_assignment_finalizer_call (expr1, init_flag); + if (final_expr) + { + if (lss == gfc_ss_terminator) + { + gfc_add_block_to_block (&block, &rse.pre); + gfc_add_expr_to_block (&block, final_expr); + } + else + { + gfc_add_block_to_block (&body, &rse.pre); + gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr); + } + } + else + gfc_add_block_to_block (&body, &rse.pre); + + /* Add the lse pre block to the body */ gfc_add_block_to_block (&body, &lse.pre); gfc_add_expr_to_block (&body, tmp); /* Add the post blocks to the body. */ diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 index 92dc50756d4..de20a147842 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 @@ -68,4 +68,4 @@ contains end function func_foo_a end program simple_leak -! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } } +! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }