[flang] AMAX0, MIN1... rewrite to MAX/MIN: make result conversion explicit

[jeanPerier]

Summary

This patch changes speficic extremum functions rewrite to generic MIN/MAX.
It applies to AMAX0, AMIN0, AMAX1, AMIN1, MAX0, MIN0, MAX1, MIN1, DMAX1,
and DMIN1.

• Do not re-write specific extremums to MAX/MIN in intrinsic Probe and let

folding rewrite it and introduc the conversion on the MIN/MAX result.

• Also make operand promotion explicit in MIN/MAX folding.

For instance, after this patch:
AMAX0(int8, int4) is rewritten to REAL(MAX(int8, INT(int4, 8)))

All this care is to avoid rewritting it to MAX(REAL(int8), REAL(int4))
that may not always be numerically equivalent to the first rewrite.

[klausler]

flang/lib/Evaluate/fold-implementation.h

700

Why is this limited to INTEGER here? Do AMAX0, AMIN0, DMAX1, and DMIN1 have separate handling elsewhere?

flang/lib/Evaluate/fold-integer.cpp

426

Since these are in alphabetical order, you should put the "min" cases lower.

[schweitz]

flang/lib/Evaluate/fold-implementation.h

696

Is sign-extension always correct? Table 16.3 suggests AMAX0 has default integer arguments, which would possibly suggest truncation for something like INTEGER_16.

[jeanPerier]

flang/lib/Evaluate/fold-implementation.h

700

No, the real case is handled implicitly in the "then" just above. If the arguments are all real they will all be processed in the first case.
This "else" is only here to handle mixed integer/real operands (in case all previous operands were integer, the first real operand gives the intermediate MIN/MAX result type).
Currently, the intrinsic probing does not prevent such mixed category cases (a warning is emitted, like with non standard kind). So AMAX0(int4, real4) is rewritten to REAL(MAX(real4, int4)) = MAX(real4, REAL(int4)).
I can add a small comment to clarify this here.

[jeanPerier]

flang/lib/Evaluate/fold-implementation.h

696

The code here is supporting a non standard extension. In standard Fortran, an INTEGER(16) argument in AMAX0 is illegal (unless it is the default integer type). Pgfortran, xlf and ifortran support non standard argument types in AMAX0. XLF and ifort never truncate the arguments but instead use REAL(MAX(a, b), 4), and that what was previously decided to do for f18 (documented in Extensions.md) . So in the INTEGER(16), the MAX would be performed on INTEGER(16) and the result be converted to REAL(4).
Pgfortran behaviour is to truncates the argument in general, but that is not true for all extremum specific intrinsics, so it is simpler and safer to align with ifort/xlf on this extension.
A warning is emitted in such non standard usage (since numerical stability between pgfortran/f18, ifort, xlf might be affected).

[jeanPerier]

Add comments in AMAX0/MIN1... rewrite algorithm.

flang/lib/Evaluate/fold-implementation.h

template <typename T> Expr<T> Folder<T>::Reshape(FunctionRef<T> &&funcRef) {
   // Invalid, prevent re-folding
   return MakeInvalidIntrinsic(std::move(funcRef));
 }
 
 template <typename T>
 Expr<T> FoldMINorMAX(
     FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {
   std::vector<Constant<T> *> constantArgs;
+  // Call Folding on all arguments, even if some are not constant,
+  // to make operand promotion explicit.
   for (auto &arg : funcRef.arguments()) {
     if (auto *cst{Folder<T>{context}.Folding(arg)}) {
       constantArgs.push_back(cst);
-    } else {
-      return Expr<T>(std::move(funcRef));
     }
   }
+  if (constantArgs.size() != funcRef.arguments().size())
+    return Expr<T>(std::move(funcRef));
   CHECK(constantArgs.size() > 0);
   Expr<T> result{std::move(*constantArgs[0])};
   for (std::size_t i{1}; i < constantArgs.size(); ++i) {
     Extremum<T> extremum{order, result, Expr<T>{std::move(*constantArgs[i])}};
     result = FoldOperation(context, std::move(extremum));
   }
   return result;
 }
 
+// For AMAX0, AMIN0, AMAX1, AMIN1, DMAX1, DMIN1, MAX0, MIN0, MAX1, and MIN1
+// a special care has to be taken to insert the conversion on the result
+// of the MIN/MAX. This is made slightly more complex by the extension
+// supported by f18 that arguments may have different kinds. This implies
+// that the created MIN/MAX result type cannot be deduced from the standard but
+// has to be deduced from the arguments.
+// e.g. AMAX0(int8, int4) is rewritten to REAL(MAX(int8, INT(int4, 8)))).
+template <typename T>
+Expr<T> RewriteSpecificMINorMAX(
+    FoldingContext &context, FunctionRef<T> &&funcRef) {
+  ActualArguments &args{funcRef.arguments()};
+  auto &intrinsic{DEREF(std::get_if<SpecificIntrinsic>(&funcRef.proc().u))};
+  // Rewrite MAX1(args) to INT(MAX(args)) and fold. Same logic for MIN1.
+  // Find result type for max/min based on the arguments.
+  DynamicType resultType{args[0].value().GetType().value()};
+  auto *resultTypeArg{&args[0]};
+  for (auto j{args.size() - 1}; j > 0; --j) {
+    DynamicType type{args[j].value().GetType().value()};
+    if (type.category() == resultType.category()) {
+      if (type.kind() > resultType.kind()) {
+        resultTypeArg = &args[j];
+        resultType = type;
+      }
+    } else if (resultType.category() == TypeCategory::Integer) {
+      // Handle mixed real/integer arguments: all the previous arguments were
+      // integers and this one is real. The type of the MAX/MIN result will
+      // be the one of the real argument.
+      resultTypeArg = &args[j];
+      resultType = type;
+    }
+  }
+  intrinsic.name =
+      intrinsic.name.find("max") != std::string::npos ? "max"s : "min"s;
+  intrinsic.characteristics.value().functionResult.value().SetType(resultType);
+  auto insertConversion{[&](const auto &x) -> Expr<T> {
+    using TR = ResultType<decltype(x)>;
+    FunctionRef<TR> maxRef{std::move(funcRef.proc()), std::move(args)};
+    return Fold(context, ConvertToType<T>(AsCategoryExpr(std::move(maxRef))));
+  }};
+  if (auto *sx{UnwrapExpr<Expr<SomeReal>>(*resultTypeArg)}) {
+    return std::visit(insertConversion, sx->u);
+  }
+  auto &sx{DEREF(UnwrapExpr<Expr<SomeInteger>>(*resultTypeArg))};
+  return std::visit(insertConversion, sx.u);
+}
+
 template <typename T>
 Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
   ActualArguments &args{funcRef.arguments()};
   for (std::optional<ActualArgument> &arg : args) {
     if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
       *expr = Fold(context, std::move(*expr));
     }
   }

flang/lib/Evaluate/fold-integer.cpp

if (name == "abs") {
     // It can be safely converted to Int4 to simplify.
     const auto fptr{name == "maskl" ? &Scalar<T>::MASKL : &Scalar<T>::MASKR};
     return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
         ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
           return fptr(static_cast<int>(places.ToInt64()));
         }));
   } else if (name == "max") {
     return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
+  } else if (name == "max0" || name == "max1") {
+    return RewriteSpecificMINorMAX(context, std::move(funcRef));
   } else if (name == "maxexponent") {
     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
       return std::visit(
           [](const auto &x) {
             using TR = typename std::decay_t<decltype(x)>::Result;
             return Expr<T>{Scalar<TR>::MAXEXPONENT};
           },
           sx->u);
if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
           [](const auto &x) {
             using TR = typename std::decay_t<decltype(x)>::Result;
             return Expr<T>{Scalar<TR>::MINEXPONENT};
           },
           sx->u);
     }
   } else if (name == "min") {
     return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
+  } else if (name == "min0" || name == "min1") {
+    return RewriteSpecificMINorMAX(context, std::move(funcRef));
   } else if (name == "mod") {
     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
         ScalarFuncWithContext<T, T, T>(
             [](FoldingContext &context, const Scalar<T> &x,
                 const Scalar<T> &y) -> Scalar<T> {
               auto quotRem{x.DivideSigned(y)};
               if (quotRem.divisionByZero) {
                 context.messages().Say("mod() by zero"_en_US);

flang/lib/Evaluate/fold-real.cpp

if (name == "acos" || name == "acosh" || name == "asin" || name == "asinh" ||
     if (auto callable{context.hostIntrinsicsLibrary()
                           .GetHostProcedureWrapper<Scalar, T, T>(name)}) {
       return FoldElementalIntrinsic<T, T>(
           context, std::move(funcRef), *callable);
     } else {
       context.messages().Say(
           "%s(real(kind=%d)) cannot be folded on host"_en_US, name, KIND);
     }
+  } else if (name == "amax0" || name == "amin0" || name == "amin1" ||
+      name == "amax1" || name == "dmin1" || name == "dmax1") {
+    return RewriteSpecificMINorMAX(context, std::move(funcRef));
   } else if (name == "atan" || name == "atan2" || name == "hypot" ||
       name == "mod") {
     std::string localName{name == "atan2" ? "atan" : name};
     CHECK(args.size() == 2);
     if (auto callable{
             context.hostIntrinsicsLibrary()
                 .GetHostProcedureWrapper<Scalar, T, T, T>(localName)}) {
       return FoldElementalIntrinsic<T, T, T>(

flang/lib/Evaluate/intrinsics.cpp

 // common Fortran compilers behavior, and as far as we can tell, is safe and
 // useful.
 struct SpecificIntrinsicInterface : public IntrinsicInterface {
   const char *generic{nullptr};
   bool isRestrictedSpecific{false};
   // Exact actual/dummy type matching is required by default for specific
   // intrinsics. If useGenericAndForceResultType is set, then the probing will
   // also attempt to use the related generic intrinsic and to convert the result
-  // to the specific intrinsic result type if needed.
+  // to the specific intrinsic result type if needed. This also prevents
+  // using the generic name so that folding can insert the conversion on the
+  // result and not the arguments.
+  //
   // This is not enabled on all specific intrinsics because an alternative
   // is to convert the actual arguments to the required dummy types and this is
   // not numerically equivalent.
-  //  e.g. IABS(INT(i), INT(j)) not equiv to INT(ABS(i, j)).
+  //  e.g. IABS(INT(i, 4)) not equiv to INT(ABS(i), 4).
   // This is allowed for restricted min/max specific functions because
   // the expected behavior is clear from their definitions. A warning is though
-  // always emitted because other compilers' behavior is not ubiquitous here.
+  // always emitted because other compilers' behavior is not ubiquitous here and
+  // the results in case of conversion overflow might not be equivalent.
+  // e.g for MIN0: INT(MIN(2147483647_8, 2*2147483647_8), 4) = 2147483647_4
+  // but: MIN(INT(2147483647_8, 4), INT(2*2147483647_8, 4)) = -2_4
+  // xlf and ifort return the first, and pgfortran the later. f18 will return
+  // the first because this matches more closely the MIN0 definition in
+  // Fortran 2018 table 16.3 (although it is still an extension to allow
+  // non default integer argument in MIN0).
   bool useGenericAndForceResultType{false};
 };
 
 static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"abs", {{"a", DefaultReal}}, DefaultReal}},
     {{"acos", {{"x", DefaultReal}}, DefaultReal}},
     {{"aimag", {{"z", DefaultComplex}}, DefaultReal}},
     {{"aint", {{"a", DefaultReal}}, DefaultReal}},
std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
   parser::Messages specificBuffer;
   auto specificRange{specificFuncs_.equal_range(call.name)};
   for (auto specIter{specificRange.first}; specIter != specificRange.second;
        ++specIter) {
     // We only need to check the cases with distinct generic names.
     if (const char *genericName{specIter->second->generic}) {
       if (auto specificCall{
               matchOrBufferMessages(*specIter->second, specificBuffer)}) {
+        if (!specIter->second->useGenericAndForceResultType) {
           specificCall->specificIntrinsic.name = genericName;
+        }
         specificCall->specificIntrinsic.isRestrictedSpecific =
             specIter->second->isRestrictedSpecific;
         // TODO test feature AdditionalIntrinsics, warn on nonstandard
         // specifics with DoublePrecisionComplex arguments.
         return specificCall;
       }
     }
   }
 
   // If there was no exact match with a specific, try to match the related
   // generic and convert the result to the specific required type.
   for (auto specIter{specificRange.first}; specIter != specificRange.second;
        ++specIter) {
     // We only need to check the cases with distinct generic names.
     if (const char *genericName{specIter->second->generic}) {
       if (specIter->second->useGenericAndForceResultType) {
         auto genericRange{genericFuncs_.equal_range(genericName)};
         for (auto genIter{genericRange.first}; genIter != genericRange.second;
              ++genIter) {
           if (auto specificCall{
                   matchOrBufferMessages(*genIter->second, specificBuffer)}) {
             // Force the call result type to the specific intrinsic result type
             DynamicType newType{GetReturnType(*specIter->second, defaults_)};
             context.messages().Say(
-                "Argument type does not match specific intrinsic '%s' "
+                "argument types do not match specific intrinsic '%s' "
                 "requirements; using '%s' generic instead and converting the "
                 "result to %s if needed"_en_US,
                 call.name, genericName, newType.AsFortran());
+            specificCall->specificIntrinsic.name = call.name;
             specificCall->specificIntrinsic.characteristics.value()
                 .functionResult.value()
                 .SetType(newType);
             return specificCall;
           }
         }
       }
     }

flang/test/Evaluate/folding04.f90

 
 module parentheses
   ! Test parentheses in folding (they are kept around constants to keep the
   ! distinction between variable and expressions and require special care).
   real(4), parameter :: x_nop = 0.1_4
   real(4), parameter :: x_p = (x_nop)
   logical, parameter :: test_parentheses1 = acos(x_p).EQ.acos(x_nop)
 end module
+
+module specific_extremums
+  ! f18 accepts all type kinds for the arguments of specific extremum intrinsics
+  ! instead of of only default kind (or double precision for DMAX1 and DMIN1).
+  ! This extensions is implemented by using the related generic intrinsic and
+  ! converting the result.
+  ! The tests below are cases where an implementation that converts the arguments to the
+  ! standard required types instead would give different results than the implementation
+  ! specified for f18 (converting the result).
+  integer(8), parameter :: max_i32_8 = 2_8**31-1  
+  integer, parameter :: expected_min0 = int(min(max_i32_8, 2_8*max_i32_8), 4)
+  !WARN: argument types do not match specific intrinsic 'min0' requirements; using 'min' generic instead and converting the result to INTEGER(4) if needed
+  integer, parameter :: result_min0 =  min0(max_i32_8, 2_8*max_i32_8)
+  ! result_min0 would be -2  if arguments were converted to default integer.
+  logical, parameter :: test_min0 = expected_min0 .EQ. result_min0
+
+  real, parameter :: expected_amax0 = real(max(max_i32_8, 2_8*max_i32_8), 4)
+  !WARN: argument types do not match specific intrinsic 'amax0' requirements; using 'max' generic instead and converting the result to REAL(4) if needed
+  real, parameter :: result_amax0 = amax0(max_i32_8, 2_8*max_i32_8)
+  ! result_amax0 would be 2.1474836E+09 if arguments were converted to default integer first.
+  logical, parameter :: test_amax0 = expected_amax0 .EQ. result_amax0
+end module