Hello world,
the attached patch fixes a rather bad ABI violation on POWER systems.
In the absence of an explicit interface and if a procedure is not in
the same file, gfortran currently generates wrong function decls -
a longstanding problem that also creates problems with LTO, because
it (correctly) complains about mismatched declarations.
Usually, we got lucky because the actual calling sequences generated
by the compiler with the wrong info happened to match the ones
with the correct info. However, our luck ran out on POWER because
as soon as arguments were passed in memory, things did not work
any more. The test case in question (see attachments) produced
wrong code on POWER, but merely warned with LTO on other systems.
The method for solving this problem can be seen in the patch - if
there is no backend decl for an external procedure, simply generate
a formal argument list from the arguments.
Regression tests turned up a few ICEs (now fixed), plus two
very invalid test cases, which I think are not worth saving.
I suspect that this will also fix a few LTO bugs, but we can always
check that after this has been committed.
I'd still like confirmation from one of the POWER people that
this also fixes the bug on that architecture.
Should this still go into gcc-9? Richard has indicated in the
PR that he thinks so. I think so too, because of the severity
of the bug(s) this fixes. Any bugs resulting from this could
be either a) ICE-on-valid (easily fixed) or b) somehow generating
a wrong decl, but we are already doing this as of this moment,
so things can not really be made much worse, and a lot better.
So, ok for trunk and for backport (with some time in between)
once gcc-8 has re-opened?
Regards
Thomas
2019-02-17 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/87689
* trans-decl.c (gfc_get_extern_function_decl): Add argument
actual_args and pass it through to gfc_get_function_type.
* trans-expr.c (conv_function_val): Add argument actual_args
and pass it on to gfc_get_extern_function_decl.
(conv_procedure_call): Pass actual arguments to conv_function_val.
* trans-types.c (get_formal_from_actual_arglist): New function.
(gfc_get_function_type): Add argument actual_args. Generate
formal args from actual args if necessary.
* trans-types.h (gfc_get_function_type): Add optional argument.
* trans.h (gfc_get_extern_function_decl): Add optional argument.
2019-02-17 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/87689
* gfortran.dg/lto/20091028-1_0.f90: Remove invalid test
case.
* gfortran.dg/lto/20091028-1_1.c: Likewise.
* gfortran.dg/lto/20091028-2_0.f90: Likewise.
* gfortran.dg/lto/20091028-2_1.c: Likewise.
* gfortran.dg/lto/pr87689_0.f: New file.
* gfortran.dg/lto/pr87689_1.f: New file.
Index: trans-decl.c
===================================================================
--- trans-decl.c (Revision 268968)
+++ trans-decl.c (Arbeitskopie)
@@ -1962,7 +1962,7 @@ get_proc_pointer_decl (gfc_symbol *sym)
/* Get a basic decl for an external function. */
tree
-gfc_get_extern_function_decl (gfc_symbol * sym)
+gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args)
{
tree type;
tree fndecl;
@@ -2135,7 +2135,7 @@ module_sym:
mangled_name = gfc_sym_mangled_function_id (sym);
}
- type = gfc_get_function_type (sym);
+ type = gfc_get_function_type (sym, actual_args);
fndecl = build_decl (input_location,
FUNCTION_DECL, name, type);
Index: trans-expr.c
===================================================================
--- trans-expr.c (Revision 268968)
+++ trans-expr.c (Arbeitskopie)
@@ -3895,7 +3895,8 @@ conv_base_obj_fcn_val (gfc_se * se, tree base_obje
static void
-conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
+ gfc_actual_arglist *actual_args)
{
tree tmp;
@@ -3913,7 +3914,7 @@ static void
else
{
if (!sym->backend_decl)
- sym->backend_decl = gfc_get_extern_function_decl (sym);
+ sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
TREE_USED (sym->backend_decl) = 1;
@@ -6580,7 +6581,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
/* Generate the actual call. */
if (base_object == NULL_TREE)
- conv_function_val (se, sym, expr);
+ conv_function_val (se, sym, expr, args);
else
conv_base_obj_fcn_val (se, base_object, expr);
Index: trans-types.c
===================================================================
--- trans-types.c (Revision 268968)
+++ trans-types.c (Arbeitskopie)
@@ -2970,9 +2970,54 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
return build_type_attribute_variant (fntype, tmp);
}
+/* Helper function - if we do not find an interface for a procedure,
+ construct it from the actual arglist. Luckily, this can only
+ happen for call by reference, so the information we actually need
+ to provide (and which would be impossible to guess from the call
+ itself) is not actually needed. */
+static void
+get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args)
+{
+ gfc_actual_arglist *a;
+ gfc_formal_arglist **f;
+ gfc_symbol *s;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int var_num;
+
+ f = &sym->formal;
+ for (a = actual_args; a != NULL; a = a->next)
+ {
+ if (a->expr)
+ {
+ (*f) = gfc_get_formal_arglist ();
+ snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
+ gfc_get_symbol (name, NULL, &s);
+ if (a->expr->ts.type == BT_PROCEDURE)
+ {
+ s->attr.flavor = FL_PROCEDURE;
+ }
+ else
+ {
+ s->ts = a->expr->ts;
+ s->attr.flavor = FL_VARIABLE;
+ if (a->expr->rank > 0)
+ {
+ s->attr.dimension = 1;
+ s->as = gfc_get_array_spec ();
+ s->as->type = AS_ASSUMED_SIZE;
+ }
+ }
+ s->attr.dummy = 1;
+ s->attr.intent = INTENT_UNKNOWN;
+ (*f)->sym = s;
+ }
+ f = &((*f)->next);
+ }
+}
+
tree
-gfc_get_function_type (gfc_symbol * sym)
+gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
{
tree type;
vec<tree, va_gc> *typelist = NULL;
@@ -3030,6 +3075,10 @@ tree
vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
}
}
+ if (sym->backend_decl == error_mark_node && actual_args != NULL
+ && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
+ || sym->attr.proc == PROC_UNKNOWN))
+ get_formal_from_actual_arglist (sym, actual_args);
/* Build the argument types for the function. */
for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
Index: trans-types.h
===================================================================
--- trans-types.h (Revision 268968)
+++ trans-types.h (Arbeitskopie)
@@ -88,7 +88,7 @@ tree gfc_sym_type (gfc_symbol *);
tree gfc_typenode_for_spec (gfc_typespec *, int c = 0);
int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
-tree gfc_get_function_type (gfc_symbol *);
+tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL);
tree gfc_type_for_size (unsigned, int);
tree gfc_type_for_mode (machine_mode, int);
Index: trans.h
===================================================================
--- trans.h (Revision 268968)
+++ trans.h (Arbeitskopie)
@@ -580,7 +580,8 @@ void gfc_merge_block_scope (stmtblock_t * block);
tree gfc_get_label_decl (gfc_st_label *);
/* Return the decl for an external function. */
-tree gfc_get_extern_function_decl (gfc_symbol *);
+tree gfc_get_extern_function_decl (gfc_symbol *,
+ gfc_actual_arglist *args = NULL);
/* Return the decl for a function. */
tree gfc_get_function_decl (gfc_symbol *);
! { dg-lto-run }
! { dg-lto-options {{ -Wno-lto-type-mismatch }} }
! PR 87689 - this used to fail for POWER, plus it used to
! give warnings about mismatches with LTO.
! Original test case by Judicaël Grasset.
program main
implicit none
character :: c
character(len=20) :: res, doesntwork_p8
external doesntwork_p8
c = 'o'
res = doesntwork_p8(c,1,2,3,4,5,6)
if (res /= 'foo') stop 3
end program main
function doesntwork_p8(c,a1,a2,a3,a4,a5,a6)
implicit none
character(len=20) :: doesntwork_p8
character :: c
integer :: a1,a2,a3,a4,a5,a6
if (a1 /= 1 .or. a2 /= 2 .or. a3 /= 3 .or. a4 /= 4 .or. a5 /= 5
& .or. a6 /= 6) stop 1
if (c /= 'o ') stop 2
doesntwork_p8 = 'foo'
return
end
