1062 lines · cpp
1//===-- lib/Evaluate/fold-logical.cpp -------------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "fold-implementation.h"10#include "fold-matmul.h"11#include "fold-reduction.h"12#include "flang/Evaluate/check-expression.h"13#include "flang/Runtime/magic-numbers.h"14 15namespace Fortran::evaluate {16 17template <typename T>18static std::optional<Expr<SomeType>> ZeroExtend(const Constant<T> &c) {19 std::vector<Scalar<LargestInt>> exts;20 for (const auto &v : c.values()) {21 exts.push_back(Scalar<LargestInt>::ConvertUnsigned(v).value);22 }23 return AsGenericExpr(24 Constant<LargestInt>(std::move(exts), ConstantSubscripts(c.shape())));25}26 27// for ALL, ANY & PARITY28template <typename T>29static Expr<T> FoldAllAnyParity(FoldingContext &context, FunctionRef<T> &&ref,30 Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,31 Scalar<T> identity) {32 static_assert(T::category == TypeCategory::Logical);33 std::optional<int> dim;34 if (std::optional<ArrayAndMask<T>> arrayAndMask{35 ProcessReductionArgs<T>(context, ref.arguments(), dim,36 /*ARRAY(MASK)=*/0, /*DIM=*/1)}) {37 OperationAccumulator accumulator{arrayAndMask->array, operation};38 return Expr<T>{DoReduction<T>(39 arrayAndMask->array, arrayAndMask->mask, dim, identity, accumulator)};40 }41 return Expr<T>{std::move(ref)};42}43 44// OUT_OF_RANGE(x,mold[,round]) references are entirely rewritten here into45// expressions, which are then folded into constants when 'x' and 'round'46// are constant. It is guaranteed that 'x' is evaluated at most once.47// TODO: unsigned48 49template <int X_RKIND, int MOLD_IKIND>50Expr<SomeReal> RealToIntBoundHelper(bool round, bool negate) {51 using RType = Type<TypeCategory::Real, X_RKIND>;52 using RealType = Scalar<RType>;53 using IntType = Scalar<Type<TypeCategory::Integer, MOLD_IKIND>>;54 RealType result{}; // 0.55 common::RoundingMode roundingMode{round56 ? common::RoundingMode::TiesAwayFromZero57 : common::RoundingMode::ToZero};58 // Add decreasing powers of two to the result to find the largest magnitude59 // value that can be converted to the integer type without overflow.60 RealType at{RealType::FromInteger(IntType{negate ? -1 : 1}).value};61 bool decrement{true};62 while (!at.template ToInteger<IntType>(roundingMode)63 .flags.test(RealFlag::Overflow)) {64 auto tmp{at.SCALE(IntType{1})};65 if (tmp.flags.test(RealFlag::Overflow)) {66 decrement = false;67 break;68 }69 at = tmp.value;70 }71 while (true) {72 if (decrement) {73 at = at.SCALE(IntType{-1}).value;74 } else {75 decrement = true;76 }77 auto tmp{at.Add(result)};78 if (tmp.flags.test(RealFlag::Inexact)) {79 break;80 } else if (!tmp.value.template ToInteger<IntType>(roundingMode)81 .flags.test(RealFlag::Overflow)) {82 result = tmp.value;83 }84 }85 return AsCategoryExpr(Constant<RType>{std::move(result)});86}87 88static Expr<SomeReal> RealToIntBound(89 int xRKind, int moldIKind, bool round, bool negate) {90 switch (xRKind) {91#define ICASES(RK) \92 switch (moldIKind) { \93 case 1: \94 return RealToIntBoundHelper<RK, 1>(round, negate); \95 break; \96 case 2: \97 return RealToIntBoundHelper<RK, 2>(round, negate); \98 break; \99 case 4: \100 return RealToIntBoundHelper<RK, 4>(round, negate); \101 break; \102 case 8: \103 return RealToIntBoundHelper<RK, 8>(round, negate); \104 break; \105 case 16: \106 return RealToIntBoundHelper<RK, 16>(round, negate); \107 break; \108 } \109 break110 case 2:111 ICASES(2);112 break;113 case 3:114 ICASES(3);115 break;116 case 4:117 ICASES(4);118 break;119 case 8:120 ICASES(8);121 break;122 case 10:123 ICASES(10);124 break;125 case 16:126 ICASES(16);127 break;128 }129 DIE("RealToIntBound: no case");130#undef ICASES131}132 133class RealToIntLimitHelper {134public:135 using Result = std::optional<Expr<SomeReal>>;136 using Types = RealTypes;137 RealToIntLimitHelper(138 FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo)139 : context_{context}, hi_{std::move(hi)}, lo_{lo} {}140 template <typename T> Result Test() {141 if (UnwrapExpr<Expr<T>>(hi_)) {142 bool promote{T::kind < 16};143 Result constResult;144 if (auto hiV{GetScalarConstantValue<T>(hi_)}) {145 auto loV{GetScalarConstantValue<T>(lo_)};146 CHECK(loV.has_value());147 auto diff{hiV->Subtract(*loV, Rounding{common::RoundingMode::ToZero})};148 promote = promote &&149 (diff.flags.test(RealFlag::Overflow) ||150 diff.flags.test(RealFlag::Inexact));151 constResult = AsCategoryExpr(Constant<T>{std::move(diff.value)});152 }153 if (promote) {154 constexpr int nextKind{T::kind < 4 ? 4 : T::kind == 4 ? 8 : 16};155 using T2 = Type<TypeCategory::Real, nextKind>;156 hi_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(hi_)))};157 lo_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(lo_)))};158 if (constResult) {159 // Use promoted constants on next iteration of SearchTypes160 return std::nullopt;161 }162 }163 if (constResult) {164 return constResult;165 } else {166 return AsCategoryExpr(std::move(hi_) - Expr<SomeReal>{lo_});167 }168 } else {169 return std::nullopt;170 }171 }172 173private:174 FoldingContext &context_;175 Expr<SomeReal> hi_;176 Expr<SomeReal> &lo_;177};178 179static std::optional<Expr<SomeReal>> RealToIntLimit(180 FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) {181 return common::SearchTypes(RealToIntLimitHelper{context, std::move(hi), lo});182}183 184// RealToRealBounds() returns a pair (HUGE(x),REAL(HUGE(mold),KIND(x)))185// when REAL(HUGE(x),KIND(mold)) overflows, and std::nullopt otherwise.186template <int X_RKIND, int MOLD_RKIND>187std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>188RealToRealBoundsHelper() {189 using RType = Type<TypeCategory::Real, X_RKIND>;190 using RealType = Scalar<RType>;191 using MoldRealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;192 if (!MoldRealType::Convert(RealType::HUGE()).flags.test(RealFlag::Overflow)) {193 return std::nullopt;194 } else {195 return std::make_pair(AsCategoryExpr(Constant<RType>{196 RealType::Convert(MoldRealType::HUGE()).value}),197 AsCategoryExpr(Constant<RType>{RealType::HUGE()}));198 }199}200 201static std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>202RealToRealBounds(int xRKind, int moldRKind) {203 switch (xRKind) {204#define RCASES(RK) \205 switch (moldRKind) { \206 case 2: \207 return RealToRealBoundsHelper<RK, 2>(); \208 break; \209 case 3: \210 return RealToRealBoundsHelper<RK, 3>(); \211 break; \212 case 4: \213 return RealToRealBoundsHelper<RK, 4>(); \214 break; \215 case 8: \216 return RealToRealBoundsHelper<RK, 8>(); \217 break; \218 case 10: \219 return RealToRealBoundsHelper<RK, 10>(); \220 break; \221 case 16: \222 return RealToRealBoundsHelper<RK, 16>(); \223 break; \224 } \225 break226 case 2:227 RCASES(2);228 break;229 case 3:230 RCASES(3);231 break;232 case 4:233 RCASES(4);234 break;235 case 8:236 RCASES(8);237 break;238 case 10:239 RCASES(10);240 break;241 case 16:242 RCASES(16);243 break;244 }245 DIE("RealToRealBounds: no case");246#undef RCASES247}248 249template <int X_IKIND, int MOLD_RKIND>250std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) {251 using IType = Type<TypeCategory::Integer, X_IKIND>;252 using IntType = Scalar<IType>;253 using RealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;254 IntType result{}; // 0255 while (true) {256 std::optional<IntType> next;257 for (int bit{0}; bit < IntType::bits; ++bit) {258 IntType power{IntType{}.IBSET(bit)};259 if (power.IsNegative()) {260 if (!negate) {261 break;262 }263 } else if (negate) {264 power = power.Negate().value;265 }266 auto tmp{power.AddSigned(result)};267 if (tmp.overflow ||268 RealType::FromInteger(tmp.value).flags.test(RealFlag::Overflow)) {269 break;270 }271 next = tmp.value;272 }273 if (next) {274 CHECK(result.CompareSigned(*next) != Ordering::Equal);275 result = *next;276 } else {277 break;278 }279 }280 if (result.CompareSigned(IntType::HUGE()) == Ordering::Equal) {281 return std::nullopt;282 } else {283 return AsCategoryExpr(Constant<IType>{std::move(result)});284 }285}286 287static std::optional<Expr<SomeInteger>> IntToRealBound(288 int xIKind, int moldRKind, bool negate) {289 switch (xIKind) {290#define RCASES(IK) \291 switch (moldRKind) { \292 case 2: \293 return IntToRealBoundHelper<IK, 2>(negate); \294 break; \295 case 3: \296 return IntToRealBoundHelper<IK, 3>(negate); \297 break; \298 case 4: \299 return IntToRealBoundHelper<IK, 4>(negate); \300 break; \301 case 8: \302 return IntToRealBoundHelper<IK, 8>(negate); \303 break; \304 case 10: \305 return IntToRealBoundHelper<IK, 10>(negate); \306 break; \307 case 16: \308 return IntToRealBoundHelper<IK, 16>(negate); \309 break; \310 } \311 break312 case 1:313 RCASES(1);314 break;315 case 2:316 RCASES(2);317 break;318 case 4:319 RCASES(4);320 break;321 case 8:322 RCASES(8);323 break;324 case 16:325 RCASES(16);326 break;327 }328 DIE("IntToRealBound: no case");329#undef RCASES330}331 332template <int X_IKIND, int MOLD_IKIND>333std::optional<Expr<SomeInteger>> IntToIntBoundHelper() {334 if constexpr (X_IKIND <= MOLD_IKIND) {335 return std::nullopt;336 } else {337 using XIType = Type<TypeCategory::Integer, X_IKIND>;338 using IntegerType = Scalar<XIType>;339 using MoldIType = Type<TypeCategory::Integer, MOLD_IKIND>;340 using MoldIntegerType = Scalar<MoldIType>;341 return AsCategoryExpr(Constant<XIType>{342 IntegerType::ConvertSigned(MoldIntegerType::HUGE()).value});343 }344}345 346static std::optional<Expr<SomeInteger>> IntToIntBound(347 int xIKind, int moldIKind) {348 switch (xIKind) {349#define ICASES(IK) \350 switch (moldIKind) { \351 case 1: \352 return IntToIntBoundHelper<IK, 1>(); \353 break; \354 case 2: \355 return IntToIntBoundHelper<IK, 2>(); \356 break; \357 case 4: \358 return IntToIntBoundHelper<IK, 4>(); \359 break; \360 case 8: \361 return IntToIntBoundHelper<IK, 8>(); \362 break; \363 case 16: \364 return IntToIntBoundHelper<IK, 16>(); \365 break; \366 } \367 break368 case 1:369 ICASES(1);370 break;371 case 2:372 ICASES(2);373 break;374 case 4:375 ICASES(4);376 break;377 case 8:378 ICASES(8);379 break;380 case 16:381 ICASES(16);382 break;383 }384 DIE("IntToIntBound: no case");385#undef ICASES386}387 388// ApplyIntrinsic() constructs the typed expression representation389// for a specific intrinsic function reference.390// TODO: maybe move into tools.h?391class IntrinsicCallHelper {392public:393 explicit IntrinsicCallHelper(SpecificCall &&call) : call_{call} {394 CHECK(proc_.IsFunction());395 typeAndShape_ = proc_.functionResult->GetTypeAndShape();396 CHECK(typeAndShape_ != nullptr);397 }398 using Result = std::optional<Expr<SomeType>>;399 using Types = LengthlessIntrinsicTypes;400 template <typename T> Result Test() {401 if (T::category == typeAndShape_->type().category() &&402 T::kind == typeAndShape_->type().kind()) {403 return AsGenericExpr(FunctionRef<T>{404 ProcedureDesignator{std::move(call_.specificIntrinsic)},405 std::move(call_.arguments)});406 } else {407 return std::nullopt;408 }409 }410 411private:412 SpecificCall call_;413 const characteristics::Procedure &proc_{414 call_.specificIntrinsic.characteristics.value()};415 const characteristics::TypeAndShape *typeAndShape_{nullptr};416};417 418static Expr<SomeType> ApplyIntrinsic(419 FoldingContext &context, const std::string &func, ActualArguments &&args) {420 auto found{421 context.intrinsics().Probe(CallCharacteristics{func}, args, context)};422 CHECK(found.has_value());423 auto result{common::SearchTypes(IntrinsicCallHelper{std::move(*found)})};424 CHECK(result.has_value());425 return *result;426}427 428static Expr<LogicalResult> CompareUnsigned(FoldingContext &context,429 const char *intrin, Expr<SomeType> &&x, Expr<SomeType> &&y) {430 Expr<SomeType> result{ApplyIntrinsic(context, intrin,431 ActualArguments{432 ActualArgument{std::move(x)}, ActualArgument{std::move(y)}})};433 return DEREF(UnwrapExpr<Expr<LogicalResult>>(result));434}435 436// Determines the right kind of INTEGER to hold the bits of a REAL type.437static Expr<SomeType> IntTransferMold(438 const TargetCharacteristics &target, DynamicType realType, bool asVector) {439 CHECK(realType.category() == TypeCategory::Real);440 int rKind{realType.kind()};441 int iKind{std::max<int>(target.GetAlignment(TypeCategory::Real, rKind),442 target.GetByteSize(TypeCategory::Real, rKind))};443 CHECK(target.CanSupportType(TypeCategory::Integer, iKind));444 DynamicType iType{TypeCategory::Integer, iKind};445 ConstantSubscripts shape;446 if (asVector) {447 shape = ConstantSubscripts{1};448 }449 Constant<SubscriptInteger> value{450 std::vector<Scalar<SubscriptInteger>>{0}, std::move(shape)};451 auto expr{ConvertToType(iType, AsGenericExpr(std::move(value)))};452 CHECK(expr.has_value());453 return std::move(*expr);454}455 456static Expr<SomeType> GetRealBits(FoldingContext &context, Expr<SomeReal> &&x) {457 auto xType{x.GetType()};458 CHECK(xType.has_value());459 bool asVector{x.Rank() > 0};460 return ApplyIntrinsic(context, "transfer",461 ActualArguments{ActualArgument{AsGenericExpr(std::move(x))},462 ActualArgument{IntTransferMold(463 context.targetCharacteristics(), *xType, asVector)}});464}465 466template <int KIND>467static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(468 FoldingContext &context,469 FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {470 using ResultType = Type<TypeCategory::Logical, KIND>;471 ActualArguments &args{funcRef.arguments()};472 // Fold x= and round= unconditionally473 if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {474 *args[0] = Fold(context, std::move(*x));475 }476 if (args.size() >= 3) {477 if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) {478 *args[2] = Fold(context, std::move(*round));479 }480 }481 if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {482 x = UnwrapExpr<Expr<SomeType>>(args[0]);483 CHECK(x != nullptr);484 if (const auto *mold{UnwrapExpr<Expr<SomeType>>(args[1])}) {485 DynamicType xType{x->GetType().value()};486 std::optional<Expr<LogicalResult>> result;487 bool alwaysFalse{false};488 if (auto *iXExpr{UnwrapExpr<Expr<SomeInteger>>(*x)}) {489 int iXKind{iXExpr->GetType().value().kind()};490 if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) {491 // INTEGER -> INTEGER492 int iMoldKind{iMoldExpr->GetType().value().kind()};493 if (auto hi{IntToIntBound(iXKind, iMoldKind)}) {494 // 'hi' is INT(HUGE(mold), KIND(x))495 // OUT_OF_RANGE(x,mold) = (x + (hi + 1)) .UGT. (2*hi + 1)496 auto one{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(497 xType, AsGenericExpr(Constant<SubscriptInteger>{1}))))};498 auto lhs{std::move(*iXExpr) +499 (Expr<SomeInteger>{*hi} + Expr<SomeInteger>{one})};500 auto two{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(501 xType, AsGenericExpr(Constant<SubscriptInteger>{2}))))};502 auto rhs{std::move(two) * std::move(*hi) + std::move(one)};503 result = CompareUnsigned(context, "bgt",504 Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});505 } else {506 alwaysFalse = true;507 }508 } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) {509 // INTEGER -> REAL510 int rMoldKind{rMoldExpr->GetType().value().kind()};511 if (auto hi{IntToRealBound(iXKind, rMoldKind, /*negate=*/false)}) {512 // OUT_OF_RANGE(x,mold) = (x - lo) .UGT. (hi - lo)513 auto lo{IntToRealBound(iXKind, rMoldKind, /*negate=*/true)};514 CHECK(lo.has_value());515 auto lhs{std::move(*iXExpr) - Expr<SomeInteger>{*lo}};516 auto rhs{std::move(*hi) - std::move(*lo)};517 result = CompareUnsigned(context, "bgt",518 Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});519 } else {520 alwaysFalse = true;521 }522 }523 } else if (auto *rXExpr{UnwrapExpr<Expr<SomeReal>>(*x)}) {524 int rXKind{rXExpr->GetType().value().kind()};525 if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) {526 // REAL -> INTEGER527 int iMoldKind{iMoldExpr->GetType().value().kind()};528 auto hi{RealToIntBound(rXKind, iMoldKind, false, false)};529 auto lo{RealToIntBound(rXKind, iMoldKind, false, true)};530 if (args.size() >= 3) {531 // Bounds depend on round= value532 if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) {533 if (const Symbol *whole{UnwrapWholeSymbolDataRef(*round)};534 whole && semantics::IsOptional(whole->GetUltimate())) {535 if (auto source{args[2]->sourceLocation()}) {536 context.Warn(common::UsageWarning::OptionalMustBePresent,537 *source,538 "ROUND= argument to OUT_OF_RANGE() is an optional dummy argument that must be present at execution"_warn_en_US);539 }540 }541 auto rlo{RealToIntBound(rXKind, iMoldKind, true, true)};542 auto rhi{RealToIntBound(rXKind, iMoldKind, true, false)};543 auto mlo{Fold(context,544 ApplyIntrinsic(context, "merge",545 ActualArguments{546 ActualArgument{Expr<SomeType>{std::move(rlo)}},547 ActualArgument{Expr<SomeType>{std::move(lo)}},548 ActualArgument{Expr<SomeType>{*round}}}))};549 auto mhi{Fold(context,550 ApplyIntrinsic(context, "merge",551 ActualArguments{552 ActualArgument{Expr<SomeType>{std::move(rhi)}},553 ActualArgument{Expr<SomeType>{std::move(hi)}},554 ActualArgument{std::move(*round)}}))};555 lo = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mlo)));556 hi = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mhi)));557 }558 }559 // OUT_OF_RANGE(x,mold[,round]) =560 // TRANSFER(x - lo, int) .UGT. TRANSFER(hi - lo, int)561 hi = Fold(context, std::move(hi));562 lo = Fold(context, std::move(lo));563 if (auto rhs{RealToIntLimit(context, std::move(hi), lo)}) {564 Expr<SomeReal> lhs{std::move(*rXExpr) - std::move(lo)};565 result = CompareUnsigned(context, "bgt",566 GetRealBits(context, std::move(lhs)),567 GetRealBits(context, std::move(*rhs)));568 }569 } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) {570 // REAL -> REAL571 // Only finite arguments with ABS(x) > HUGE(mold) are .TRUE.572 // OUT_OF_RANGE(x,mold) =573 // TRANSFER(ABS(x) - HUGE(mold), int) - 1 .ULT.574 // TRANSFER(HUGE(mold), int)575 // Note that OUT_OF_RANGE(+/-Inf or NaN,mold) =576 // TRANSFER(+Inf or Nan, int) - 1 .ULT. TRANSFER(HUGE(mold), int)577 int rMoldKind{rMoldExpr->GetType().value().kind()};578 if (auto bounds{RealToRealBounds(rXKind, rMoldKind)}) {579 auto &[moldHuge, xHuge]{*bounds};580 Expr<SomeType> abs{ApplyIntrinsic(context, "abs",581 ActualArguments{582 ActualArgument{Expr<SomeType>{std::move(*rXExpr)}}})};583 auto &absR{DEREF(UnwrapExpr<Expr<SomeReal>>(abs))};584 Expr<SomeType> diffBits{585 GetRealBits(context, std::move(absR) - std::move(moldHuge))};586 auto &diffBitsI{DEREF(UnwrapExpr<Expr<SomeInteger>>(diffBits))};587 Expr<SomeType> decr{std::move(diffBitsI) -588 Expr<SomeInteger>{Expr<SubscriptInteger>{1}}};589 result = CompareUnsigned(context, "blt", std::move(decr),590 GetRealBits(context, std::move(xHuge)));591 } else {592 alwaysFalse = true;593 }594 }595 }596 if (alwaysFalse) {597 // xType can never overflow moldType, so598 // OUT_OF_RANGE(x) = (x /= 0) .AND. .FALSE.599 // which has the same shape as x.600 Expr<LogicalResult> scalarFalse{601 Constant<LogicalResult>{Scalar<LogicalResult>{false}}};602 if (x->Rank() > 0) {603 if (auto nez{Relate(context.messages(), RelationalOperator::NE,604 std::move(*x),605 AsGenericExpr(Constant<SubscriptInteger>{0}))}) {606 result = Expr<LogicalResult>{LogicalOperation<LogicalResult::kind>{607 LogicalOperator::And, std::move(*nez), std::move(scalarFalse)}};608 }609 } else {610 result = std::move(scalarFalse);611 }612 }613 if (result) {614 auto restorer{context.messages().DiscardMessages()};615 return Fold(616 context, AsExpr(ConvertToType<ResultType>(std::move(*result))));617 }618 }619 }620 return AsExpr(std::move(funcRef));621}622 623static std::optional<common::RoundingMode> GetRoundingMode(624 const std::optional<ActualArgument> &arg) {625 if (arg) {626 if (const auto *cst{UnwrapExpr<Constant<SomeDerived>>(*arg)}) {627 if (auto constr{cst->GetScalarValue()}) {628 if (StructureConstructorValues & values{constr->values()};629 values.size() == 1) {630 const Expr<SomeType> &value{values.begin()->second.value()};631 if (auto code{ToInt64(value)}) {632 return static_cast<common::RoundingMode>(*code);633 }634 }635 }636 }637 }638 return std::nullopt;639}640 641template <int KIND>642Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(643 FoldingContext &context,644 FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {645 using T = Type<TypeCategory::Logical, KIND>;646 ActualArguments &args{funcRef.arguments()};647 auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};648 CHECK(intrinsic);649 std::string name{intrinsic->name};650 if (name == "all") {651 return FoldAllAnyParity(652 context, std::move(funcRef), &Scalar<T>::AND, Scalar<T>{true});653 } else if (name == "allocated") {654 if (IsNullAllocatable(args[0]->UnwrapExpr())) {655 return Expr<T>{false};656 }657 } else if (name == "any") {658 return FoldAllAnyParity(659 context, std::move(funcRef), &Scalar<T>::OR, Scalar<T>{false});660 } else if (name == "associated") {661 if (IsNullPointer(args[0]->UnwrapExpr()) ||662 (args[1] && IsNullPointer(args[1]->UnwrapExpr()))) {663 return Expr<T>{false};664 }665 } else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") {666 static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);667 668 // The arguments to these intrinsics can be of different types. In that669 // case, the shorter of the two would need to be zero-extended to match670 // the size of the other. If at least one of the operands is not a constant,671 // the zero-extending will be done during lowering. Otherwise, the folding672 // must be done here.673 std::optional<Expr<SomeType>> constArgs[2];674 for (int i{0}; i <= 1; i++) {675 if (BOZLiteralConstant * x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {676 constArgs[i] = AsGenericExpr(Constant<LargestInt>{std::move(*x)});677 } else if (auto *x{UnwrapExpr<Expr<SomeInteger>>(args[i])}) {678 common::visit(679 [&](const auto &ix) {680 using IntT = typename std::decay_t<decltype(ix)>::Result;681 if (auto *c{UnwrapConstantValue<IntT>(ix)}) {682 constArgs[i] = ZeroExtend(*c);683 }684 },685 x->u);686 }687 }688 689 if (constArgs[0] && constArgs[1]) {690 auto fptr{&Scalar<LargestInt>::BGE};691 if (name == "bge") { // done in fptr declaration692 } else if (name == "bgt") {693 fptr = &Scalar<LargestInt>::BGT;694 } else if (name == "ble") {695 fptr = &Scalar<LargestInt>::BLE;696 } else if (name == "blt") {697 fptr = &Scalar<LargestInt>::BLT;698 } else {699 common::die("missing case to fold intrinsic function %s", name.c_str());700 }701 702 for (int i{0}; i <= 1; i++) {703 *args[i] = std::move(constArgs[i].value());704 }705 706 return FoldElementalIntrinsic<T, LargestInt, LargestInt>(context,707 std::move(funcRef),708 ScalarFunc<T, LargestInt, LargestInt>(709 [&fptr](710 const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {711 return Scalar<T>{std::invoke(fptr, i, j)};712 }));713 } else {714 return Expr<T>{std::move(funcRef)};715 }716 } else if (name == "btest") {717 using SameInt = Type<TypeCategory::Integer, KIND>;718 if (const auto *ix{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {719 return common::visit(720 [&](const auto &x) {721 using IT = ResultType<decltype(x)>;722 return FoldElementalIntrinsic<T, IT, SameInt>(context,723 std::move(funcRef),724 ScalarFunc<T, IT, SameInt>(725 [&](const Scalar<IT> &x, const Scalar<SameInt> &pos) {726 auto posVal{pos.ToInt64()};727 if (posVal < 0 || posVal >= x.bits) {728 context.messages().Say(729 "POS=%jd out of range for BTEST"_err_en_US,730 static_cast<std::intmax_t>(posVal));731 }732 return Scalar<T>{x.BTEST(posVal)};733 }));734 },735 ix->u);736 } else if (const auto *ux{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {737 return common::visit(738 [&](const auto &x) {739 using UT = ResultType<decltype(x)>;740 return FoldElementalIntrinsic<T, UT, SameInt>(context,741 std::move(funcRef),742 ScalarFunc<T, UT, SameInt>(743 [&](const Scalar<UT> &x, const Scalar<SameInt> &pos) {744 auto posVal{pos.ToInt64()};745 if (posVal < 0 || posVal >= x.bits) {746 context.messages().Say(747 "POS=%jd out of range for BTEST"_err_en_US,748 static_cast<std::intmax_t>(posVal));749 }750 return Scalar<T>{x.BTEST(posVal)};751 }));752 },753 ux->u);754 }755 } else if (name == "dot_product") {756 return FoldDotProduct<T>(context, std::move(funcRef));757 } else if (name == "extends_type_of") {758 // Type extension testing with EXTENDS_TYPE_OF() ignores any type759 // parameters. Returns a constant truth value when the result is known now.760 if (args[0] && args[1]) {761 auto t0{args[0]->GetType()};762 auto t1{args[1]->GetType()};763 if (t0 && t1) {764 if (auto result{t0->ExtendsTypeOf(*t1)}) {765 return Expr<T>{*result};766 }767 }768 }769 } else if (name == "isnan" || name == "__builtin_ieee_is_nan") {770 // Only replace the type of the function if we can do the fold771 if (args[0] && args[0]->UnwrapExpr() &&772 IsActuallyConstant(*args[0]->UnwrapExpr())) {773 auto restorer{context.messages().DiscardMessages()};774 using DefaultReal = Type<TypeCategory::Real, 4>;775 return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),776 ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {777 return Scalar<T>{x.IsNotANumber()};778 }));779 }780 } else if (name == "__builtin_ieee_is_negative") {781 auto restorer{context.messages().DiscardMessages()};782 using DefaultReal = Type<TypeCategory::Real, 4>;783 if (args[0] && args[0]->UnwrapExpr() &&784 IsActuallyConstant(*args[0]->UnwrapExpr())) {785 return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),786 ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {787 return Scalar<T>{x.IsNegative()};788 }));789 }790 } else if (name == "__builtin_ieee_is_normal") {791 auto restorer{context.messages().DiscardMessages()};792 using DefaultReal = Type<TypeCategory::Real, 4>;793 if (args[0] && args[0]->UnwrapExpr() &&794 IsActuallyConstant(*args[0]->UnwrapExpr())) {795 return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),796 ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {797 return Scalar<T>{x.IsNormal()};798 }));799 }800 } else if (name == "is_contiguous") {801 if (args.at(0)) {802 std::optional<bool> knownContiguous;803 if (auto *expr{args[0]->UnwrapExpr()}) {804 knownContiguous = IsContiguous(*expr, context);805 } else if (auto *assumedType{args[0]->GetAssumedTypeDummy()}) {806 knownContiguous = IsContiguous(*assumedType, context);807 }808 if (knownContiguous) {809 if (*knownContiguous) {810 if (auto source{args[0]->sourceLocation()}) {811 context.Warn(common::UsageWarning::ConstantIsContiguous, *source,812 "is_contiguous() is always true for named constants and subobjects of named constants"_warn_en_US);813 }814 }815 return Expr<T>{*knownContiguous};816 }817 }818 } else if (name == "is_iostat_end") {819 if (args[0] && args[0]->UnwrapExpr() &&820 IsActuallyConstant(*args[0]->UnwrapExpr())) {821 using Int64 = Type<TypeCategory::Integer, 8>;822 return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef),823 ScalarFunc<T, Int64>([](const Scalar<Int64> &x) {824 return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_END};825 }));826 }827 } else if (name == "is_iostat_eor") {828 if (args[0] && args[0]->UnwrapExpr() &&829 IsActuallyConstant(*args[0]->UnwrapExpr())) {830 using Int64 = Type<TypeCategory::Integer, 8>;831 return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef),832 ScalarFunc<T, Int64>([](const Scalar<Int64> &x) {833 return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_EOR};834 }));835 }836 } else if (name == "lge" || name == "lgt" || name == "lle" || name == "llt") {837 // Rewrite LGE/LGT/LLE/LLT into ASCII character relations838 auto *cx0{UnwrapExpr<Expr<SomeCharacter>>(args[0])};839 auto *cx1{UnwrapExpr<Expr<SomeCharacter>>(args[1])};840 if (cx0 && cx1) {841 return Fold(context,842 ConvertToType<T>(843 PackageRelation(name == "lge" ? RelationalOperator::GE844 : name == "lgt" ? RelationalOperator::GT845 : name == "lle" ? RelationalOperator::LE846 : RelationalOperator::LT,847 ConvertToType<Ascii>(std::move(*cx0)),848 ConvertToType<Ascii>(std::move(*cx1)))));849 }850 } else if (name == "logical") {851 if (auto *expr{UnwrapExpr<Expr<SomeLogical>>(args[0])}) {852 return Fold(context, ConvertToType<T>(std::move(*expr)));853 }854 } else if (name == "matmul") {855 return FoldMatmul(context, std::move(funcRef));856 } else if (name == "out_of_range") {857 return RewriteOutOfRange<KIND>(context, std::move(funcRef));858 } else if (name == "parity") {859 return FoldAllAnyParity(860 context, std::move(funcRef), &Scalar<T>::NEQV, Scalar<T>{false});861 } else if (name == "same_type_as") {862 // Type equality testing with SAME_TYPE_AS() ignores any type parameters.863 // Returns a constant truth value when the result is known now.864 if (args[0] && args[1]) {865 auto t0{args[0]->GetType()};866 auto t1{args[1]->GetType()};867 if (t0 && t1) {868 if (auto result{t0->SameTypeAs(*t1)}) {869 return Expr<T>{*result};870 }871 }872 }873 } else if (name == "__builtin_ieee_support_datatype") {874 return Expr<T>{true};875 } else if (name == "__builtin_ieee_support_denormal") {876 return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(877 IeeeFeature::Denormal)};878 } else if (name == "__builtin_ieee_support_divide") {879 return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(880 IeeeFeature::Divide)};881 } else if (name == "__builtin_ieee_support_flag") {882 if (context.targetCharacteristics().ieeeFeatures().test(883 IeeeFeature::Flags)) {884 if (args[0]) {885 if (const auto *cst{UnwrapExpr<Constant<SomeDerived>>(args[0])}) {886 if (auto constr{cst->GetScalarValue()}) {887 if (StructureConstructorValues & values{constr->values()};888 values.size() == 1) {889 const Expr<SomeType> &value{values.begin()->second.value()};890 if (auto flag{ToInt64(value)}) {891 if (flag != _FORTRAN_RUNTIME_IEEE_DENORM) {892 // Check for suppport for standard exceptions.893 return Expr<T>{894 context.targetCharacteristics().ieeeFeatures().test(895 IeeeFeature::Flags)};896 } else if (args[1]) {897 // Check for nonstandard ieee_denorm exception support for898 // a given kind.899 return Expr<T>{context.targetCharacteristics()900 .hasSubnormalExceptionSupport(901 args[1]->GetType().value().kind())};902 } else {903 // Check for nonstandard ieee_denorm exception support for904 // all kinds.905 return Expr<T>{context.targetCharacteristics()906 .hasSubnormalExceptionSupport()};907 }908 }909 }910 }911 }912 }913 }914 } else if (name == "__builtin_ieee_support_halting") {915 if (!context.targetCharacteristics()916 .haltingSupportIsUnknownAtCompileTime()) {917 return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(918 IeeeFeature::Halting)};919 }920 } else if (name == "__builtin_ieee_support_inf") {921 return Expr<T>{922 context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Inf)};923 } else if (name == "__builtin_ieee_support_io") {924 return Expr<T>{925 context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Io)};926 } else if (name == "__builtin_ieee_support_nan") {927 return Expr<T>{928 context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::NaN)};929 } else if (name == "__builtin_ieee_support_rounding") {930 if (context.targetCharacteristics().ieeeFeatures().test(931 IeeeFeature::Rounding)) {932 if (auto mode{GetRoundingMode(args[0])}) {933 return Expr<T>{mode != common::RoundingMode::TiesAwayFromZero};934 }935 }936 } else if (name == "__builtin_ieee_support_sqrt") {937 return Expr<T>{938 context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Sqrt)};939 } else if (name == "__builtin_ieee_support_standard") {940 // ieee_support_standard depends in part on ieee_support_halting.941 if (!context.targetCharacteristics()942 .haltingSupportIsUnknownAtCompileTime()) {943 return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(944 IeeeFeature::Standard)};945 }946 } else if (name == "__builtin_ieee_support_subnormal") {947 return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(948 IeeeFeature::Subnormal)};949 } else if (name == "__builtin_ieee_support_underflow_control") {950 // Setting kind=0 checks subnormal flushing control across all type kinds.951 if (args[0]) {952 return Expr<T>{953 context.targetCharacteristics().hasSubnormalFlushingControl(954 args[0]->GetType().value().kind())};955 } else {956 return Expr<T>{957 context.targetCharacteristics().hasSubnormalFlushingControl(958 /*any=*/false)};959 }960 }961 return Expr<T>{std::move(funcRef)};962}963 964template <typename T>965Expr<LogicalResult> FoldOperation(966 FoldingContext &context, Relational<T> &&relation) {967 if (auto array{ApplyElementwise(context, relation,968 std::function<Expr<LogicalResult>(Expr<T> &&, Expr<T> &&)>{969 [=](Expr<T> &&x, Expr<T> &&y) {970 return Expr<LogicalResult>{Relational<SomeType>{971 Relational<T>{relation.opr, std::move(x), std::move(y)}}};972 }})}) {973 return *array;974 }975 if (auto folded{OperandsAreConstants(relation)}) {976 bool result{};977 if constexpr (T::category == TypeCategory::Integer) {978 result =979 Satisfies(relation.opr, folded->first.CompareSigned(folded->second));980 } else if constexpr (T::category == TypeCategory::Unsigned) {981 result = Satisfies(982 relation.opr, folded->first.CompareUnsigned(folded->second));983 } else if constexpr (T::category == TypeCategory::Real) {984 result = Satisfies(relation.opr, folded->first.Compare(folded->second));985 } else if constexpr (T::category == TypeCategory::Complex) {986 result = (relation.opr == RelationalOperator::EQ) ==987 folded->first.Equals(folded->second);988 } else if constexpr (T::category == TypeCategory::Character) {989 result = Satisfies(relation.opr, Compare(folded->first, folded->second));990 } else {991 static_assert(T::category != TypeCategory::Logical);992 }993 return Expr<LogicalResult>{Constant<LogicalResult>{result}};994 }995 return Expr<LogicalResult>{Relational<SomeType>{std::move(relation)}};996}997 998Expr<LogicalResult> FoldOperation(999 FoldingContext &context, Relational<SomeType> &&relation) {1000 return common::visit(1001 [&](auto &&x) {1002 return Expr<LogicalResult>{FoldOperation(context, std::move(x))};1003 },1004 std::move(relation.u));1005}1006 1007template <int KIND>1008Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(1009 FoldingContext &context, Not<KIND> &&x) {1010 if (auto array{ApplyElementwise(context, x)}) {1011 return *array;1012 }1013 using Ty = Type<TypeCategory::Logical, KIND>;1014 auto &operand{x.left()};1015 if (auto value{GetScalarConstantValue<Ty>(operand)}) {1016 return Expr<Ty>{Constant<Ty>{!value->IsTrue()}};1017 }1018 return Expr<Ty>{x};1019}1020 1021template <int KIND>1022Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(1023 FoldingContext &context, LogicalOperation<KIND> &&operation) {1024 using LOGICAL = Type<TypeCategory::Logical, KIND>;1025 if (auto array{ApplyElementwise(context, operation,1026 std::function<Expr<LOGICAL>(Expr<LOGICAL> &&, Expr<LOGICAL> &&)>{1027 [=](Expr<LOGICAL> &&x, Expr<LOGICAL> &&y) {1028 return Expr<LOGICAL>{LogicalOperation<KIND>{1029 operation.logicalOperator, std::move(x), std::move(y)}};1030 }})}) {1031 return *array;1032 }1033 if (auto folded{OperandsAreConstants(operation)}) {1034 bool xt{folded->first.IsTrue()}, yt{folded->second.IsTrue()}, result{};1035 switch (operation.logicalOperator) {1036 case LogicalOperator::And:1037 result = xt && yt;1038 break;1039 case LogicalOperator::Or:1040 result = xt || yt;1041 break;1042 case LogicalOperator::Eqv:1043 result = xt == yt;1044 break;1045 case LogicalOperator::Neqv:1046 result = xt != yt;1047 break;1048 case LogicalOperator::Not:1049 DIE("not a binary operator");1050 }1051 return Expr<LOGICAL>{Constant<LOGICAL>{result}};1052 }1053 return Expr<LOGICAL>{std::move(operation)};1054}1055 1056#ifdef _MSC_VER // disable bogus warning about missing definitions1057#pragma warning(disable : 4661)1058#endif1059FOR_EACH_LOGICAL_KIND(template class ExpressionBase, )1060template class ExpressionBase<SomeLogical>;1061} // namespace Fortran::evaluate1062