[flang] IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE

flang/include/flang/Evaluate/target.h

@@ -52,6 +52,12 @@ class TargetCharacteristics {
   }
   void set_areSubnormalsFlushedToZero(bool yes = true);
 
+  // Check if a given real kind has flushing control.
+  bool hasSubnormalFlushingControl(int kind) const;
+  // Check if any or all real kinds have flushing control.
+  bool hasSubnormalFlushingControl(bool any = false) const;
+  void set_hasSubnormalFlushingControl(int kind, bool yes = true);
+
   Rounding roundingMode() const { return roundingMode_; }
   void set_roundingMode(Rounding);
 
@@ -111,13 +117,14 @@ class TargetCharacteristics {
   const IeeeFeatures &ieeeFeatures() const { return ieeeFeatures_; }
 
 private:
-  static constexpr int maxKind{32};
-  std::uint8_t byteSize_[common::TypeCategory_enumSize][maxKind]{};
-  std::uint8_t align_[common::TypeCategory_enumSize][maxKind]{};
+  static constexpr int maxKind{16};
+  std::uint8_t byteSize_[common::TypeCategory_enumSize][maxKind + 1]{};
+  std::uint8_t align_[common::TypeCategory_enumSize][maxKind + 1]{};
   bool isBigEndian_{false};
   bool isPPC_{false};
   bool isOSWindows_{false};
   bool areSubnormalsFlushedToZero_{false};
+  bool hasSubnormalFlushingControl_[maxKind + 1]{};
   Rounding roundingMode_{defaultRounding};
   std::size_t procedurePointerByteSize_{8};
   std::size_t procedurePointerAlignment_{8};

flang/include/flang/Lower/PFTBuilder.h

@@ -723,6 +723,7 @@ struct FunctionLikeUnit : public ProgramUnit {
   bool hasIeeeAccess{false};
   bool mayModifyHaltingMode{false};
   bool mayModifyRoundingMode{false};
+  bool mayModifyUnderflowMode{false};
   /// Terminal basic block (if any)
   mlir::Block *finalBlock{};
   HostAssociations hostAssociations;

flang/include/flang/Optimizer/Builder/IntrinsicCall.h

@@ -166,11 +166,6 @@ struct IntrinsicLibrary {
   getRuntimeCallGenerator(llvm::StringRef name,
                           mlir::FunctionType soughtFuncType);
 
-  /// Helper to generate TODOs for module procedures that must be intercepted in
-  /// lowering and are not yet implemented.
-  template <const char *intrinsicName>
-  void genModuleProcTODO(llvm::ArrayRef<fir::ExtendedValue>);
-
   void genAbort(llvm::ArrayRef<fir::ExtendedValue>);
   /// Lowering for the ABS intrinsic. The ABS intrinsic expects one argument in
   /// the llvm::ArrayRef. The ABS intrinsic is lowered into MLIR/FIR operation
@@ -278,6 +273,7 @@ struct IntrinsicLibrary {
   template <bool isGet>
   void genIeeeGetOrSetStatus(llvm::ArrayRef<fir::ExtendedValue>);
   void genIeeeGetRoundingMode(llvm::ArrayRef<fir::ExtendedValue>);
+  void genIeeeGetUnderflowMode(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genIeeeInt(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genIeeeIsFinite(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genIeeeIsNan(mlir::Type, llvm::ArrayRef<mlir::Value>);
@@ -295,6 +291,7 @@ struct IntrinsicLibrary {
   template <bool isFlag>
   void genIeeeSetFlagOrHaltingMode(llvm::ArrayRef<fir::ExtendedValue>);
   void genIeeeSetRoundingMode(llvm::ArrayRef<fir::ExtendedValue>);
+  void genIeeeSetUnderflowMode(llvm::ArrayRef<fir::ExtendedValue>);
   template <mlir::arith::CmpFPredicate pred>
   mlir::Value genIeeeSignalingCompare(mlir::Type resultType,
                                       llvm::ArrayRef<mlir::Value>);

flang/include/flang/Optimizer/Builder/Runtime/Exceptions.h

@@ -26,5 +26,9 @@ namespace fir::runtime {
 mlir::Value genMapExcept(fir::FirOpBuilder &builder, mlir::Location loc,
                          mlir::Value excepts);
 
+mlir::Value genGetUnderflowMode(fir::FirOpBuilder &builder, mlir::Location loc);
+void genSetUnderflowMode(fir::FirOpBuilder &builder, mlir::Location loc,
+                         mlir::Value bit);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_EXCEPTIONS_H

flang/include/flang/Runtime/exceptions.h

@@ -24,6 +24,10 @@ extern "C" {
 // This mapping is done at runtime to support cross compilation.
 std::uint32_t RTNAME(MapException)(std::uint32_t excepts);
 
+// Get and set the ieee underflow mode if supported; otherwise nops.
+bool RTNAME(GetUnderflowMode)(void);
+void RTNAME(SetUnderflowMode)(bool flag);
+
 } // extern "C"
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_EXCEPTIONS_H_

flang/include/flang/Tools/TargetSetup.h

@@ -29,6 +29,11 @@ namespace Fortran::tools {
     targetCharacteristics.DisableType(
         Fortran::common::TypeCategory::Real, /*kind=*/10);
   }
+  if (targetTriple.getArch() == llvm::Triple::ArchType::x86_64) {
+    targetCharacteristics.set_hasSubnormalFlushingControl(/*kind=*/3);
+    targetCharacteristics.set_hasSubnormalFlushingControl(/*kind=*/4);
+    targetCharacteristics.set_hasSubnormalFlushingControl(/*kind=*/8);
+  }
 
   // Figure out if we can support F128: see
   // flang/runtime/Float128Math/math-entries.h

flang/lib/Evaluate/fold-logical.cpp

@@ -890,8 +890,16 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
     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)};
+    // Setting kind=0 checks subnormal flushing control across all type kinds.
+    if (args[0]) {
+      return Expr<T>{
+          context.targetCharacteristics().hasSubnormalFlushingControl(
+              args[0]->GetType().value().kind())};
+    } else {
+      return Expr<T>{
+          context.targetCharacteristics().hasSubnormalFlushingControl(
+              /*any=*/false)};
+    }
   }
   return Expr<T>{std::move(funcRef)};
 }

flang/lib/Evaluate/target.cpp

@@ -17,7 +17,7 @@ Rounding TargetCharacteristics::defaultRounding;
 
 TargetCharacteristics::TargetCharacteristics() {
   auto enableCategoryKinds{[this](TypeCategory category) {
-    for (int kind{0}; kind < maxKind; ++kind) {
+    for (int kind{1}; kind <= maxKind; ++kind) {
       if (CanSupportType(category, kind)) {
         auto byteSize{static_cast<std::size_t>(kind)};
         if (category == TypeCategory::Real ||
@@ -70,14 +70,14 @@ bool TargetCharacteristics::EnableType(common::TypeCategory category,
 
 void TargetCharacteristics::DisableType(
     common::TypeCategory category, std::int64_t kind) {
-  if (kind >= 0 && kind < maxKind) {
+  if (kind > 0 && kind <= maxKind) {
     align_[static_cast<int>(category)][kind] = 0;
   }
 }
 
 std::size_t TargetCharacteristics::GetByteSize(
     common::TypeCategory category, std::int64_t kind) const {
-  if (kind >= 0 && kind < maxKind) {
+  if (kind > 0 && kind <= maxKind) {
     return byteSize_[static_cast<int>(category)][kind];
   } else {
     return 0;
@@ -86,7 +86,7 @@ std::size_t TargetCharacteristics::GetByteSize(
 
 std::size_t TargetCharacteristics::GetAlignment(
     common::TypeCategory category, std::int64_t kind) const {
-  if (kind >= 0 && kind < maxKind) {
+  if (kind > 0 && kind <= maxKind) {
     return align_[static_cast<int>(category)][kind];
   } else {
     return 0;
@@ -108,6 +108,30 @@ void TargetCharacteristics::set_areSubnormalsFlushedToZero(bool yes) {
   areSubnormalsFlushedToZero_ = yes;
 }
 
+// Check if a given real kind has flushing control.
+bool TargetCharacteristics::hasSubnormalFlushingControl(int kind) const {
+  CHECK(kind > 0 && kind <= maxKind);
+  CHECK(CanSupportType(TypeCategory::Real, kind));
+  return hasSubnormalFlushingControl_[kind];
+}
+
+// Check if any or all real kinds have flushing control.
+bool TargetCharacteristics::hasSubnormalFlushingControl(bool any) const {
+  for (int kind{1}; kind <= maxKind; ++kind) {
+    if (CanSupportType(TypeCategory::Real, kind) &&
+        hasSubnormalFlushingControl_[kind] == any) {
+      return any;
+    }
+  }
+  return !any;
+}
+
+void TargetCharacteristics::set_hasSubnormalFlushingControl(
+    int kind, bool yes) {
+  CHECK(kind > 0 && kind <= maxKind);
+  hasSubnormalFlushingControl_[kind] = yes;
+}
+
 void TargetCharacteristics::set_roundingMode(Rounding rounding) {
   roundingMode_ = rounding;
 }

flang/lib/Lower/Bridge.cpp

@@ -39,6 +39,7 @@
 #include "flang/Optimizer/Builder/Runtime/Character.h"
 #include "flang/Optimizer/Builder/Runtime/Derived.h"
 #include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"
+#include "flang/Optimizer/Builder/Runtime/Exceptions.h"
 #include "flang/Optimizer/Builder/Runtime/Main.h"
 #include "flang/Optimizer/Builder/Runtime/Ragged.h"
 #include "flang/Optimizer/Builder/Runtime/Stop.h"
@@ -5181,8 +5182,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
       genOpenMPSymbolProperties(*this, var);
   }
 
-  /// Where applicable, save the exception state and halting and rounding
-  /// modes at function entry and restore them at function exits.
+  /// Where applicable, save the exception state and halting, rounding, and
+  /// underflow modes at function entry, and restore them at function exits.
   void manageFPEnvironment(Fortran::lower::pft::FunctionLikeUnit &funit) {
     mlir::Location loc = toLocation();
     mlir::Location endLoc =
@@ -5224,7 +5225,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
       });
     }
     if (funit.mayModifyRoundingMode) {
-      // F18 Clause 17.4.5: In a procedure [...], the processor shall not
+      // F18 Clause 17.4p5: In a procedure [...], the processor shall not
       // change the rounding modes on entry, and on return shall ensure that
       // the rounding modes are the same as they were on entry.
       mlir::func::FuncOp getRounding =
@@ -5237,6 +5238,18 @@ class FirConverter : public Fortran::lower::AbstractConverter {
         builder->create<fir::CallOp>(endLoc, setRounding, roundingMode);
       });
     }
+    if ((funit.mayModifyUnderflowMode) &&
+        (bridge.getTargetCharacteristics().hasSubnormalFlushingControl(
+            /*any=*/true))) {
+      // F18 Clause 17.5p2: In a procedure [...], the processor shall not
+      // change the underflow mode on entry, and on return shall ensure that
+      // the underflow mode is the same as it was on entry.
+      mlir::Value underflowMode =
+          fir::runtime::genGetUnderflowMode(*builder, loc);
+      bridge.fctCtx().attachCleanup([=]() {
+        fir::runtime::genSetUnderflowMode(*builder, loc, {underflowMode});
+      });
+    }
   }
 
   /// Start translation of a function.

flang/lib/Lower/PFTBuilder.cpp

@@ -161,11 +161,14 @@ class PFTBuilder {
       return;
     if (procName.starts_with("ieee_set_modes_") ||
         procName.starts_with("ieee_set_status_"))
-      proc->mayModifyHaltingMode = proc->mayModifyRoundingMode = true;
+      proc->mayModifyHaltingMode = proc->mayModifyRoundingMode =
+          proc->mayModifyUnderflowMode = true;
     else if (procName.starts_with("ieee_set_halting_mode_"))
       proc->mayModifyHaltingMode = true;
     else if (procName.starts_with("ieee_set_rounding_mode_"))
       proc->mayModifyRoundingMode = true;
+    else if (procName.starts_with("ieee_set_underflow_mode_"))
+      proc->mayModifyUnderflowMode = true;
   }
 
   /// Convert an IfStmt into an IfConstruct, retaining the IfStmt as the

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -95,10 +95,6 @@ static bool isStaticallyPresent(const fir::ExtendedValue &exv) {
   return !isStaticallyAbsent(exv);
 }
 
-/// IEEE module procedure names not yet implemented for genModuleProcTODO.
-static constexpr char ieee_get_underflow_mode[] = "ieee_get_underflow_mode";
-static constexpr char ieee_set_underflow_mode[] = "ieee_set_underflow_mode";
-
 using I = IntrinsicLibrary;
 
 /// Flag to indicate that an intrinsic argument has to be handled as
@@ -328,7 +324,10 @@ static constexpr IntrinsicHandler handlers[]{
        {"radix", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
     {"ieee_get_status", &I::genIeeeGetOrSetStatus</*isGet=*/true>},
-    {"ieee_get_underflow_mode", &I::genModuleProcTODO<ieee_get_underflow_mode>},
+    {"ieee_get_underflow_mode",
+     &I::genIeeeGetUnderflowMode,
+     {{{"gradual", asAddr}}},
+     /*isElemental=*/false},
     {"ieee_int", &I::genIeeeInt},
     {"ieee_is_finite", &I::genIeeeIsFinite},
     {"ieee_is_nan", &I::genIeeeIsNan},
@@ -375,7 +374,7 @@ static constexpr IntrinsicHandler handlers[]{
        {"radix", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
     {"ieee_set_status", &I::genIeeeGetOrSetStatus</*isGet=*/false>},
-    {"ieee_set_underflow_mode", &I::genModuleProcTODO<ieee_set_underflow_mode>},
+    {"ieee_set_underflow_mode", &I::genIeeeSetUnderflowMode},
     {"ieee_signaling_eq",
      &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OEQ>},
     {"ieee_signaling_ge",
@@ -2295,12 +2294,6 @@ mlir::Value IntrinsicLibrary::genConversion(mlir::Type resultType,
   return builder.convertWithSemantics(loc, resultType, args[0]);
 }
 
-template <const char *intrinsicName>
-void IntrinsicLibrary::genModuleProcTODO(
-    llvm::ArrayRef<fir::ExtendedValue> args) {
-  crashOnMissingIntrinsic(loc, intrinsicName);
-}
-
 // ABORT
 void IntrinsicLibrary::genAbort(llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 0);
@@ -4471,6 +4464,14 @@ void IntrinsicLibrary::genIeeeGetOrSetStatus(
   genRuntimeCall(isGet ? "fegetenv" : "fesetenv", i32Ty, addr);
 }
 
+// IEEE_GET_UNDERFLOW_MODE
+void IntrinsicLibrary::genIeeeGetUnderflowMode(
+    llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+  mlir::Value flag = fir::runtime::genGetUnderflowMode(builder, loc);
+  builder.createStoreWithConvert(loc, flag, fir::getBase(args[0]));
+}
+
 // IEEE_INT
 mlir::Value IntrinsicLibrary::genIeeeInt(mlir::Type resultType,
                                          llvm::ArrayRef<mlir::Value> args) {
@@ -5135,6 +5136,15 @@ void IntrinsicLibrary::genIeeeSetRoundingMode(
   builder.create<fir::CallOp>(loc, setRound, mode);
 }
 
+// IEEE_SET_UNDERFLOW_MODE
+void IntrinsicLibrary::genIeeeSetUnderflowMode(
+    llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+  mlir::Value gradual = builder.create<fir::ConvertOp>(loc, builder.getI1Type(),
+                                                       getBase(args[0]));
+  fir::runtime::genSetUnderflowMode(builder, loc, {gradual});
+}
+
 // IEEE_SIGNALING_EQ, IEEE_SIGNALING_GE, IEEE_SIGNALING_GT,
 // IEEE_SIGNALING_LE, IEEE_SIGNALING_LT, IEEE_SIGNALING_NE
 template <mlir::arith::CmpFPredicate pred>

flang/lib/Optimizer/Builder/Runtime/Exceptions.cpp

@@ -20,3 +20,17 @@ mlir::Value fir::runtime::genMapExcept(fir::FirOpBuilder &builder,
       fir::runtime::getRuntimeFunc<mkRTKey(MapException)>(loc, builder)};
   return builder.create<fir::CallOp>(loc, func, excepts).getResult(0);
 }
+
+mlir::Value fir::runtime::genGetUnderflowMode(fir::FirOpBuilder &builder,
+                                              mlir::Location loc) {
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(GetUnderflowMode)>(loc, builder)};
+  return builder.create<fir::CallOp>(loc, func).getResult(0);
+}
+
+void fir::runtime::genSetUnderflowMode(fir::FirOpBuilder &builder,
+                                       mlir::Location loc, mlir::Value flag) {
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(SetUnderflowMode)>(loc, builder)};
+  builder.create<fir::CallOp>(loc, func, flag);
+}

flang/runtime/exceptions.cpp

@@ -11,6 +11,9 @@
 #include "flang/Runtime/exceptions.h"
 #include "terminator.h"
 #include <cfenv>
+#if __x86_64__
+#include <xmmintrin.h>
+#endif
 
 // When not supported, these macro are undefined in cfenv.h,
 // set them to zero in that case.
@@ -78,5 +81,22 @@ uint32_t RTNAME(MapException)(uint32_t excepts) {
 // on some systems, e.g. Solaris, so omit object size comparison for now.
 // TODO: consider femode_t object size comparison once its more mature.
 
+bool RTNAME(GetUnderflowMode)(void) {
+#if __x86_64__
+  // The MXCSR Flush to Zero flag is the negation of the ieee_get_underflow_mode
+  // GRADUAL argument. It affects real computations of kinds 3, 4, and 8.
+  return _MM_GET_FLUSH_ZERO_MODE() == _MM_FLUSH_ZERO_OFF;
+#else
+  return false;
+#endif
+}
+void RTNAME(SetUnderflowMode)(bool flag) {
+#if __x86_64__
+  // The MXCSR Flush to Zero flag is the negation of the ieee_set_underflow_mode
+  // GRADUAL argument. It affects real computations of kinds 3, 4, and 8.
+  _MM_SET_FLUSH_ZERO_MODE(flag ? _MM_FLUSH_ZERO_OFF : _MM_FLUSH_ZERO_ON);
+#endif
+}
+
 } // extern "C"
 } // namespace Fortran::runtime

flang/test/Evaluate/fold-ieee.f90

@@ -58,7 +58,7 @@ module m
   logical, parameter :: test_sn_all = ieee_support_subnormal()
   logical, parameter :: test_sn_4 = ieee_support_subnormal(1.)
   logical, parameter :: test_sn_8 = ieee_support_subnormal(1.d0)
-  logical, parameter :: test_uc_all = ieee_support_underflow_control()
+  logical, parameter :: test_uc_all = .not. ieee_support_underflow_control()
   logical, parameter :: test_uc_4 = ieee_support_underflow_control(1.)
   logical, parameter :: test_uc_8 = ieee_support_underflow_control(1.d0)
 end

flang/test/Evaluate/folding18.f90

@@ -65,11 +65,11 @@ module m
     .and. ieee_support_subnormal(1.0_8) &
     .and. ieee_support_subnormal(1.0_10) &
     .and. ieee_support_subnormal(1.0_16)
-  logical, parameter :: test_ieee_support_underflow_control = ieee_support_underflow_control() &
-    .and. ieee_support_underflow_control(1.0_2) &
+  logical, parameter :: test_ieee_support_underflow_control = .not. ieee_support_underflow_control() &
+    .and. .not. ieee_support_underflow_control(1.0_2) &
     .and. ieee_support_underflow_control(1.0_3) &
     .and. ieee_support_underflow_control(1.0_4) &
     .and. ieee_support_underflow_control(1.0_8) &
-    .and. ieee_support_underflow_control(1.0_10) &
-    .and. ieee_support_underflow_control(1.0_16)
+    .and. .not. ieee_support_underflow_control(1.0_10) &
+    .and. .not. ieee_support_underflow_control(1.0_16)
 end module