diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 4f3ae82d39c..29be7804e11 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -5981,6 +5981,20 @@ post_call: gfc_add_block_to_block (&parmse->post, &block); } +/* Helper function - generate a memory barrier. */ + +static tree +trans_memory_barrier (void) +{ + tree tmp; + + tmp = gfc_build_string_const (sizeof ("memory"), "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + return tmp; +} /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. @@ -7692,6 +7706,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else conv_base_obj_fcn_val (se, base_object, expr); + /* FIXME: Special handing of ieee_set_rounding_mode - we clobber + memory here to avoid common subexpression moving code past calls + to ieee_set_rounding_mode. This should only be done for + floating point, but currently gcc offers no other possibility. + See PR 108329. */ + + if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC + && strcmp (sym->name, "ieee_set_rounding_mode") == 0) + { + tree tmp = trans_memory_barrier (); + gfc_add_expr_to_block (&post, tmp); + } + /* If there are alternate return labels, function type should be integer. Can't modify the type in place though, since it can be shared with other functions. For dummy arguments, the typing is done to diff --git a/gcc/testsuite/gfortran.dg/rounding_4.f90 b/gcc/testsuite/gfortran.dg/rounding_4.f90 new file mode 100644 index 00000000000..e8799da67dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/rounding_4.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +module y + implicit none + integer, parameter :: wp = selected_real_kind(15) +contains + subroutine foo(a,b,c) + use ieee_arithmetic + real(kind=wp), dimension(4), intent(out) :: a + real(kind=wp), intent(in) :: b, c + type (ieee_round_type), dimension(4), parameter :: mode = & + [ieee_nearest, ieee_to_zero, ieee_up, ieee_down] + call ieee_set_rounding_mode (mode(1)) + a(1) = b + c + call ieee_set_rounding_mode (mode(2)) + a(2) = b + c + call ieee_set_rounding_mode (mode(3)) + a(3) = b + c + call ieee_set_rounding_mode (mode(4)) + a(4) = b + c + end subroutine foo +end module y + +program main + use y + real(kind=wp), dimension(4) :: a + call foo(a,0.1_wp,0.2_wp) + if (a(1) <= a(2)) stop 1 + if (a(3) <= a(4)) stop 2 + if (a(1) /= a(3)) stop 3 + if (a(2) /= a(4)) stop 4 +end program main