From patchwork Mon Nov 27 17:35:22 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andrew Jenner X-Patchwork-Id: 170348 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:ce62:0:b0:403:3b70:6f57 with SMTP id o2csp3321155vqx; Mon, 27 Nov 2023 09:36:09 -0800 (PST) X-Google-Smtp-Source: AGHT+IGol57Nc7UBnZhXJTDC4YbXyBCN2Oy/UOTKBIVOVGSjl78kcwQL44quD9IvyfWGhGqD6Jq5 X-Received: by 2002:a05:6808:1455:b0:3b8:33dd:fae9 with SMTP id x21-20020a056808145500b003b833ddfae9mr19052807oiv.12.1701106569371; Mon, 27 Nov 2023 09:36:09 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1701106569; cv=pass; d=google.com; s=arc-20160816; b=JvPZe8kE/xWfaihE3IX+WaZaou/gBRTtKRwR1Qv8HD5ll+wcg5bytpuQEBvUqeRVZ5 0TjIGY4ZuUP/AuMEwYhmpXRfHXQ3Amaj7uHStgnB1cAFb5jXypB9S4HdY6Ra+WrI3u4c N7J/itk7ipUAAcp+REj8Q234t7dFzRvl9a0SCsxTFoUL3pJai9os+LRUen4RIYO6j4TD CvWts4gRWF2inpEkIc3wKzllIdlOFI7rWPxDH5/vefe3wSwxkeZZHhZ3qsWv5KpTkRyL 7Onj9iJlHPIoFG54Ftt2rwAC9jC52S7DmzBw/5R9IvCRcgH7EgreR23ixr/T4cYjmm8S SyRA== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:cc:subject:from:to :content-language:user-agent:mime-version:date:message-id :ironport-sdr:arc-filter:dmarc-filter:delivered-to; bh=CbLlgXdA/dbX/2cwv2jqbJ3Da6YgJFwvdYzKJ0C+zHA=; fh=rhVRaQj6BPb6QZ9PS7j5J+ifrpecGUOUHoIExrVnkXY=; b=WiwxmuD4xw78F4jV4AFHbZ69ytb8STXB/6vRQamj1O4YNy0uh39LYzgcTqB8TSGsgH fjvaq4fVfhxnclwiJ82njAcnLYSzV4uvTqaourpUlh4c1mzQFEcD9jRNstDaBEFBH1Ik XRAAwR0zsr7XiFg6tBNpqhRKORDlEKOVYLawkY6BIaMYns42U1xRgmM58XYIzcYG717d yq6dBFDJsQf81JllIFYzC+d9Q8hclbhOr16sT2h2nXp7/nzA9mMvQNg3jXS8H97Z2IkL E4MWmJRL9cXQfWaxS/uQUSbk67bsOcQi5Lu/X6X9qFCpCF9bqblrSc6PhPJgivsb7drd lDPg== ARC-Authentication-Results: i=2; mx.google.com; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id t3-20020a05622a148300b00423804bdaadsi9783482qtx.10.2023.11.27.09.36.09 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 27 Nov 2023 09:36:09 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id A7D093860757 for ; Mon, 27 Nov 2023 17:36:06 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 4C9393857BBD; Mon, 27 Nov 2023 17:35:39 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 4C9393857BBD Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 4C9393857BBD Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=68.232.137.180 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701106541; cv=none; b=h3MuMLHAah1TIcrtYb//H40uBvZY9PD2jz0IKFOuwa0tCy9K7INzUT7unFlODVcBsPgsuNo0S9Cfs2mh1xG7CbF4ke+D9Ssb0M0NYCjVXUPo0OaeFhDajBg7PJUhGDcKVqXUqs80GiBfghaT0zb/KBNwc4o/zghSNuI/gv6jCDU= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701106541; c=relaxed/simple; bh=EvEAzduTDSVYkjFQBQX5Zo4oTAc7uGqId5jDt9eACDI=; h=Message-ID:Date:MIME-Version:To:From:Subject; b=oXd6WKLkDIcGrpIFZLK+tqc2BMqV47hj7EZylHU0fHzD1q5nKXkFPldySeSrEXRAAP2xZpBzvfFZnpthVtl4xXXjdxu6vvEJjfPuS3aNUg7E8UerOC4sCi3iDUZxScxsy3UlumkT/ZpKQL2mpKZa11ONpT6wKcCNVInKkiNi14E= ARC-Authentication-Results: i=1; server2.sourceware.org X-CSE-ConnectionGUID: fqSCgObPSUuhQdhPY3qJjQ== X-CSE-MsgGUID: ADb0E63pSU+thGPOmur69g== X-IronPort-AV: E=Sophos;i="6.04,231,1695715200"; d="scan'208";a="23814329" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa3.mentor.iphmx.com with ESMTP; 27 Nov 2023 09:35:30 -0800 IronPort-SDR: H/VSWDyyPZ2weRECY7PUa0JNOQyRsv+wALOulMjOxkfqEFx+58jZRRkLWw1AlqidIeJikPy4nj ntbaN7qzi1DVTT+6IVGQHM/Lhod0jfxqWbBn/nILoOI5O1sx+8cPL3aSmNJWIRhho0Vu1GlmMK gcR6phaWMAfGMfAroNj2GXPBT8klSFeB7e62a5z4OF8udup81ARsRbzk0iTC0reiV+r9ZUSRin jEW2rb5bFSn+qnw8TD6Jevl+LBs1zkctvGJWGeu+f06enHUarTFDcEoEZTCFUTQ5JvqtiGeMb8 /HI= Message-ID: <4733a0ea-1a3e-4cf3-8b1e-3e1efac91dd0@codesourcery.com> Date: Mon, 27 Nov 2023 17:35:22 +0000 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gcc Patches , From: Andrew Jenner Subject: [PATCH v2] Fortran: fix reallocation on assignment of polymorphic variables [PR110415] CC: Tobias Burnus X-ClientProxiedBy: svr-orw-mbx-11.mgc.mentorg.com (147.34.90.211) To svr-ies-mbx-10.mgc.mentorg.com (139.181.222.10) X-Spam-Status: No, score=-11.3 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_PASS, SPF_PASS, 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1783739522369702357 X-GMAIL-MSGID: 1783739522369702357 This is the second version of the patch - previous discussion at: https://gcc.gnu.org/pipermail/gcc-patches/2023-November/636671.html This patch adds the testcase from PR110415 and fixes the bug. The problem is that in a couple of places in trans_class_assignment in trans-expr.cc, we need to get the run-time size of the polymorphic object from the vtbl, but we are currently getting that vtbl from the lhs of the assignment rather than the rhs. This gives us the old value of the size but we need to pass the new size to __builtin_malloc and __builtin_realloc. I'm fixing this by adding a parameter to trans_class_vptr_len_assignment to retrieve the tree corresponding the vptr from the object on the rhs of the assignment, and then passing this where it is needed. In the case where trans_class_vptr_len_assignment returns NULL_TREE for the rhs vptr we use the lhs vptr as before. To get this to work I also needed to change the implementation of trans_class_vptr_len_assignment to create a temporary for the assignment in more circumstances. Currently, the "a = func()" assignment in MAIN__ doesn't hit the "Create a temporary for complication expressions" case on line 9951 because "DECL_P (rse->expr)" is true - the expression has already been placed into a temporary. That means we don't hit the "if (temp_rhs ..." case on line 10038 and go on to get the vptr_expr from "gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts))" on line 10057 which is the vtbl of the static type rather than the dynamic one from the rhs. So with this fix we create an extra temporary, but that should be optimised away in the middle-end so there should be no run-time effect. I'm not sure if this is the best way to fix this (the Fortran front-end is new territory for me) but I've verified that the testcase passes with this change, fails without it, and that the change does not introduce any FAILs when running the gfortran testcases on x86_64-pc-linux-gnu. After the previous submission, Tobias Burnus found a closely related problem and contributed testcases and a fix for it, which I have incorporated into this version of the patch. The problem in this case is with the __builtin_realloc call that is executed if one polymorphic variable is replaced by another. The return value of this call was being ignored rather than used to replace the pointer being reallocated. Is this OK for mainline, GCC 13 and OG13? Thanks, Andrew gcc/fortran/ PR fortran/110415 * trans-expr.cc (trans_class_vptr_len_assignment): Add from_vptrp parameter. Populate it. Don't check for DECL_P when deciding whether to create temporary. (trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add NULL argument to trans_class_vptr_len_assignment calls. (trans_class_assignment): Get rhs_vptr from trans_class_vptr_len_assignment and use it for determining size for allocation/reallocation. Use return value from realloc. gcc/testsuite/ PR fortran/110415 * gfortran.dg/pr110415.f90: New test. * gfortran.dg/asan/pr110415-2.f90: New test. * gfortran.dg/asan/pr110415-3.f90: New test. diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 50c4604a025..bfe9996ced6 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -9936,7 +9936,8 @@ trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr) static tree trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, gfc_expr * re, gfc_se *rse, - tree * to_lenp, tree * from_lenp) + tree * to_lenp, tree * from_lenp, + tree * from_vptrp) { gfc_se se; gfc_expr * vptr_expr; @@ -9944,10 +9945,11 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, bool set_vptr = false, temp_rhs = false; stmtblock_t *pre = block; tree class_expr = NULL_TREE; + tree from_vptr = 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)) + && rse->expr != NULL_TREE) { if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) class_expr = gfc_get_class_from_expr (rse->expr); @@ -10044,6 +10046,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, tmp = rse->expr; se.expr = gfc_class_vptr_get (tmp); + from_vptr = se.expr; if (UNLIMITED_POLY (re)) from_len = gfc_class_len_get (tmp); @@ -10065,6 +10068,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, gfc_free_expr (vptr_expr); gfc_add_block_to_block (block, &se.pre); gcc_assert (se.post.head == NULL_TREE); + from_vptr = se.expr; } gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr), se.expr)); @@ -10093,11 +10097,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, } } - /* Return the _len trees only, when requested. */ + /* Return the _len and _vptr trees only, when requested. */ if (to_lenp) *to_lenp = to_len; if (from_lenp) *from_lenp = from_len; + if (from_vptrp) + *from_vptrp = from_vptr; return lhs_vptr; } @@ -10166,7 +10172,7 @@ trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse, { expr1_vptr = trans_class_vptr_len_assignment (block, expr1, expr2, rse, - NULL, NULL); + NULL, NULL, NULL); gfc_add_block_to_block (block, &rse->pre); tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp"); gfc_add_modify (&lse->pre, tmp, rse->expr); @@ -10242,7 +10248,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS) { trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, - NULL); + NULL, NULL); lse.expr = gfc_class_data_get (lse.expr); } @@ -10371,7 +10377,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (expr1->ts.type == BT_CLASS) expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, - NULL, NULL); + NULL, NULL, + NULL); } } else if (expr2->expr_type == EXPR_VARIABLE) @@ -10388,7 +10395,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) rse.expr = NULL_TREE; rse.string_length = strlen_rhs; trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, - NULL, NULL); + NULL, NULL, NULL); } if (remap == NULL) @@ -10421,7 +10428,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, - NULL); + NULL, NULL); gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); gfc_add_modify (&lse.pre, tmp, rse.expr); @@ -11819,7 +11826,7 @@ 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, old_vptr; + tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr; vec *args = NULL; bool final_expr; @@ -11843,7 +11850,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, } vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, - &from_len); + &from_len, &rhs_vptr); + if (rhs_vptr == NULL_TREE) + rhs_vptr = vptr; /* Generate (re)allocation of the lhs. */ if (class_realloc) @@ -11856,7 +11865,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, else old_vptr = build_int_cst (TREE_TYPE (vptr), 0); - size = gfc_vptr_size_get (vptr); + size = gfc_vptr_size_get (rhs_vptr); tmp = lse->expr; class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) ? gfc_class_data_get (tmp) : tmp; @@ -11870,12 +11879,14 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, /* Reallocate if dynamic types are different. */ gfc_init_block (&re_alloc); + tmp = fold_convert (pvoid_type_node, class_han); re = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_REALLOC), 2, - fold_convert (pvoid_type_node, class_han), - size); + tmp, size); + re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp, + re); tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, vptr, old_vptr); + logical_type_node, rhs_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); diff --git a/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 b/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 new file mode 100755 index 00000000000..f4ff1823e54 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +implicit none + type, abstract :: p + integer :: a = 4 + end type p + + type, extends(p) :: c + integer :: b = 7 + character(len=:), allocatable :: str, str2(:) + end type c + + type, extends(p) :: d + integer :: ef = 7 + end type d + + class(p), allocatable :: a + + a = func() + + a = func2() + + a = func() + + deallocate(a) + +contains + function func2() result(a) + class(p), allocatable :: a + a = d() + end function func2 + + function func() result(a) + class(p), allocatable :: a + + a = c() + select type(a) + type is (c) + a%str = 'abcd' + a%str2 = ['abcd','efgh'] + end select + end function func +end program diff --git a/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 b/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 new file mode 100755 index 00000000000..65c018d805f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +implicit none + type, abstract :: p + integer :: a = 4 + end type p + + type, extends(p) :: c + integer :: b = 7 + character(len=:), allocatable :: str, str2(:) + end type c + + type, extends(p) :: d + integer :: ef = 7 + end type d + + class(p), allocatable :: a(:) + + a = func() + + a = func2() + + a = func() + + deallocate(a) + +contains + function func2() result(a) + class(p), allocatable :: a(:) + a = [d(),d()] + end function func2 + + function func() result(a) + class(p), allocatable :: a(:) + + a = [c(),c(),c()] + select type(a) + type is (c) + a(1)%str = 'abcd' + a(2)%str = 'abc' + a(3)%str = 'abcd4' + a(1)%str2 = ['abcd','efgh'] + a(2)%str2 = ['bcd','fgh'] + a(3)%str2 = ['abcd6','efgh7'] + end select + end function func +end program diff --git a/gcc/testsuite/gfortran.dg/pr110415.f90 b/gcc/testsuite/gfortran.dg/pr110415.f90 new file mode 100644 index 00000000000..f647cc4c52c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr110415.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! + type, abstract :: p + end type p + + type, extends(p) :: c + end type c + + class(p), allocatable :: a + + a = func() +contains + function func() result(a) + class(p), allocatable :: a + + a = c() + end function func +end program