From patchwork Mon Jul 26 20:32:23 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [Fortran] PR 40873 - -fwhole-program decl fixes Date: Mon, 26 Jul 2010 10:32:23 -0000 From: Tobias Burnus X-Patchwork-Id: 59948 Message-Id: <4C4DF0D7.2020001@net-b.de> To: gcc patches , gfortran , Paul Richard Thomas Dear all, the attached patch is rather obvious - after one has found the right spots. a) If Fortran tried first to resolve "call proc()" and then only generated the code for "subroutine proc()", two separate declarations where created - thus the decl of "subroutine proc()" was never called -- and therefore, with -fwhole-program, "subroutine proc()" was optimized away - causing linker errors. The solution is simple: When obtaining the external decl, first generate the decl for the real procedure - and place it at the global binding level. b) gfortran did not properly resolve procedures if they were declared with INTERFACE, causing crashes for assumed-shape dummies. For those, one needs to change the dummy from AS_DEFERRED to AS_ASSUMED_SHAPE, but this was not be done for the real global symbol. Well, as consequence, one got an ICE in trans*.c when treating it as AS_DEFERRED array. The solution was to also handle INTERFACE; afterwards, I had to adapt (and to conditionally disable) some checks. Build and and currently regtesting on x86-64-linux. If there is no failure: OK for the trunk? Tobias PS: While now most of the -fwhole-file/-fwhole-program bugs are now fixed, there are still a couple of ice-on-valid-code and wrong-code bugs left to fix, e.g. PR 45087 (-fwhole-file issues of 2 polyhedron tests), PR 44945 (no gsym created for symbols of external-file modules), PR 45077 (ICE). 2010-07-26 Tobias Burnus PR fortran/40873 * trans-decl.c (gfc_get_extern_function_decl): Fix generation for functions which are later in the same file. (gfc_create_function_decl, build_function_decl, build_entry_thunks): Add global argument. * trans.c (gfc_generate_module_code): Update gfc_create_function_decl call. * trans.h (gfc_create_function_decl): Update prototype. * resolve.c (resolve_global_procedure): Also resolve for IFSRC_IFBODY. 2010-07-26 Tobias Burnus PR fortran/40873 * gfortran.dg/whole_file_22.f90: New test. * gfortran.dg/whole_file_23.f90: New test. Index: gcc/testsuite/gfortran.dg/whole_file_23.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_23.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/whole_file_23.f90 (Revision 0) @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR fortran/40873 +! +! Failed to compile (segfault) with -fwhole-file. +! Cf. PR 40873 comment 24; test case taken from +! PR fortran/31867 comment 6. +! + +pure integer function lensum (words, sep) + character (len=*), intent(in) :: words(:), sep + lensum = (size (words)-1) * len (sep) + sum (len_trim (words)) +end function + +module util_mod + implicit none + interface + pure integer function lensum (words, sep) + character (len=*), intent(in) :: words(:), sep + end function + end interface + contains + function join (words, sep) result(str) +! trim and concatenate a vector of character variables, +! inserting sep between them + character (len=*), intent(in) :: words(:), sep + character (len=lensum (words, sep)) :: str + integer :: i, nw + nw = size (words) + str = "" + if (nw < 1) then + return + else + str = words(1) + end if + do i=2,nw + str = trim (str) // sep // words(i) + end do + end function join +end module util_mod +! +program xjoin + use util_mod, only: join + implicit none + character (len=5) :: words(2) = (/"two ","three"/) + write (*,"(1x,'words = ',a)") "'"//join (words, "&")//"'" +end program xjoin + +! { dg-final { cleanup-modules "util_mod" } } Index: gcc/testsuite/gfortran.dg/whole_file_22.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_22.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/whole_file_22.f90 (Revision 0) @@ -0,0 +1,38 @@ +! { dg-do link } +! { dg-options "-fwhole-program -O3 -g" } +! +! PR fortran/40873 +! + program prog + call one() + call two() + call test() + end program prog + subroutine one() + call three() + end subroutine one + subroutine two() + call three() + end subroutine two + subroutine three() + end subroutine three + +SUBROUTINE c() + CALL a() +END SUBROUTINE c + +SUBROUTINE a() +END SUBROUTINE a + +MODULE M +CONTAINS + SUBROUTINE b() + CALL c() + END SUBROUTINE +END MODULE + +subroutine test() +USE M +CALL b() +END + Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 162542) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -913,7 +913,7 @@ gfc_is_constant_expr (gfc_expr *e) || gfc_is_constant_expr (e->value.op.op2))); case EXPR_VARIABLE: - return 0; + return (e->symtree->n.sym->attr.flavour == FL_PARAMETER); case EXPR_FUNCTION: case EXPR_PPC: Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (Revision 162542) +++ gcc/fortran/trans.c (Arbeitskopie) @@ -1388,7 +1388,7 @@ gfc_generate_module_code (gfc_namespace if (!n->proc_name) continue; - gfc_create_function_decl (n); + gfc_create_function_decl (n, false); gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE); DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; gfc_module_add_decl (entry, n->proc_name->backend_decl); Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 162542) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -449,7 +449,7 @@ void gfc_allocate_lang_decl (tree); tree gfc_advance_chain (tree, int); /* Create a decl for a function. */ -void gfc_create_function_decl (gfc_namespace *); +void gfc_create_function_decl (gfc_namespace *, bool); /* Generate the code for a function. */ void gfc_generate_function_code (gfc_namespace *); /* Output a BLOCK DATA program unit. */ @@ -537,7 +537,7 @@ void gfc_process_block_locals (gfc_names /* Output initialization/clean-up code that was deferred. */ void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *); -/* somewhere! */ +/* In f95-lang.c. */ tree pushdecl (tree); tree pushdecl_top_level (tree); void pushlevel (int); @@ -545,6 +545,8 @@ tree poplevel (int, int, int); tree getdecls (void); tree gfc_truthvalue_conversion (tree); tree gfc_builtin_function (tree); + +/* In trans-types.c. */ struct array_descr_info; bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 162542) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -1816,7 +1816,8 @@ resolve_global_procedure (gfc_symbol *sy gfc_global_used (gsym, where); if (gfc_option.flag_whole_file - && sym->attr.if_source == IFSRC_UNKNOWN + && (sym->attr.if_source == IFSRC_UNKNOWN + || sym->attr.if_source == IFSRC_IFBODY) && gsym->type != GSYM_UNKNOWN && gsym->ns && gsym->ns->resolved != -1 @@ -1902,7 +1903,7 @@ resolve_global_procedure (gfc_symbol *sy sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&def_sym->ts)); - if (def_sym->formal) + if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY) { gfc_formal_arglist *arg = def_sym->formal; for ( ; arg; arg = arg->next) @@ -1969,14 +1970,19 @@ resolve_global_procedure (gfc_symbol *sy where); /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ - if (def_sym->result->attr.pointer - || def_sym->result->attr.allocatable) + if ((def_sym->result->attr.pointer + || def_sym->result->attr.allocatable) + && (sym->attr.if_source != IFSRC_IFBODY + || def_sym->result->attr.pointer + != sym->result->attr.pointer) + || (def_sym->result->attr.allocatable + != sym->result->attr.allocatable)) gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " "result must have an explicit interface", sym->name, where); /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ - if (sym->ts.type == BT_CHARACTER + if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY && def_sym->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; @@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sy } /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ - if (def_sym->attr.elemental) + if (def_sym->attr.elemental && !sym->attr.elemental) { gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " "interface", sym->name, &sym->declared_at); } /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ - if (def_sym->attr.is_bind_c) + if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c) { gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " "an explicit interface", sym->name, &sym->declared_at); @@ -2010,7 +2016,8 @@ resolve_global_procedure (gfc_symbol *sy && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); - gfc_procedure_use (def_sym, actual, where); + if (sym->attr.if_source != IFSRC_IFBODY) + gfc_procedure_use (def_sym, actual, where); gfc_errors_to_warnings (0); } Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (Revision 162542) +++ gcc/fortran/trans-decl.c (Arbeitskopie) @@ -1413,8 +1413,26 @@ gfc_get_extern_function_decl (gfc_symbol && !sym->backend_decl && gsym && gsym->ns && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) - && gsym->ns->proc_name->backend_decl) + && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) { + if (!gsym->ns->proc_name->backend_decl) + { + /* By construction, the external function cannot be + a contained procedure. */ + locus old_loc; + tree save_fn_decl = current_function_decl; + + current_function_decl = NULL_TREE; + gfc_get_backend_locus (&old_loc); + push_cfun (cfun); + + gfc_create_function_decl (gsym->ns, true); + + pop_cfun (); + gfc_set_backend_locus (&old_loc); + current_function_decl = save_fn_decl; + } + /* If the namespace has entries, the proc_name is the entry master. Find the entry and use its backend_decl. otherwise, use the proc_name backend_decl. */ @@ -1574,7 +1592,7 @@ gfc_get_extern_function_decl (gfc_symbol a master function with alternate entry points. */ static void -build_function_decl (gfc_symbol * sym) +build_function_decl (gfc_symbol * sym, bool global) { tree fndecl, type, attributes; symbol_attribute attr; @@ -1682,7 +1700,11 @@ build_function_decl (gfc_symbol * sym) /* Layout the function declaration and put it in the binding level of the current function. */ - pushdecl (fndecl); + + if (global) + pushdecl_top_level (fndecl); + else + pushdecl (fndecl); sym->backend_decl = fndecl; } @@ -1955,7 +1977,7 @@ trans_function_start (gfc_symbol * sym) /* Create thunks for alternate entry points. */ static void -build_entry_thunks (gfc_namespace * ns) +build_entry_thunks (gfc_namespace * ns, bool global) { gfc_formal_arglist *formal; gfc_formal_arglist *thunk_formal; @@ -1977,7 +1999,7 @@ build_entry_thunks (gfc_namespace * ns) thunk_sym = el->sym; - build_function_decl (thunk_sym); + build_function_decl (thunk_sym, global); create_function_arglist (thunk_sym); trans_function_start (thunk_sym); @@ -2137,17 +2159,18 @@ build_entry_thunks (gfc_namespace * ns) /* Create a decl for a function, and create any thunks for alternate entry - points. */ + points. If global is true, generate the function in the global binding + level, otherwise in the current binding level (which can be global). */ void -gfc_create_function_decl (gfc_namespace * ns) +gfc_create_function_decl (gfc_namespace * ns, bool global) { /* Create a declaration for the master function. */ - build_function_decl (ns->proc_name); + build_function_decl (ns->proc_name, global); /* Compile the entry thunks. */ if (ns->entries) - build_entry_thunks (ns); + build_entry_thunks (ns, global); /* Now create the read argument list. */ create_function_arglist (ns->proc_name); @@ -3728,7 +3751,7 @@ gfc_generate_contained_functions (gfc_na if (ns->parent != parent) continue; - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); } for (ns = parent->contained; ns; ns = ns->sibling) @@ -4364,7 +4387,7 @@ gfc_generate_function_code (gfc_namespac /* Create the declaration for functions with global scope. */ if (!sym->backend_decl) - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); fndecl = sym->backend_decl; old_context = current_function_decl;