[flang] Fold real-valued MODULO() and MOD()

[klausler]

Summary

Evaluate real-valued references to the intrinsic functions MODULO
and MOD at compilation time without recourse to an external math
library.

flang/include/flang/Evaluate/real.h

ValueWithRealFlags<Real> Subtract(
     return Add(y.Negate(), rounding);
   }
   ValueWithRealFlags<Real> Multiply(
       const Real &, Rounding rounding = defaultRounding) const;
   ValueWithRealFlags<Real> Divide(
       const Real &, Rounding rounding = defaultRounding) const;
 
   ValueWithRealFlags<Real> SQRT(Rounding rounding = defaultRounding) const;
-
   // NEAREST(), IEEE_NEXT_AFTER(), IEEE_NEXT_UP(), and IEEE_NEXT_DOWN()
   ValueWithRealFlags<Real> NEAREST(bool upward) const;
-
   // HYPOT(x,y)=SQRT(x**2 + y**2) computed so as to avoid spurious
   // intermediate overflows.
   ValueWithRealFlags<Real> HYPOT(
       const Real &, Rounding rounding = defaultRounding) const;
+  // DIM(X,Y) = MAX(X-Y, 0)
+  ValueWithRealFlags<Real> DIM(
+      const Real &, Rounding rounding = defaultRounding) const;
+  // MOD(x,y) = x - AINT(x/y)*y
+  // MODULO(x,y) = x - FLOOR(x/y)*y
+  ValueWithRealFlags<Real> MOD(
+      const Real &, Rounding rounding = defaultRounding) const;
+  ValueWithRealFlags<Real> MODULO(
+      const Real &, Rounding rounding = defaultRounding) const;
 
   // DIM(X,Y) = MAX(X-Y, 0)
   ValueWithRealFlags<Real> DIM(
       const Real &, Rounding rounding = defaultRounding) const;
 
   template <typename INT> constexpr INT EXPONENT() const {
     if (Exponent() == maxExponent) {
       return INT::HUGE();

flang/lib/Evaluate/fold-real.cpp

if (auto callable{GetHostRuntimeWrapper<T, T>(name)}) {
           context, std::move(funcRef), *callable);
     } else {
       context.messages().Say(
           "%s(real(kind=%d)) cannot be folded on host"_warn_en_US, name, KIND);
     }
   } else if (name == "amax0" || name == "amin0" || name == "amin1" ||
       name == "amax1" || name == "dmin1" || name == "dmax1") {
     return RewriteSpecificMINorMAX(context, std::move(funcRef));
-  } else if (name == "atan" || name == "atan2" || name == "mod") {
+  } else if (name == "atan" || name == "atan2") {
     std::string localName{name == "atan" ? "atan2" : name};
     CHECK(args.size() == 2);
     if (auto callable{GetHostRuntimeWrapper<T, T, T>(localName)}) {
       return FoldElementalIntrinsic<T, T, T>(
           context, std::move(funcRef), *callable);
     } else {
       context.messages().Say(
           "%s(real(kind=%d), real(kind%d)) cannot be folded on host"_warn_en_US,
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
             }));
   } else if (name == "max") {
     return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
   } else if (name == "maxval") {
     return FoldMaxvalMinval<T>(context, std::move(funcRef),
         RelationalOperator::GT, T::Scalar::HUGE().Negate());
   } else if (name == "merge") {
     return FoldMerge<T>(context, std::move(funcRef));
+  } else if (name == "min") {
+    return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
+  } else if (name == "minval") {
+    return FoldMaxvalMinval<T>(
+        context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE());
+  } else if (name == "mod") {
+    CHECK(args.size() == 2);
+    return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
+        ScalarFunc<T, T, T>(
+            [&context](const Scalar<T> &x, const Scalar<T> &y) -> Scalar<T> {
+              auto result{x.MOD(y)};
+              if (result.flags.test(RealFlag::DivideByZero)) {
+                context.messages().Say(
+                    "second argument to MOD must not be zero"_warn_en_US);
+              }
+              return result.value;
+            }));
+  } else if (name == "modulo") {
+    CHECK(args.size() == 2);
+    return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
+        ScalarFunc<T, T, T>(
+            [&context](const Scalar<T> &x, const Scalar<T> &y) -> Scalar<T> {
+              auto result{x.MODULO(y)};
+              if (result.flags.test(RealFlag::DivideByZero)) {
+                context.messages().Say(
+                    "second argument to MODULO must not be zero"_warn_en_US);
+              }
+              return result.value;
+            }));
   } else if (name == "nearest") {
     if (const auto *sExpr{UnwrapExpr<Expr<SomeReal>>(args[1])}) {
       return common::visit(
           [&](const auto &sVal) {
             using TS = ResultType<decltype(sVal)>;
             return FoldElementalIntrinsic<T, T, TS>(context, std::move(funcRef),
                 ScalarFunc<T, T, TS>([&](const Scalar<T> &x,
                                          const Scalar<TS> &s) -> Scalar<T> {
if (const auto *sExpr{UnwrapExpr<Expr<SomeReal>>(args[1])}) {
                     context.messages().Say(
                         "NEAREST intrinsic folding: bad argument"_warn_en_US);
                   }
                   return result.value;
                 }));
           },
           sExpr->u);
     }
-  } else if (name == "min") {
-    return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
-  } else if (name == "minval") {
-    return FoldMaxvalMinval<T>(
-        context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE());
   } else if (name == "product") {
     auto one{Scalar<T>::FromInteger(value::Integer<8>{1}).value};
     return FoldProduct<T>(context, std::move(funcRef), one);
   } else if (name == "real" || name == "dble") {
     if (auto *expr{args[0].value().UnwrapExpr()}) {
       return ToReal<KIND>(context, std::move(*expr));
     }
   } else if (name == "rrspacing") {

flang/lib/Evaluate/intrinsics-library.cpp

static constexpr HostRuntimeFunction table[]{
       FolderFactory<F, F{std::cosh}>::Create("cosh"),
       FolderFactory<F, F{std::erf}>::Create("erf"),
       FolderFactory<F, F{std::erfc}>::Create("erfc"),
       FolderFactory<F, F{std::exp}>::Create("exp"),
       FolderFactory<F, F{std::tgamma}>::Create("gamma"),
       FolderFactory<F, F{std::log}>::Create("log"),
       FolderFactory<F, F{std::log10}>::Create("log10"),
       FolderFactory<F, F{std::lgamma}>::Create("log_gamma"),
-      FolderFactory<F2, F2{std::fmod}>::Create("mod"),
       FolderFactory<F2, F2{std::pow}>::Create("pow"),
       FolderFactory<F, F{std::sin}>::Create("sin"),
       FolderFactory<F, F{std::sinh}>::Create("sinh"),
       FolderFactory<F, F{std::tan}>::Create("tan"),
       FolderFactory<F, F{std::tanh}>::Create("tanh"),
   };
   // Note: cmath does not have modulo and erfc_scaled equivalent
 

flang/lib/Evaluate/real.cpp

if (IsNotANumber() || y.IsNotANumber()) {
     result = sqrt.value.Multiply(ABS(), rounding);
     if (inexact) {
       result.flags.set(RealFlag::Inexact);
     }
   }
   return result;
 }
 
+// MOD(x,y) = x - AINT(x/y)*y
+template <typename W, int P>
+ValueWithRealFlags<Real<W, P>> Real<W, P>::MOD(
+    const Real &y, Rounding rounding) const {
+  ValueWithRealFlags<Real> result;
+  Real quotient{Divide(y, rounding).AccumulateFlags(result.flags)};
+  Real toInt{quotient.ToWholeNumber(common::RoundingMode::ToZero)
+                 .AccumulateFlags(result.flags)};
+  Real product{toInt.Multiply(y, rounding).AccumulateFlags(result.flags)};
+  result.value = Subtract(product, rounding).AccumulateFlags(result.flags);
+  return result;
+}
+
+// MODULO(x,y) = x - FLOOR(x/y)*y
+template <typename W, int P>
+ValueWithRealFlags<Real<W, P>> Real<W, P>::MODULO(
+    const Real &y, Rounding rounding) const {
+  ValueWithRealFlags<Real> result;
+  Real quotient{Divide(y, rounding).AccumulateFlags(result.flags)};
+  Real toInt{quotient.ToWholeNumber(common::RoundingMode::Down)
+                 .AccumulateFlags(result.flags)};
+  Real product{toInt.Multiply(y, rounding).AccumulateFlags(result.flags)};
+  result.value = Subtract(product, rounding).AccumulateFlags(result.flags);
+  return result;
+}
+
 template <typename W, int P>
 ValueWithRealFlags<Real<W, P>> Real<W, P>::DIM(
     const Real &y, Rounding rounding) const {
   ValueWithRealFlags<Real> result;
   if (IsNotANumber() || y.IsNotANumber()) {
     result.flags.set(RealFlag::InvalidArgument);
     result.value = NotANumber();
   } else if (Compare(y) == Relation::Greater) {

flang/test/Evaluate/fold-mod.f90

+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of integer and real MOD and MODULO
+module m1
+  logical, parameter :: test_mod_i1 = mod(8, 5) == 3
+  logical, parameter :: test_mod_i2 = mod(-8, 5) == -3
+  logical, parameter :: test_mod_i3 = mod(8, -5) == 3
+  logical, parameter :: test_mod_i4 = mod(-8, -5) == -3
+
+  logical, parameter :: test_mod_r1 = mod(3., 2.) == 1.
+  logical, parameter :: test_mod_r2 = mod(8., 5.) == 3.
+  logical, parameter :: test_mod_r3 = mod(-8., 5.) == -3.
+  logical, parameter :: test_mod_r4 = mod(8., -5.) == 3.
+  logical, parameter :: test_mod_r5 = mod(-8., -5.) == -3.
+
+  logical, parameter :: test_modulo_i1 = modulo(8, 5) == 3
+  logical, parameter :: test_modulo_i2 = modulo(-8, 5) == 2
+  logical, parameter :: test_modulo_i3 = modulo(8, -5) == -2
+  logical, parameter :: test_modulo_i4 = modulo(-8, -5) == -3
+
+  logical, parameter :: test_modulo_r1 = modulo(8., 5.) == 3.
+  logical, parameter :: test_modulo_r2 = modulo(-8., 5.) == 2.
+  logical, parameter :: test_modulo_r3 = modulo(8., -5.) == -2.
+  logical, parameter :: test_modulo_r4 = modulo(-8., -5.) == -3.
+end module

flang/test/Evaluate/folding04.f90

module real_tests
   real(4), parameter :: nan_r4_acos3 = acos(r4_nmax)
   TEST_ISNAN(nan_r4_acos3)
   !WARN: warning: invalid argument on intrinsic function
   real(4), parameter :: nan_r4_acos4 = acos(r4_ninf)
   TEST_ISNAN(nan_r4_acos4)
   !WARN: warning: invalid argument on intrinsic function
   real(4), parameter :: nan_r4_acos5 = acos(r4_pinf)
   TEST_ISNAN(nan_r4_acos5)
+  !WARN: warning: second argument to MOD must not be zero
+  real(4), parameter :: nan_r4_mod = mod(3.5, 0.)
+  TEST_ISNAN(nan_r4_mod)
 
   !WARN: warning: overflow on intrinsic function
   logical, parameter :: test_exp_overflow = exp(256._4).EQ.r4_pinf
 end module
 
 module parentheses
   ! Test parentheses in folding (they are kept around constants to keep the
   ! distinction between variable and expressions and require special care).