Patches gfc_conv_procedure_call (+ called functions).
Found via OpenMP_VV which uses rather pointlessly 'if
(omp_is_initial_device() .eqv. .true.)' – instead of using 'if (omp_…())'.
This failed with an ICE as the middle end did not like 'if (<integer(4)>
== <logical(4)>)' comparisons.
The initial idea was to create a new builtin, returning logical(4)
instead of int, but 'logical(4)' is not readily available and adding
support to 5 FE did not seem to be the most sensible.
In addition, I realized that the current code used
__builtin_omp_is_initial_device also when an address was needed, which
the ME does not handle. (It strictly compile-time expands the builtin.)
Thus, I moved it to the call site – plus handle the type conversion if
needed.
[I guess, we eventually want to add support for more builtins. For
instance, acc_on_device would be a candidate, but I could imagine some
additional builtins.]
OK for mainline?
Tobias
Fortran/OpenMP: Fix __builtin_omp_is_initial_device
It turned out that 'if (omp_is_initial_device() .eqv. true)' gave an ICE
due to comparing 'int' with 'logical(4)'. When digging deeper, it also
turned out that when the procedure pointer is needed, the builtin cannot
be used, either. (Follow up to r15-2799-gf1bfba3a9b3f31 )
Fixes additionally the BT_BOOL data type, which was 'char'/integer(1)
instead of bool, backing the booleaness; use bool_type_node as the rest
of GCC.
gcc/fortran/ChangeLog:
* trans-decl.cc (gfc_get_extern_function_decl): Move
__builtin_omp_is_initial_device handling to ...
* trans-expr.cc (get_builtin_fn): ... this new function.
(conv_function_val): Call it; add is_builtin intent-out argument.
(gfc_conv_procedure_call): Use it.
* types.def (BT_BOOL): Fix type by using bool_type_node.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/target-is-initial-device-3.f90: New test.
gcc/fortran/trans-decl.cc | 9 ----
gcc/fortran/trans-expr.cc | 34 ++++++++++++---
gcc/fortran/types.def | 3 +-
.../libgomp.fortran/target-is-initial-device-3.f90 | 50 ++++++++++++++++++++++
4 files changed, 79 insertions(+), 17 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 2586c6d7a79..56b6202510e 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2231,15 +2231,6 @@ gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args,
to know that. */
gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
- if (!gfc_option.disable_omp_is_initial_device
- && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
- && !strcmp (sym->name, "omp_is_initial_device"))
- {
- sym->backend_decl
- = builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
- return sym->backend_decl;
- }
-
if (sym->attr.proc_pointer)
return get_proc_pointer_decl (sym);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9f223a1314a..e27c5e62055 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4381,13 +4381,24 @@ conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
se->expr = build_fold_addr_expr_loc (input_location, se->expr);
}
+static tree
+get_builtin_fn (gfc_symbol * sym)
+{
+ if (!gfc_option.disable_omp_is_initial_device
+ && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
+ && !strcmp (sym->name, "omp_is_initial_device"))
+ return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
+
+ return NULL_TREE;
+}
static void
-conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
- gfc_actual_arglist *actual_args)
+conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
+ gfc_expr * expr, gfc_actual_arglist *actual_args)
{
tree tmp;
+ *is_builtin = false;
if (gfc_is_proc_ptr_comp (expr))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
@@ -4404,9 +4415,13 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
if (!sym->backend_decl)
sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
- TREE_USED (sym->backend_decl) = 1;
-
- tmp = sym->backend_decl;
+ if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
+ *is_builtin = true;
+ else
+ {
+ TREE_USED (sym->backend_decl) = 1;
+ tmp = sym->backend_decl;
+ }
if (sym->attr.cray_pointee)
{
@@ -6324,6 +6339,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist *arg;
int has_alternate_specifier = 0;
bool need_interface_mapping;
+ bool is_builtin;
bool callee_alloc;
bool ulim_copy;
gfc_typespec ts;
@@ -8164,7 +8180,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Generate the actual call. */
if (base_object == NULL_TREE)
- conv_function_val (se, sym, expr, args);
+ conv_function_val (se, &is_builtin, sym, expr, args);
else
conv_base_obj_fcn_val (se, base_object, expr);
@@ -8189,6 +8205,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fntype = TREE_TYPE (TREE_TYPE (se->expr));
se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
+ /* Builtin functions may have a different return type; for instance,
+ omp_is_initial_device is logical(4) but the builtin uses 'int'. */
+ if (is_builtin
+ && TREE_TYPE (TREE_TYPE (sym->backend_decl)) != TREE_TYPE (fntype))
+ se->expr = fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)),
+ se->expr);
/* Allocatable scalar function results must be freed and nullified
after use. This necessitates the creation of a temporary to
hold the result to prevent duplicate calls. */
diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def
index 390cc9542f7..aa61750ec59 100644
--- a/gcc/fortran/types.def
+++ b/gcc/fortran/types.def
@@ -45,8 +45,7 @@ along with GCC; see the file COPYING3. If not see
the type pointed to. */
DEF_PRIMITIVE_TYPE (BT_VOID, void_type_node)
-DEF_PRIMITIVE_TYPE (BT_BOOL,
- (*lang_hooks.types.type_for_size) (BOOL_TYPE_SIZE, 1))
+DEF_PRIMITIVE_TYPE (BT_BOOL, boolean_type_node)
DEF_PRIMITIVE_TYPE (BT_INT, integer_type_node)
DEF_PRIMITIVE_TYPE (BT_UINT, unsigned_type_node)
DEF_PRIMITIVE_TYPE (BT_LONG, long_integer_type_node)
diff --git a/libgomp/testsuite/libgomp.fortran/target-is-initial-device-3.f90 b/libgomp/testsuite/libgomp.fortran/target-is-initial-device-3.f90
new file mode 100644
index 00000000000..3ce24f1757d
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-is-initial-device-3.f90
@@ -0,0 +1,50 @@
+! { dg-additional-options "-fdump-tree-original" }
+!
+! Check that EXPR_EQ works with __builtin_omp_is_initial_device,
+! which returns an 'int' while Fortran uses 'logical(4)'.
+!
+! Check that 'call ff (omp_is_initial_device)' accesses the library
+! function and not the builtin.
+!
+! { dg-final { scan-tree-dump-times "__builtin_omp_is_initial_device \\(\\)" 14 "original" } } */
+! { dg-final { scan-tree-dump "ff \\(omp_is_initial_device\\);" "original" } } */
+!
+program main
+ use omp_lib, only: omp_is_initial_device
+ implicit none (type, external)
+
+ logical(1) :: t1
+ logical(2) :: f2
+ t1 = .true.
+ f2 = .false.
+
+ if (omp_is_initial_device () .eqv. .true.) then
+ else
+ stop 1
+ end if
+ if (omp_is_initial_device () .neqv. .true.) stop 2
+ if (omp_is_initial_device () .eqv. .false.) stop 3
+ if (omp_is_initial_device () .neqv. .false.) then
+ else
+ stop 4
+ end if
+
+ if (omp_is_initial_device () .neqv. .true._1) stop 5
+ if (omp_is_initial_device () .eqv. .false._1) stop 6
+ if (omp_is_initial_device () .neqv. .true._2) stop 7
+ if (omp_is_initial_device () .eqv. .false._2) stop 8
+ if (omp_is_initial_device () .neqv. .true._4) stop 9
+ if (omp_is_initial_device () .eqv. .false._4) stop 10
+ if (omp_is_initial_device () .neqv. .true._8) stop 11
+ if (omp_is_initial_device () .eqv. .false._8) stop 12
+
+ if (omp_is_initial_device () .neqv. t1) stop 13
+ if (omp_is_initial_device () .eqv. f2) stop 14
+
+ call ff (omp_is_initial_device)
+contains
+ subroutine ff(xx)
+ procedure (omp_is_initial_device) :: xx
+ if (.not. xx ()) stop 15
+ end
+end
