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-exception 6 // 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 15 namespace Fortran::evaluate { 16 17 template <typename T> 18 static 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 & PARITY 28 template <typename T> 29 static 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 into 45 // 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 48 template <int X_RKIND, int MOLD_IKIND> 49 Expr<SomeReal> RealToIntBoundHelper(bool round, bool negate) { 50 using RType = Type<TypeCategory::Real, X_RKIND>; 51 using RealType = Scalar<RType>; 52 using IntType = Scalar<Type<TypeCategory::Integer, MOLD_IKIND>>; 53 RealType result{}; // 0. 54 common::RoundingMode roundingMode{round 55 ? common::RoundingMode::TiesAwayFromZero 56 : common::RoundingMode::ToZero}; 57 // Add decreasing powers of two to the result to find the largest magnitude 58 // value that can be converted to the integer type without overflow. 59 RealType at{RealType::FromInteger(IntType{negate ? -1 : 1}).value}; 60 bool decrement{true}; 61 while (!at.template ToInteger<IntType>(roundingMode) 62 .flags.test(RealFlag::Overflow)) { 63 auto tmp{at.SCALE(IntType{1})}; 64 if (tmp.flags.test(RealFlag::Overflow)) { 65 decrement = false; 66 break; 67 } 68 at = tmp.value; 69 } 70 while (true) { 71 if (decrement) { 72 at = at.SCALE(IntType{-1}).value; 73 } else { 74 decrement = true; 75 } 76 auto tmp{at.Add(result)}; 77 if (tmp.flags.test(RealFlag::Inexact)) { 78 break; 79 } else if (!tmp.value.template ToInteger<IntType>(roundingMode) 80 .flags.test(RealFlag::Overflow)) { 81 result = tmp.value; 82 } 83 } 84 return AsCategoryExpr(Constant<RType>{std::move(result)}); 85 } 86 87 static Expr<SomeReal> RealToIntBound( 88 int xRKind, int moldIKind, bool round, bool negate) { 89 switch (xRKind) { 90 #define ICASES(RK) \ 91 switch (moldIKind) { \ 92 case 1: \ 93 return RealToIntBoundHelper<RK, 1>(round, negate); \ 94 break; \ 95 case 2: \ 96 return RealToIntBoundHelper<RK, 2>(round, negate); \ 97 break; \ 98 case 4: \ 99 return RealToIntBoundHelper<RK, 4>(round, negate); \ 100 break; \ 101 case 8: \ 102 return RealToIntBoundHelper<RK, 8>(round, negate); \ 103 break; \ 104 case 16: \ 105 return RealToIntBoundHelper<RK, 16>(round, negate); \ 106 break; \ 107 } \ 108 break 109 case 2: 110 ICASES(2); 111 break; 112 case 3: 113 ICASES(3); 114 break; 115 case 4: 116 ICASES(4); 117 break; 118 case 8: 119 ICASES(8); 120 break; 121 case 10: 122 ICASES(10); 123 break; 124 case 16: 125 ICASES(16); 126 break; 127 } 128 DIE("RealToIntBound: no case"); 129 #undef ICASES 130 } 131 132 class RealToIntLimitHelper { 133 public: 134 using Result = std::optional<Expr<SomeReal>>; 135 using Types = RealTypes; 136 RealToIntLimitHelper( 137 FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) 138 : context_{context}, hi_{std::move(hi)}, lo_{lo} {} 139 template <typename T> Result Test() { 140 if (UnwrapExpr<Expr<T>>(hi_)) { 141 bool promote{T::kind < 16}; 142 Result constResult; 143 if (auto hiV{GetScalarConstantValue<T>(hi_)}) { 144 auto loV{GetScalarConstantValue<T>(lo_)}; 145 CHECK(loV.has_value()); 146 auto diff{hiV->Subtract(*loV, Rounding{common::RoundingMode::ToZero})}; 147 promote = promote && 148 (diff.flags.test(RealFlag::Overflow) || 149 diff.flags.test(RealFlag::Inexact)); 150 constResult = AsCategoryExpr(Constant<T>{std::move(diff.value)}); 151 } 152 if (promote) { 153 constexpr int nextKind{T::kind < 4 ? 4 : T::kind == 4 ? 8 : 16}; 154 using T2 = Type<TypeCategory::Real, nextKind>; 155 hi_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(hi_)))}; 156 lo_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(lo_)))}; 157 if (constResult) { 158 // Use promoted constants on next iteration of SearchTypes 159 return std::nullopt; 160 } 161 } 162 if (constResult) { 163 return constResult; 164 } else { 165 return AsCategoryExpr(std::move(hi_) - Expr<SomeReal>{lo_}); 166 } 167 } else { 168 return std::nullopt; 169 } 170 } 171 172 private: 173 FoldingContext &context_; 174 Expr<SomeReal> hi_; 175 Expr<SomeReal> &lo_; 176 }; 177 178 static std::optional<Expr<SomeReal>> RealToIntLimit( 179 FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) { 180 return common::SearchTypes(RealToIntLimitHelper{context, std::move(hi), lo}); 181 } 182 183 // RealToRealBounds() returns a pair (HUGE(x),REAL(HUGE(mold),KIND(x))) 184 // when REAL(HUGE(x),KIND(mold)) overflows, and std::nullopt otherwise. 185 template <int X_RKIND, int MOLD_RKIND> 186 std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>> 187 RealToRealBoundsHelper() { 188 using RType = Type<TypeCategory::Real, X_RKIND>; 189 using RealType = Scalar<RType>; 190 using MoldRealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>; 191 if (!MoldRealType::Convert(RealType::HUGE()).flags.test(RealFlag::Overflow)) { 192 return std::nullopt; 193 } else { 194 return std::make_pair(AsCategoryExpr(Constant<RType>{ 195 RealType::Convert(MoldRealType::HUGE()).value}), 196 AsCategoryExpr(Constant<RType>{RealType::HUGE()})); 197 } 198 } 199 200 static std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>> 201 RealToRealBounds(int xRKind, int moldRKind) { 202 switch (xRKind) { 203 #define RCASES(RK) \ 204 switch (moldRKind) { \ 205 case 2: \ 206 return RealToRealBoundsHelper<RK, 2>(); \ 207 break; \ 208 case 3: \ 209 return RealToRealBoundsHelper<RK, 3>(); \ 210 break; \ 211 case 4: \ 212 return RealToRealBoundsHelper<RK, 4>(); \ 213 break; \ 214 case 8: \ 215 return RealToRealBoundsHelper<RK, 8>(); \ 216 break; \ 217 case 10: \ 218 return RealToRealBoundsHelper<RK, 10>(); \ 219 break; \ 220 case 16: \ 221 return RealToRealBoundsHelper<RK, 16>(); \ 222 break; \ 223 } \ 224 break 225 case 2: 226 RCASES(2); 227 break; 228 case 3: 229 RCASES(3); 230 break; 231 case 4: 232 RCASES(4); 233 break; 234 case 8: 235 RCASES(8); 236 break; 237 case 10: 238 RCASES(10); 239 break; 240 case 16: 241 RCASES(16); 242 break; 243 } 244 DIE("RealToRealBounds: no case"); 245 #undef RCASES 246 } 247 248 template <int X_IKIND, int MOLD_RKIND> 249 std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) { 250 using IType = Type<TypeCategory::Integer, X_IKIND>; 251 using IntType = Scalar<IType>; 252 using RealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>; 253 IntType result{}; // 0 254 while (true) { 255 std::optional<IntType> next; 256 for (int bit{0}; bit < IntType::bits; ++bit) { 257 IntType power{IntType{}.IBSET(bit)}; 258 if (power.IsNegative()) { 259 if (!negate) { 260 break; 261 } 262 } else if (negate) { 263 power = power.Negate().value; 264 } 265 auto tmp{power.AddSigned(result)}; 266 if (tmp.overflow || 267 RealType::FromInteger(tmp.value).flags.test(RealFlag::Overflow)) { 268 break; 269 } 270 next = tmp.value; 271 } 272 if (next) { 273 CHECK(result.CompareSigned(*next) != Ordering::Equal); 274 result = *next; 275 } else { 276 break; 277 } 278 } 279 if (result.CompareSigned(IntType::HUGE()) == Ordering::Equal) { 280 return std::nullopt; 281 } else { 282 return AsCategoryExpr(Constant<IType>{std::move(result)}); 283 } 284 } 285 286 static std::optional<Expr<SomeInteger>> IntToRealBound( 287 int xIKind, int moldRKind, bool negate) { 288 switch (xIKind) { 289 #define RCASES(IK) \ 290 switch (moldRKind) { \ 291 case 2: \ 292 return IntToRealBoundHelper<IK, 2>(negate); \ 293 break; \ 294 case 3: \ 295 return IntToRealBoundHelper<IK, 3>(negate); \ 296 break; \ 297 case 4: \ 298 return IntToRealBoundHelper<IK, 4>(negate); \ 299 break; \ 300 case 8: \ 301 return IntToRealBoundHelper<IK, 8>(negate); \ 302 break; \ 303 case 10: \ 304 return IntToRealBoundHelper<IK, 10>(negate); \ 305 break; \ 306 case 16: \ 307 return IntToRealBoundHelper<IK, 16>(negate); \ 308 break; \ 309 } \ 310 break 311 case 1: 312 RCASES(1); 313 break; 314 case 2: 315 RCASES(2); 316 break; 317 case 4: 318 RCASES(4); 319 break; 320 case 8: 321 RCASES(8); 322 break; 323 case 16: 324 RCASES(16); 325 break; 326 } 327 DIE("IntToRealBound: no case"); 328 #undef RCASES 329 } 330 331 template <int X_IKIND, int MOLD_IKIND> 332 std::optional<Expr<SomeInteger>> IntToIntBoundHelper() { 333 if constexpr (X_IKIND <= MOLD_IKIND) { 334 return std::nullopt; 335 } else { 336 using XIType = Type<TypeCategory::Integer, X_IKIND>; 337 using IntegerType = Scalar<XIType>; 338 using MoldIType = Type<TypeCategory::Integer, MOLD_IKIND>; 339 using MoldIntegerType = Scalar<MoldIType>; 340 return AsCategoryExpr(Constant<XIType>{ 341 IntegerType::ConvertSigned(MoldIntegerType::HUGE()).value}); 342 } 343 } 344 345 static std::optional<Expr<SomeInteger>> IntToIntBound( 346 int xIKind, int moldIKind) { 347 switch (xIKind) { 348 #define ICASES(IK) \ 349 switch (moldIKind) { \ 350 case 1: \ 351 return IntToIntBoundHelper<IK, 1>(); \ 352 break; \ 353 case 2: \ 354 return IntToIntBoundHelper<IK, 2>(); \ 355 break; \ 356 case 4: \ 357 return IntToIntBoundHelper<IK, 4>(); \ 358 break; \ 359 case 8: \ 360 return IntToIntBoundHelper<IK, 8>(); \ 361 break; \ 362 case 16: \ 363 return IntToIntBoundHelper<IK, 16>(); \ 364 break; \ 365 } \ 366 break 367 case 1: 368 ICASES(1); 369 break; 370 case 2: 371 ICASES(2); 372 break; 373 case 4: 374 ICASES(4); 375 break; 376 case 8: 377 ICASES(8); 378 break; 379 case 16: 380 ICASES(16); 381 break; 382 } 383 DIE("IntToIntBound: no case"); 384 #undef ICASES 385 } 386 387 // ApplyIntrinsic() constructs the typed expression representation 388 // for a specific intrinsic function reference. 389 // TODO: maybe move into tools.h? 390 class IntrinsicCallHelper { 391 public: 392 explicit IntrinsicCallHelper(SpecificCall &&call) : call_{call} { 393 CHECK(proc_.IsFunction()); 394 typeAndShape_ = proc_.functionResult->GetTypeAndShape(); 395 CHECK(typeAndShape_ != nullptr); 396 } 397 using Result = std::optional<Expr<SomeType>>; 398 using Types = LengthlessIntrinsicTypes; 399 template <typename T> Result Test() { 400 if (T::category == typeAndShape_->type().category() && 401 T::kind == typeAndShape_->type().kind()) { 402 return AsGenericExpr(FunctionRef<T>{ 403 ProcedureDesignator{std::move(call_.specificIntrinsic)}, 404 std::move(call_.arguments)}); 405 } else { 406 return std::nullopt; 407 } 408 } 409 410 private: 411 SpecificCall call_; 412 const characteristics::Procedure &proc_{ 413 call_.specificIntrinsic.characteristics.value()}; 414 const characteristics::TypeAndShape *typeAndShape_{nullptr}; 415 }; 416 417 static Expr<SomeType> ApplyIntrinsic( 418 FoldingContext &context, const std::string &func, ActualArguments &&args) { 419 auto found{ 420 context.intrinsics().Probe(CallCharacteristics{func}, args, context)}; 421 CHECK(found.has_value()); 422 auto result{common::SearchTypes(IntrinsicCallHelper{std::move(*found)})}; 423 CHECK(result.has_value()); 424 return *result; 425 } 426 427 static Expr<LogicalResult> CompareUnsigned(FoldingContext &context, 428 const char *intrin, Expr<SomeType> &&x, Expr<SomeType> &&y) { 429 Expr<SomeType> result{ApplyIntrinsic(context, intrin, 430 ActualArguments{ 431 ActualArgument{std::move(x)}, ActualArgument{std::move(y)}})}; 432 return DEREF(UnwrapExpr<Expr<LogicalResult>>(result)); 433 } 434 435 // Determines the right kind of INTEGER to hold the bits of a REAL type. 436 static Expr<SomeType> IntTransferMold( 437 const TargetCharacteristics &target, DynamicType realType, bool asVector) { 438 CHECK(realType.category() == TypeCategory::Real); 439 int rKind{realType.kind()}; 440 int iKind{std::max<int>(target.GetAlignment(TypeCategory::Real, rKind), 441 target.GetByteSize(TypeCategory::Real, rKind))}; 442 CHECK(target.CanSupportType(TypeCategory::Integer, iKind)); 443 DynamicType iType{TypeCategory::Integer, iKind}; 444 ConstantSubscripts shape; 445 if (asVector) { 446 shape = ConstantSubscripts{1}; 447 } 448 Constant<SubscriptInteger> value{ 449 std::vector<Scalar<SubscriptInteger>>{0}, std::move(shape)}; 450 auto expr{ConvertToType(iType, AsGenericExpr(std::move(value)))}; 451 CHECK(expr.has_value()); 452 return std::move(*expr); 453 } 454 455 static Expr<SomeType> GetRealBits(FoldingContext &context, Expr<SomeReal> &&x) { 456 auto xType{x.GetType()}; 457 CHECK(xType.has_value()); 458 bool asVector{x.Rank() > 0}; 459 return ApplyIntrinsic(context, "transfer", 460 ActualArguments{ActualArgument{AsGenericExpr(std::move(x))}, 461 ActualArgument{IntTransferMold( 462 context.targetCharacteristics(), *xType, asVector)}}); 463 } 464 465 template <int KIND> 466 static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange( 467 FoldingContext &context, 468 FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) { 469 using ResultType = Type<TypeCategory::Logical, KIND>; 470 ActualArguments &args{funcRef.arguments()}; 471 // Fold x= and round= unconditionally 472 if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) { 473 *args[0] = Fold(context, std::move(*x)); 474 } 475 if (args.size() >= 3) { 476 if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) { 477 *args[2] = Fold(context, std::move(*round)); 478 } 479 } 480 if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) { 481 x = UnwrapExpr<Expr<SomeType>>(args[0]); 482 CHECK(x != nullptr); 483 if (const auto *mold{UnwrapExpr<Expr<SomeType>>(args[1])}) { 484 DynamicType xType{x->GetType().value()}; 485 DynamicType moldType{mold->GetType().value()}; 486 std::optional<Expr<LogicalResult>> result; 487 bool alwaysFalse{false}; 488 if (auto *iXExpr{UnwrapExpr<Expr<SomeInteger>>(*x)}) { 489 DynamicType iXType{iXExpr->GetType().value()}; 490 int iXKind{iXExpr->GetType().value().kind()}; 491 if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) { 492 // INTEGER -> INTEGER 493 int iMoldKind{iMoldExpr->GetType().value().kind()}; 494 if (auto hi{IntToIntBound(iXKind, iMoldKind)}) { 495 // 'hi' is INT(HUGE(mold), KIND(x)) 496 // OUT_OF_RANGE(x,mold) = (x + (hi + 1)) .UGT. (2*hi + 1) 497 auto one{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType( 498 xType, AsGenericExpr(Constant<SubscriptInteger>{1}))))}; 499 auto lhs{std::move(*iXExpr) + 500 (Expr<SomeInteger>{*hi} + Expr<SomeInteger>{one})}; 501 auto two{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType( 502 xType, AsGenericExpr(Constant<SubscriptInteger>{2}))))}; 503 auto rhs{std::move(two) * std::move(*hi) + std::move(one)}; 504 result = CompareUnsigned(context, "bgt", 505 Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)}); 506 } else { 507 alwaysFalse = true; 508 } 509 } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) { 510 // INTEGER -> REAL 511 int rMoldKind{rMoldExpr->GetType().value().kind()}; 512 if (auto hi{IntToRealBound(iXKind, rMoldKind, /*negate=*/false)}) { 513 // OUT_OF_RANGE(x,mold) = (x - lo) .UGT. (hi - lo) 514 auto lo{IntToRealBound(iXKind, rMoldKind, /*negate=*/true)}; 515 CHECK(lo.has_value()); 516 auto lhs{std::move(*iXExpr) - Expr<SomeInteger>{*lo}}; 517 auto rhs{std::move(*hi) - std::move(*lo)}; 518 result = CompareUnsigned(context, "bgt", 519 Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)}); 520 } else { 521 alwaysFalse = true; 522 } 523 } 524 } else if (auto *rXExpr{UnwrapExpr<Expr<SomeReal>>(*x)}) { 525 DynamicType rXType{rXExpr->GetType().value()}; 526 int rXKind{rXExpr->GetType().value().kind()}; 527 if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) { 528 // REAL -> INTEGER 529 int iMoldKind{iMoldExpr->GetType().value().kind()}; 530 auto hi{RealToIntBound(rXKind, iMoldKind, false, false)}; 531 auto lo{RealToIntBound(rXKind, iMoldKind, false, true)}; 532 if (args.size() >= 3) { 533 // Bounds depend on round= value 534 if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) { 535 if (const Symbol * whole{UnwrapWholeSymbolDataRef(*round)}; 536 whole && semantics::IsOptional(whole->GetUltimate())) { 537 if (auto source{args[2]->sourceLocation()}) { 538 context.messages().Say(*source, 539 "ROUND= argument to OUT_OF_RANGE() is an optional dummy argument that must be present at execution"_warn_en_US); 540 } 541 } 542 auto rlo{RealToIntBound(rXKind, iMoldKind, true, true)}; 543 auto rhi{RealToIntBound(rXKind, iMoldKind, true, false)}; 544 auto mlo{Fold(context, 545 ApplyIntrinsic(context, "merge", 546 ActualArguments{ 547 ActualArgument{Expr<SomeType>{std::move(rlo)}}, 548 ActualArgument{Expr<SomeType>{std::move(lo)}}, 549 ActualArgument{Expr<SomeType>{*round}}}))}; 550 auto mhi{Fold(context, 551 ApplyIntrinsic(context, "merge", 552 ActualArguments{ 553 ActualArgument{Expr<SomeType>{std::move(rhi)}}, 554 ActualArgument{Expr<SomeType>{std::move(hi)}}, 555 ActualArgument{std::move(*round)}}))}; 556 lo = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mlo))); 557 hi = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mhi))); 558 } 559 } 560 // OUT_OF_RANGE(x,mold[,round]) = 561 // TRANSFER(x - lo, int) .UGT. TRANSFER(hi - lo, int) 562 hi = Fold(context, std::move(hi)); 563 lo = Fold(context, std::move(lo)); 564 if (auto rhs{RealToIntLimit(context, std::move(hi), lo)}) { 565 Expr<SomeReal> lhs{std::move(*rXExpr) - std::move(lo)}; 566 result = CompareUnsigned(context, "bgt", 567 GetRealBits(context, std::move(lhs)), 568 GetRealBits(context, std::move(*rhs))); 569 } 570 } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) { 571 // REAL -> REAL 572 // Only finite arguments with ABS(x) > HUGE(mold) are .TRUE. 573 // OUT_OF_RANGE(x,mold) = 574 // TRANSFER(ABS(x) - HUGE(mold), int) - 1 .ULT. 575 // TRANSFER(HUGE(mold), int) 576 // Note that OUT_OF_RANGE(+/-Inf or NaN,mold) = 577 // TRANSFER(+Inf or Nan, int) - 1 .ULT. TRANSFER(HUGE(mold), int) 578 int rMoldKind{rMoldExpr->GetType().value().kind()}; 579 if (auto bounds{RealToRealBounds(rXKind, rMoldKind)}) { 580 auto &[moldHuge, xHuge]{*bounds}; 581 Expr<SomeType> abs{ApplyIntrinsic(context, "abs", 582 ActualArguments{ 583 ActualArgument{Expr<SomeType>{std::move(*rXExpr)}}})}; 584 auto &absR{DEREF(UnwrapExpr<Expr<SomeReal>>(abs))}; 585 Expr<SomeType> diffBits{ 586 GetRealBits(context, std::move(absR) - std::move(moldHuge))}; 587 auto &diffBitsI{DEREF(UnwrapExpr<Expr<SomeInteger>>(diffBits))}; 588 Expr<SomeType> decr{std::move(diffBitsI) - 589 Expr<SomeInteger>{Expr<SubscriptInteger>{1}}}; 590 result = CompareUnsigned(context, "blt", std::move(decr), 591 GetRealBits(context, std::move(xHuge))); 592 } else { 593 alwaysFalse = true; 594 } 595 } 596 } 597 if (alwaysFalse) { 598 // xType can never overflow moldType, so 599 // OUT_OF_RANGE(x) = (x /= 0) .AND. .FALSE. 600 // which has the same shape as x. 601 Expr<LogicalResult> scalarFalse{ 602 Constant<LogicalResult>{Scalar<LogicalResult>{false}}}; 603 if (x->Rank() > 0) { 604 if (auto nez{Relate(context.messages(), RelationalOperator::NE, 605 std::move(*x), 606 AsGenericExpr(Constant<SubscriptInteger>{0}))}) { 607 result = Expr<LogicalResult>{LogicalOperation<LogicalResult::kind>{ 608 LogicalOperator::And, std::move(*nez), std::move(scalarFalse)}}; 609 } 610 } else { 611 result = std::move(scalarFalse); 612 } 613 } 614 if (result) { 615 auto restorer{context.messages().DiscardMessages()}; 616 return Fold( 617 context, AsExpr(ConvertToType<ResultType>(std::move(*result)))); 618 } 619 } 620 } 621 return AsExpr(std::move(funcRef)); 622 } 623 624 template <int KIND> 625 Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction( 626 FoldingContext &context, 627 FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) { 628 using T = Type<TypeCategory::Logical, KIND>; 629 ActualArguments &args{funcRef.arguments()}; 630 auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}; 631 CHECK(intrinsic); 632 std::string name{intrinsic->name}; 633 using SameInt = Type<TypeCategory::Integer, KIND>; 634 if (name == "all") { 635 return FoldAllAnyParity( 636 context, std::move(funcRef), &Scalar<T>::AND, Scalar<T>{true}); 637 } else if (name == "any") { 638 return FoldAllAnyParity( 639 context, std::move(funcRef), &Scalar<T>::OR, Scalar<T>{false}); 640 } else if (name == "associated") { 641 bool gotConstant{true}; 642 const Expr<SomeType> *firstArgExpr{args[0]->UnwrapExpr()}; 643 if (!firstArgExpr || !IsNullPointer(*firstArgExpr)) { 644 gotConstant = false; 645 } else if (args[1]) { // There's a second argument 646 const Expr<SomeType> *secondArgExpr{args[1]->UnwrapExpr()}; 647 if (!secondArgExpr || !IsNullPointer(*secondArgExpr)) { 648 gotConstant = false; 649 } 650 } 651 return gotConstant ? Expr<T>{false} : Expr<T>{std::move(funcRef)}; 652 } else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") { 653 static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>); 654 655 // The arguments to these intrinsics can be of different types. In that 656 // case, the shorter of the two would need to be zero-extended to match 657 // the size of the other. If at least one of the operands is not a constant, 658 // the zero-extending will be done during lowering. Otherwise, the folding 659 // must be done here. 660 std::optional<Expr<SomeType>> constArgs[2]; 661 for (int i{0}; i <= 1; i++) { 662 if (BOZLiteralConstant * x{UnwrapExpr<BOZLiteralConstant>(args[i])}) { 663 constArgs[i] = AsGenericExpr(Constant<LargestInt>{std::move(*x)}); 664 } else if (auto *x{UnwrapExpr<Expr<SomeInteger>>(args[i])}) { 665 common::visit( 666 [&](const auto &ix) { 667 using IntT = typename std::decay_t<decltype(ix)>::Result; 668 if (auto *c{UnwrapConstantValue<IntT>(ix)}) { 669 constArgs[i] = ZeroExtend(*c); 670 } 671 }, 672 x->u); 673 } 674 } 675 676 if (constArgs[0] && constArgs[1]) { 677 auto fptr{&Scalar<LargestInt>::BGE}; 678 if (name == "bge") { // done in fptr declaration 679 } else if (name == "bgt") { 680 fptr = &Scalar<LargestInt>::BGT; 681 } else if (name == "ble") { 682 fptr = &Scalar<LargestInt>::BLE; 683 } else if (name == "blt") { 684 fptr = &Scalar<LargestInt>::BLT; 685 } else { 686 common::die("missing case to fold intrinsic function %s", name.c_str()); 687 } 688 689 for (int i{0}; i <= 1; i++) { 690 *args[i] = std::move(constArgs[i].value()); 691 } 692 693 return FoldElementalIntrinsic<T, LargestInt, LargestInt>(context, 694 std::move(funcRef), 695 ScalarFunc<T, LargestInt, LargestInt>( 696 [&fptr]( 697 const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) { 698 return Scalar<T>{std::invoke(fptr, i, j)}; 699 })); 700 } else { 701 return Expr<T>{std::move(funcRef)}; 702 } 703 } else if (name == "btest") { 704 if (const auto *ix{UnwrapExpr<Expr<SomeInteger>>(args[0])}) { 705 return common::visit( 706 [&](const auto &x) { 707 using IT = ResultType<decltype(x)>; 708 return FoldElementalIntrinsic<T, IT, SameInt>(context, 709 std::move(funcRef), 710 ScalarFunc<T, IT, SameInt>( 711 [&](const Scalar<IT> &x, const Scalar<SameInt> &pos) { 712 auto posVal{pos.ToInt64()}; 713 if (posVal < 0 || posVal >= x.bits) { 714 context.messages().Say( 715 "POS=%jd out of range for BTEST"_err_en_US, 716 static_cast<std::intmax_t>(posVal)); 717 } 718 return Scalar<T>{x.BTEST(posVal)}; 719 })); 720 }, 721 ix->u); 722 } 723 } else if (name == "dot_product") { 724 return FoldDotProduct<T>(context, std::move(funcRef)); 725 } else if (name == "extends_type_of") { 726 // Type extension testing with EXTENDS_TYPE_OF() ignores any type 727 // parameters. Returns a constant truth value when the result is known now. 728 if (args[0] && args[1]) { 729 auto t0{args[0]->GetType()}; 730 auto t1{args[1]->GetType()}; 731 if (t0 && t1) { 732 if (auto result{t0->ExtendsTypeOf(*t1)}) { 733 return Expr<T>{*result}; 734 } 735 } 736 } 737 } else if (name == "isnan" || name == "__builtin_ieee_is_nan") { 738 // Only replace the type of the function if we can do the fold 739 if (args[0] && args[0]->UnwrapExpr() && 740 IsActuallyConstant(*args[0]->UnwrapExpr())) { 741 auto restorer{context.messages().DiscardMessages()}; 742 using DefaultReal = Type<TypeCategory::Real, 4>; 743 return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef), 744 ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) { 745 return Scalar<T>{x.IsNotANumber()}; 746 })); 747 } 748 } else if (name == "__builtin_ieee_is_negative") { 749 auto restorer{context.messages().DiscardMessages()}; 750 using DefaultReal = Type<TypeCategory::Real, 4>; 751 if (args[0] && args[0]->UnwrapExpr() && 752 IsActuallyConstant(*args[0]->UnwrapExpr())) { 753 return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef), 754 ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) { 755 return Scalar<T>{x.IsNegative()}; 756 })); 757 } 758 } else if (name == "__builtin_ieee_is_normal") { 759 auto restorer{context.messages().DiscardMessages()}; 760 using DefaultReal = Type<TypeCategory::Real, 4>; 761 if (args[0] && args[0]->UnwrapExpr() && 762 IsActuallyConstant(*args[0]->UnwrapExpr())) { 763 return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef), 764 ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) { 765 return Scalar<T>{x.IsNormal()}; 766 })); 767 } 768 } else if (name == "is_contiguous") { 769 if (args.at(0)) { 770 if (auto *expr{args[0]->UnwrapExpr()}) { 771 if (auto contiguous{IsContiguous(*expr, context)}) { 772 return Expr<T>{*contiguous}; 773 } 774 } else if (auto *assumedType{args[0]->GetAssumedTypeDummy()}) { 775 if (auto contiguous{IsContiguous(*assumedType, context)}) { 776 return Expr<T>{*contiguous}; 777 } 778 } 779 } 780 } else if (name == "is_iostat_end") { 781 if (args[0] && args[0]->UnwrapExpr() && 782 IsActuallyConstant(*args[0]->UnwrapExpr())) { 783 using Int64 = Type<TypeCategory::Integer, 8>; 784 return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef), 785 ScalarFunc<T, Int64>([](const Scalar<Int64> &x) { 786 return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_END}; 787 })); 788 } 789 } else if (name == "is_iostat_eor") { 790 if (args[0] && args[0]->UnwrapExpr() && 791 IsActuallyConstant(*args[0]->UnwrapExpr())) { 792 using Int64 = Type<TypeCategory::Integer, 8>; 793 return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef), 794 ScalarFunc<T, Int64>([](const Scalar<Int64> &x) { 795 return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_EOR}; 796 })); 797 } 798 } else if (name == "lge" || name == "lgt" || name == "lle" || name == "llt") { 799 // Rewrite LGE/LGT/LLE/LLT into ASCII character relations 800 auto *cx0{UnwrapExpr<Expr<SomeCharacter>>(args[0])}; 801 auto *cx1{UnwrapExpr<Expr<SomeCharacter>>(args[1])}; 802 if (cx0 && cx1) { 803 return Fold(context, 804 ConvertToType<T>( 805 PackageRelation(name == "lge" ? RelationalOperator::GE 806 : name == "lgt" ? RelationalOperator::GT 807 : name == "lle" ? RelationalOperator::LE 808 : RelationalOperator::LT, 809 ConvertToType<Ascii>(std::move(*cx0)), 810 ConvertToType<Ascii>(std::move(*cx1))))); 811 } 812 } else if (name == "logical") { 813 if (auto *expr{UnwrapExpr<Expr<SomeLogical>>(args[0])}) { 814 return Fold(context, ConvertToType<T>(std::move(*expr))); 815 } 816 } else if (name == "matmul") { 817 return FoldMatmul(context, std::move(funcRef)); 818 } else if (name == "out_of_range") { 819 return RewriteOutOfRange<KIND>(context, std::move(funcRef)); 820 } else if (name == "parity") { 821 return FoldAllAnyParity( 822 context, std::move(funcRef), &Scalar<T>::NEQV, Scalar<T>{false}); 823 } else if (name == "same_type_as") { 824 // Type equality testing with SAME_TYPE_AS() ignores any type parameters. 825 // Returns a constant truth value when the result is known now. 826 if (args[0] && args[1]) { 827 auto t0{args[0]->GetType()}; 828 auto t1{args[1]->GetType()}; 829 if (t0 && t1) { 830 if (auto result{t0->SameTypeAs(*t1)}) { 831 return Expr<T>{*result}; 832 } 833 } 834 } 835 } else if (name == "__builtin_ieee_support_datatype" || 836 name == "__builtin_ieee_support_denormal" || 837 name == "__builtin_ieee_support_divide" || 838 name == "__builtin_ieee_support_inf" || 839 name == "__builtin_ieee_support_io" || 840 name == "__builtin_ieee_support_nan" || 841 name == "__builtin_ieee_support_sqrt" || 842 name == "__builtin_ieee_support_standard" || 843 name == "__builtin_ieee_support_subnormal" || 844 name == "__builtin_ieee_support_underflow_control") { 845 return Expr<T>{true}; 846 } 847 return Expr<T>{std::move(funcRef)}; 848 } 849 850 template <typename T> 851 Expr<LogicalResult> FoldOperation( 852 FoldingContext &context, Relational<T> &&relation) { 853 if (auto array{ApplyElementwise(context, relation, 854 std::function<Expr<LogicalResult>(Expr<T> &&, Expr<T> &&)>{ 855 [=](Expr<T> &&x, Expr<T> &&y) { 856 return Expr<LogicalResult>{Relational<SomeType>{ 857 Relational<T>{relation.opr, std::move(x), std::move(y)}}}; 858 }})}) { 859 return *array; 860 } 861 if (auto folded{OperandsAreConstants(relation)}) { 862 bool result{}; 863 if constexpr (T::category == TypeCategory::Integer) { 864 result = 865 Satisfies(relation.opr, folded->first.CompareSigned(folded->second)); 866 } else if constexpr (T::category == TypeCategory::Real) { 867 result = Satisfies(relation.opr, folded->first.Compare(folded->second)); 868 } else if constexpr (T::category == TypeCategory::Complex) { 869 result = (relation.opr == RelationalOperator::EQ) == 870 folded->first.Equals(folded->second); 871 } else if constexpr (T::category == TypeCategory::Character) { 872 result = Satisfies(relation.opr, Compare(folded->first, folded->second)); 873 } else { 874 static_assert(T::category != TypeCategory::Logical); 875 } 876 return Expr<LogicalResult>{Constant<LogicalResult>{result}}; 877 } 878 return Expr<LogicalResult>{Relational<SomeType>{std::move(relation)}}; 879 } 880 881 Expr<LogicalResult> FoldOperation( 882 FoldingContext &context, Relational<SomeType> &&relation) { 883 return common::visit( 884 [&](auto &&x) { 885 return Expr<LogicalResult>{FoldOperation(context, std::move(x))}; 886 }, 887 std::move(relation.u)); 888 } 889 890 template <int KIND> 891 Expr<Type<TypeCategory::Logical, KIND>> FoldOperation( 892 FoldingContext &context, Not<KIND> &&x) { 893 if (auto array{ApplyElementwise(context, x)}) { 894 return *array; 895 } 896 using Ty = Type<TypeCategory::Logical, KIND>; 897 auto &operand{x.left()}; 898 if (auto value{GetScalarConstantValue<Ty>(operand)}) { 899 return Expr<Ty>{Constant<Ty>{!value->IsTrue()}}; 900 } 901 return Expr<Ty>{x}; 902 } 903 904 template <int KIND> 905 Expr<Type<TypeCategory::Logical, KIND>> FoldOperation( 906 FoldingContext &context, LogicalOperation<KIND> &&operation) { 907 using LOGICAL = Type<TypeCategory::Logical, KIND>; 908 if (auto array{ApplyElementwise(context, operation, 909 std::function<Expr<LOGICAL>(Expr<LOGICAL> &&, Expr<LOGICAL> &&)>{ 910 [=](Expr<LOGICAL> &&x, Expr<LOGICAL> &&y) { 911 return Expr<LOGICAL>{LogicalOperation<KIND>{ 912 operation.logicalOperator, std::move(x), std::move(y)}}; 913 }})}) { 914 return *array; 915 } 916 if (auto folded{OperandsAreConstants(operation)}) { 917 bool xt{folded->first.IsTrue()}, yt{folded->second.IsTrue()}, result{}; 918 switch (operation.logicalOperator) { 919 case LogicalOperator::And: 920 result = xt && yt; 921 break; 922 case LogicalOperator::Or: 923 result = xt || yt; 924 break; 925 case LogicalOperator::Eqv: 926 result = xt == yt; 927 break; 928 case LogicalOperator::Neqv: 929 result = xt != yt; 930 break; 931 case LogicalOperator::Not: 932 DIE("not a binary operator"); 933 } 934 return Expr<LOGICAL>{Constant<LOGICAL>{result}}; 935 } 936 return Expr<LOGICAL>{std::move(operation)}; 937 } 938 939 #ifdef _MSC_VER // disable bogus warning about missing definitions 940 #pragma warning(disable : 4661) 941 #endif 942 FOR_EACH_LOGICAL_KIND(template class ExpressionBase, ) 943 template class ExpressionBase<SomeLogical>; 944 } // namespace Fortran::evaluate 945