[flang] Fold SCALE()

[klausler]

Summary

Fold references to the intrinsic function SCALE().

[jeanPerier]

Please check why windows bot is failing. Code LGTM.

[klausler]

No-op update to see whether spurious Windows buildbot failure was indeed unrelated to this change.

[klausler]

Minor tweak, attempting to dodge mysterious MSVC build issue.

[klausler]

Disable bogus warning from MSVC in unrelated source files that is somehow triggered by this change.

[klausler]

Add nearly redundant test case in attempt to get the pre-merge build bots to wake up and look at the patch again.

[klausler]

Still trying to find a way around a bogus MSVC warning that was triggered by this change.

[klausler]

Iterating; now trying to work around a bogus error message on a reference to a template member function of a template class.

[klausler]

MSVC difficulties are resolved; rebase, reformat, and retest before landing.

flang/include/flang/Evaluate/real.h

public:
   }
 
   static constexpr int DIGITS{binaryPrecision};
   static constexpr int PRECISION{Details::decimalPrecision};
   static constexpr int RANGE{Details::decimalRange};
   static constexpr int MAXEXPONENT{maxExponent - exponentBias};
   static constexpr int MINEXPONENT{2 - exponentBias};
 
+  // SCALE(); also known as IEEE_SCALB and (in IEEE-754 '08) ScaleB.
+  template <typename INT>
+  ValueWithRealFlags<Real> SCALE(
+      const INT &by, Rounding rounding = defaultRounding) const {
+    auto expo{exponentBias + by.ToInt64()};
+    if (IsZero()) {
+      expo = exponentBias; // ignore by, don't overflow
+    } else if (by > INT{maxExponent}) {
+      expo = maxExponent;
+    } else if (by < INT{-exponentBias}) {
+      expo = -1;
+    }
+    Real twoPow;
+    RealFlags flags{
+        twoPow.Normalize(false, static_cast<int>(expo), Fraction::MASKL(1))};
+    ValueWithRealFlags<Real> result{Multiply(twoPow, rounding)};
+    result.flags |= flags;
+    return result;
+  }
+
   constexpr Real FlushSubnormalToZero() const {
     if (IsSubnormal()) {
       return Real{};
     }
     return *this;
   }
 
   // TODO: Configurable NotANumber representations

flang/lib/Evaluate/constant.cpp

std::size_t Constant<SomeDerived>::CopyFrom(const Constant<SomeDerived> &source,
     const std::vector<int> *dimOrder) {
   return Base::CopyFrom(source, count, resultSubscripts, dimOrder);
 }
 
 bool ComponentCompare::operator()(SymbolRef x, SymbolRef y) const {
   return semantics::SymbolSourcePositionCompare{}(x, y);
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 INSTANTIATE_CONSTANT_TEMPLATES
 } // namespace Fortran::evaluate

flang/lib/Evaluate/expression.cpp

return std::visit(
       [](const auto &kx) { return std::decay_t<decltype(kx)>::Result::kind; },
       u);
 }
 
 std::optional<Expr<SubscriptInteger>> Expr<SomeCharacter>::LEN() const {
   return std::visit([](const auto &kx) { return kx.LEN(); }, u);
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 INSTANTIATE_EXPRESSION_TEMPLATES
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-character.cpp

if (newLength < oldLength) {
       folded->first.append(newLength - oldLength, ' ');
     }
     CHECK(static_cast<ConstantSubscript>(folded->first.size()) == newLength);
     return Expr<Result>{Constant<Result>{std::move(folded->first)}};
   }
   return Expr<Result>{std::move(x)};
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 FOR_EACH_CHARACTER_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeCharacter>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-complex.cpp

Expr<Type<TypeCategory::Complex, KIND>> FoldOperation(
   using Result = Type<TypeCategory::Complex, KIND>;
   if (auto folded{OperandsAreConstants(x)}) {
     return Expr<Result>{
         Constant<Result>{Scalar<Result>{folded->first, folded->second}}};
   }
   return Expr<Result>{std::move(x)};
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 FOR_EACH_COMPLEX_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeComplex>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-integer.cpp

 std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {
   if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {
     return ToInt64(*intExpr);
   } else {
     return std::nullopt;
   }
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 FOR_EACH_INTEGER_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeInteger>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-logical.cpp

if (auto folded{OperandsAreConstants(operation)}) {
     case LogicalOperator::Not:
       DIE("not a binary operator");
     }
     return Expr<LOGICAL>{Constant<LOGICAL>{result}};
   }
   return Expr<LOGICAL>{std::move(operation)};
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 FOR_EACH_LOGICAL_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeLogical>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-real.cpp

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") {
     if (auto *expr{args[0].value().UnwrapExpr()}) {
       return ToReal<KIND>(context, std::move(*expr));
     }
+  } else if (name == "scale") {
+    if (const auto *byExpr{UnwrapExpr<Expr<SomeInteger>>(args[1])}) {
+      return std::visit(
+          [&](const auto &byVal) {
+            using TBY = ResultType<decltype(byVal)>;
+            return FoldElementalIntrinsic<T, T, TBY>(context,
+                std::move(funcRef),
+                ScalarFunc<T, T, TBY>(
+                    [&](const Scalar<T> &x, const Scalar<TBY> &y) -> Scalar<T> {
+                      ValueWithRealFlags<Scalar<T>> result{x.
+// MSVC chokes on the keyword "template" here in a call to a
+// member function template.
+#ifndef _MSC_VER
+                                                           template
+#endif
+                                                           SCALE(y)};
+                      if (result.flags.test(RealFlag::Overflow)) {
+                        context.messages().Say(
+                            "SCALE intrinsic folding overflow"_en_US);
+                      }
+                      return result.value;
+                    }));
+          },
+          byExpr->u);
+    }
   } else if (name == "sign") {
     return FoldElementalIntrinsic<T, T, T>(
         context, std::move(funcRef), &Scalar<T>::SIGN);
   } else if (name == "sqrt") {
     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
         ScalarFunc<T, T>(
             [](const Scalar<T> &x) -> Scalar<T> { return x.SQRT().value; }));
   } else if (name == "sum") {
     return FoldSum<T>(context, std::move(funcRef));
   } else if (name == "tiny") {
     return Expr<T>{Scalar<T>::TINY()};
   }
   // TODO: dim, dot_product, fraction, matmul,
-  // modulo, nearest, norm2, rrspacing, scale,
+  // modulo, nearest, norm2, rrspacing,
   // __builtin_next_after/down/up,
   // set_exponent, spacing, transfer,
   // bessel_jn (transformational) and bessel_yn (transformational)
   return Expr<T>{std::move(funcRef)};
 }
 
 template <int KIND>
 Expr<Type<TypeCategory::Real, KIND>> FoldOperation(
if (x.isImaginaryPart) {
       return Expr<Part>{Constant<Part>{value->AIMAG()}};
     } else {
       return Expr<Part>{Constant<Part>{value->REAL()}};
     }
   }
   return Expr<Part>{std::move(x)};
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 FOR_EACH_REAL_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeReal>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/formatting.cpp

std::visit(
             }
             rhs.AsFortran(o << " => ");
           },
       },
       u);
   return o;
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 INSTANTIATE_CONSTANT_TEMPLATES
 INSTANTIATE_EXPRESSION_TEMPLATES
 INSTANTIATE_VARIABLE_TEMPLATES
 } // namespace Fortran::evaluate

flang/lib/Evaluate/variable.cpp

 bool Designator<T>::operator==(const Designator<T> &that) const {
   return TestVariableEquality(*this, that);
 }
 bool DescriptorInquiry::operator==(const DescriptorInquiry &that) const {
   return field_ == that.field_ && base_ == that.base_ &&
       dimension_ == that.dimension_;
 }
 
+#ifdef _MSC_VER // disable bogus warning about missing definitions
+#pragma warning(disable : 4661)
+#endif
 INSTANTIATE_VARIABLE_TEMPLATES
 } // namespace Fortran::evaluate
 
 template class Fortran::common::Indirection<Fortran::evaluate::Component, true>;

flang/test/Evaluate/errors01.f90

subroutine s9
     !CHECK: error: SOURCE= argument to SPREAD has rank 15 but must have rank less than 15
     integer, parameter :: bad1 = spread(rank15, 1, 1)
     integer, parameter :: matrix(2, 2) = reshape([1, 2, 3, 4], [2, 2])
     !CHECK: error: DIM=0 argument to SPREAD must be between 1 and 3
     integer, parameter :: bad2 = spread(matrix, 0, 1)
     !CHECK: error: DIM=4 argument to SPREAD must be between 1 and 3
     integer, parameter :: bad3 = spread(matrix, 4, 1)
   end subroutine
+  subroutine warnings
+    real, parameter :: ok1 = scale(0.0, 99999) ! 0.0
+    real, parameter :: ok2 = scale(1.0, -99999) ! 0.0
+    !CHECK: SCALE intrinsic folding overflow
+    real, parameter :: bad1 = scale(1.0, 99999)
+  end subroutine
 end module

flang/test/Evaluate/fold-scale.f90

+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of SCALE()
+module m
+  logical, parameter :: test_1 = scale(1.0, 1) == 2.0
+  logical, parameter :: test_2 = scale(0.0, 1) == 0.0
+  logical, parameter :: test_3 = sign(1.0, scale(-0.0, 1)) == -1.0
+  logical, parameter :: test_4 = sign(1.0, scale(0.0, 0)) == 1.0
+  logical, parameter :: test_5 = scale(1.0, -1) == 0.5
+  logical, parameter :: test_6 = scale(2.0, -1) == 1.0
+end module
+