From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 55656 invoked by alias); 8 May 2015 10:54:56 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 55630 invoked by uid 89); 8 May 2015 10:54:55 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.6 required=5.0 tests=AWL,BAYES_00,FREEMAIL_FROM,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Fri, 08 May 2015 10:54:52 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx103) with ESMTPSA (Nemesis) id 0M5csW-1ZAObO0bDU-00xZXE; Fri, 08 May 2015 12:54:46 +0200 Date: Fri, 08 May 2015 10:54:00 -0000 From: Andre Vehreschild To: Mikael Morin Cc: GCC-Patches-ML , GCC-Fortran-ML Subject: Re: [Patch, Fortran, PR58586, v3] ICE with derived type with allocatable component passed by value Message-ID: <20150508125444.50e234d6@gmx.de> In-Reply-To: <554B3B23.3050800@sfr.fr> References: <20150415200304.7101aca9@gmx.de> <55337CF3.9010002@sfr.fr> <20150423200052.2e7a1311@gmx.de> <553CBC80.2050208@sfr.fr> <20150505110026.7ecbc229@gmx.de> <554B3B23.3050800@sfr.fr> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/+qhADK5H=Q3AaBFdftRS0=h" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-05/txt/msg00642.txt.bz2 --MP_/+qhADK5H=Q3AaBFdftRS0=h Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 4908 Hi Mikael, thanks for the review. I still have some questions/remarks before commiting: On Thu, 07 May 2015 12:14:59 +0200 Mikael Morin wrote: > > @@ -2158,6 +2158,8 @@ build_function_decl (gfc_symbol * sym, bool global) > > gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id > > (sym)); > > sym->backend_decl = fndecl; > > + if (sym == sym->result && !sym->result->backend_decl) > > + sym->result->backend_decl = result_decl; > > Something is seriously misbehaving if the condition is true, and setting > sym->backend_decl to result_decl doesn't seem any better than keeping it > NULL. > So, please remove this change Did that. I think this was a relic from the start of me trying to understand what was the issue and how to fix it. Later I didn't check, if it was still necessary. Sorry for that. > > @@ -5898,8 +5900,21 @@ gfc_generate_function_code (gfc_namespace * ns) > > > > if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) > > { > > + bool artificial_result_decl = false; > > tree result = get_proc_result (sym); > > > > + /* Make sure that a function returning an object with > > + alloc/pointer_components always has a result, where at least > > + the allocatable/pointer components are set to zero. */ > > + if (result == NULL_TREE && sym->attr.function > > + && sym->ts.type == BT_DERIVED > > + && (sym->ts.u.derived->attr.alloc_comp > > + || sym->ts.u.derived->attr.pointer_comp)) > > + { > > + artificial_result_decl = true; > > + result = gfc_get_fake_result_decl (sym, 0); > > + } > > I expect the "fake" result decl to be needed in more cases. > For example, if type is BT_CLASS. > Here is a variant of alloc_comp_class_4.f03:c_init for such a case. > > class(c) function c_init2() > allocatable :: c_init2 > end function > > or even without class: > > type(t) function t_init() > allocatable :: t_init > end function > > for some any type t. > > So, remove the check for alloc_comp/pointer_comp and permit BT_CLASS. > One minor thing, check sym->result's type and attribute instead of sym's > here. It should not make a difference, but I think it's more correct. I am d'accord with checking sym->result, but I am not happy with removing the checks for alloc_comp|pointer_comp. When I got you right there, you propose the if to be like this: if (result == NULL_TREE && sym->attr.function && (sym->result->ts.type == BT_DERIVED || sym->result->ts.type == BT_CLASS)) Removing the attribute checks means to initialize every derived/class type result, which may change the semantics of the code more than intented. Look for example at this code type t integer :: i = 5 end type type(t) function static_t_init() end function When one compiles this code with -Wreturn-type, then the warning of an uninitialized return value is issued at the function declaration. Nevertheless the result of static_t_init is validly initialized and i is 5. This may confuse users. I therefore came to the very ugly solution to make this: if (result == NULL_TREE && sym->attr.function && ((sym->result->ts.type == BT_DERIVED && (sym->results->attr.allocatable || sym->result->ts.u.derived->attr.alloc_comp || sym->result->ts.u.derived->attr.pointer_comp)) || (sym->result->ts.type == BT_CLASS && (CLASS_DATA (sym->result)->attr.allocatable || CLASS_DATA (sym->result)->attr.alloc_comp || CLASS_DATA (sym->result)->attr.pointer_comp)))) (I am not yet sure, whether the pointer attribute needs to be added to.) With the code above the result of static_t_init is not initialized with all the consequences. So what do you propose to do here? Btw, I think I found an additional bug during testing: type(t) function t_init() allocatable :: t_init end function when called by: type(t), allocatable :: temp temp = t_init() a segfault occurs, because the result of t_init() is NULL, which is dereferenced by the caller in this pseudo-code: if (temp != 0B) goto L.12; temp = (struct t *) __builtin_malloc (4); L.12:; *temp = *t_init (); <-- This obviously is problematic. > The rest looks good. > The patch is OK with the suggested changes above. Thanks. > I don't think the test functions above work well enough to be > incorporated in a testcase for now. ?? I don't get you there? What do you mean? Do you think the alloc_comp_class_3/4.* are not correctly testing the issue? Any idea of how to test this better? I mean the pr is about this artificial constructs. I merely struck it in search of a pr about allocatable components. Attached is a version of the patch that I currently use. Note the testcase alloc_comp_class_4.f03 fails currently, because of the error noted above in line 94. Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de --MP_/+qhADK5H=Q3AaBFdftRS0=h Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr58586_4.patch Content-length: 9368 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2ac4689..72df35e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -14093,10 +14093,15 @@ resolve_symbol (gfc_symbol *sym) if ((!a->save && !a->dummy && !a->pointer && !a->in_common && !a->use_assoc - && (a->referenced || a->result) - && !(a->function && sym != sym->result)) + && !a->result && !a->function) || (a->dummy && a->intent == INTENT_OUT && !a->pointer)) apply_default_init (sym); + else if (a->function && sym->result && a->access != ACCESS_PRIVATE + && (sym->ts.u.derived->attr.alloc_comp + || sym->ts.u.derived->attr.pointer_comp)) + /* Mark the result symbol to be referenced, when it has allocatable + components. */ + sym->result->attr.referenced = 1; } if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4c18920..bcafd8c5 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -5898,8 +5898,26 @@ gfc_generate_function_code (gfc_namespace * ns) if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) { + bool artificial_result_decl = false; tree result = get_proc_result (sym); + /* Make sure that a function returning an object with + alloc/pointer_components always has a result, where at least + the allocatable/pointer components are set to zero. */ + if (result == NULL_TREE && sym->attr.function + && ((sym->result->ts.type == BT_DERIVED + && (sym->result->attr.allocatable + || sym->result->ts.u.derived->attr.alloc_comp + || sym->result->ts.u.derived->attr.pointer_comp)) + || (sym->result->ts.type == BT_CLASS + && (CLASS_DATA (sym->result)->attr.allocatable + || CLASS_DATA (sym->result)->attr.alloc_comp + || CLASS_DATA (sym->result)->attr.pointer_comp)))) + { + artificial_result_decl = true; + result = gfc_get_fake_result_decl (sym, 0); + } + if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer) { if (sym->attr.allocatable && sym->attr.dimension == 0 @@ -5918,16 +5936,26 @@ gfc_generate_function_code (gfc_namespace * ns) null_pointer_node)); } else if (sym->ts.type == BT_DERIVED - && sym->ts.u.derived->attr.alloc_comp && !sym->attr.allocatable) { - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); - gfc_add_expr_to_block (&init, tmp); + gfc_expr *init_exp; + init_exp = gfc_default_initializer (&sym->ts); + if (init_exp) + { + tmp = gfc_trans_structure_assign (result, init_exp, 0); + gfc_free_expr (init_exp); + gfc_add_expr_to_block (&init, tmp); + } + else if (sym->ts.u.derived->attr.alloc_comp) + { + rank = sym->as ? sym->as->rank : 0; + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); + gfc_add_expr_to_block (&init, tmp); + } } } - if (result == NULL_TREE) + if (result == NULL_TREE || artificial_result_decl) { /* TODO: move to the appropriate place in resolve.c. */ if (warn_return_type && sym == sym->result) @@ -5937,7 +5965,7 @@ gfc_generate_function_code (gfc_namespace * ns) if (warn_return_type) TREE_NO_WARNING(sym->backend_decl) = 1; } - else + if (result != NULL_TREE) gfc_add_expr_to_block (&body, gfc_generate_return ()); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4bbd685..16e584a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1472,7 +1472,6 @@ realloc_lhs_warning (bt type, bool array, locus *where) } -static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init); static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); @@ -5341,12 +5340,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS) && e->ts.u.derived->attr.alloc_comp && !(e->symtree && e->symtree->n.sym->attr.pointer) - && e->expr_type != EXPR_VARIABLE && !e->rank - && e->expr_type != EXPR_STRUCTURE) + && e->expr_type != EXPR_VARIABLE && !e->rank) { int parm_rank; - tmp = build_fold_indirect_ref_loc (input_location, - parmse.expr); + /* It is known the e returns a structure type with at least one + allocatable component. When e is a function, ensure that the + function is called once only by using a temporary variable. */ + if (!DECL_P (parmse.expr)) + parmse.expr = gfc_evaluate_now_loc (input_location, + parmse.expr, &se->pre); + + if (fsym && fsym->attr.value) + tmp = parmse.expr; + else + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + parm_rank = e->rank; switch (parm_kind) { @@ -7137,7 +7146,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, /* Assign a derived type constructor to a variable. */ -static tree +tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) { gfc_constructor *c; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e2a1fea..3198c55 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -666,6 +666,9 @@ tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespe /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); +/* Assign a derived type constructor to a variable. */ +tree gfc_trans_structure_assign (tree, gfc_expr *, bool); + /* Generate code for an assignment, includes scalarization. */ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool); diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 new file mode 100644 index 0000000..0753e33 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-Wreturn-type" } +! +! Check that pr58586 is fixed now. +! Based on a contribution by Vladimir Fuka +! Contibuted by Andre Vehreschild + +program test_pr58586 + implicit none + + type :: a + end type + + type :: c + type(a), allocatable :: a + end type + + type :: b + integer, allocatable :: a + end type + + type :: t + integer, allocatable :: comp + end type + type :: u + type(t), allocatable :: comp + end type + + + ! These two are merely to check, if compilation works + call add(b()) + call add(b(null())) + + ! This needs to execute, to see whether the segfault at runtime is resolved + call add_c(c_init()) + + call sub(u()) +contains + + subroutine add (d) + type(b), value :: d + end subroutine + + subroutine add_c (d) + type(c), value :: d + end subroutine + + type(c) function c_init() ! { dg-warning "not set" } + end function + + subroutine sub(d) + type(u), value :: d + end subroutine +end program test_pr58586 + diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 new file mode 100644 index 0000000..e4c796e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 @@ -0,0 +1,104 @@ +! { dg-do run } +! { dg-options "-Wreturn-type" } +! +! Check that pr58586 is fixed now. +! Based on a contribution by Vladimir Fuka +! Contibuted by Andre Vehreschild + +module test_pr58586_mod + implicit none + + type :: a + end type + + type :: c + type(a), allocatable :: a + end type + + type :: d + contains + procedure :: init => d_init + end type + + type, extends(d) :: e + contains + procedure :: init => e_init + end type + + type :: b + integer, allocatable :: a + end type + + type t + integer :: i = 5 + end type + +contains + + subroutine add (d) + type(b), value :: d + end subroutine + + subroutine add_c (d) + type(c), value :: d + end subroutine + + subroutine add_class_c (d) + class(c), value :: d + end subroutine + + subroutine add_t (d) + type(t), value :: d + end subroutine + + type(c) function c_init() ! { dg-warning "not set" } + end function + + class(c) function c_init2() ! { dg-warning "not set" } + allocatable :: c_init2 + end function + + type(c) function d_init(this) ! { dg-warning "not set" } + class(d) :: this + end function + + type(c) function e_init(this) + class(e) :: this + allocate (e_init%a) + end function + + type(t) function t_init() ! { dg-warning "not set" } + allocatable :: t_init + end function + + type(t) function static_t_init() ! { dg-warning "not set" } + end function +end module test_pr58586_mod + +program test_pr58586 + use test_pr58586_mod + + class(d), allocatable :: od + class(e), allocatable :: oe + type(t), allocatable :: temp + + ! These two are merely to check, if compilation works + call add(b()) + call add(b(null())) + + ! This needs to execute, to see whether the segfault at runtime is resolved + call add_c(c_init()) + call add_class_c(c_init2()) + + call add_t(static_t_init()) + temp = t_init() ! <-- This derefs a null-pointer currently + if (allocated (temp)) call abort() + + allocate(od) + call add_c(od%init()) + deallocate(od) + allocate(oe) + call add_c(oe%init()) + deallocate(oe) +end program + --MP_/+qhADK5H=Q3AaBFdftRS0=h--