[flang] Fold IEEE_SUPPORT_xxx() intrinsic functions

flang/include/flang/Common/Fortran.h

@@ -67,12 +67,14 @@ ENUM_CLASS(
 const char *AsFortran(DefinedIo);
 
 // Floating-point rounding modes; these are packed into a byte to save
-// room in the runtime's format processing context structure.
+// room in the runtime's format processing context structure.  These
+// enumerators are defined with the corresponding values returned from
+// llvm.get.rounding.
 enum class RoundingMode : std::uint8_t {
-  TiesToEven, // ROUND=NEAREST, RN - default IEEE rounding
   ToZero, // ROUND=ZERO, RZ - truncation
-  Down, // ROUND=DOWN, RD
+  TiesToEven, // ROUND=NEAREST, RN - default IEEE rounding
   Up, // ROUND=UP, RU
+  Down, // ROUND=DOWN, RD
   TiesAwayFromZero, // ROUND=COMPATIBLE, RC - ties round away from zero
 };
 

flang/include/flang/Evaluate/common.h

@@ -128,9 +128,9 @@ static constexpr bool Satisfies(RelationalOperator op, Relation relation) {
   return false; // silence g++ warning
 }
 
-ENUM_CLASS(
-    RealFlag, Overflow, DivideByZero, InvalidArgument, Underflow, Inexact)
-
+// These are ordered like the bits in a common fenv.h header file.
+ENUM_CLASS(RealFlag, InvalidArgument, Denorm, DivideByZero, Overflow, Underflow,
+    Inexact)
 using RealFlags = common::EnumSet<RealFlag, RealFlag_enumSize>;
 
 template <typename A> struct ValueWithRealFlags {

flang/include/flang/Evaluate/target.h

@@ -13,6 +13,8 @@
 #define FORTRAN_EVALUATE_TARGET_H_
 
 #include "flang/Common/Fortran.h"
+#include "flang/Common/enum-class.h"
+#include "flang/Common/enum-set.h"
 #include "flang/Evaluate/common.h"
 #include <cstdint>
 
@@ -32,6 +34,11 @@ struct Rounding {
 #endif
 };
 
+ENUM_CLASS(IeeeFeature, Denormal, Divide, Flags, Halting, Inf, Io, NaN,
+    Rounding, Sqrt, Standard, Subnormal, UnderflowControl)
+
+using IeeeFeatures = common::EnumSet<IeeeFeature, 16>;
+
 class TargetCharacteristics {
 public:
   TargetCharacteristics();
@@ -95,6 +102,9 @@ class TargetCharacteristics {
   bool isPPC() const { return isPPC_; }
   void set_isPPC(bool isPPC = false);
 
+  IeeeFeatures &ieeeFeatures() { return ieeeFeatures_; }
+  const IeeeFeatures &ieeeFeatures() const { return ieeeFeatures_; }
+
 private:
   static constexpr int maxKind{32};
   std::uint8_t byteSize_[common::TypeCategory_enumSize][maxKind]{};
@@ -110,6 +120,11 @@ class TargetCharacteristics {
   std::size_t maxAlignment_{8 /*at least*/};
   std::string compilerOptionsString_;
   std::string compilerVersionString_;
+  IeeeFeatures ieeeFeatures_{IeeeFeature::Denormal, IeeeFeature::Divide,
+      IeeeFeature::Flags, IeeeFeature::Halting, IeeeFeature::Inf,
+      IeeeFeature::Io, IeeeFeature::NaN, IeeeFeature::Rounding,
+      IeeeFeature::Sqrt, IeeeFeature::Standard, IeeeFeature::Subnormal,
+      IeeeFeature::UnderflowControl};
 };
 
 } // namespace Fortran::evaluate

flang/include/flang/Evaluate/tools.h

@@ -1320,6 +1320,10 @@ bool IsBuiltinCPtr(const Symbol &);
 bool IsEventType(const DerivedTypeSpec *);
 bool IsLockType(const DerivedTypeSpec *);
 bool IsNotifyType(const DerivedTypeSpec *);
+// Is this derived type IEEE_FLAG_TYPE from module ISO_IEEE_EXCEPTIONS?
+bool IsIeeeFlagType(const DerivedTypeSpec *);
+// Is this derived type IEEE_ROUND_TYPE from module ISO_IEEE_ARITHMETIC?
+bool IsIeeeRoundType(const DerivedTypeSpec *);
 // Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV?
 bool IsTeamType(const DerivedTypeSpec *);
 // Is this derived type TEAM_TYPE, C_PTR, or C_FUNPTR?

flang/lib/Evaluate/fold-logical.cpp

@@ -620,6 +620,24 @@ static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
   return AsExpr(std::move(funcRef));
 }
 
+static std::optional<common::RoundingMode> GetRoundingMode(
+    const std::optional<ActualArgument> &arg) {
+  if (arg) {
+    if (const auto *cst{UnwrapExpr<Constant<SomeDerived>>(*arg)}) {
+      if (auto constr{cst->GetScalarValue()}) {
+        if (StructureConstructorValues & values{constr->values()};
+            values.size() == 1) {
+          const Expr<SomeType> &value{values.begin()->second.value()};
+          if (auto code{ToInt64(value)}) {
+            return static_cast<common::RoundingMode>(*code);
+          }
+        }
+      }
+    }
+  }
+  return std::nullopt;
+}
+
 template <int KIND>
 Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
     FoldingContext &context,
@@ -831,17 +849,48 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
         }
       }
     }
-  } else if (name == "__builtin_ieee_support_datatype" ||
-      name == "__builtin_ieee_support_denormal" ||
-      name == "__builtin_ieee_support_divide" ||
-      name == "__builtin_ieee_support_inf" ||
-      name == "__builtin_ieee_support_io" ||
-      name == "__builtin_ieee_support_nan" ||
-      name == "__builtin_ieee_support_sqrt" ||
-      name == "__builtin_ieee_support_standard" ||
-      name == "__builtin_ieee_support_subnormal" ||
-      name == "__builtin_ieee_support_underflow_control") {
+  } else if (name == "__builtin_ieee_support_datatype") {
     return Expr<T>{true};
+  } else if (name == "__builtin_ieee_support_denormal") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::Denormal)};
+  } else if (name == "__builtin_ieee_support_divide") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::Divide)};
+  } else if (name == "__builtin_ieee_support_flag") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::Flags)};
+  } else if (name == "__builtin_ieee_support_halting") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::Halting)};
+  } else if (name == "__builtin_ieee_support_inf") {
+    return Expr<T>{
+        context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Inf)};
+  } else if (name == "__builtin_ieee_support_io") {
+    return Expr<T>{
+        context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Io)};
+  } else if (name == "__builtin_ieee_support_nan") {
+    return Expr<T>{
+        context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::NaN)};
+  } else if (name == "__builtin_ieee_support_rounding") {
+    if (context.targetCharacteristics().ieeeFeatures().test(
+            IeeeFeature::Rounding)) {
+      if (auto mode{GetRoundingMode(args[0])}) {
+        return Expr<T>{mode != common::RoundingMode::TiesAwayFromZero};
+      }
+    }
+  } else if (name == "__builtin_ieee_support_sqrt") {
+    return Expr<T>{
+        context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Sqrt)};
+  } else if (name == "__builtin_ieee_support_standard") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::Standard)};
+  } else if (name == "__builtin_ieee_support_subnormal") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::Subnormal)};
+  } else if (name == "__builtin_ieee_support_underflow_control") {
+    return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
+        IeeeFeature::UnderflowControl)};
   }
   return Expr<T>{std::move(funcRef)};
 }

flang/lib/Evaluate/intrinsics.cpp

@@ -88,6 +88,8 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
     sameKind,
     operand, // match any kind, with promotion (non-standard)
     typeless, // BOZ literals are INTEGER with this kind
+    ieeeFlagType, // IEEE_FLAG_TYPE from ISO_FORTRAN_EXCEPTION
+    ieeeRoundType, // IEEE_ROUND_TYPE from ISO_FORTRAN_ARITHMETIC
     teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
     kindArg, // this argument is KIND=
     effectiveKind, // for function results: "kindArg" value, possibly defaulted
@@ -121,6 +123,9 @@ static constexpr TypePattern DefaultChar{CharType, KindCode::defaultCharKind};
 static constexpr TypePattern DefaultLogical{
     LogicalType, KindCode::defaultLogicalKind};
 static constexpr TypePattern BOZ{IntType, KindCode::typeless};
+static constexpr TypePattern IeeeFlagType{DerivedType, KindCode::ieeeFlagType};
+static constexpr TypePattern IeeeRoundType{
+    DerivedType, KindCode::ieeeRoundType};
 static constexpr TypePattern TeamType{DerivedType, KindCode::teamType};
 static constexpr TypePattern DoublePrecision{
     RealType, KindCode::doublePrecision};
@@ -940,6 +945,12 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"__builtin_ieee_support_divide",
         {{"x", AnyReal, Rank::elemental, Optionality::optional}},
         DefaultLogical},
+    {"__builtin_ieee_support_flag",
+        {{"flag", IeeeFlagType, Rank::scalar},
+            {"x", AnyReal, Rank::elemental, Optionality::optional}},
+        DefaultLogical},
+    {"__builtin_ieee_support_halting", {{"flag", IeeeFlagType, Rank::scalar}},
+        DefaultLogical},
     {"__builtin_ieee_support_inf",
         {{"x", AnyReal, Rank::elemental, Optionality::optional}},
         DefaultLogical},
@@ -949,6 +960,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"__builtin_ieee_support_nan",
         {{"x", AnyReal, Rank::elemental, Optionality::optional}},
         DefaultLogical},
+    {"__builtin_ieee_support_rounding",
+        {{"round_value", IeeeRoundType, Rank::scalar},
+            {"x", AnyReal, Rank::elemental, Optionality::optional}},
+        DefaultLogical},
     {"__builtin_ieee_support_sqrt",
         {{"x", AnyReal, Rank::elemental, Optionality::optional}},
         DefaultLogical},
@@ -1851,6 +1866,16 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     case KindCode::typeless:
       argOk = false;
       break;
+    case KindCode::ieeeFlagType:
+      argOk = !type->IsUnlimitedPolymorphic() &&
+          type->category() == TypeCategory::Derived &&
+          semantics::IsIeeeFlagType(&type->GetDerivedTypeSpec());
+      break;
+    case KindCode::ieeeRoundType:
+      argOk = !type->IsUnlimitedPolymorphic() &&
+          type->category() == TypeCategory::Derived &&
+          semantics::IsIeeeRoundType(&type->GetDerivedTypeSpec());
+      break;
     case KindCode::teamType:
       argOk = !type->IsUnlimitedPolymorphic() &&
           type->category() == TypeCategory::Derived &&

flang/lib/Evaluate/tools.cpp

@@ -1754,13 +1754,34 @@ bool IsSequenceOrBindCType(const DerivedTypeSpec *derived) {
           derived->typeSymbol().get<DerivedTypeDetails>().sequence());
 }
 
+static bool IsSameModule(const Scope *x, const Scope *y) {
+  if (x == y) {
+    return true;
+  } else if (x && y) {
+    // Allow for a builtin module to be read from distinct paths
+    const Symbol *xSym{x->symbol()};
+    const Symbol *ySym{y->symbol()};
+    if (xSym && ySym && xSym->name() == ySym->name()) {
+      const auto *xMod{xSym->detailsIf<ModuleDetails>()};
+      const auto *yMod{ySym->detailsIf<ModuleDetails>()};
+      if (xMod && yMod) {
+        auto xHash{xMod->moduleFileHash()};
+        auto yHash{yMod->moduleFileHash()};
+        return xHash && yHash && *xHash == *yHash;
+      }
+    }
+  }
+  return false;
+}
+
 bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
-  if (!derived) {
-    return false;
-  } else {
+  if (derived) {
     const auto &symbol{derived->typeSymbol()};
-    return &symbol.owner() == symbol.owner().context().GetBuiltinsScope() &&
-        symbol.name() == "__builtin_"s + name;
+    const Scope &scope{symbol.owner()};
+    return symbol.name() == "__builtin_"s + name &&
+        IsSameModule(&scope, scope.context().GetBuiltinsScope());
+  } else {
+    return false;
   }
 }
 
@@ -1790,6 +1811,14 @@ bool IsNotifyType(const DerivedTypeSpec *derived) {
   return IsBuiltinDerivedType(derived, "notify_type");
 }
 
+bool IsIeeeFlagType(const DerivedTypeSpec *derived) {
+  return IsBuiltinDerivedType(derived, "ieee_flag_type");
+}
+
+bool IsIeeeRoundType(const DerivedTypeSpec *derived) {
+  return IsBuiltinDerivedType(derived, "ieee_round_type");
+}
+
 bool IsTeamType(const DerivedTypeSpec *derived) {
   return IsBuiltinDerivedType(derived, "team_type");
 }

flang/module/__fortran_builtins.f90

@@ -6,6 +6,8 @@
 !
 !===------------------------------------------------------------------------===!
 
+include '../include/flang/Runtime/magic-numbers.h'
+
 ! These naming shenanigans prevent names from Fortran intrinsic modules
 ! from being usable on INTRINSIC statements, and force the program
 ! to USE the standard intrinsic modules in order to access the
@@ -49,6 +51,42 @@
     integer(kind=int64), private :: __count
   end type
 
+  type, public :: __builtin_ieee_flag_type
+    integer(kind=1), private :: flag = 0
+  end type
+
+  type(__builtin_ieee_flag_type), parameter, public :: &
+    __builtin_ieee_invalid = &
+      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INVALID), &
+    __builtin_ieee_overflow = &
+      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_OVERFLOW), &
+    __builtin_ieee_divide_by_zero = &
+      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO), &
+    __builtin_ieee_underflow = &
+      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_UNDERFLOW), &
+    __builtin_ieee_inexact = &
+      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INEXACT), &
+    __builtin_ieee_denorm = & ! extension
+      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DENORM)
+
+  type, public :: __builtin_ieee_round_type
+    integer(kind=1), private :: mode = 0
+  end type
+
+  type(__builtin_ieee_round_type), parameter, public :: &
+    __builtin_ieee_to_zero = &
+      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_TO_ZERO), &
+    __builtin_ieee_nearest = &
+      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_NEAREST), &
+    __builtin_ieee_up = &
+      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_UP), &
+    __builtin_ieee_down = &
+      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_DOWN), &
+    __builtin_ieee_away = &
+      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_AWAY), &
+    __builtin_ieee_other = &
+      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_OTHER)
+
   type, public :: __builtin_team_type
     integer(kind=int64), private :: __id
   end type
@@ -74,8 +112,10 @@
   intrinsic :: __builtin_ieee_selected_real_kind
   intrinsic :: __builtin_ieee_support_datatype, &
     __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
+    __builtin_ieee_support_flag, __builtin_ieee_support_halting, &
     __builtin_ieee_support_inf, __builtin_ieee_support_io, &
-    __builtin_ieee_support_nan, __builtin_ieee_support_sqrt, &
+    __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
+    __builtin_ieee_support_sqrt, &
     __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
     __builtin_ieee_support_underflow_control
   public :: __builtin_fma
@@ -87,8 +127,10 @@
   public :: __builtin_ieee_selected_real_kind
   public :: __builtin_ieee_support_datatype, &
     __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
+    __builtin_ieee_support_flag, __builtin_ieee_support_halting, &
     __builtin_ieee_support_inf, __builtin_ieee_support_io, &
-    __builtin_ieee_support_nan, __builtin_ieee_support_sqrt, &
+    __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
+    __builtin_ieee_support_sqrt, &
     __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
     __builtin_ieee_support_underflow_control