From patchwork Tue Dec 20 16:07:50 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 88611 Delivered-To: patch@linaro.org Received: by 10.140.20.101 with SMTP id 92csp1800559qgi; Tue, 20 Dec 2016 08:08:21 -0800 (PST) X-Received: by 10.84.218.76 with SMTP id f12mr35389plm.141.1482250101767; Tue, 20 Dec 2016 08:08:21 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id q12si22737841pgc.52.2016.12.20.08.08.21 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Tue, 20 Dec 2016 08:08:21 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-444858-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-444858-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-444858-patch=linaro.org@gcc.gnu.org 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=UsiNc8JU5Rusxe5l NHRDO7QJVZ+hiDJFc2gZ5/M5btHwtKakJLNDdKSN7D7cJzwEuBwWZ6d4URYufXJQ TwDdEo43QvMXYNISKZWdWN4xjRwqmbpu/0E7s+NJE1BZ/enY2vMeZTuFzSbYMR+v xUKLOyIzIVe6BTk7J1FnBjJjSqU= 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=+pVgyLXXsChfBM1SiyMjWf Su8/c=; b=jwhxnx5XtbVtkwcBh4U3qPznkeRcZcD7KMnTHB4iqPI0NhFJs7po5G rxEgd/KVl9QD7i8mzKWQYdf+xb3UbjNwFJoQ0Pj5GTEsKwl6dXi94pj0igv9+muL A7UzDEuTPZo//oXPF3Gz0BCdhj6Lfzg9Xn57rCYdcRmDL64jpa7tM= Received: (qmail 3087 invoked by alias); 20 Dec 2016 16:08:09 -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 3062 invoked by uid 89); 20 Dec 2016 16:08:08 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.5 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=hazardous, Results, lse, Therefore X-Spam-User: qpsmtpd, 3 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.19) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 20 Dec 2016 16:07:58 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx002 [212.227.17.190]) with ESMTPSA (Nemesis) id 0McVKy-1c1hXs0NKC-00Hgmt; Tue, 20 Dec 2016 17:07:52 +0100 Date: Tue, 20 Dec 2016 17:07:50 +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: <20161220170750.6ef0d9d8@vepi2> In-Reply-To: References: <20161219124343.3c3baf4c@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:tO4uuQ3AqXM=:0LYoQLdzwc9xz93ypXkR22 r9hpYTgmUVFhiBfm6TwSJTHb0pq8Sk01WBbXtitKy88gWttDXSi1XVfe6DAPiQF6OcIsfsadb NUzV1KfriuJItBfbNo38+cZyu0W2qJCl27iaAm6NJKZmZj5qjkShj410TwrWBfDqdpLYlZlM7 cdz3yP9uAFwowlaVm8EkpiQmulsPHzbO36i/VuaBOMC/1xCxZwJsN5tjEmv2x1cDFAxmslEgp rWG7GahFtsAZEzmmvoiImF6By90Bsa/TlJiAAUeeymXUfMrlO7fwJTVEBzGJQrS3VRrb2NADo zUNkG91lBUpbxZC+4AeKK3wrN6g3KmJSqFHfNf8Li+vppvtHY9SJy5mgAV9yBPSZWYuRLlxEe L/1eEg3w4Ugfs+pjW6mXuXBebUbDrRoDDQIoBJMF1iA1IzqADvS8q+y2K3IrIkfaHDB344+qg ktFV1B0M//7TyRyPy039prUDRlRNXU36ee8es6XBnMs9y9rOfIoZWAQH+zo9U0BVkdPsnJFFW udPqeFwHS29X2WDUeUJ1JAyRqmfize28cWCL8wsoWGO71gH1eU+GGeot0GUwKpVPTYiePwXR3 k/i6O4T+xSz7tVS68vbXt3jd+zFcXdZZpFMBUtvjWGUj3ydTE0gqH5+a6Kc8g+FajpEVSk0Bs 44xLg3w8ssmusk1YF18/K1tKo48V/bIdg3i4bHsqSFcvDThnum24sgZJEIDj7RGxCEeVsyeI9 daH66XSfBs2duwzkx3trco0hbRJK4Pc5pHTKh9jr6xSpybME2hMo9enbzhs= 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? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de gcc/testsuite/ChangeLog: 2016-12-20 Andre Vehreschild * gfortran.dg/class_assign_1.f08: New test. gcc/fortran/ChangeLog: 2016-12-20 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. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index cbff9ae..ce7927c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -9635,17 +9635,38 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) 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; @@ -9971,15 +9992,10 @@ 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)); - /* 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) @@ -10021,7 +10037,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 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); diff --git a/gcc/testsuite/gfortran.dg/class_assign_1.f08 b/gcc/testsuite/gfortran.dg/class_assign_1.f08 new file mode 100644 index 0000000..fb1f655 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_assign_1.f08 @@ -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 +