From patchwork Tue Nov 10 13:25:45 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1397647 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=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=pass (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: 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=qct39eIe; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (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 4CVpXf6BHyz9sPB for ; Wed, 11 Nov 2020 00:26:08 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 47A583861899; Tue, 10 Nov 2020 13:26:05 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 47A583861899 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1605014765; bh=ibYbneVvVyXpWoc1M1Mk1ggR0uAyeT9A66OPhYAWgjg=; h=References:In-Reply-To:Date:Subject:To:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To: From; b=qct39eIe2a12s1IGBhS59JVyIZzPIBEPGYKgfyXMrVSFuFC8aEI49s/jeobRKXXSU 3Qkc+rAsCQvsXXEb5BjH5qQReRIVNMoev8yW46qqmdZpKI9BcqufcWhzRQUS1jbxFi 8ykcLqJxMPMSqaGXwSZpnPzl0AvnIS5hU2HGZUMk= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x130.google.com (mail-lf1-x130.google.com [IPv6:2a00:1450:4864:20::130]) by sourceware.org (Postfix) with ESMTPS id 5934D386103F; Tue, 10 Nov 2020 13:25:59 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 5934D386103F Received: by mail-lf1-x130.google.com with SMTP id f11so11217017lfs.3; Tue, 10 Nov 2020 05:25:59 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:mime-version:references:in-reply-to:from:date :message-id:subject:to; bh=0P/WfdraKz+jIiRhOzVH+LU/17CfKLLsYs8wXlwNT6s=; b=Hf4Py+z1S9vYo34l87xmXyzltX9Con2YXYKfQ8OaZS8YKz17xEFPGKE9sldxGLC2SY zWTjIUh53TsIVVj24a4f1ZGZC2T6m1jo3j8J6OAPDvXOeIUmMv7n2HMX1LGdYBzbK9BM C8yPIbJitDvBVrtVkXD3VArz4iq33OtPoKk9pqOrge2M8Q9ZnzFSDraeRVtXuoo1Mk8U QB37p1YhVnrkxAfJrlxujWq9CWwI5KUyQiV1ocfIICiiOg+85JEDHl+Ttiaa1W2H4y0M H48amSw3wxDknpV8ww7PbIeDqoYAJeve6wnBi7mZxBg28dLITlOIt2zPujN/alyFvLrB 1PEg== X-Gm-Message-State: AOAM533/EZnOwu0enIyGu4NEzo2/kaENJfeJpNbRUXBZQ2+iLVhRdkSx rQaoKM4V+KIQBdrqKzbSsbHydJQt+9l9cux6aEs87IWmtlGciw== X-Google-Smtp-Source: ABdhPJyPmKnFn1fgipPjBEFN45Bk1clqrwbzHDFNsAA4A9v14mYdfakuNxfz7MskooIuVzz+lqQkqnixzTLflt1VEtU= X-Received: by 2002:ac2:4543:: with SMTP id j3mr3054814lfm.511.1605014757343; Tue, 10 Nov 2020 05:25:57 -0800 (PST) MIME-Version: 1.0 References: In-Reply-To: Date: Tue, 10 Nov 2020 13:25:45 +0000 Message-ID: Subject: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type To: "fortran@gcc.gnu.org" , gcc-patches , Thomas Koenig , Andre Vehreschild X-Spam-Status: No, score=-9.9 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, KAM_SHORT, RCVD_IN_DNSWL_NONE, 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-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@gcc.gnu.org Sender: "Gcc-patches" Hi Everyone, I am afraid that this is a rather long sad story, mainly due to my efforts with gfortran being interrupted by daytime work. I posted the first version of the patch nearly a year ago but this was derailed by Tobias's question at: https://gcc.gnu.org/legacy-ml/fortran/2019-11/msg00098.html My recent attempt to post this patch were disrupted by the patch itself disappearing from the posting. Thanks to Andre and Thomas for pointing this out. Since then, I have been working on downstream PRs and this has led to a reworking of the unposted version. (i) The attached fixes the original problem and is tested by gfortran.dg/unlimited_polymorphic_32.f03. (ii) In fixing the original problem, a fair amount of effort was required to get the element length correct for class temporaries produced by dependencies in class assignment. This is reflected in the changes to trans_array.c(gfc_alloc_allocatable_for_assignment) and the new function get_class_info_from_ss. (iii) Tobias's testcase in the above posting to the list didn't address itself to class arrays of the original problem. However, it revealed that reallocation was not occuring at all for scalar assignments. This is fixed by the large chunk in trans-expr.c(trans_class_assignment). The array case is 'fixed' by testing for unequal element sizes between lhs and rhs before reallocation in gfc_alloc_allocatable_for_assignment. This is difficult to test for since, in most cases, the system returns that same address after reallocation. (iv) dependency_57.f90 segfaulted at runtime. The other work in trans_class_assignment was required to fix this. (v) A number of minor tidy ups were done including the new function gfc_resize_class_size_with_len to eliminate some repeated code. Note: Chunks of code are coming within scalarization loops that should be outside: x->_vptr = (struct __vtype__STAR * {ref-all}) &__vtab_INTEGER_4_; x->_len = 0; D.3977 = x->_vptr->_size; D.3978 = x->_len; D.3979 = D.3978 > 0 ? D.3977 * D.3978 : D.3977; also in many cases of class assignment, the lhs vptr is being set more than once outside the loop when temporaries are involved. I will try to iron out these issues later on. This all bootstraps and regtests on FC31/x86_64 - OK for master? Cheers Paul As well as the PR this patch fixes problems in handling class objects; most importantly class array temporaries, required when dependences occur in class assignment, and a correct implementation of reallocation on assignment. 2020-11-10 Paul Thomas gcc/fortran PR fortran/83118 * resolve.c (resolve_ordinary_assign): Generate a vtable if necessary for scalar non-polymorphic rhs's to unlimited lhs's. * trans-array.c (get_class_info_from_ss): New function. (gfc_trans_allocate_array_storage): Defer obtaining class element type until all sources of class exprs are tried. Use class API rather than TREE_OPERAND. Look for class expressions in ss->info by calling get_class_info_from_ss. After obtain the element size for class descriptors. Where the element type is unknown, cast the data as character(len=size) to overcome unlimited polymorphic problems. (structure_alloc_comps): Replace code that replicates the new function gfc_resize_class_size_with_len. (gfc_alloc_allocatable_for_assignment): Obtain element size for lhs in cases of deferred characters and class enitities. Move code for the element size of rhs to start of block. Clean up extraction of class parameters throughout this function. After the shape check test whether or not the lhs and rhs element sizes are the same. Use earlier evaluation of 'cond_null'. Reallocation of lhs only to happen if size changes or element size changes. * trans-expr.c (gfc_resize_class_size_with_len): New function. (gfc_conv_procedure_call): Ensure the vtable is present for passing a non-class actual to an unlimited formal. (trans_class_vptr_len_assignment): For expressions of type BT_CLASS, extract the class expression if necessary. Use a statement block outside the loop body. Ensure that 'rhs' is of the correct type. Obtain rhs vptr in all circumstances. (gfc_trans_assignment_1): Simplify some of the logic with 'realloc_flag'. Set 'vptr_copy' for all array assignments to unlimited polymorphic lhs. * trans-c (gfc_build_array_ref): Call gfc_resize_class_size_ with_len to correct span for unlimited polymorphic decls. * trans.h : Add prototype for gfc_resize_class_size_with_len. gcc/testsuite/ PR fortran/83118 * gfortran.dg/dependency_57.f90: Change to dg-run and test for correct result. * gfortran.dg/unlimited_polymorphic_32.f03: New test. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1641eb6ca10..daa947af9d1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11054,7 +11054,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) /* Make sure there is a vtable and, in particular, a _copy for the rhs type. */ - if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS) + if (UNLIMITED_POLY (lhs) && rhs->ts.type != BT_CLASS) gfc_find_vtab (&rhs->ts); bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b2c39aa32de..0abebfdc937 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1030,7 +1030,6 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); tmp = TREE_TYPE (tmp); /* The descriptor itself. */ tmp = gfc_get_element_type (tmp); - gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc))); packed = gfc_create_var (build_pointer_type (tmp), "data"); tmp = build_call_expr_loc (input_location, @@ -1139,6 +1138,112 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) } +/* Use the information in the ss to obtain the required information about + the type and size of an array temporary, when the lhs in an assignment + is a class expression. */ + +static tree +get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) +{ + gfc_ss *lhs_ss; + gfc_ss *rhs_ss; + tree tmp; + tree tmp2; + tree vptr; + tree rhs_class_expr = NULL_TREE; + tree lhs_class_expr = NULL_TREE; + bool unlimited_rhs = false; + bool unlimited_lhs = false; + gfc_symbol *vtab; + + /* The second element in the loop chain contains the source for the + temporary; ie. the rhs of the assignment. */ + rhs_ss = ss->loop->ss->loop_chain; + if (rhs_ss != gfc_ss_terminator + && rhs_ss->info + && rhs_ss->info->expr + && rhs_ss->info->expr->ts.type == BT_CLASS + && rhs_ss->info->data.array.descriptor) + { + rhs_class_expr + = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); + unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); + } + + /* For an assignment the lhs is the next element in the loop chain. + If we have a class rhs, this had better be a class variable + expression! */ + lhs_ss = rhs_ss->loop_chain; + if (lhs_ss->info + && lhs_ss->info->expr + && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE + && lhs_ss->info->expr->ts.type == BT_CLASS) + { + tmp = lhs_ss->info->data.array.descriptor; + unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); + } + else + tmp = NULL_TREE; + + /* Get the lhs class expression. */ + if (tmp != NULL_TREE) + lhs_class_expr = gfc_get_class_from_expr (tmp); + else + return NULL_TREE; + + gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); + + /* Set the lhs vptr and, if necessary, the _len field. */ + if (rhs_class_expr) + { + /* Both lhs and rhs are class expressions. */ + tmp = gfc_class_vptr_get (lhs_class_expr); + gfc_add_modify (pre, tmp, + fold_convert (TREE_TYPE (tmp), + gfc_class_vptr_get (rhs_class_expr))); + if (unlimited_lhs) + { + tmp = gfc_class_len_get (lhs_class_expr); + if (unlimited_rhs) + tmp2 = gfc_class_len_get (rhs_class_expr); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + gfc_add_modify (pre, tmp, tmp2); + } + } + else + { + /* lhs is class and rhs is intrinsic or derived type. */ + *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); + *eltype = gfc_get_element_type (*eltype); + vtab = gfc_find_vtab (&rhs_ss->info->expr->ts); + vptr = vtab->backend_decl; + if (vptr == NULL_TREE) + vptr = gfc_get_symbol_decl (vtab); + vptr = gfc_build_addr_expr (NULL_TREE, vptr); + tmp = gfc_class_vptr_get (lhs_class_expr); + gfc_add_modify (pre, tmp, + fold_convert (TREE_TYPE (tmp), vptr)); + + if (unlimited_lhs) + { + tmp = gfc_class_len_get (lhs_class_expr); + if (rhs_ss->info + && rhs_ss->info->expr + && rhs_ss->info->expr->ts.type == BT_CHARACTER) + tmp2 = build_int_cst (TREE_TYPE (tmp), + rhs_ss->info->expr->ts.kind); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + gfc_add_modify (pre, tmp, tmp2); + } + } + + return rhs_class_expr; +} + + + /* Generate code to create and initialize the descriptor for a temporary array. This is used for both temporaries needed by the scalarizer, and functions returning arrays. Adjusts the loop variables to be @@ -1184,13 +1289,44 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, { gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); class_expr = build_fold_indirect_ref_loc (input_location, initial); - eltype = TREE_TYPE (class_expr); - eltype = gfc_get_element_type (eltype); /* Obtain the structure (class) expression. */ - class_expr = TREE_OPERAND (class_expr, 0); + class_expr = gfc_get_class_from_expr (class_expr); gcc_assert (class_expr); } + /* Otherwise, some expressions, such as class functions, arising from + dependency checking in assignments come here with class element type. + The descriptor can be obtained from the ss->info and then converted + to the class object. */ + if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) + { + class_expr = get_class_info_from_ss (pre, ss, &eltype); + gcc_assert ((class_expr != NULL_TREE) + || !GFC_CLASS_TYPE_P (eltype)); + } + + if (class_expr == NULL_TREE) + elemsize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (eltype)); + else + { + /* Unlimited polymorphic entities are initialised with NULL vptr. They + can be tested for by checking if the len field is present. If so + test the vptr before using the vtable size. */ + tmp = gfc_class_vptr_get (class_expr); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + elemsize = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, + tmp, + gfc_class_vtab_size_get (class_expr), + gfc_index_zero_node); + elemsize = gfc_evaluate_now (elemsize, pre); + elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize); + eltype = gfc_get_character_type_len (1, elemsize); + } + memset (from, 0, sizeof (from)); memset (to, 0, sizeof (to)); @@ -1339,12 +1475,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, } } - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - else - elemsize = gfc_class_vtab_size_get (class_expr); - /* Get the size of the array. */ if (size && !callee_alloc) { @@ -3373,18 +3503,10 @@ build_class_array_ref (gfc_se *se, tree base, tree index) size = gfc_class_vtab_size_get (decl); /* For unlimited polymorphic entities then _len component needs to be - multiplied with the size. If no _len component is present, then - gfc_class_len_or_zero_get () return a zero_node. */ - tmp = gfc_class_len_or_zero_get (decl); - if (!integer_zerop (tmp)) - size = fold_build2 (MULT_EXPR, TREE_TYPE (index), - fold_convert (TREE_TYPE (index), size), - fold_build2 (MAX_EXPR, TREE_TYPE (index), - fold_convert (TREE_TYPE (index), tmp), - fold_convert (TREE_TYPE (index), - integer_one_node))); - else - size = fold_convert (TREE_TYPE (index), size); + multiplied with the size. */ + size = gfc_resize_class_size_with_len (&se->pre, decl, size); + + size = fold_convert (TREE_TYPE (index), size); /* Build the address of the element. */ type = TREE_TYPE (TREE_TYPE (base)); @@ -9233,21 +9355,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, for the malloc call. */ if (UNLIMITED_POLY (c)) { - tree ctmp; gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp), gfc_class_len_get (comp)); - - size = gfc_evaluate_now (size, &tmpblock); - tmp = gfc_class_len_get (comp); - ctmp = fold_build2_loc (input_location, MULT_EXPR, - size_type_node, size, - fold_convert (size_type_node, tmp)); - tmp = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp, - build_zero_cst (TREE_TYPE (tmp))); - size = fold_build3_loc (input_location, COND_EXPR, - size_type_node, tmp, ctmp, size); - size = gfc_evaluate_now (size, &tmpblock); + size = gfc_resize_class_size_with_len (&tmpblock, comp, size); } /* Coarray component have to have the same allocation status and @@ -10033,6 +10143,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tree alloc_expr; tree size1; tree size2; + tree elemsize1; + tree elemsize2; tree array1; tree cond_null; tree cond; @@ -10112,6 +10224,108 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); array1 = gfc_conv_descriptor_data_get (desc); + if (expr2) + desc2 = rss->info->data.array.descriptor; + else + desc2 = NULL_TREE; + + /* Get the old lhs element size for deferred character and class expr1. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr1->ts.u.cl->backend_decl + && VAR_P (expr1->ts.u.cl->backend_decl)) + elemsize1 = expr1->ts.u.cl->backend_decl; + else + elemsize1 = lss->info->string_length; + } + else if (expr1->ts.type == BT_CLASS) + { + tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE; + if (tmp != NULL_TREE) + { + tmp2 = gfc_class_vptr_get (tmp); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp2, + build_int_cst (TREE_TYPE (tmp2), 0)); + elemsize1 = gfc_class_vtab_size_get (tmp); + elemsize1 = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + elemsize1, gfc_index_zero_node); + } + else + elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts)); + } + else + elemsize1 = NULL_TREE; + if (elemsize1 != NULL_TREE) + elemsize1 = gfc_evaluate_now (elemsize1, &fblock); + + /* Get the new lhs size in bytes. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr2->ts.deferred) + { + if (expr2->ts.u.cl->backend_decl + && VAR_P (expr2->ts.u.cl->backend_decl)) + tmp = expr2->ts.u.cl->backend_decl; + else + tmp = rss->info->string_length; + } + else + { + tmp = expr2->ts.u.cl->backend_decl; + if (!tmp && expr2->expr_type == EXPR_OP + && expr2->value.op.op == INTRINSIC_CONCAT) + { + tmp = concat_str_length (expr2); + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + else if (!tmp && expr2->ts.u.cl->length) + { + gfc_se tmpse; + gfc_init_se (&tmpse, NULL); + gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, + gfc_charlen_type_node); + tmp = tmpse.expr; + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); + } + + if (expr1->ts.u.cl->backend_decl + && VAR_P (expr1->ts.u.cl->backend_decl)) + gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); + else + gfc_add_modify (&fblock, lss->info->string_length, tmp); + + if (expr1->ts.kind > 1) + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + expr1->ts.kind)); + } + else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) + { + tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + expr1->ts.u.cl->backend_decl); + } + else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS) + { + tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE; + if (tmp != NULL_TREE) + tmp = gfc_class_vtab_size_get (tmp); + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts)); + } + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + elemsize2 = fold_convert (gfc_array_index_type, tmp); + elemsize2 = gfc_evaluate_now (elemsize2, &fblock); + /* 7.4.1.3 "If variable is an allocated allocatable variable, it is deallocated if expr is an array of different shape or any of the corresponding length type parameter values of variable and expr @@ -10131,6 +10345,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, rss->info->string_length); cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, tmp, cond_null); + cond_null= gfc_evaluate_now (cond_null, &fblock); } else cond_null= gfc_evaluate_now (cond_null, &fblock); @@ -10179,6 +10394,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_expr_to_block (&fblock, tmp); } + /* ...else if the element lengths are not the same also go to + setting the bounds and doing the reallocation.... */ + if (elemsize1 != NULL_TREE) + { + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + elemsize1, elemsize2); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + } + /* ....else jump past the (re)alloc code. */ tmp = build1_v (GOTO_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); @@ -10201,11 +10429,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_expr_to_block (&fblock, tmp); /* Get the rhs size and fix it. */ - if (expr2) - desc2 = rss->info->data.array.descriptor; - else - desc2 = NULL_TREE; - size2 = gfc_index_one_node; for (n = 0; n < expr2->rank; n++) { @@ -10320,69 +10543,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, linfo->delta[dim], tmp); } - /* Get the new lhs size in bytes. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr2->ts.deferred) - { - if (expr2->ts.u.cl->backend_decl - && VAR_P (expr2->ts.u.cl->backend_decl)) - tmp = expr2->ts.u.cl->backend_decl; - else - tmp = rss->info->string_length; - } - else - { - tmp = expr2->ts.u.cl->backend_decl; - if (!tmp && expr2->expr_type == EXPR_OP - && expr2->value.op.op == INTRINSIC_CONCAT) - { - tmp = concat_str_length (expr2); - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - else if (!tmp && expr2->ts.u.cl->length) - { - gfc_se tmpse; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, - gfc_charlen_type_node); - tmp = tmpse.expr; - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - } - - if (expr1->ts.u.cl->backend_decl - && VAR_P (expr1->ts.u.cl->backend_decl)) - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); - else - gfc_add_modify (&fblock, lss->info->string_length, tmp); - - if (expr1->ts.kind > 1) - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), - tmp, build_int_cst (TREE_TYPE (tmp), - expr1->ts.kind)); - } - else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) - { - tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - expr1->ts.u.cl->backend_decl); - } - else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); - tmp = fold_convert (gfc_array_index_type, tmp); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - gfc_conv_descriptor_span_set (&fblock, desc, tmp); + gfc_conv_descriptor_span_set (&fblock, desc, elemsize2); size2 = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - tmp, size2); + elemsize2, size2); size2 = fold_convert (size_type_node, size2); size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size2, size_one_node); @@ -10403,7 +10569,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, tmp, gfc_get_dtype_rank_type (expr1->rank,type)); } - else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + else if (expr1->ts.type == BT_CLASS) { tree type; tmp = gfc_conv_descriptor_dtype (desc); @@ -10411,19 +10577,32 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, tmp, gfc_get_dtype_rank_type (expr2->rank,type)); /* Set the _len field as well... */ - tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); - if (expr2->ts.type == BT_CHARACTER) - gfc_add_modify (&fblock, tmp, - fold_convert (TREE_TYPE (tmp), - TYPE_SIZE_UNIT (type))); - else - gfc_add_modify (&fblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); + if (UNLIMITED_POLY (expr1)) + { + tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); + if (expr2->ts.type == BT_CHARACTER) + gfc_add_modify (&fblock, tmp, + fold_convert (TREE_TYPE (tmp), + TYPE_SIZE_UNIT (type))); + else + gfc_add_modify (&fblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + } /* ...and the vptr. */ tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0)); - tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); - tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); - gfc_add_modify (&fblock, tmp, tmp2); + if (expr2->ts.type == BT_CLASS && !VAR_P (desc2) + && TREE_CODE (desc2) == COMPONENT_REF) + { + tmp2 = gfc_get_class_from_expr (desc2); + tmp2 = gfc_class_vptr_get (tmp2); + } + else + { + tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); + tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); + } + + gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); } else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) { @@ -10499,11 +10678,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_block_to_block (&realloc_block, &caf_se.post); realloc_expr = gfc_finish_block (&realloc_block); - /* Only reallocate if sizes are different. */ + /* Reallocate if sizes or dynamic types are different. */ + if (elemsize1) + { + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + elemsize1, elemsize2); + tmp = gfc_evaluate_now (tmp, &fblock); + neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, neq_size, tmp); + } tmp = build3_v (COND_EXPR, neq_size, realloc_expr, build_empty_stmt (input_location)); - realloc_expr = tmp; + realloc_expr = tmp; /* Malloc expression. */ gfc_init_block (&alloc_block); @@ -10550,11 +10737,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, alloc_expr = gfc_finish_block (&alloc_block); /* Malloc if not allocated; realloc otherwise. */ - tmp = build_int_cst (TREE_TYPE (array1), 0); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, - array1, tmp); - tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr); + tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); gfc_add_expr_to_block (&fblock, tmp); /* Make sure that the scalarizer data pointer is updated. */ @@ -10564,7 +10747,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, linfo->data, tmp); } - /* Add the exit label. */ + /* Add the label for same shape lhs and rhs. */ tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2167de455b8..0489e397cea 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -257,6 +257,42 @@ gfc_class_len_or_zero_get (tree decl) } +tree +gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size) +{ + tree tmp; + tree tmp2; + tree type; + + tmp = gfc_class_len_or_zero_get (class_expr); + + /* Include the len value in the element size if present. */ + if (!integer_zerop (tmp)) + { + type = TREE_TYPE (size); + if (block) + { + size = gfc_evaluate_now (size, block); + tmp = gfc_evaluate_now (fold_convert (type , tmp), block); + } + tmp2 = fold_build2_loc (input_location, MULT_EXPR, + type, size, tmp); + tmp = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, tmp, + build_zero_cst (type)); + size = fold_build3_loc (input_location, COND_EXPR, + type, tmp, tmp2, size); + } + else + return size; + + if (block) + size = gfc_evaluate_now (size, block); + + return size; +} + + /* Get the specified FIELD from the VPTR. */ static tree @@ -5613,8 +5649,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { /* The intrinsic type needs to be converted to a temporary CLASS object for the unlimited polymorphic formal. */ + gfc_find_vtab (&e->ts); gfc_init_se (&parmse, se); gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts); + } else if (se->ss && se->ss->info->useflags) { @@ -8926,14 +8964,32 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr; bool set_vptr = false, temp_rhs = false; stmtblock_t *pre = block; + tree class_expr = NULL_TREE; /* Create a temporary for complicated expressions. */ if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL && rse->expr != NULL_TREE && !DECL_P (rse->expr)) { - tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); - pre = &rse->pre; - gfc_add_modify (&rse->pre, tmp, rse->expr); + if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) + class_expr = gfc_get_class_from_expr (rse->expr); + + if (rse->loop) + pre = &rse->loop->pre; + else + pre = &rse->pre; + + if (class_expr != NULL_TREE && UNLIMITED_POLY (re)) + { + tmp = TREE_OPERAND (rse->expr, 0); + tmp = gfc_create_var (TREE_TYPE (tmp), "rhs"); + gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0)); + } + else + { + tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); + gfc_add_modify (&rse->pre, tmp, rse->expr); + } + rse->expr = tmp; temp_rhs = true; } @@ -9001,9 +9057,17 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, else if (temp_rhs && re->ts.type == BT_CLASS) { vptr_expr = NULL; - se.expr = gfc_class_vptr_get (rse->expr); + if (class_expr) + tmp = class_expr; + else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) + tmp = gfc_get_class_from_expr (rse->expr); + else + tmp = rse->expr; + + se.expr = gfc_class_vptr_get (tmp); if (UNLIMITED_POLY (re)) - from_len = gfc_class_len_get (rse->expr); + from_len = gfc_class_len_get (tmp); + } else if (re->expr_type != EXPR_NULL) /* Only when rhs is non-NULL use its declared type for vptr @@ -9810,8 +9874,12 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) return true; /* Functions returning pointers or allocatables need temporaries. */ - if (gfc_expr_attr (expr2).pointer - || gfc_expr_attr (expr2).allocatable) + c = expr2->value.function.esym + ? (expr2->value.function.esym->attr.pointer + || expr2->value.function.esym->attr.allocatable) + : (expr2->symtree->n.sym->attr.pointer + || expr2->symtree->n.sym->attr.allocatable); + if (c) return true; /* Character array functions need temporaries unless the @@ -10666,23 +10734,53 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_se *lse, gfc_se *rse, bool use_vptr_copy, bool class_realloc) { - tree tmp, fcn, stdcopy, to_len, from_len, vptr; + tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr; vec *args = NULL; + /* Store the old vptr so that dynamic types can be compared for + reallocation to occur or not. */ + if (class_realloc) + { + tmp = lse->expr; + if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_get_class_from_expr (tmp); + } + vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, &from_len); - /* Generate allocation of the lhs. */ + /* Generate (re)allocation of the lhs. */ if (class_realloc) { - stmtblock_t alloc; - tree class_han; + stmtblock_t alloc, re_alloc; + tree class_han, re, size; - tmp = gfc_vptr_size_get (vptr); + if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block); + else + old_vptr = build_int_cst (TREE_TYPE (vptr), 0); + + size = gfc_vptr_size_get (vptr); class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) ? gfc_class_data_get (lse->expr) : lse->expr; + + /* Allocate block. */ gfc_init_block (&alloc); - gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE); + gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE); + + /* Reallocate if dynamic types are different. */ + gfc_init_block (&re_alloc); + re = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_REALLOC), 2, + fold_convert (pvoid_type_node, class_han), + size); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, vptr, old_vptr); + re = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, re, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&re_alloc, re); + + /* Allocate if _data is NULL, reallocate otherwise. */ tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, class_han, build_int_cst (prvoid_type_node, 0)); @@ -10690,7 +10788,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_unlikely (tmp, PRED_FORTRAN_FAIL_ALLOC), gfc_finish_block (&alloc), - build_empty_stmt (input_location)); + gfc_finish_block (&re_alloc)); gfc_add_expr_to_block (&lse->pre, tmp); } @@ -10793,6 +10891,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false; symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; bool is_poly_assign; + bool realloc_flag; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -10833,6 +10932,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || gfc_is_class_array_ref (expr2, NULL) || gfc_is_class_scalar_expr (expr2)); + realloc_flag = flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2); /* Only analyze the expressions for coarray properties, when in coarray-lib mode. */ @@ -11077,8 +11180,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (is_poly_assign) tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, use_vptr_copy || (lhs_attr.allocatable - && !lhs_attr.dimension), - flag_realloc_lhs && !lhs_attr.pointer); + && !lhs_attr.dimension), + !realloc_flag && flag_realloc_lhs + && !lhs_attr.pointer); else if (flag_coarray == GFC_FCOARRAY_LIB && lhs_caf_attr.codimension && rhs_caf_attr.codimension && ((lhs_caf_attr.allocatable && lhs_refs_comp) @@ -11183,10 +11287,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* F2003: Allocate or reallocate lhs of allocatable array. */ - if (flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2)) + if (realloc_flag) { realloc_lhs_warning (expr1->ts.type, true, &expr1->where); ompws_flags &= ~OMPWS_SCALARIZER_WS; @@ -11295,8 +11396,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, return tmp; } - if (UNLIMITED_POLY (expr1) && expr1->rank - && expr2->ts.type != BT_CLASS) + if (UNLIMITED_POLY (expr1) && expr1->rank) use_vptr_copy = true; /* Fallback to the scalarizer to generate explicit loops. */ diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 025abe38985..a1239ec2b53 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -435,21 +435,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) /* Check if this is an unlimited polymorphic object carrying a character payload. In this case, the 'len' field is non-zero. */ if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - { - tmp = gfc_class_len_or_zero_get (decl); - if (!integer_zerop (tmp)) - { - tree cond; - tree stype = TREE_TYPE (span); - tmp = fold_convert (stype, tmp); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, tmp, - build_int_cst (stype, 0)); - tmp = fold_build2 (MULT_EXPR, stype, span, tmp); - span = fold_build3_loc (input_location, COND_EXPR, stype, - cond, span, tmp); - } - } + span = gfc_resize_class_size_with_len (NULL, decl, span); } else if (decl) span = get_array_span (type, decl); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 16b4215605e..437a570c484 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -423,6 +423,7 @@ tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); tree gfc_class_len_or_zero_get (tree); +tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree); gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ diff --git a/gcc/testsuite/gfortran.dg/dependency_57.f90 b/gcc/testsuite/gfortran.dg/dependency_57.f90 index fdf95b24c63..e8aab334b62 100644 --- a/gcc/testsuite/gfortran.dg/dependency_57.f90 +++ b/gcc/testsuite/gfortran.dg/dependency_57.f90 @@ -1,12 +1,18 @@ -! { dg-do compile } +! { dg-do run } ! PR 92755 - this used to cause an ICE. ! Original test case by Gerhard Steinmetz program p type t + integer :: i end type type t2 class(t), allocatable :: a(:) end type type(t2) :: z + z%a = [t(1),t(2),t(3)] z%a = [z%a] + select type (y => z%a) + type is (t) + if (any (y%i .ne. [1, 2, 3])) stop 1 + end select end