diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h --- a/flang/include/flang/Lower/IntrinsicCall.h +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -75,9 +75,8 @@ /// Return how argument \p argName should be lowered given the rules for the /// intrinsic function. The argument names are the one defined by the standard. -ArgLoweringRule lowerIntrinsicArgumentAs(mlir::Location, - const IntrinsicArgumentLoweringRules &, - llvm::StringRef argName); +ArgLoweringRule lowerIntrinsicArgumentAs(const IntrinsicArgumentLoweringRules &, + unsigned position); /// Return place-holder for absent intrinsic arguments. fir::ExtendedValue getAbsentIntrinsicArgument(); diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -571,6 +571,16 @@ return obj.GetLastSymbol().GetUltimate(); } +static bool +isIntrinsicModuleProcRef(const Fortran::evaluate::ProcedureRef &procRef) { + const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol(); + if (!symbol) + return false; + const Fortran::semantics::Symbol *module = + symbol->GetUltimate().owner().GetSymbol(); + return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC); +} + namespace { /// Lowering of Fortran::evaluate::Expr expressions @@ -2099,17 +2109,20 @@ fir::factory::getNonDeferredLengthParams(exv)); } - /// Generate a call to an intrinsic function. - ExtValue - genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, - const Fortran::evaluate::SpecificIntrinsic &intrinsic, - llvm::Optional resultType) { + /// Generate a call to a Fortran intrinsic or intrinsic module procedure. + ExtValue genIntrinsicRef( + const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional resultType, + llvm::Optional intrinsic = + llvm::None) { llvm::SmallVector operands; - llvm::StringRef name = intrinsic.name; + std::string name = + intrinsic ? intrinsic->name + : procRef.proc().GetSymbol()->GetUltimate().name().ToString(); mlir::Location loc = getLoc(); - if (Fortran::lower::intrinsicRequiresCustomOptionalHandling( - procRef, intrinsic, converter)) { + if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling( + procRef, *intrinsic, converter)) { using ExvAndPresence = std::pair>; llvm::SmallVector operands; auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) { @@ -2122,7 +2135,7 @@ operands.emplace_back(genval(expr), llvm::None); }; Fortran::lower::prepareCustomIntrinsicArgument( - procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg, + procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg, converter); auto getArgument = [&](std::size_t i) -> ExtValue { @@ -2141,10 +2154,9 @@ const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = Fortran::lower::getIntrinsicArgumentLowering(name); - for (const auto &[arg, dummy] : - llvm::zip(procRef.arguments(), - intrinsic.characteristics.value().dummyArguments)) { - auto *expr = Fortran::evaluate::UnwrapExpr(arg); + for (const auto &arg : llvm::enumerate(procRef.arguments())) { + auto *expr = + Fortran::evaluate::UnwrapExpr(arg.value()); if (!expr) { // Absent optional. operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); @@ -2157,8 +2169,7 @@ } // Ad-hoc argument lowering handling. Fortran::lower::ArgLoweringRule argRules = - Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering, - dummy.name); + Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index()); if (argRules.handleDynamicOptional && Fortran::evaluate::MayBePassedAsAbsentOptional( *expr, converter.getFoldingContext())) { @@ -2204,13 +2215,6 @@ operands, stmtCtx); } - template - bool isCharacterType(const A &exp) { - if (auto type = exp.GetType()) - return type->category() == Fortran::common::TypeCategory::Character; - return false; - } - /// helper to detect statement functions static bool isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) { @@ -2220,6 +2224,7 @@ return details->stmtFunction().has_value(); return false; } + /// Generate Statement function calls ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) { const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol(); @@ -2832,6 +2837,13 @@ Fortran::lower::getAdaptToByRefAttr(builder)}); } + template + bool isCharacterType(const A &exp) { + if (auto type = exp.GetType()) + return type->category() == Fortran::common::TypeCategory::Character; + return false; + } + /// Lower an actual argument that must be passed via an address. /// This generates of the copy-in/copy-out if the actual is not contiguous, or /// the creation of the temp if the actual is a variable and \p byValue is @@ -2930,9 +2942,13 @@ if (isElementalProcWithArrayArgs(procRef)) fir::emitFatalError(loc, "trying to lower elemental procedure with array " "arguments as normal procedure"); + if (const Fortran::evaluate::SpecificIntrinsic *intrinsic = procRef.proc().GetSpecificIntrinsic()) - return genIntrinsicRef(procRef, *intrinsic, resultType); + return genIntrinsicRef(procRef, resultType, *intrinsic); + + if (isIntrinsicModuleProcRef(procRef)) + return genIntrinsicRef(procRef, resultType); if (isStatementFunctionCall(procRef)) return genStmtFunctionRef(procRef); @@ -4685,18 +4701,22 @@ return genarr(x); } - // A procedure reference to a Fortran elemental intrinsic procedure. + // A reference to a Fortran elemental intrinsic or intrinsic module procedure. CC genElementalIntrinsicProcRef( const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional retTy, - const Fortran::evaluate::SpecificIntrinsic &intrinsic) { + llvm::Optional intrinsic = + llvm::None) { + llvm::SmallVector operands; - llvm::StringRef name = intrinsic.name; + std::string name = + intrinsic ? intrinsic->name + : procRef.proc().GetSymbol()->GetUltimate().name().ToString(); const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = Fortran::lower::getIntrinsicArgumentLowering(name); mlir::Location loc = getLoc(); - if (Fortran::lower::intrinsicRequiresCustomOptionalHandling( - procRef, intrinsic, converter)) { + if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling( + procRef, *intrinsic, converter)) { using CcPairT = std::pair>; llvm::SmallVector operands; auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) { @@ -4719,11 +4739,10 @@ operands.emplace_back(genElementalArgument(expr), llvm::None); }; Fortran::lower::prepareCustomIntrinsicArgument( - procRef, intrinsic, retTy, prepareOptionalArg, prepareOtherArg, + procRef, *intrinsic, retTy, prepareOptionalArg, prepareOtherArg, converter); fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); - llvm::StringRef name = intrinsic.name; return [=](IterSpace iters) -> ExtValue { auto getArgument = [&](std::size_t i) -> ExtValue { return operands[i].first(iters); @@ -4737,11 +4756,9 @@ }; } /// Otherwise, pre-lower arguments and use intrinsic lowering utility. - for (const auto &[arg, dummy] : - llvm::zip(procRef.arguments(), - intrinsic.characteristics.value().dummyArguments)) { + for (const auto &arg : llvm::enumerate(procRef.arguments())) { const auto *expr = - Fortran::evaluate::UnwrapExpr(arg); + Fortran::evaluate::UnwrapExpr(arg.value()); if (!expr) { // Absent optional. operands.emplace_back([=](IterSpace) { return mlir::Value{}; }); @@ -4752,8 +4769,7 @@ } else { // Ad-hoc argument lowering handling. Fortran::lower::ArgLoweringRule argRules = - Fortran::lower::lowerIntrinsicArgumentAs(getLoc(), *argLowering, - dummy.name); + Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index()); if (argRules.handleDynamicOptional && Fortran::evaluate::MayBePassedAsAbsentOptional( *expr, converter.getFoldingContext())) { @@ -4955,6 +4971,8 @@ // The intrinsic procedure is called once per element of the array. return genElementalIntrinsicProcRef(procRef, retTy, *intrin); } + if (isIntrinsicModuleProcRef(procRef)) + return genElementalIntrinsicProcRef(procRef, retTy); if (ScalarExprLowering::isStatementFunctionCall(procRef)) fir::emitFatalError(loc, "statement function cannot be elemental"); @@ -4971,12 +4989,12 @@ // Elide any implicit loop iters. return [=, &procRef](IterSpace) { return ScalarExprLowering{loc, converter, symMap, stmtCtx} - .genIntrinsicRef(procRef, *intrinsic, retTy); + .genIntrinsicRef(procRef, retTy, *intrinsic); }; } return genarr( ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef( - procRef, *intrinsic, retTy)); + procRef, retTy, *intrinsic)); } if (explicitSpaceIsActive() && procRef.Rank() == 0) { diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -43,9 +43,9 @@ #define PGMATH_DECLARE #include "flang/Evaluate/pgmath.h.inc" -/// This file implements lowering of Fortran intrinsic procedures. -/// Intrinsics are lowered to a mix of FIR and MLIR operations as -/// well as call to runtime functions or LLVM intrinsics. +/// This file implements lowering of Fortran intrinsic procedures and Fortran +/// intrinsic module procedures. A call may be inlined with a mix of FIR and +/// MLIR operations, or as a call to a runtime function or LLVM intrinsic. /// Lowering of intrinsic procedure calls is based on a map that associates /// Fortran intrinsic generic names to FIR generator functions. @@ -493,6 +493,10 @@ mlir::Value genIbits(mlir::Type, llvm::ArrayRef); mlir::Value genIbset(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genIchar(mlir::Type, llvm::ArrayRef); + mlir::Value genIeeeIsFinite(mlir::Type, llvm::ArrayRef); + template + fir::ExtendedValue genIeeeTypeCompare(mlir::Type, + llvm::ArrayRef); mlir::Value genIeor(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genIndex(mlir::Type, llvm::ArrayRef); mlir::Value genIor(mlir::Type, llvm::ArrayRef); @@ -758,6 +762,11 @@ {"ibits", &I::genIbits}, {"ibset", &I::genIbset}, {"ichar", &I::genIchar}, + {"ieee_class_eq", &I::genIeeeTypeCompare}, + {"ieee_class_ne", &I::genIeeeTypeCompare}, + {"ieee_is_finite", &I::genIeeeIsFinite}, + {"ieee_round_eq", &I::genIeeeTypeCompare}, + {"ieee_round_ne", &I::genIeeeTypeCompare}, {"ieor", &I::genIeor}, {"index", &I::genIndex, @@ -1410,9 +1419,33 @@ // IntrinsicLibrary //===----------------------------------------------------------------------===// -/// Emit a TODO error message for as yet unimplemented intrinsics. -static void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) { - TODO(loc, "missing intrinsic lowering: " + llvm::Twine(name)); +static bool isIntrinsicModuleProcedure(llvm::StringRef name) { + return name.startswith("c_") || name.startswith("compiler_") || + name.startswith("ieee_"); +} + +/// Return the generic name of an intrinsic module procedure specific name. +/// Remove any "__builtin_" prefix, and any specific suffix of the form +/// {_[ail]?[0-9]+}*, such as _1 or _a4. +llvm::StringRef genericName(llvm::StringRef specificName) { + const std::string builtin = "__builtin_"; + llvm::StringRef name = specificName.startswith(builtin) + ? specificName.drop_front(builtin.size()) + : specificName; + size_t size = name.size(); + if (isIntrinsicModuleProcedure(name)) + while (isdigit(name[size - 1])) + while (name[--size] != '_') + ; + return name.drop_back(name.size() - size); +} + +/// Generate a TODO error message for an as yet unimplemented intrinsic. +void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) { + if (isIntrinsicModuleProcedure(name)) + TODO(loc, "intrinsic module procedure: " + llvm::Twine(name)); + else + TODO(loc, "intrinsic: " + llvm::Twine(name)); } template @@ -1502,9 +1535,10 @@ } fir::ExtendedValue -IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name, +IntrinsicLibrary::genIntrinsicCall(llvm::StringRef specificName, llvm::Optional resultType, llvm::ArrayRef args) { + llvm::StringRef name = genericName(specificName); if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) { bool outline = handler->outline || outlineAllIntrinsics; return std::visit( @@ -1695,10 +1729,10 @@ mlir::func::FuncOp funcOp = getRuntimeFunction(loc, builder, name, soughtFuncType); if (!funcOp) { - std::string buffer("not yet implemented: missing intrinsic lowering: "); - llvm::raw_string_ostream sstream(buffer); - sstream << name << "\nrequested type was: " << soughtFuncType << '\n'; - fir::emitFatalError(loc, buffer); + std::string nameAndType; + llvm::raw_string_ostream sstream(nameAndType); + sstream << name << "\nrequested type: " << soughtFuncType; + crashOnMissingIntrinsic(loc, nameAndType); } mlir::FunctionType actualFuncType = funcOp.getFunctionType(); @@ -2621,6 +2655,67 @@ return builder.create(loc, resultType, code); } +// IEEE_CLASS_TYPE OPERATOR(==), OPERATOR(/=) +// IEEE_ROUND_TYPE OPERATOR(==), OPERATOR(/=) +template +fir::ExtendedValue +IntrinsicLibrary::genIeeeTypeCompare(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + mlir::Value arg0 = fir::getBase(args[0]); + mlir::Value arg1 = fir::getBase(args[1]); + auto recType = + fir::unwrapPassByRefType(arg0.getType()).dyn_cast(); + assert(recType.getTypeList().size() == 1 && "expected exactly one component"); + auto [fieldName, fieldType] = recType.getTypeList().front(); + mlir::Type fieldIndexType = fir::FieldType::get(recType.getContext()); + mlir::Value field = builder.create( + loc, fieldIndexType, fieldName, recType, fir::getTypeParams(arg0)); + mlir::Value left = builder.create( + loc, fieldType, + builder.create(loc, builder.getRefType(fieldType), + arg0, field)); + mlir::Value right = builder.create( + loc, fieldType, + builder.create(loc, builder.getRefType(fieldType), + arg1, field)); + return builder.create(loc, pred, left, right); +} + +// IEEE_IS_FINITE +mlir::Value +IntrinsicLibrary::genIeeeIsFinite(mlir::Type resultType, + llvm::ArrayRef args) { + // IEEE_IS_FINITE(X) is true iff exponent(X) is the max exponent of kind(X). + assert(args.size() == 1); + mlir::Value floatVal = fir::getBase(args[0]); + mlir::FloatType floatType = floatVal.getType().dyn_cast(); + int floatBits = floatType.getWidth(); + mlir::Type intType = builder.getIntegerType( + floatType.isa() ? 128 : floatBits); + mlir::Value intVal = + builder.create(loc, intType, floatVal); + int significandBits; + if (floatType.isa()) + significandBits = 23; + else if (floatType.isa()) + significandBits = 52; + else // problems elsewhere for other kinds + TODO(loc, "intrinsic module procedure: ieee_is_finite"); + mlir::Value significand = + builder.createIntegerConstant(loc, intType, significandBits); + int exponentBits = floatBits - 1 - significandBits; + mlir::Value maxExponent = + builder.createIntegerConstant(loc, intType, (1 << exponentBits) - 1); + mlir::Value exponent = genIbits( + intType, {intVal, significand, + builder.createIntegerConstant(loc, intType, exponentBits)}); + return builder.createConvert( + loc, resultType, + builder.create(loc, mlir::arith::CmpIPredicate::ne, + exponent, maxExponent)); +} + // IEOR mlir::Value IntrinsicLibrary::genIeor(mlir::Type resultType, llvm::ArrayRef args) { @@ -2811,7 +2906,7 @@ // LGE, LGT, LLE, LLT template fir::ExtendedValue -IntrinsicLibrary::genCharacterCompare(mlir::Type type, +IntrinsicLibrary::genCharacterCompare(mlir::Type resultType, llvm::ArrayRef args) { assert(args.size() == 2); return fir::runtime::genCharCompare( @@ -3850,15 +3945,11 @@ /// Return how argument \p argName should be lowered given the rules for the /// intrinsic function. Fortran::lower::ArgLoweringRule Fortran::lower::lowerIntrinsicArgumentAs( - mlir::Location loc, const IntrinsicArgumentLoweringRules &rules, - llvm::StringRef argName) { - for (const IntrinsicDummyArgument &arg : rules.args) { - if (arg.name && arg.name == argName) - return {arg.lowerAs, arg.handleDynamicOptional}; - } - fir::emitFatalError( - loc, "internal: unknown intrinsic argument name in lowering '" + argName + - "'"); + const IntrinsicArgumentLoweringRules &rules, unsigned position) { + assert(position < sizeof(rules.args) / sizeof(decltype(*rules.args)) && + "invalid argument"); + return {rules.args[position].lowerAs, + rules.args[position].handleDynamicOptional}; } //===----------------------------------------------------------------------===// diff --git a/flang/module/__fortran_ieee_exceptions.f90 b/flang/module/__fortran_ieee_exceptions.f90 --- a/flang/module/__fortran_ieee_exceptions.f90 +++ b/flang/module/__fortran_ieee_exceptions.f90 @@ -124,13 +124,13 @@ end interface #define IEEE_SUPPORT_FLAG_R(XKIND) \ - pure logical function ieee_support_flag_a##XKIND(flag, x); \ + logical function ieee_support_flag_a##XKIND(flag, x); \ import ieee_flag_type; \ type(ieee_flag_type), intent(in) :: flag; \ real(XKIND), intent(in) :: x(..); \ end function ieee_support_flag_a##XKIND; interface ieee_support_flag - pure logical function ieee_support_flag(flag) + logical function ieee_support_flag(flag) import ieee_flag_type type(ieee_flag_type), intent(in) :: flag end function ieee_support_flag diff --git a/flang/module/ieee_arithmetic.f90 b/flang/module/ieee_arithmetic.f90 --- a/flang/module/ieee_arithmetic.f90 +++ b/flang/module/ieee_arithmetic.f90 @@ -514,7 +514,7 @@ real(XKIND), intent(in) :: x(..); \ end function ieee_support_rounding_a##XKIND; interface ieee_support_rounding - pure logical function ieee_support_rounding(round_value) + logical function ieee_support_rounding(round_value) import ieee_round_type type(ieee_round_type), intent(in) :: round_value end function ieee_support_rounding diff --git a/flang/test/Lower/intrinsic-procedures/ieee_is_finite.f90 b/flang/test/Lower/intrinsic-procedures/ieee_is_finite.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/intrinsic-procedures/ieee_is_finite.f90 @@ -0,0 +1,68 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: @_QPis_finite_test +subroutine is_finite_test(x, y) + use ieee_arithmetic, only: ieee_is_finite + real(4) x + real(8) y + ! CHECK: %[[V_3:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_4:[0-9]+]] = arith.bitcast %[[V_3]] : f32 to i32 + ! CHECK: %[[V_5:[0-9]+]] = arith.subi %c32{{.*}}, %c8{{.*}} : i32 + ! CHECK: %[[V_6:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_5]] : i32 + ! CHECK: %[[V_7:[0-9]+]] = arith.shrsi %[[V_4]], %c23{{.*}} : i32 + ! CHECK: %[[V_8:[0-9]+]] = arith.andi %[[V_7]], %[[V_6]] : i32 + ! CHECK: %[[V_9:[0-9]+]] = arith.cmpi eq, %c8{{.*}}, %c0{{.*}} : i32 + ! CHECK: %[[V_10:[0-9]+]] = arith.select %[[V_9]], %c0{{.*}}, %[[V_8]] : i32 + ! CHECK: %[[V_11:[0-9]+]] = arith.cmpi ne, %[[V_10]], %c255{{.*}} : i32 + ! CHECK: %[[V_12:[0-9]+]] = fir.convert %[[V_11]] : (i1) -> !fir.logical<4> + ! CHECK: %[[V_13:[0-9]+]] = fir.convert %[[V_12]] : (!fir.logical<4>) -> i1 + print*, ieee_is_finite(x) + + ! CHECK: %[[V_19:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_20:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_21:[0-9]+]] = arith.addf %[[V_19]], %[[V_20]] : f32 + ! CHECK: %[[V_22:[0-9]+]] = arith.bitcast %[[V_21]] : f32 to i32 + ! CHECK: %[[V_23:[0-9]+]] = arith.subi %c32{{.*}}, %c8{{.*}} : i32 + ! CHECK: %[[V_24:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_23]] : i32 + ! CHECK: %[[V_25:[0-9]+]] = arith.shrsi %[[V_22]], %c23{{.*}} : i32 + ! CHECK: %[[V_26:[0-9]+]] = arith.andi %[[V_25]], %[[V_24]] : i32 + ! CHECK: %[[V_27:[0-9]+]] = arith.cmpi eq, %c8{{.*}}, %c0{{.*}} : i32 + ! CHECK: %[[V_28:[0-9]+]] = arith.select %[[V_27]], %c0{{.*}}, %[[V_26]] : i32 + ! CHECK: %[[V_29:[0-9]+]] = arith.cmpi ne, %[[V_28]], %c255{{.*}} : i32 + ! CHECK: %[[V_30:[0-9]+]] = fir.convert %[[V_29]] : (i1) -> !fir.logical<4> + ! CHECK: %[[V_31:[0-9]+]] = fir.convert %[[V_30]] : (!fir.logical<4>) -> i1 + print*, ieee_is_finite(x+x) + + ! CHECK: %[[V_37:[0-9]+]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[V_38:[0-9]+]] = arith.bitcast %[[V_37]] : f64 to i64 + ! CHECK: %[[V_39:[0-9]+]] = arith.subi %c64{{.*}}, %c11{{.*}} : i64 + ! CHECK: %[[V_40:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_39]] : i64 + ! CHECK: %[[V_41:[0-9]+]] = arith.shrsi %[[V_38]], %c52{{.*}} : i64 + ! CHECK: %[[V_42:[0-9]+]] = arith.andi %[[V_41]], %[[V_40]] : i64 + ! CHECK: %[[V_43:[0-9]+]] = arith.cmpi eq, %c11{{.*}}, %c0{{.*}} : i64 + ! CHECK: %[[V_44:[0-9]+]] = arith.select %[[V_43]], %c0{{.*}}, %[[V_42]] : i64 + ! CHECK: %[[V_45:[0-9]+]] = arith.cmpi ne, %[[V_44]], %c2047{{.*}} : i64 + ! CHECK: %[[V_46:[0-9]+]] = fir.convert %[[V_45]] : (i1) -> !fir.logical<4> + ! CHECK: %[[V_47:[0-9]+]] = fir.convert %[[V_46]] : (!fir.logical<4>) -> i1 + print*, ieee_is_finite(y) + + ! CHECK: %[[V_53:[0-9]+]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[V_54:[0-9]+]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[V_55:[0-9]+]] = arith.addf %[[V_53]], %[[V_54]] : f64 + ! CHECK: %[[V_56:[0-9]+]] = arith.bitcast %[[V_55]] : f64 to i64 + ! CHECK: %[[V_57:[0-9]+]] = arith.subi %c64{{.*}}, %c11{{.*}} : i64 + ! CHECK: %[[V_58:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_57]] : i64 + ! CHECK: %[[V_59:[0-9]+]] = arith.shrsi %[[V_56]], %c52{{.*}} : i64 + ! CHECK: %[[V_60:[0-9]+]] = arith.andi %[[V_59]], %[[V_58]] : i64 + ! CHECK: %[[V_61:[0-9]+]] = arith.cmpi eq, %c11{{.*}}, %c0{{.*}} : i64 + ! CHECK: %[[V_62:[0-9]+]] = arith.select %[[V_61]], %c0{{.*}}, %[[V_60]] : i64 + ! CHECK: %[[V_63:[0-9]+]] = arith.cmpi ne, %[[V_62]], %c2047{{.*}} : i64 + ! CHECK: %[[V_64:[0-9]+]] = fir.convert %[[V_63]] : (i1) -> !fir.logical<4> + ! CHECK: %[[V_65:[0-9]+]] = fir.convert %[[V_64]] : (!fir.logical<4>) -> i1 + print*, ieee_is_finite(y+y) +end subroutine is_finite_test + + real(4) x + real(8) y + call is_finite_test(huge(x), huge(y)) +end diff --git a/flang/test/Lower/intrinsic-procedures/ieee_operator_eq.f90 b/flang/test/Lower/intrinsic-procedures/ieee_operator_eq.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/intrinsic-procedures/ieee_operator_eq.f90 @@ -0,0 +1,46 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: @_QPs +subroutine s(r1,r2) + use ieee_arithmetic, only: ieee_round_type, operator(==) + type(ieee_round_type) :: r1, r2 + ! CHECK: %[[V_3:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_4:[0-9]+]] = fir.coordinate_of %arg0, %[[V_3]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: %[[V_5:[0-9]+]] = fir.load %[[V_4]] : !fir.ref + ! CHECK: %[[V_6:[0-9]+]] = fir.coordinate_of %arg1, %[[V_3]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: %[[V_7:[0-9]+]] = fir.load %[[V_6]] : !fir.ref + ! CHECK: %[[V_8:[0-9]+]] = arith.cmpi eq, %[[V_5]], %[[V_7]] : i8 + ! CHECK: %[[V_9:[0-9]+]] = fir.call @_FortranAioOutputLogical(%{{.*}}, %[[V_8]]) : (!fir.ref, i1) -> i1 + print*, r1 == r2 +end + +! CHECK-LABEL: @_QQmain + use ieee_arithmetic, only: ieee_round_type, ieee_nearest, ieee_to_zero + interface + subroutine s(r1,r2) + import ieee_round_type + type(ieee_round_type) :: r1, r2 + end + end interface + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_1:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_2:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_3:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_4:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_5:[0-9]+]] = fir.coordinate_of %[[V_3]], %[[V_4]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c2{{.*}} to %[[V_5]] : !fir.ref + ! CHECK: %[[V_6:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_7:[0-9]+]] = fir.coordinate_of %[[V_2]], %[[V_6]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c1{{.*}} to %[[V_7]] : !fir.ref + call s(ieee_to_zero, ieee_nearest) + + ! CHECK: fir.call @_QPs(%[[V_3]], %[[V_2]]) : (!fir.ref>, !fir.ref>) -> () + ! CHECK: %[[V_8:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_9:[0-9]+]] = fir.coordinate_of %[[V_1]], %[[V_8]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c1{{.*}} to %[[V_9]] : !fir.ref + ! CHECK: %[[V_10:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}> + ! CHECK: %[[V_11:[0-9]+]] = fir.coordinate_of %[[V_0]], %[[V_10]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c1{{.*}} to %[[V_11]] : !fir.ref + ! CHECK: fir.call @_QPs(%[[V_1]], %[[V_0]]) : (!fir.ref>, !fir.ref>) -> () + call s(ieee_nearest, ieee_nearest) +end