[flang] Modifications to ieee floating point environment procedures

flang/include/flang/Evaluate/target.h

@@ -112,6 +112,9 @@ class TargetCharacteristics {
   bool isPPC() const { return isPPC_; }
   void set_isPPC(bool isPPC = false);
 
+  bool isSPARC() const { return isSPARC_; }
+  void set_isSPARC(bool isSPARC = false);
+
   bool isOSWindows() const { return isOSWindows_; }
   void set_isOSWindows(bool isOSWindows = false) {
     isOSWindows_ = isOSWindows;
@@ -126,6 +129,7 @@ class TargetCharacteristics {
   std::uint8_t align_[common::TypeCategory_enumSize][maxKind + 1]{};
   bool isBigEndian_{false};
   bool isPPC_{false};
+  bool isSPARC_{false};
   bool isOSWindows_{false};
   bool haltingSupportIsUnknownAtCompileTime_{false};
   bool areSubnormalsFlushedToZero_{false};

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

@@ -269,10 +269,8 @@ struct IntrinsicLibrary {
   mlir::Value genIeeeCopySign(mlir::Type, llvm::ArrayRef<mlir::Value>);
   void genIeeeGetFlag(llvm::ArrayRef<fir::ExtendedValue>);
   void genIeeeGetHaltingMode(llvm::ArrayRef<fir::ExtendedValue>);
-  template <bool isGet>
-  void genIeeeGetOrSetModes(llvm::ArrayRef<fir::ExtendedValue>);
-  template <bool isGet>
-  void genIeeeGetOrSetStatus(llvm::ArrayRef<fir::ExtendedValue>);
+  template <bool isGet, bool isModes>
+  void genIeeeGetOrSetModesOrStatus(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>);

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

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

flang/include/flang/Runtime/exceptions.h

@@ -13,6 +13,7 @@
 
 #include "flang/Runtime/entry-names.h"
 #include <cinttypes>
+#include <cstddef>
 
 namespace Fortran::runtime {
 
@@ -32,6 +33,10 @@ bool RTNAME(SupportHalting)(uint32_t except);
 bool RTNAME(GetUnderflowMode)(void);
 void RTNAME(SetUnderflowMode)(bool flag);
 
+// Get the byte size of ieee_modes_type and ieee_status_type data.
+std::size_t RTNAME(GetModesTypeSize)(void);
+std::size_t RTNAME(GetStatusTypeSize)(void);
+
 } // extern "C"
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_EXCEPTIONS_H_

flang/include/flang/Runtime/magic-numbers.h

@@ -118,11 +118,10 @@ ieee_arithmetic module rounding procedures.
 #define _FORTRAN_RUNTIME_IEEE_OTHER 5
 
 #if 0
-The size of derived types ieee_modes_type and ieee_status_type from intrinsic
-module ieee_exceptions must be large enough to hold an fenv.h object of type
-femode_t and fenv_t, respectively. These types have members that are declared
-as int arrays with the following extents to allow build time validation of
-these sizes in cross compilation environments.
+INTEGER(kind=4) extents for ieee_exceptions module types ieee_modes_type and
+ieee_status_type. These extent values are large enough to hold femode_t and
+fenv_t data in many environments. An environment that does not meet these
+size constraints may allocate memory with runtime size values.
 #endif
 #define _FORTRAN_RUNTIME_IEEE_FEMODE_T_EXTENT 2
 #define _FORTRAN_RUNTIME_IEEE_FENV_T_EXTENT 8

flang/include/flang/Tools/TargetSetup.h

@@ -71,6 +71,9 @@ namespace Fortran::tools {
   if (targetTriple.isPPC())
     targetCharacteristics.set_isPPC(true);
 
+  if (targetTriple.isSPARC())
+    targetCharacteristics.set_isSPARC(true);
+
   if (targetTriple.isOSWindows())
     targetCharacteristics.set_isOSWindows(true);
 

flang/lib/Evaluate/target.cpp

@@ -104,6 +104,7 @@ void TargetCharacteristics::set_isBigEndian(bool isBig) {
 }
 
 void TargetCharacteristics::set_isPPC(bool isPowerPC) { isPPC_ = isPowerPC; }
+void TargetCharacteristics::set_isSPARC(bool isSPARC) { isSPARC_ = isSPARC; }
 
 void TargetCharacteristics::set_areSubnormalsFlushedToZero(bool yes) {
   areSubnormalsFlushedToZero_ = yes;

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -50,6 +50,7 @@
 #include "llvm/Support/Debug.h"
 #include "llvm/Support/MathExtras.h"
 #include "llvm/Support/raw_ostream.h"
+#include <cfenv> // temporary -- only used in genIeeeGetOrSetModesOrStatus
 #include <mlir/IR/Value.h>
 #include <optional>
 
@@ -318,13 +319,15 @@ static constexpr IntrinsicHandler handlers[]{
     {"ieee_get_halting_mode",
      &I::genIeeeGetHaltingMode,
      {{{"flag", asValue}, {"halting", asAddr}}}},
-    {"ieee_get_modes", &I::genIeeeGetOrSetModes</*isGet=*/true>},
+    {"ieee_get_modes",
+     &I::genIeeeGetOrSetModesOrStatus</*isGet=*/true, /*isModes=*/true>},
     {"ieee_get_rounding_mode",
      &I::genIeeeGetRoundingMode,
      {{{"round_value", asAddr, handleDynamicOptional},
        {"radix", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
-    {"ieee_get_status", &I::genIeeeGetOrSetStatus</*isGet=*/true>},
+    {"ieee_get_status",
+     &I::genIeeeGetOrSetModesOrStatus</*isGet=*/true, /*isModes=*/false>},
     {"ieee_get_underflow_mode",
      &I::genIeeeGetUnderflowMode,
      {{{"gradual", asAddr}}},
@@ -368,13 +371,15 @@ static constexpr IntrinsicHandler handlers[]{
     {"ieee_set_flag", &I::genIeeeSetFlagOrHaltingMode</*isFlag=*/true>},
     {"ieee_set_halting_mode",
      &I::genIeeeSetFlagOrHaltingMode</*isFlag=*/false>},
-    {"ieee_set_modes", &I::genIeeeGetOrSetModes</*isGet=*/false>},
+    {"ieee_set_modes",
+     &I::genIeeeGetOrSetModesOrStatus</*isGet=*/false, /*isModes=*/true>},
     {"ieee_set_rounding_mode",
      &I::genIeeeSetRoundingMode,
      {{{"round_value", asValue, handleDynamicOptional},
        {"radix", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
-    {"ieee_set_status", &I::genIeeeGetOrSetStatus</*isGet=*/false>},
+    {"ieee_set_status",
+     &I::genIeeeGetOrSetModesOrStatus</*isGet=*/false, /*isModes=*/false>},
     {"ieee_set_underflow_mode", &I::genIeeeSetUnderflowMode},
     {"ieee_signaling_eq",
      &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OEQ>},
@@ -4106,11 +4111,12 @@ void IntrinsicLibrary::genRaiseExcept(int excepts, mlir::Value cond) {
 // Return a reference to the contents of a derived type with one field.
 // Also return the field type.
 static std::pair<mlir::Value, mlir::Type>
-getFieldRef(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value rec) {
+getFieldRef(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value rec,
+            unsigned index = 0) {
   auto recType =
       mlir::dyn_cast<fir::RecordType>(fir::unwrapPassByRefType(rec.getType()));
-  assert(recType.getTypeList().size() == 1 && "expected exactly one component");
-  auto [fieldName, fieldTy] = recType.getTypeList().front();
+  assert(index < recType.getTypeList().size() && "not enough components");
+  auto [fieldName, fieldTy] = recType.getTypeList()[index];
   mlir::Value field = builder.create<fir::FieldIndexOp>(
       loc, fir::FieldType::get(recType.getContext()), fieldName, recType,
       fir::getTypeParams(rec));
@@ -4500,15 +4506,60 @@ void IntrinsicLibrary::genIeeeGetHaltingMode(
 }
 
 // IEEE_GET_MODES, IEEE_SET_MODES
-template <bool isGet>
-void IntrinsicLibrary::genIeeeGetOrSetModes(
+// IEEE_GET_STATUS, IEEE_SET_STATUS
+template <bool isGet, bool isModes>
+void IntrinsicLibrary::genIeeeGetOrSetModesOrStatus(
     llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 1);
-  mlir::Type ptrTy = builder.getRefType(builder.getIntegerType(32));
+#ifndef __GLIBC_USE_IEC_60559_BFP_EXT // only use of "#include <cfenv>"
+  // No definitions of fegetmode, fesetmode
+  llvm::StringRef func = isModes
+                             ? (isGet ? "ieee_get_modes" : "ieee_set_modes")
+                             : (isGet ? "ieee_get_status" : "ieee_set_status");
+  TODO(loc, "intrinsic module procedure: " + func);
+#else
   mlir::Type i32Ty = builder.getIntegerType(32);
-  mlir::Value addr =
-      builder.create<fir::ConvertOp>(loc, ptrTy, getBase(args[0]));
-  genRuntimeCall(isGet ? "fegetmode" : "fesetmode", i32Ty, addr);
+  mlir::Type i64Ty = builder.getIntegerType(64);
+  mlir::Type ptrTy = builder.getRefType(i32Ty);
+  mlir::Value addr;
+  if (fir::getTargetTriple(builder.getModule()).isSPARC()) {
+    // Floating point environment data is larger than the __data field
+    // allotment. Allocate data space from the heap.
+    auto [fieldRef, fieldTy] =
+        getFieldRef(builder, loc, fir::getBase(args[0]), 1);
+    addr = builder.create<fir::BoxAddrOp>(
+        loc, builder.create<fir::LoadOp>(loc, fieldRef));
+    mlir::Type heapTy = addr.getType();
+    mlir::Value allocated = builder.create<mlir::arith::CmpIOp>(
+        loc, mlir::arith::CmpIPredicate::ne,
+        builder.createConvert(loc, i64Ty, addr),
+        builder.createIntegerConstant(loc, i64Ty, 0));
+    auto ifOp = builder.create<fir::IfOp>(loc, heapTy, allocated,
+                                          /*withElseRegion=*/true);
+    builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+    builder.create<fir::ResultOp>(loc, addr);
+    builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
+    mlir::Value byteSize =
+        isModes ? fir::runtime::genGetModesTypeSize(builder, loc)
+                : fir::runtime::genGetStatusTypeSize(builder, loc);
+    byteSize = builder.createConvert(loc, builder.getIndexType(), byteSize);
+    addr =
+        builder.create<fir::AllocMemOp>(loc, extractSequenceType(heapTy),
+                                        /*typeparams=*/std::nullopt, byteSize);
+    mlir::Value shape = builder.create<fir::ShapeOp>(loc, byteSize);
+    builder.create<fir::StoreOp>(
+        loc, builder.create<fir::EmboxOp>(loc, fieldTy, addr, shape), fieldRef);
+    builder.create<fir::ResultOp>(loc, addr);
+    builder.setInsertionPointAfter(ifOp);
+    addr = builder.create<fir::ConvertOp>(loc, ptrTy, ifOp.getResult(0));
+  } else {
+    // Place floating point environment data in __data storage.
+    addr = builder.create<fir::ConvertOp>(loc, ptrTy, getBase(args[0]));
+  }
+  llvm::StringRef func = isModes ? (isGet ? "fegetmode" : "fesetmode")
+                                 : (isGet ? "fegetenv" : "fesetenv");
+  genRuntimeCall(func, i32Ty, addr);
+#endif
 }
 
 // Check that an explicit ieee_[get|set]_rounding_mode call radix value is 2.
@@ -4541,18 +4592,6 @@ void IntrinsicLibrary::genIeeeGetRoundingMode(
   builder.create<fir::StoreOp>(loc, mode, fieldRef);
 }
 
-// IEEE_GET_STATUS, IEEE_SET_STATUS
-template <bool isGet>
-void IntrinsicLibrary::genIeeeGetOrSetStatus(
-    llvm::ArrayRef<fir::ExtendedValue> args) {
-  assert(args.size() == 1);
-  mlir::Type ptrTy = builder.getRefType(builder.getIntegerType(32));
-  mlir::Type i32Ty = builder.getIntegerType(32);
-  mlir::Value addr =
-      builder.create<fir::ConvertOp>(loc, ptrTy, getBase(args[0]));
-  genRuntimeCall(isGet ? "fegetenv" : "fesetenv", i32Ty, addr);
-}
-
 // IEEE_GET_UNDERFLOW_MODE
 void IntrinsicLibrary::genIeeeGetUnderflowMode(
     llvm::ArrayRef<fir::ExtendedValue> args) {

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

@@ -42,3 +42,17 @@ void fir::runtime::genSetUnderflowMode(fir::FirOpBuilder &builder,
       fir::runtime::getRuntimeFunc<mkRTKey(SetUnderflowMode)>(loc, builder)};
   builder.create<fir::CallOp>(loc, func, flag);
 }
+
+mlir::Value fir::runtime::genGetModesTypeSize(fir::FirOpBuilder &builder,
+                                              mlir::Location loc) {
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(GetModesTypeSize)>(loc, builder)};
+  return builder.create<fir::CallOp>(loc, func).getResult(0);
+}
+
+mlir::Value fir::runtime::genGetStatusTypeSize(fir::FirOpBuilder &builder,
+                                               mlir::Location loc) {
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(GetStatusTypeSize)>(loc, builder)};
+  return builder.create<fir::CallOp>(loc, func).getResult(0);
+}

flang/module/__fortran_ieee_exceptions.f90

@@ -36,13 +36,15 @@
     ieee_all(*) = [ ieee_usual, ieee_underflow, ieee_inexact ]
 
   type, public :: ieee_modes_type ! Fortran 2018, 17.7
-    private ! opaque fenv.h femode_t data
+    private ! opaque fenv.h femode_t data; code will access only one component
     integer(kind=4) :: __data(_FORTRAN_RUNTIME_IEEE_FEMODE_T_EXTENT)
+    integer(kind=1), allocatable :: __allocatable_data(:)
   end type ieee_modes_type
 
   type, public :: ieee_status_type ! Fortran 2018, 17.7
-    private ! opaque fenv.h fenv_t data
+    private ! opaque fenv.h fenv_t data; code will access only one component
     integer(kind=4) :: __data(_FORTRAN_RUNTIME_IEEE_FENV_T_EXTENT)
+    integer(kind=1), allocatable :: __allocatable_data(:)
   end type ieee_status_type
 
 ! Define specifics with 1 LOGICAL or REAL argument for generic G.

flang/runtime/exceptions.cpp

@@ -15,14 +15,10 @@
 #include <xmmintrin.h>
 #endif
 
-// When not supported, these macro are undefined in cfenv.h,
-// set them to zero in that case.
+// fenv.h may not define exception macros.
 #ifndef FE_INVALID
 #define FE_INVALID 0
 #endif
-#ifndef __FE_DENORM
-#define __FE_DENORM 0 // denorm is nonstandard
-#endif
 #ifndef FE_DIVBYZERO
 #define FE_DIVBYZERO 0
 #endif
@@ -46,7 +42,11 @@ uint32_t RTNAME(MapException)(uint32_t excepts) {
   Terminator terminator{__FILE__, __LINE__};
 
   static constexpr uint32_t v{FE_INVALID};
-  static constexpr uint32_t s{__FE_DENORM}; // subnormal
+#if __x86_64__
+  static constexpr uint32_t s{__FE_DENORM}; // nonstandard, not a #define
+#else
+  static constexpr uint32_t s{0};
+#endif
   static constexpr uint32_t z{FE_DIVBYZERO};
   static constexpr uint32_t o{FE_OVERFLOW};
   static constexpr uint32_t u{FE_UNDERFLOW};
@@ -62,25 +62,13 @@ uint32_t RTNAME(MapException)(uint32_t excepts) {
   static constexpr uint32_t map[]{xm};
   static constexpr uint32_t mapSize{sizeof(map) / sizeof(uint32_t)};
   static_assert(mapSize == 64);
-  if (excepts == 0 || excepts >= mapSize) {
+  if (excepts >= mapSize) {
     terminator.Crash("Invalid excepts value: %d", excepts);
   }
   uint32_t except_value = map[excepts];
-  if (except_value == 0) {
-    terminator.Crash(
-        "Excepts value %d not supported by flang runtime", excepts);
-  }
   return except_value;
 }
 
-// Verify that the size of ieee_modes_type and ieee_status_type objects from
-// intrinsic module file __fortran_ieee_exceptions.f90 are large enough to
-// hold fenv_t object.
-// TODO: fenv_t can be way larger than
-//	sizeof(int) * _FORTRAN_RUNTIME_IEEE_FENV_T_EXTENT
-// on some systems, e.g. Solaris, so omit object size comparison for now.
-// TODO: consider femode_t object size comparison once its more mature.
-
 // Check if the processor has the ability to control whether to halt or
 // continue execution when a given exception is raised.
 bool RTNAME(SupportHalting)([[maybe_unused]] uint32_t except) {
@@ -103,7 +91,7 @@ bool RTNAME(SupportHalting)([[maybe_unused]] uint32_t except) {
 }
 
 bool RTNAME(GetUnderflowMode)(void) {
-#if __x86_64__
+#if _MM_FLUSH_ZERO_MASK
   // 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;
@@ -112,12 +100,23 @@ bool RTNAME(GetUnderflowMode)(void) {
 #endif
 }
 void RTNAME(SetUnderflowMode)(bool flag) {
-#if __x86_64__
+#if _MM_FLUSH_ZERO_MASK
   // 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
 }
 
+size_t RTNAME(GetModesTypeSize)(void) {
+#ifdef __GLIBC_USE_IEC_60559_BFP_EXT
+  return sizeof(femode_t); // byte size of ieee_modes_type data
+#else
+  return 8; // femode_t is not defined
+#endif
+}
+size_t RTNAME(GetStatusTypeSize)(void) {
+  return sizeof(fenv_t); // byte size of ieee_status_type data
+}
+
 } // extern "C"
 } // namespace Fortran::runtime