From patchwork Fri Dec 23 10:28:13 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 708407 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3tlPkM5nRdz9snk for ; Fri, 23 Dec 2016 21:28:42 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="uFLTZvQG"; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=x1agIuvN1wgslERW Z2fjm17oGGkCjvKGDgIpltjvUUcFBINcpiCUkZIeZsRebDMilMhVWjz1E9CiRdVL 2lSn0lSVjF/yf+s0UPxl/hIiz8TaQ3hb2KwcrK25MU7K1tAHXN2KjQz/3xZLquOX FqmT2LPQc79/xrcbOQM524HPGuc= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=yAQvI84lxTscF+3oY5n1S9 C92eI=; b=uFLTZvQGoiICNdViH0iiMnzKwno+UzE9Wqz7S7BdwlPAuiz5p49yW7 I4et5EBeOrYWc8leuwn7AKqwdnXXBwX/vpezz0AkM8n1+ofB9YEg/Y1dk1cvbCaF 18WgppXtntVfAstf0YTXqKnTKWd0VQvnBrKNqfnc9Wn8ENORZ2uC4= Received: (qmail 31320 invoked by alias); 23 Dec 2016 10:28:32 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 31288 invoked by uid 89); 23 Dec 2016 10:28:31 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.6 required=5.0 tests=AWL, BAYES_50, FREEMAIL_FROM, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=no version=3.3.2 spammy=(unknown), polymorphic, explanations, Results X-Spam-User: qpsmtpd, 3 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 23 Dec 2016 10:28:21 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx003 [212.227.17.190]) with ESMTPSA (Nemesis) id 0LaFmY-1czR7T3cTe-00m37P; Fri, 23 Dec 2016 11:28:14 +0100 Date: Fri, 23 Dec 2016 11:28:13 +0100 From: Andre Vehreschild To: Janus Weil Cc: GCC-Patches-ML , GCC-Fortran-ML , Damian Rouson Subject: Re: [PATCH, Fortran, alloc_poly, v2] Fix allocation of memory for polymorphic assignment Message-ID: <20161223112813.19b1b0f1@vepi2> In-Reply-To: References: <20161219124343.3c3baf4c@vepi2> <20161220170750.6ef0d9d8@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:iU2dQV50sGU=:lX1uezpm44fG6ff9L5+yt6 WAoPU94HzNkgLWytSsyiN7W2G9qnDiRFe7jnf6lTLC1w8Gzf207diEuqF++Rll6Jdby6wXBY6 VZEXqc+UDvR6f68hw3Czr+K9hIVq7p1jH9c080J1vQOqMoWuBQfn1FhGo424CscNRrKGVAaN4 6BS7aEjPMuqg2ylQSG8Lmei+FoiU1weLBSNbciUQ018Xj/fP/vzVc98loFB6AIyl2SZFCWfiP gRHgcXdbx4T4k/Ty3MyHhqarNo1Bog5vvHS0qDxgw8pnM3vPdkOR2hro43JyGOLh8t1rx7r1F 8uUZsbFy7H0maK7VZNsSlwdMMSeolq06XIgXMa/vIRnCnE+ZSHONtSLFck6LSfjNqna3b1bwo gAcLWYuZB77T9brDc5WexXzxDd+vnOo1QJpmHmJzPW+HGIjj4Y71uiAENeNvfkpvS/WrsRf03 dXQ2fqDa6h8fV2LDZwpLOdaATBOAdtKwk3p41KRGswnnBr+E6WqBkXa9JjBaJ4/VTI9sY+LXG UnTZiSUQMtx1MOAGwTh5jL1kg6iWWDZEPcY2cUQhP+DZ2vPY2O6BwTFlq83Dq1G4VgDqHfkuP qQh8raTS4vJqMHgFdHEHCTYP3z+z2vEhqWA15/iDWdzb9qm1+S9Hm4vdvxTrB5rRqmGaF7sYA nFB5JYAhcTkXgq505xZ6Jf0eQzN3X9P6TS1BePKk2yqkxzzGGF22PElpYJ6b8aK7pHfItpHMv R66y4Jfy5WlV6LWLA+YOlooO6B9z0yL+CssklWXLp84YOF/MGAwnGaOzTXo= Hi Janus, hi all, thanks for the review. Committed as r243909. Regards, Andre On Thu, 22 Dec 2016 23:26:19 +0100 Janus Weil wrote: > 2016-12-20 17:07 GMT+01:00 Andre Vehreschild : > > Hi Janus, > > > >> 1) After adding that code block in gfc_trans_assignment_1, it seems > >> like the comment above is outdated, right? > > > > Thanks for noting. > > > >> 2) Wouldn't it be better to move this block, which does the correct > >> allocation for CLASS variables, into > >> "alloc_scalar_allocatable_for_assignment", where the allocation for > >> all other cases is done? > > > > I tried to, but that would have meant to extend the interface of > > alloc_scalar_allocatable_for_assignment significantly, while at the location > > where I finally added the code, I could use the data available. Secondly > > putting the malloc at the correct location is not possible at > > alloc_scalar_... because the pre-blocks have already been joined to the > > body. That way the malloc was always placed either before even the vptr was > > set, or after the data was copied. Both options were quite hazardous. > > > > I now went to add the allocation into trans_class_assignment (). This allows > > even more reuse of already present and needed data, e.g., the vptr. > > > > Bootstrapped and regtested ok on x86_64-linux/f23. Ok for trunk? > > Thanks for the explanations. The patch is ok with me in this form. > > Cheers, > Janus Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 243908) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -9625,18 +9625,39 @@ static tree trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, - gfc_se *lse, gfc_se *rse, bool use_vptr_copy) + gfc_se *lse, gfc_se *rse, bool use_vptr_copy, + bool class_realloc) { - tree tmp; - tree fcn; - tree stdcopy, to_len, from_len; + tree tmp, fcn, stdcopy, to_len, from_len, vptr; vec *args = NULL; - tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, + vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, &from_len); - fcn = gfc_vptr_copy_get (tmp); + /* Generate allocation of the lhs. */ + if (class_realloc) + { + stmtblock_t alloc; + tree class_han; + tmp = gfc_vptr_size_get (vptr); + class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + gfc_init_block (&alloc); + gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE); + tmp = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, class_han, + build_int_cst (prvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (tmp, + PRED_FORTRAN_FAIL_ALLOC), + gfc_finish_block (&alloc), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&lse->pre, tmp); + } + + fcn = gfc_vptr_copy_get (vptr); + tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) ? gfc_class_data_get (rse->expr) : rse->expr; if (use_vptr_copy) @@ -9961,15 +9982,10 @@ } if (is_poly_assign) - { - tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, - use_vptr_copy || (lhs_attr.allocatable - && !lhs_attr.dimension)); - /* Modify the expr1 after the assignment, to allow the realloc below. - Therefore only needed, when realloc_lhs is enabled. */ - if (flag_realloc_lhs && !lhs_attr.pointer) - gfc_add_data_component (expr1); - } + tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, + use_vptr_copy || (lhs_attr.allocatable + && !lhs_attr.dimension), + 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) @@ -10011,7 +10027,8 @@ if (lss == gfc_ss_terminator) { /* F2003: Add the code for reallocation on assignment. */ - if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)) + if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1) + && !is_poly_assign) alloc_scalar_allocatable_for_assignment (&block, string_length, expr1, expr2); Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 243908) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,10 @@ +2016-12-23 Andre Vehreschild + + * trans-expr.c (trans_class_assignment): Allocate memory of _vptr->size + before assigning an allocatable class object. + (gfc_trans_assignment_1): Flag that (re-)alloc of the class object + shall be done. + 2016-12-21 Jakub Jelinek PR fortran/78866 Index: gcc/testsuite/gfortran.dg/class_assign_1.f08 =================================================================== --- gcc/testsuite/gfortran.dg/class_assign_1.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/class_assign_1.f08 (Revision 243909) @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Check that reallocation of the lhs is done with the correct memory size. + + +module base_mod + + type, abstract :: base + contains + procedure(base_add), deferred :: add + generic :: operator(+) => add + end type base + + abstract interface + module function base_add(l, r) result(res) + class(base), intent(in) :: l + integer, intent(in) :: r + class(base), allocatable :: res + end function base_add + end interface + +contains + + subroutine foo(x) + class(base), intent(inout), allocatable :: x + class(base), allocatable :: t + + t = x + 2 + x = t + 40 + end subroutine foo + +end module base_mod + +module extend_mod + use base_mod + + type, extends(base) :: extend + integer :: i + contains + procedure :: add + end type extend + +contains + module function add(l, r) result(res) + class(extend), intent(in) :: l + integer, intent(in) :: r + class(base), allocatable :: res + select type (l) + class is (extend) + res = extend(l%i + r) + class default + error stop "Unkown class to add to." + end select + end function +end module extend_mod + +program test_poly_ass + use extend_mod + use base_mod + + class(base), allocatable :: obj + obj = extend(0) + call foo(obj) + select type (obj) + class is (extend) + if (obj%i /= 42) error stop + class default + error stop "Result's type wrong." + end select +end program test_poly_ass + Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 243908) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,7 @@ +2016-12-23 Andre Vehreschild + + * gfortran.dg/class_assign_1.f08: New test. + 2016-12-23 Toma Tabacu * gcc.target/mips/oddspreg-2.c (dg-options): Remove dg-skip-if for