This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: rfc: multiple decls for functions
On Tuesday 23 December 2008 01:12:24 Daniel Franke wrote:
> Currently applying the patch and dabbling with it myself ...
Looks good so far. I'm down to one kind of regressions by now :)
It turns out that backend_decls of derived types are not shared between
namespaces (symbol.c, gfc_free_dt_list()). This wasn't a problem as long as,
e.g. a function returning such a type had different decls in different places.
With a unique decl for the function (that got its TYPE in another namespace)
it appears that target and return type are not identical.
A somewhat minimal example of the problem:
MODULE m
TYPE :: t
INTEGER :: i
END TYPE
CONTAINS
FUNCTION bar ()
TYPE(t) :: bar
bar%i = 42
END FUNCTION
END MODULE
USE m
TYPE(t) :: c
c = foo () ! ICE in fold-const.c as the types of C and FOO are different
! and fold-convert doesn't know how to convert RECORD_TYPEs
END
Similar code that doesn't use a module but a main program and a contained
function works as expected.
Please find my (still experimental) patch attached. With this, the testsuite
shows 16 failing testcases [1]. All the ICEs are identical, it is triggered by
above example. The remaining ones are execution errors that might be fixed
together with the problem outlined above or may be numerical issues that
surfaced with inlining.
Cheers
Daniel
[1] List of failing tests, ICE first:
alloc_comp_assign_6.f90
extends_4.f03 -O0
function_kinds_1.f90 -O0
function_types_2.f90 -O
module_function_type_1.f90 -O
used_types_2.f90 -O
used_types_22.f90 -O
used_types_8.f90 -O
gfortran.fortran-torture/execute/entry_8.f90, -O0
default_initialization_3.f90 -O2 execution test
entry_13.f90 -O2 execution test
import.f90 -O3 -fomit-frame-pointer execution test
import4.f90 -O3 -fomit-frame-pointer execution test
integer_exponentiation_3.F90 -O execution test [numerical]
typebound_call_3.f03 -O3 -fomit-frame-pointer execution test
gfortran.fortran-torture/execute/function_module_1.f90 execution
Index: trans.h
===================================================================
--- trans.h (revision 142899)
+++ trans.h (working copy)
@@ -500,6 +500,7 @@ tree gfc_build_library_function_decl (tr
/* somewhere! */
tree pushdecl (tree);
tree pushdecl_top_level (tree);
+tree find_fndecl (tree name);
void pushlevel (int);
tree poplevel (int, int, int);
tree getdecls (void);
Index: f95-lang.c
===================================================================
--- f95-lang.c (revision 142899)
+++ f95-lang.c (working copy)
@@ -490,7 +490,6 @@ pushdecl (tree decl)
/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */
-
tree
pushdecl_top_level (tree x)
{
@@ -503,6 +502,24 @@ pushdecl_top_level (tree x)
return t;
}
+/* Look for a function decl with a given name. */
+tree
+find_fndecl (tree name)
+{
+ struct binding_level *b;
+ tree t;
+
+/*fprintf(stderr, "find_fndecl: looking for %s ... ", name->identifier.id.str);*/
+ for (b = current_binding_level; b; b = b->level_chain)
+ for (t = b->names; t; t = TREE_CHAIN (t))
+ if (TREE_CODE (t) == FUNCTION_DECL && DECL_ASSEMBLER_NAME (t) == name) {
+/* fprintf(stderr, "found\n");*/
+ return t;
+ }
+
+/* fprintf(stderr, "not found\n");*/
+ return NULL_TREE;
+}
/* Clear the binding stack. */
static void
Index: trans-decl.c
===================================================================
--- trans-decl.c (revision 142899)
+++ trans-decl.c (working copy)
@@ -326,18 +326,58 @@ gfc_sym_mangled_function_id (gfc_symbol
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
- if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
- || (sym->module != NULL && (sym->attr.external
- || sym->attr.if_source == IFSRC_IFBODY)))
- {
- /* Main program is mangled into MAIN__. */
- if (sym->attr.is_main_program)
- return get_identifier ("MAIN__");
+ /* Main program is mangled into MAIN__. */
+ if (sym->attr.is_main_program)
+ return get_identifier ("MAIN__");
- /* Intrinsic procedures are never mangled. */
- if (sym->attr.proc == PROC_INTRINSIC)
- return get_identifier (sym->name);
+ /* Intrinsic procedures are never mangled. */
+ if (sym->attr.proc == PROC_INTRINSIC)
+ return get_identifier (sym->name);
+
+ /* Procedures contained within module procedures. */
+ if (/*sym->module == NULL */
+ sym->attr.contained
+ && sym->attr.if_source == IFSRC_DECL
+ && sym->attr.proc == PROC_INTERNAL
+ && sym->ns->proc_name->attr.proc == PROC_MODULE
+ && sym->ns->proc_name->attr.flavor == FL_PROCEDURE
+ && sym->ns->proc_name->ns->proc_name
+ && sym->ns->proc_name->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ snprintf (name, sizeof name, "__%s_MOD_%s_CONT_%s",
+ sym->ns->proc_name->ns->proc_name->name,
+ sym->ns->proc_name->name,
+ sym->name);
+ return get_identifier (name);
+ }
+ /* Module procedures. */
+ if (sym->module != NULL
+ && (sym->attr.if_source == IFSRC_DECL
+ || sym->attr.if_source == IFSRC_IFBODY)
+ && sym->attr.proc == PROC_MODULE
+ && sym->attr.flavor == FL_PROCEDURE
+ && !sym->attr.external)
+ {
+ snprintf (name, sizeof name, "__%s_MOD_%s",
+ sym->module, sym->name);
+ return get_identifier (name);
+ }
+
+ /* Procedures contained in external procedures. */
+ if (sym->module == NULL
+ && sym->attr.proc == PROC_INTERNAL)
+ {
+ snprintf (name, sizeof name, "__%s_CONT_%s",
+ sym->ns->proc_name->name, sym->name);
+ return get_identifier (name);
+ }
+
+ /* External procedures. */
+ if (sym->module == NULL
+ || sym->attr.external
+ || sym->attr.proc == PROC_EXTERNAL)
+ {
if (gfc_option.flag_underscoring)
{
has_underscore = strchr (sym->name, '_') != 0;
@@ -350,11 +390,8 @@ gfc_sym_mangled_function_id (gfc_symbol
else
return get_identifier (sym->name);
}
- else
- {
- snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
- return get_identifier (name);
- }
+
+ gcc_assert(!"name mangling incomplete");
}
@@ -1195,6 +1232,57 @@ get_proc_pointer_decl (gfc_symbol *sym)
}
+static tree
+build_result_decl(gfc_symbol *sym, tree fndecl)
+{
+ /* Figure out the return type of the declared function, and build a
+ RESULT_DECL for it. If this is a subroutine with alternate
+ returns, build a RESULT_DECL for it. */
+
+ tree type, result_decl = NULL_TREE;
+
+ /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
+ if (sym->attr.function)
+ {
+ if (gfc_return_by_reference (sym))
+ type = void_type_node;
+ else
+ {
+ if (sym->result != sym)
+ result_decl = gfc_sym_identifier (sym->result);
+
+ type = TREE_TYPE (TREE_TYPE (fndecl));
+ }
+ }
+ else
+ {
+ /* Look for alternate return placeholders. */
+ gfc_formal_arglist *f;
+ int has_alternate_returns = 0;
+
+ for (f = sym->formal; f; f = f->next)
+ {
+ if (f->sym == NULL)
+ {
+ has_alternate_returns = 1;
+ break;
+ }
+ }
+
+ if (has_alternate_returns)
+ type = integer_type_node;
+ else
+ type = void_type_node;
+ }
+
+ result_decl = build_decl (RESULT_DECL, result_decl, type);
+ DECL_ARTIFICIAL (result_decl) = 1;
+ DECL_IGNORED_P (result_decl) = 1;
+ return result_decl;
+}
+
+
+
/* Get a basic decl for an external function. */
tree
@@ -1275,16 +1363,54 @@ gfc_get_extern_function_decl (gfc_symbol
mangled_name = gfc_sym_mangled_function_id (sym);
}
- type = gfc_get_function_type (sym);
- fndecl = build_decl (FUNCTION_DECL, name, type);
+ /* We try to see if a function decl already exists with this name. */
+ fndecl = find_fndecl (mangled_name);
+ if (fndecl == NULL_TREE)
+ {
+ /* We need to create a new function decl. */
+ type = gfc_get_function_type (sym);
+ fndecl = build_decl (FUNCTION_DECL, name, type);
+ SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
- SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
- /* If the return type is a pointer, avoid alias issues by setting
- DECL_IS_MALLOC to nonzero. This means that the function should be
- treated as if it were a malloc, meaning it returns a pointer that
- is not an alias. */
- if (POINTER_TYPE_P (type))
- DECL_IS_MALLOC (fndecl) = 1;
+/* printf(" --> building decl for called function/subroutine: %s\n", mangled_name->identifier.id.str); */
+
+ /* If the return type is a pointer, avoid alias issues by setting
+ DECL_IS_MALLOC to nonzero. This means that the function should be
+ treated as if it were a malloc, meaning it returns a pointer that
+ is not an alias. */
+ if (POINTER_TYPE_P (type))
+ DECL_IS_MALLOC (fndecl) = 1;
+
+ DECL_EXTERNAL (fndecl) = 1;
+
+ /* This specifies if a function is globally addressable, i.e. it is
+ the opposite of declaring static in C. */
+ TREE_PUBLIC (fndecl) = 1;
+
+ if (DECL_CONTEXT (fndecl) == NULL_TREE)
+ pushdecl_top_level (fndecl);
+ }
+ else
+ {
+ tree result_decl = build_result_decl(sym, fndecl), type = gfc_get_function_type (sym);
+
+/*printf(" --> updating decl for called function/subroutine: %s\n", mangled_name->identifier.id.str);*/
+
+ /* Here we may update TYPE and RESULT information of an external call.
+ For example, if the symbol was used as an actual argument, its type
+ is a VOID_TYPE, however, it might be a function returning a REAL
+ value. To reflect this, the type is updated if necessary. */
+ if (VOID_TYPE_P(TREE_TYPE(TREE_TYPE(fndecl)))
+ && !VOID_TYPE_P(type))
+ TREE_TYPE (fndecl) = type;
+
+ if (DECL_RESULT(fndecl) == NULL_TREE
+ && result_decl != NULL_TREE)
+ {
+ DECL_CONTEXT (result_decl) = fndecl;
+ DECL_RESULT (fndecl) = result_decl;
+ }
+ }
/* Set the context of this decl. */
if (0 && sym->ns && sym->ns->proc_name)
@@ -1298,12 +1424,6 @@ gfc_get_extern_function_decl (gfc_symbol
DECL_CONTEXT (fndecl) = NULL_TREE;
}
- DECL_EXTERNAL (fndecl) = 1;
-
- /* This specifies if a function is globally addressable, i.e. it is
- the opposite of declaring static in C. */
- TREE_PUBLIC (fndecl) = 1;
-
/* Set attributes for PURE functions. A call to PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
@@ -1311,6 +1431,7 @@ gfc_get_extern_function_decl (gfc_symbol
{
if (sym->attr.function && !gfc_return_by_reference (sym))
DECL_PURE_P (fndecl) = 1;
+
/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
parameters and don't use alternate returns (is this
allowed?). In that case, calls to them are meaningless, and
@@ -1323,10 +1444,6 @@ gfc_get_extern_function_decl (gfc_symbol
TREE_THIS_VOLATILE(fndecl) = 1;
sym->backend_decl = fndecl;
-
- if (DECL_CONTEXT (fndecl) == NULL_TREE)
- pushdecl_top_level (fndecl);
-
return fndecl;
}
@@ -1338,10 +1455,7 @@ gfc_get_extern_function_decl (gfc_symbol
static void
build_function_decl (gfc_symbol * sym)
{
- tree fndecl, type;
- symbol_attribute attr;
- tree result_decl;
- gfc_formal_arglist *f;
+ tree fndecl, result_decl, name, mangled_name;
gcc_assert (!sym->backend_decl);
gcc_assert (!sym->attr.external);
@@ -1356,54 +1470,41 @@ build_function_decl (gfc_symbol * sym)
|| TREE_CODE (DECL_CONTEXT (current_function_decl))
== NAMESPACE_DECL);
- type = gfc_get_function_type (sym);
- fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
+ name = gfc_sym_identifier (sym);
+ mangled_name = gfc_sym_mangled_function_id (sym);
+ fndecl = find_fndecl (mangled_name);
- /* Perform name mangling if this is a top level or module procedure. */
- if (current_function_decl == NULL_TREE)
- SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
-
- /* Figure out the return type of the declared function, and build a
- RESULT_DECL for it. If this is a subroutine with alternate
- returns, build a RESULT_DECL for it. */
- attr = sym->attr;
+ /* If we have found a fndecl and it doesn't have a location,
+ it has to be a library function that we're compiling during
+ compilation of libgfortran. The debugger doesn't like that, so
+ we set the location. */
+ if (fndecl && DECL_IS_BUILTIN (fndecl))
+ gfc_set_decl_location (fndecl, &sym->declared_at);
- result_decl = NULL_TREE;
- /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
- if (attr.function)
+ if (fndecl == NULL_TREE)
{
- if (gfc_return_by_reference (sym))
- type = void_type_node;
- else
- {
- if (sym->result != sym)
- result_decl = gfc_sym_identifier (sym->result);
+ tree type = gfc_get_function_type (sym);
+ fndecl = build_decl (FUNCTION_DECL, name, type);
- type = TREE_TYPE (TREE_TYPE (fndecl));
- }
+ SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
+
+/*printf(" --> building decl for function/subroutine: %s\n", gfc_sym_mangled_function_id (sym)->identifier.id.str);*/
+
+ /* Layout the function declaration and put it in the binding level
+ of the current function. */
+ pushdecl (fndecl);
}
- else
+ else if (DECL_EXTERNAL (fndecl))
{
- /* Look for alternate return placeholders. */
- int has_alternate_returns = 0;
- for (f = sym->formal; f; f = f->next)
- {
- if (f->sym == NULL)
- {
- has_alternate_returns = 1;
- break;
- }
- }
+/*printf(" --> updating external decl for function/subroutine: %s\n", gfc_sym_mangled_function_id (sym)->identifier.id.str); */
+ DECL_EXTERNAL (fndecl) = 0;
- if (has_alternate_returns)
- type = integer_type_node;
- else
- type = void_type_node;
+ /* A function that has been seen before, but without proper interface.
+ Here we add the information the explicit interface provides. */
+ TREE_TYPE (fndecl) = gfc_get_function_type (sym);
}
- result_decl = build_decl (RESULT_DECL, result_decl, type);
- DECL_ARTIFICIAL (result_decl) = 1;
- DECL_IGNORED_P (result_decl) = 1;
+ result_decl = build_result_decl(sym, fndecl);
DECL_CONTEXT (result_decl) = fndecl;
DECL_RESULT (fndecl) = result_decl;
@@ -1414,7 +1515,7 @@ build_function_decl (gfc_symbol * sym)
DECL_IS_MALLOC to nonzero. This means that the function should be
treated as if it were a malloc, meaning it returns a pointer that
is not an alias. */
- if (POINTER_TYPE_P (type))
+ if (POINTER_TYPE_P (DECL_RESULT (fndecl)))
DECL_IS_MALLOC (fndecl) = 1;
/* Set up all attributes for the function. */
@@ -1433,26 +1534,22 @@ build_function_decl (gfc_symbol * sym)
/* Set attributes for PURE functions. A call to a PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
- if (attr.pure || attr.elemental)
+ if (sym->attr.pure || sym->attr.elemental)
{
/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
including an alternate return. In that case it can also be
marked as PURE. See also in gfc_get_extern_function_decl(). */
- if (attr.function && !gfc_return_by_reference (sym))
+ if (sym->attr.function && !gfc_return_by_reference (sym))
DECL_PURE_P (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
/* For -fwhole-program to work well, the main program needs to have the
"externally_visible" attribute. */
- if (attr.is_main_program)
+ if (sym->attr.is_main_program)
DECL_ATTRIBUTES (fndecl)
= tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
- /* Layout the function declaration and put it in the binding level
- of the current function. */
- pushdecl (fndecl);
-
sym->backend_decl = fndecl;
}