diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -656,13 +656,15 @@ Expr FoldMINorMAX( FoldingContext &context, FunctionRef &&funcRef, Ordering order) { std::vector *> 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{context}.Folding(arg)}) { constantArgs.push_back(cst); - } else { - return Expr(std::move(funcRef)); } } + if (constantArgs.size() != funcRef.arguments().size()) + return Expr(std::move(funcRef)); CHECK(constantArgs.size() > 0); Expr result{std::move(*constantArgs[0])}; for (std::size_t i{1}; i < constantArgs.size(); ++i) { @@ -672,6 +674,52 @@ 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 +Expr RewriteSpecificMINorMAX( + FoldingContext &context, FunctionRef &&funcRef) { + ActualArguments &args{funcRef.arguments()}; + auto &intrinsic{DEREF(std::get_if(&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 { + using TR = ResultType; + FunctionRef maxRef{std::move(funcRef.proc()), std::move(args)}; + return Fold(context, ConvertToType(AsCategoryExpr(std::move(maxRef)))); + }}; + if (auto *sx{UnwrapExpr>(*resultTypeArg)}) { + return std::visit(insertConversion, sx->u); + } + auto &sx{DEREF(UnwrapExpr>(*resultTypeArg))}; + return std::visit(insertConversion, sx.u); +} + template Expr FoldOperation(FoldingContext &context, FunctionRef &&funcRef) { ActualArguments &args{funcRef.arguments()}; diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -423,6 +423,8 @@ })); } 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>(args[0])}) { return std::visit( @@ -448,6 +450,8 @@ } } 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(context, std::move(funcRef), ScalarFuncWithContext( diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp --- a/flang/lib/Evaluate/fold-real.cpp +++ b/flang/lib/Evaluate/fold-real.cpp @@ -37,6 +37,9 @@ 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}; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -753,14 +753,24 @@ // 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}; }; @@ -1948,7 +1958,9 @@ if (const char *genericName{specIter->second->generic}) { if (auto specificCall{ matchOrBufferMessages(*specIter->second, specificBuffer)}) { - specificCall->specificIntrinsic.name = genericName; + if (!specIter->second->useGenericAndForceResultType) { + specificCall->specificIntrinsic.name = genericName; + } specificCall->specificIntrinsic.isRestrictedSpecific = specIter->second->isRestrictedSpecific; // TODO test feature AdditionalIntrinsics, warn on nonstandard @@ -1973,10 +1985,11 @@ // 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); diff --git a/flang/test/Evaluate/folding04.f90 b/flang/test/Evaluate/folding04.f90 --- a/flang/test/Evaluate/folding04.f90 +++ b/flang/test/Evaluate/folding04.f90 @@ -44,3 +44,25 @@ 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