Hello world,
the attached patch fixes PR 90813, a regression with proc pointers.
The problem was quite complex, and I'd like to thank the people
who helped debug this; the most important clue came from Richard.
The problem was that, for a procedure pointer variable declared
in a module in the same file, we were using a different backend
decl in the module than in the main program. This led to the
later parts of the compiler to think that the procedure pointer
was actually two variables which could not alias. Optimization
on some architectures such as Aarch64 and POWER (but not
on x86_64) then led to reordering of stores, leading to a segfault.
The solution is to put the mangled names into the global
variable table, and to look for it when getting its backend
declaration.
While debugging it, I also put in an option to dump the global
symbol table to standard output. I have included this in this
patch because I think this may not be the last bug in that
area :-)
Regression-tested on powerpc64le-unknown-linux-gnu, where the
segfault showed up. No test case because is is already
in the test suite. Doc changes checked with "make dvi" and
"make pdf".
OK for trunk?
Regards
Thomas
2019-07-28 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/90813
* dump-parse-tree.c (show_global_symbol): New function.
(gfc_dump_global_symbols): New function.
* gfortran.h (gfc_traverse_gsymbol): Add prototype.
(gfc_dump_global_symbols): Likewise.
* invoke.texi: Document -fdump-fortran-global.
* lang.opt: Add -fdump-fortran-global.
* parse.c (gfc_parse_file): Handle flag_dump_fortran_global.
* symbol.c (gfc_traverse_gsymbol): New function.
* trans-decl.c (sym_identifier): New function.
(mangled_identifier): New function, doing most of the work
of gfc_sym_mangled_identifier.
(gfc_sym_mangled_identifier): Use mangled_identifier. Add mangled
identifier to global symbol table.
(get_proc_pointer_decl): Use backend decl from global identifier
if present.
Index: dump-parse-tree.c
===================================================================
--- dump-parse-tree.c (Revision 273855)
+++ dump-parse-tree.c (Arbeitskopie)
@@ -3462,3 +3462,36 @@ write_interop_decl (gfc_symbol *sym)
else if (sym->attr.flavor == FL_PROCEDURE)
write_proc (sym, true);
}
+
+/* This section deals with dumping the global symbol tree. */
+
+/* Callback function for printing out the contents of the tree. */
+
+static void
+show_global_symbol (gfc_gsymbol *gsym, void *f_data)
+{
+ FILE *out;
+ out = (FILE *) f_data;
+
+ if (gsym->name)
+ fprintf (out, "name=%s", gsym->name);
+
+ if (gsym->sym_name)
+ fprintf (out, ", sym_name=%s", gsym->sym_name);
+
+ if (gsym->mod_name)
+ fprintf (out, ", mod_name=%s", gsym->mod_name);
+
+ if (gsym->binding_label)
+ fprintf (out, ", binding_label=%s", gsym->binding_label);
+
+ fputc ('\n', out);
+}
+
+/* Show all global symbols. */
+
+void
+gfc_dump_global_symbols (FILE *f)
+{
+ gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f);
+}
Index: gfortran.h
===================================================================
--- gfortran.h (Revision 273855)
+++ gfortran.h (Arbeitskopie)
@@ -3128,6 +3128,7 @@ void gfc_enforce_clean_symbol_state (void);
gfc_gsymbol *gfc_get_gsymbol (const char *, bool bind_c);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_gsymbol *gfc_find_case_gsymbol (gfc_gsymbol *, const char *);
+void gfc_traverse_gsymbol (gfc_gsymbol *, void (*)(gfc_gsymbol *, void *), void *);
gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
@@ -3471,6 +3472,7 @@ void gfc_delete_bbt (void *, void *, compare_fn);
void gfc_dump_parse_tree (gfc_namespace *, FILE *);
void gfc_dump_c_prototypes (gfc_namespace *, FILE *);
void gfc_dump_external_c_prototypes (FILE *);
+void gfc_dump_global_symbols (FILE *);
/* parse.c */
bool gfc_parse_file (void);
Index: invoke.texi
===================================================================
--- invoke.texi (Revision 273855)
+++ invoke.texi (Arbeitskopie)
@@ -157,7 +157,8 @@ and warnings}.
@item Debugging Options
@xref{Debugging Options,,Options for debugging your program or GNU Fortran}.
@gccoptlist{-fbacktrace -fdump-fortran-optimized -fdump-fortran-original @gol
--fdump-parse-tree -ffpe-trap=@var{list} -ffpe-summary=@var{list}
+-fdump-fortran-global -fdump-parse-tree -ffpe-trap=@var{list} @gol
+-ffpe-summary=@var{list}
}
@item Directory Options
@@ -1199,6 +1200,14 @@ change between releases. This option may also gene
compiler errors for features which have only recently been added. This
option is deprecated; use @code{-fdump-fortran-original} instead.
+@item -fdump-fortran-global
+@opindex @code{fdump-fortran-global}
+Output a list of the global identifiers after translating into
+middle-end representation. Mostly useful for debugging the GNU Fortran
+compiler itself. The output generated by this option might change
+between releases. This option may also generate internal compiler
+errors for features which have only recently been added.
+
@item -ffpe-trap=@var{list}
@opindex @code{ffpe-trap=}@var{list}
Specify a list of floating point exception traps to enable. On most
Index: lang.opt
===================================================================
--- lang.opt (Revision 273855)
+++ lang.opt (Arbeitskopie)
@@ -512,6 +512,10 @@ fdump-fortran-optimized
Fortran Var(flag_dump_fortran_optimized)
Display the code tree after front end optimization.
+fdump-fortran-global
+Fortran Var(flag_dump_fortran_global)
+Display the global symbol table after parsing.
+
fdump-parse-tree
Fortran Alias(fdump-fortran-original)
Display the code tree after parsing; deprecated option.
Index: parse.c
===================================================================
--- parse.c (Revision 273855)
+++ parse.c (Arbeitskopie)
@@ -6366,6 +6366,13 @@ done:
/* Do the translation. */
translate_all_program_units (gfc_global_ns_list);
+ /* Dump the global symbol ist. We only do this here because part
+ of it is generated after mangling the identifiers in
+ trans-decl.c. */
+
+ if (flag_dump_fortran_global)
+ gfc_dump_global_symbols (stdout);
+
gfc_end_source_files ();
return true;
Index: symbol.c
===================================================================
--- symbol.c (Revision 273855)
+++ symbol.c (Arbeitskopie)
@@ -4357,7 +4357,20 @@ gfc_get_gsymbol (const char *name, bool bind_c)
return s;
}
+void
+gfc_traverse_gsymbol (gfc_gsymbol *gsym,
+ void (*do_something) (gfc_gsymbol *, void *),
+ void *data)
+{
+ if (gsym->left)
+ gfc_traverse_gsymbol (gsym->left, do_something, data);
+ (*do_something) (gsym, data);
+
+ if (gsym->right)
+ gfc_traverse_gsymbol (gsym->right, do_something, data);
+}
+
static gfc_symbol *
get_iso_c_binding_dt (int sym_id)
{
Index: trans-decl.c
===================================================================
--- trans-decl.c (Revision 273855)
+++ trans-decl.c (Arbeitskopie)
@@ -345,39 +345,45 @@ gfc_get_label_decl (gfc_st_label * lp)
}
}
+/* Return the name of an identifier. */
+static const char *
+sym_identifier (gfc_symbol *sym)
+{
+ if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+ return "MAIN__";
+ else
+ return sym->name;
+}
+
/* Convert a gfc_symbol to an identifier of the same name. */
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
- if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
- return (get_identifier ("MAIN__"));
- else
- return (get_identifier (sym->name));
+ return get_identifier (sym_identifier (sym));
}
+/* Construct mangled name from symbol name. */
-/* Construct mangled name from symbol name. */
-
-static tree
-gfc_sym_mangled_identifier (gfc_symbol * sym)
+static const char *
+mangled_identifier (gfc_symbol *sym)
{
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
-
+ static char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
/* Prevent the mangling of identifiers that have an assigned
binding label (mainly those that are bind(c)). */
+
if (sym->attr.is_bind_c == 1 && sym->binding_label)
- return get_identifier (sym->binding_label);
+ return sym->binding_label;
if (!sym->fn_result_spec)
{
if (sym->module == NULL)
- return gfc_sym_identifier (sym);
+ return sym_identifier (sym);
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
- return get_identifier (name);
+ return name;
}
}
else
@@ -392,18 +398,41 @@ gfc_sym_identifier (gfc_symbol * sym)
sym->ns->proc_name->module,
sym->ns->proc_name->name,
sym->name);
- return get_identifier (name);
+ return name;
}
else
{
snprintf (name, sizeof name, "__%s_PROC_%s",
sym->ns->proc_name->name, sym->name);
- return get_identifier (name);
+ return name;
}
}
}
+/* Get mangled identifier, adding the symbol to the global table if
+ it is not yet already there. */
+static tree
+gfc_sym_mangled_identifier (gfc_symbol * sym)
+{
+ tree result;
+ gfc_gsymbol *gsym;
+ const char *name;
+
+ name = mangled_identifier (sym);
+ result = get_identifier (name);
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym == NULL)
+ {
+ gsym = gfc_get_gsymbol (name, false);
+ gsym->ns = sym->ns;
+ gsym->sym_name = sym->name;
+ }
+
+ return result;
+}
+
/* Construct mangled function name from symbol name. */
static tree
@@ -1914,6 +1943,22 @@ get_proc_pointer_decl (gfc_symbol *sym)
tree decl;
tree attributes;
+ if (sym->module || sym->fn_result_spec)
+ {
+ const char *name;
+ gfc_gsymbol *gsym;
+
+ name = mangled_identifier (sym);
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym != NULL)
+ {
+ gfc_symbol *s;
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ return s->backend_decl;
+ }
+ }
+
decl = sym->backend_decl;
if (decl)
return decl;
