[flang] IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE (llvm#118551)

Implement IEEE_GET_UNDERFLOW_MODE and IEEE_SET_UNDERFLOW_MODE. Update
IEEE_SUPPORT_UNDERFLOW_CONTROL to enable support for indvidual REAL
kinds.

Author: vdonaldson

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