| Message ID | 7d637428-5aab-f3f6-e698-ecaf93084c96@netcologne.de |
|---|---|
| State | New |
| Headers | show |
| Series | [fortran] Correct fndecls for some library functions | expand |
> this patch makes sure that we pass the correct fn decls for > some of our library functions. cshift and others still remain > to be implemented. > > This is a step in our voyage to stop lying to the middle end :-) > > Regression-tested. OK for trunk? Ping? (I am not 100% sure this mail ever made it to the mailing list, but it is in the archive at https://gcc.gnu.org/pipermail/fortran/2020-November/055303.html ).
Hi Thomas. Thomas Koenig via Fortran <fortran@gcc.gnu.org> wrote: > >> this patch makes sure that we pass the correct fn decls for >> some of our library functions. cshift and others still remain >> to be implemented. >> This is a step in our voyage to stop lying to the middle end :-) >> Regression-tested. OK for trunk? > > Ping? > > (I am not 100% sure this mail ever made it to the mailing list, > but it is in the archive at > > https://gcc.gnu.org/pipermail/fortran/2020-November/055303.html > > ). Very much in favour of accuracy to the middle end (and ultimately lowering of calls). Is there some testcase that can be used to see a progression from applying this patch? Iain
Hi Iain, > Is there some testcase that can be used to see a progression from > applying this patch? I haven't been able to find anything. Previously, everything was passed as ". r r r r r r" and so on; there were also too many arguments for functions like findloc. Since "r " is the most conservative thing you can do, I suppose it didn't lead to wrong code, at least. Best regards Thomas
Hello Thomas, On 15.11.20 18:52, Thomas Koenig via Fortran wrote: > > this patch makes sure that we pass the correct fn decls for > some of our library functions. cshift and others still remain > to be implemented. Thanks > +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) > ... > + ADD_CHAR ('.'); /* Function return. */ Shouldn't this be ".c" instead of ". " as neither global memory is read nor written to? > + if (expr->rank == 0) > + { > + if (expr->ts.type == BT_CHARACTER) > + { > + ADD_CHAR ('w'); /* Address of character. */ > + ADD_CHAR ('.'); /* Length of character. */ > + } > + } > + else > + ADD_CHAR ('w'); /* Return value is a descriptor. */ shouldn't this be "o"? Otherwise, it looks good to me. Tobias ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter
Hi Thomas, On 25.11.20 12:58, Tobias Burnus wrote: > On 15.11.20 18:52, Thomas Koenig via Fortran wrote: >> +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) >> ... >> + ADD_CHAR ('.'); /* Function return. */ > Shouldn't this be ".c" instead of ". " as neither global memory is > read nor written to? >> + if (expr->rank == 0) >> ... >> + else >> + ADD_CHAR ('w'); /* Return value is a descriptor. */ > shouldn't this be "o"? Scratch that - as it is an array descriptor, "w" is correct – the bounds etc. are not reset. > Otherwise, it looks good to me. Tobias ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter
Am 27.11.20 um 16:46 schrieb Tobias Burnus: > Hi Thomas, > > On 25.11.20 12:58, Tobias Burnus wrote: >> On 15.11.20 18:52, Thomas Koenig via Fortran wrote: >>> +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) >>> ... >>> + ADD_CHAR ('.'); /* Function return. */ >> Shouldn't this be ".c" instead of ". " as neither global memory is >> read nor written to? I tried this, but it led to regressions. Rather than try to find out why exactly, I added a FIXME for later. >>> + if (expr->rank == 0) >>> ... >>> + else >>> + ADD_CHAR ('w'); /* Return value is a descriptor. */ >> shouldn't this be "o"? > Scratch that - as it is an array descriptor, "w" is correct – the bounds > etc. are not reset. >> Otherwise, it looks good to me. Committed as in the attached patch. Thanks for the review! Best regards Thomas diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 71d5c670e55..b556e7598a0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2075,7 +2075,8 @@ 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_actual_arglist *actual_args) +gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) { tree type; tree fndecl; @@ -2287,7 +2288,8 @@ module_sym: mangled_name = gfc_sym_mangled_function_id (sym); } - type = gfc_get_function_type (sym, actual_args); + type = gfc_get_function_type (sym, actual_args, fnspec); + fndecl = build_decl (input_location, FUNCTION_DECL, name, type); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index d17b623924c..bcc13ce79c6 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -40,6 +40,8 @@ along with GCC; see the file COPYING3. If not see #include "trans-types.h" #include "trans-array.h" #include "dependency.h" /* For CAF array alias analysis. */ +#include "attribs.h" + /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ /* This maps Fortran intrinsic math functions to external library or GCC @@ -4257,10 +4259,69 @@ remove_empty_actual_arguments (gfc_actual_arglist **ap) } } +#define MAX_SPEC_ARG 12 + +/* Make up an fn spec that's right for intrinsic functions that we + want to call. */ + +static char * +intrinsic_fnspec (gfc_expr *expr) +{ + static char fnspec_buf[MAX_SPEC_ARG*2+1]; + char *fp; + int i; + int num_char_args; + +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) + + /* Set the fndecl. */ + fp = fnspec_buf; + /* Function return value. FIXME: Check if the second letter could + be something other than a space, for further optimization. */ + ADD_CHAR ('.'); + if (expr->rank == 0) + { + if (expr->ts.type == BT_CHARACTER) + { + ADD_CHAR ('w'); /* Address of character. */ + ADD_CHAR ('.'); /* Length of character. */ + } + } + else + ADD_CHAR ('w'); /* Return value is a descriptor. */ + + num_char_args = 0; + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + { + if (a->expr == NULL) + continue; + + if (a->name && strcmp (a->name,"%VAL") == 0) + ADD_CHAR ('.'); + else + { + if (a->expr->rank > 0) + ADD_CHAR ('r'); + else + ADD_CHAR ('R'); + } + num_char_args += a->expr->ts.type == BT_CHARACTER; + gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2); + } + + for (i = 0; i < num_char_args; i++) + ADD_CHAR ('.'); + + *fp = '\0'; + return fnspec_buf; +} + +#undef MAX_SPEC_ARG +#undef ADD_CHAR + /* Generate the right symbol for the specific intrinsic function and modify the expr accordingly. This assumes that absent optional - arguments should be removed. FIXME: This should be extended for - procedures which do not ignore optional arguments (PR 97454). */ + arguments should be removed. */ gfc_symbol * specific_intrinsic_symbol (gfc_expr *expr) @@ -4278,14 +4339,19 @@ specific_intrinsic_symbol (gfc_expr *expr) gfc_copy_formal_args_intr (sym, expr->value.function.isym, expr->value.function.actual, true); sym->backend_decl - = gfc_get_extern_function_decl (sym, expr->value.function.actual); + = gfc_get_extern_function_decl (sym, expr->value.function.actual, + intrinsic_fnspec (expr)); } + remove_empty_actual_arguments (&(expr->value.function.actual)); return sym; } -/* Generate a call to an external intrinsic function. */ +/* Generate a call to an external intrinsic function. FIXME: So far, + this only works for functions which are called with well-defined + types; CSHIFT and friends will come later. */ + static void gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) { @@ -4302,11 +4368,16 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) switch (expr->value.function.isym->id) { + case GFC_ISYM_ANY: + case GFC_ISYM_ALL: case GFC_ISYM_FINDLOC: case GFC_ISYM_MAXLOC: case GFC_ISYM_MINLOC: case GFC_ISYM_MAXVAL: case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: specific_symbol = true; break; default: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b7129dcbe6d..281cc7d34ab 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -3009,7 +3009,8 @@ create_fn_spec (gfc_symbol *sym, tree fntype) } tree -gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args) +gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) { tree type; vec<tree, va_gc> *typelist = NULL; @@ -3193,7 +3194,19 @@ arg_type_list_done: type = build_varargs_function_type_vec (type, typelist); else type = build_function_type_vec (type, typelist); - type = create_fn_spec (sym, type); + + /* If we were passed an fn spec, add it here, otherwise determine it from + the formal arguments. */ + if (fnspec) + { + tree tmp; + int spec_len = strlen (fnspec); + tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec)); + tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type)); + type = build_type_attribute_variant (type, tmp); + } + else + type = create_fn_spec (sym, type); return type; } diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 56074f1b83b..1b59287996b 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -88,7 +88,8 @@ 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 *, gfc_actual_arglist *args = NULL); +tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL, + const char *fnspec = NULL); tree gfc_type_for_size (unsigned, int); tree gfc_type_for_mode (machine_mode, int); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 16b4215605e..6e417c43e8c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -608,7 +608,8 @@ tree gfc_get_label_decl (gfc_st_label *); /* Return the decl for an external function. */ tree gfc_get_extern_function_decl (gfc_symbol *, - gfc_actual_arglist *args = NULL); + gfc_actual_arglist *args = NULL, + const char *fnspec = NULL); /* Return the decl for a function. */ tree gfc_get_function_decl (gfc_symbol *);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 71d5c670e55..b556e7598a0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2075,7 +2075,8 @@ 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_actual_arglist *actual_args) +gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) { tree type; tree fndecl; @@ -2287,7 +2288,8 @@ module_sym: mangled_name = gfc_sym_mangled_function_id (sym); } - type = gfc_get_function_type (sym, actual_args); + type = gfc_get_function_type (sym, actual_args, fnspec); + fndecl = build_decl (input_location, FUNCTION_DECL, name, type); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e0afc10d105..98230963adc 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -40,6 +40,8 @@ along with GCC; see the file COPYING3. If not see #include "trans-types.h" #include "trans-array.h" #include "dependency.h" /* For CAF array alias analysis. */ +#include "attribs.h" + /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ /* This maps Fortran intrinsic math functions to external library or GCC @@ -4257,10 +4259,67 @@ remove_empty_actual_arguments (gfc_actual_arglist **ap) } } +#define MAX_SPEC_ARG 12 + +/* Make up an fn spec that's right for intrinsic functions that we + want to call. */ + +static char * +intrinsic_fnspec (gfc_expr *expr) +{ + static char fnspec_buf[MAX_SPEC_ARG*2+1]; + char *fp; + int i; + int num_char_args; + +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) + + /* Set the fndecl. */ + fp = fnspec_buf; + ADD_CHAR ('.'); /* Function return. */ + if (expr->rank == 0) + { + if (expr->ts.type == BT_CHARACTER) + { + ADD_CHAR ('w'); /* Address of character. */ + ADD_CHAR ('.'); /* Length of character. */ + } + } + else + ADD_CHAR ('w'); /* Return value is a descriptor. */ + + num_char_args = 0; + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + { + if (a->expr == NULL) + continue; + + if (a->name && strcmp (a->name,"%VAL") == 0) + ADD_CHAR ('.'); + else + { + if (a->expr->rank > 0) + ADD_CHAR ('r'); + else + ADD_CHAR ('R'); + } + num_char_args += a->expr->ts.type == BT_CHARACTER; + gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2); + } + + for (i = 0; i < num_char_args; i++) + ADD_CHAR ('.'); + + *fp = '\0'; + return fnspec_buf; +} + +#undef MAX_SPEC_ARG +#undef ADD_CHAR + /* Generate the right symbol for the specific intrinsic function and modify the expr accordingly. This assumes that absent optional - arguments should be removed. FIXME: This should be extended for - procedures which do not ignore optional arguments (PR 97454). */ + arguments should be removed. */ gfc_symbol * specific_intrinsic_symbol (gfc_expr *expr) @@ -4278,14 +4337,19 @@ specific_intrinsic_symbol (gfc_expr *expr) gfc_copy_formal_args_intr (sym, expr->value.function.isym, expr->value.function.actual, true); sym->backend_decl - = gfc_get_extern_function_decl (sym, expr->value.function.actual); + = gfc_get_extern_function_decl (sym, expr->value.function.actual, + intrinsic_fnspec (expr)); } + remove_empty_actual_arguments (&(expr->value.function.actual)); return sym; } -/* Generate a call to an external intrinsic function. */ +/* Generate a call to an external intrinsic function. FIXME: So far, + this only works for functions which are called with well-defined + types; CSHIFT and friends will come later. */ + static void gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) { @@ -4302,11 +4366,16 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) switch (expr->value.function.isym->id) { + case GFC_ISYM_ANY: + case GFC_ISYM_ALL: case GFC_ISYM_FINDLOC: case GFC_ISYM_MAXLOC: case GFC_ISYM_MINLOC: case GFC_ISYM_MAXVAL: case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: specific_symbol = true; break; default: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b7129dcbe6d..281cc7d34ab 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -3009,7 +3009,8 @@ create_fn_spec (gfc_symbol *sym, tree fntype) } tree -gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args) +gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) { tree type; vec<tree, va_gc> *typelist = NULL; @@ -3193,7 +3194,19 @@ arg_type_list_done: type = build_varargs_function_type_vec (type, typelist); else type = build_function_type_vec (type, typelist); - type = create_fn_spec (sym, type); + + /* If we were passed an fn spec, add it here, otherwise determine it from + the formal arguments. */ + if (fnspec) + { + tree tmp; + int spec_len = strlen (fnspec); + tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec)); + tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type)); + type = build_type_attribute_variant (type, tmp); + } + else + type = create_fn_spec (sym, type); return type; } diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 56074f1b83b..1b59287996b 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -88,7 +88,8 @@ 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 *, gfc_actual_arglist *args = NULL); +tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL, + const char *fnspec = NULL); tree gfc_type_for_size (unsigned, int); tree gfc_type_for_mode (machine_mode, int); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 16b4215605e..6e417c43e8c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -608,7 +608,8 @@ tree gfc_get_label_decl (gfc_st_label *); /* Return the decl for an external function. */ tree gfc_get_extern_function_decl (gfc_symbol *, - gfc_actual_arglist *args = NULL); + gfc_actual_arglist *args = NULL, + const char *fnspec = NULL); /* Return the decl for a function. */ tree gfc_get_function_decl (gfc_symbol *);