diff options
Diffstat (limited to 'flang')
41 files changed, 581 insertions, 98 deletions
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 6d87209..c9cc027 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -182,6 +182,13 @@ end Note that internally the main program symbol name is all uppercase, unlike the names of all other symbols, which are usually all lowercase. This may make a difference in testing/debugging. +* A `PROCEDURE()` with no interface name or type may be called as an + subroutine with an implicit interface, F'2023 15.4.3.6 paragraph 4 and + C1525 notwithstanding. + This is a universally portable feature, and it also applies to + `PROCEDURE(), POINTER, NOPASS` derived type components. + Such procedures may *not* be referenced as implicitly typed functions + without first being associated with a function pointer. ## Extensions, deletions, and legacy features supported by default @@ -954,4 +961,3 @@ print *, [(j,j=1,10)] "&GRP A(1:)=1. 2. 3./". This extension is necessarily disabled when the type of the array has an accessible defined formatted READ subroutine. - diff --git a/flang/include/flang/Evaluate/common.h b/flang/include/flang/Evaluate/common.h index 0263f15..3d220af 100644 --- a/flang/include/flang/Evaluate/common.h +++ b/flang/include/flang/Evaluate/common.h @@ -303,10 +303,16 @@ public: return common::ScopedSet(analyzingPDTComponentKindSelector_, true); } + common::Restorer<std::string> SetRealFlagWarningContext(std::string str) { + return common::ScopedSet(realFlagWarningContext_, str); + } + parser::CharBlock SaveTempName(std::string &&name) { return {*tempNames_.emplace(std::move(name)).first}; } + void RealFlagWarnings(const RealFlags &, const char *op); + private: parser::ContextualMessages messages_; const common::IntrinsicTypeDefaultKinds &defaults_; @@ -318,8 +324,8 @@ private: std::map<parser::CharBlock, ConstantSubscript> impliedDos_; const common::LanguageFeatureControl &languageFeatures_; std::set<std::string> &tempNames_; + std::string realFlagWarningContext_; }; -void RealFlagWarnings(FoldingContext &, const RealFlags &, const char *op); } // namespace Fortran::evaluate #endif // FORTRAN_EVALUATE_COMMON_H_ diff --git a/flang/include/flang/Lower/OpenMP/Clauses.h b/flang/include/flang/Lower/OpenMP/Clauses.h index 7492466..688d017 100644 --- a/flang/include/flang/Lower/OpenMP/Clauses.h +++ b/flang/include/flang/Lower/OpenMP/Clauses.h @@ -294,6 +294,7 @@ using Permutation = tomp::clause::PermutationT<TypeTy, IdTy, ExprTy>; using TaskReduction = tomp::clause::TaskReductionT<TypeTy, IdTy, ExprTy>; using ThreadLimit = tomp::clause::ThreadLimitT<TypeTy, IdTy, ExprTy>; using Threads = tomp::clause::ThreadsT<TypeTy, IdTy, ExprTy>; +using Threadset = tomp::clause::ThreadsetT<TypeTy, IdTy, ExprTy>; using Transparent = tomp::clause::TransparentT<TypeTy, IdTy, ExprTy>; using To = tomp::clause::ToT<TypeTy, IdTy, ExprTy>; using UnifiedAddress = tomp::clause::UnifiedAddressT<TypeTy, IdTy, ExprTy>; diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.h b/flang/include/flang/Optimizer/Dialect/FIROps.h index 62ef8b4..4651f2b 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.h +++ b/flang/include/flang/Optimizer/Dialect/FIROps.h @@ -20,6 +20,7 @@ #include "mlir/Dialect/LLVMIR/LLVMAttrs.h" #include "mlir/Interfaces/LoopLikeInterface.h" #include "mlir/Interfaces/SideEffectInterfaces.h" +#include "mlir/Interfaces/ViewLikeInterface.h" namespace fir { diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td index 58a317c..bae52d6 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -17,6 +17,7 @@ include "mlir/Dialect/Arith/IR/ArithBase.td" include "mlir/Dialect/Arith/IR/ArithOpsInterfaces.td" include "mlir/Dialect/LLVMIR/LLVMAttrDefs.td" +include "mlir/Interfaces/ViewLikeInterface.td" include "flang/Optimizer/Dialect/CUF/Attributes/CUFAttr.td" include "flang/Optimizer/Dialect/FIRDialect.td" include "flang/Optimizer/Dialect/FIRTypes.td" @@ -2828,7 +2829,8 @@ def fir_VolatileCastOp : fir_SimpleOneResultOp<"volatile_cast", [Pure]> { let hasFolder = 1; } -def fir_ConvertOp : fir_SimpleOneResultOp<"convert", [NoMemoryEffect]> { +def fir_ConvertOp + : fir_SimpleOneResultOp<"convert", [NoMemoryEffect, ViewLikeOpInterface]> { let summary = "encapsulates all Fortran entity type conversions"; let description = [{ @@ -2866,6 +2868,7 @@ def fir_ConvertOp : fir_SimpleOneResultOp<"convert", [NoMemoryEffect]> { static bool isPointerCompatible(mlir::Type ty); static bool canBeConverted(mlir::Type inType, mlir::Type outType); static bool areVectorsCompatible(mlir::Type inTy, mlir::Type outTy); + mlir::Value getViewSource() { return getValue(); } }]; let hasCanonicalizer = 1; } diff --git a/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h b/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h new file mode 100644 index 0000000..7afe97a --- /dev/null +++ b/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h @@ -0,0 +1,58 @@ +//===- FIROpenACCOpsInterfaces.h --------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// +// +// This file contains external operation interfaces for FIR. +// +//===----------------------------------------------------------------------===// + +#ifndef FLANG_OPTIMIZER_OPENACC_FIROPENACC_OPS_INTERFACES_H_ +#define FLANG_OPTIMIZER_OPENACC_FIROPENACC_OPS_INTERFACES_H_ + +#include "mlir/Dialect/OpenACC/OpenACC.h" + +namespace fir { +class DeclareOp; +} // namespace fir + +namespace hlfir { +class DeclareOp; +class DesignateOp; +} // namespace hlfir + +namespace fir::acc { + +template <typename Op> +struct PartialEntityAccessModel + : public mlir::acc::PartialEntityAccessOpInterface::ExternalModel< + PartialEntityAccessModel<Op>, Op> { + mlir::Value getBaseEntity(mlir::Operation *op) const; + + // Default implementation - returns false (partial view) + bool isCompleteView(mlir::Operation *op) const { return false; } +}; + +// Full specializations for declare operations +template <> +struct PartialEntityAccessModel<fir::DeclareOp> + : public mlir::acc::PartialEntityAccessOpInterface::ExternalModel< + PartialEntityAccessModel<fir::DeclareOp>, fir::DeclareOp> { + mlir::Value getBaseEntity(mlir::Operation *op) const; + bool isCompleteView(mlir::Operation *op) const; +}; + +template <> +struct PartialEntityAccessModel<hlfir::DeclareOp> + : public mlir::acc::PartialEntityAccessOpInterface::ExternalModel< + PartialEntityAccessModel<hlfir::DeclareOp>, hlfir::DeclareOp> { + mlir::Value getBaseEntity(mlir::Operation *op) const; + bool isCompleteView(mlir::Operation *op) const; +}; + +} // namespace fir::acc + +#endif // FLANG_OPTIMIZER_OPENACC_FIROPENACC_OPS_INTERFACES_H_ diff --git a/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.h b/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.h index 4817ed9..3167c55 100644 --- a/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.h +++ b/flang/include/flang/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.h @@ -60,6 +60,8 @@ struct OpenACCMappableModel getOffsetInBytes(mlir::Type type, mlir::Value var, mlir::ValueRange accBounds, const mlir::DataLayout &dataLayout) const; + bool hasUnknownDimensions(mlir::Type type) const; + llvm::SmallVector<mlir::Value> generateAccBounds(mlir::Type type, mlir::Value var, mlir::OpBuilder &builder) const; diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h index bb97069..a7398a4 100644 --- a/flang/include/flang/Parser/dump-parse-tree.h +++ b/flang/include/flang/Parser/dump-parse-tree.h @@ -685,6 +685,8 @@ public: NODE_ENUM(OmpTaskDependenceType, Value) NODE(parser, OmpTaskReductionClause) NODE(OmpTaskReductionClause, Modifier) + NODE(parser, OmpThreadsetClause) + NODE_ENUM(OmpThreadsetClause, ThreadsetPolicy) NODE(parser, OmpToClause) NODE(OmpToClause, Modifier) NODE(parser, OmpTraitProperty) diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index c3a8c2e..375790a 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -4825,6 +4825,14 @@ struct OmpTaskReductionClause { std::tuple<MODIFIERS(), OmpObjectList> t; }; +// Ref: [6.0:442] +// threadset-clause -> +// THREADSET(omp_pool|omp_team) +struct OmpThreadsetClause { + ENUM_CLASS(ThreadsetPolicy, Omp_Pool, Omp_Team) + WRAPPER_CLASS_BOILERPLATE(OmpThreadsetClause, ThreadsetPolicy); +}; + // Ref: [4.5:107-109], [5.0:176-180], [5.1:205-210], [5.2:167-168] // // to-clause (in DECLARE TARGET) -> diff --git a/flang/include/flang/Semantics/dump-expr.h b/flang/include/flang/Semantics/dump-expr.h index 2dbd4cb..5a78e13 100644 --- a/flang/include/flang/Semantics/dump-expr.h +++ b/flang/include/flang/Semantics/dump-expr.h @@ -48,10 +48,11 @@ private: // "... [with T = xyz; std::string_view = ...]" #ifdef __clang__ std::string_view front("[T = "); + std::string_view back("]"); #else std::string_view front("[with T = "); -#endif std::string_view back("; std::string_view ="); +#endif #elif defined(_MSC_VER) #define DUMP_EXPR_SHOW_TYPE diff --git a/flang/lib/Evaluate/common.cpp b/flang/lib/Evaluate/common.cpp index 46c75a5..ed6a0ef 100644 --- a/flang/lib/Evaluate/common.cpp +++ b/flang/lib/Evaluate/common.cpp @@ -13,24 +13,28 @@ using namespace Fortran::parser::literals; namespace Fortran::evaluate { -void RealFlagWarnings( - FoldingContext &context, const RealFlags &flags, const char *operation) { +void FoldingContext::RealFlagWarnings( + const RealFlags &flags, const char *operation) { static constexpr auto warning{common::UsageWarning::FoldingException}; if (flags.test(RealFlag::Overflow)) { - context.Warn(warning, "overflow on %s"_warn_en_US, operation); + Warn(warning, "overflow on %s%s"_warn_en_US, operation, + realFlagWarningContext_); } if (flags.test(RealFlag::DivideByZero)) { if (std::strcmp(operation, "division") == 0) { - context.Warn(warning, "division by zero"_warn_en_US); + Warn(warning, "division by zero%s"_warn_en_US, realFlagWarningContext_); } else { - context.Warn(warning, "division by zero on %s"_warn_en_US, operation); + Warn(warning, "division by zero on %s%s"_warn_en_US, operation, + realFlagWarningContext_); } } if (flags.test(RealFlag::InvalidArgument)) { - context.Warn(warning, "invalid argument on %s"_warn_en_US, operation); + Warn(warning, "invalid argument on %s%s"_warn_en_US, operation, + realFlagWarningContext_); } if (flags.test(RealFlag::Underflow)) { - context.Warn(warning, "underflow on %s"_warn_en_US, operation); + Warn(warning, "underflow on %s%s"_warn_en_US, operation, + realFlagWarningContext_); } } diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h index 3fdf3a6..52ea627 100644 --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -1862,7 +1862,7 @@ Expr<TO> FoldOperation( std::snprintf(buffer, sizeof buffer, "INTEGER(%d) to REAL(%d) conversion", Operand::kind, TO::kind); - RealFlagWarnings(ctx, converted.flags, buffer); + ctx.RealFlagWarnings(converted.flags, buffer); } return ScalarConstantToExpr(std::move(converted.value)); } else if constexpr (FromCat == TypeCategory::Real) { @@ -1871,7 +1871,7 @@ Expr<TO> FoldOperation( if (!converted.flags.empty()) { std::snprintf(buffer, sizeof buffer, "REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind); - RealFlagWarnings(ctx, converted.flags, buffer); + ctx.RealFlagWarnings(converted.flags, buffer); } if (ctx.targetCharacteristics().areSubnormalsFlushedToZero()) { converted.value = converted.value.FlushSubnormalToZero(); @@ -2012,7 +2012,7 @@ Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) { } else { auto sum{folded->first.Add( folded->second, context.targetCharacteristics().roundingMode())}; - RealFlagWarnings(context, sum.flags, "addition"); + context.RealFlagWarnings(sum.flags, "addition"); if (context.targetCharacteristics().areSubnormalsFlushedToZero()) { sum.value = sum.value.FlushSubnormalToZero(); } @@ -2041,7 +2041,7 @@ Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) { } else { auto difference{folded->first.Subtract( folded->second, context.targetCharacteristics().roundingMode())}; - RealFlagWarnings(context, difference.flags, "subtraction"); + context.RealFlagWarnings(difference.flags, "subtraction"); if (context.targetCharacteristics().areSubnormalsFlushedToZero()) { difference.value = difference.value.FlushSubnormalToZero(); } @@ -2070,7 +2070,7 @@ Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) { } else { auto product{folded->first.Multiply( folded->second, context.targetCharacteristics().roundingMode())}; - RealFlagWarnings(context, product.flags, "multiplication"); + context.RealFlagWarnings(product.flags, "multiplication"); if (context.targetCharacteristics().areSubnormalsFlushedToZero()) { product.value = product.value.FlushSubnormalToZero(); } @@ -2141,7 +2141,7 @@ Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) { } } if (!isCanonicalNaNOrInf) { - RealFlagWarnings(context, quotient.flags, "division"); + context.RealFlagWarnings(quotient.flags, "division"); } if (context.targetCharacteristics().areSubnormalsFlushedToZero()) { quotient.value = quotient.value.FlushSubnormalToZero(); @@ -2201,7 +2201,7 @@ Expr<T> FoldOperation(FoldingContext &context, RealToIntPower<T> &&x) { [&](auto &y) -> Expr<T> { if (auto folded{OperandsAreConstants(x.left(), y)}) { auto power{evaluate::IntPower(folded->first, folded->second)}; - RealFlagWarnings(context, power.flags, "power with INTEGER exponent"); + context.RealFlagWarnings(power.flags, "power with INTEGER exponent"); if (context.targetCharacteristics().areSubnormalsFlushedToZero()) { power.value = power.value.FlushSubnormalToZero(); } diff --git a/flang/lib/Evaluate/host.cpp b/flang/lib/Evaluate/host.cpp index 25409ac..bf02496 100644 --- a/flang/lib/Evaluate/host.cpp +++ b/flang/lib/Evaluate/host.cpp @@ -140,8 +140,8 @@ void HostFloatingPointEnvironment::CheckAndRestoreFloatingPointEnvironment( } if (!flags_.empty()) { - RealFlagWarnings( - context, flags_, "evaluation of intrinsic function or operation"); + context.RealFlagWarnings( + flags_, "evaluation of intrinsic function or operation"); } errno = 0; if (fesetenv(&originalFenv_) != 0) { diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp index 9820aa3..d8af524 100644 --- a/flang/lib/Evaluate/intrinsics-library.cpp +++ b/flang/lib/Evaluate/intrinsics-library.cpp @@ -1043,7 +1043,7 @@ std::optional<HostRuntimeWrapper> GetHostRuntimeWrapper(const std::string &name, if (const auto *hostFunction{ SearchHostRuntime(name, biggerResultType, biggerArgTypes)}) { auto hostFolderWithChecks{AddArgumentVerifierIfAny(name, *hostFunction)}; - return [hostFunction, resultType, hostFolderWithChecks]( + return [hostFunction, resultType, hostFolderWithChecks, name]( FoldingContext &context, std::vector<Expr<SomeType>> &&args) { auto nArgs{args.size()}; for (size_t i{0}; i < nArgs; ++i) { @@ -1051,6 +1051,8 @@ std::optional<HostRuntimeWrapper> GetHostRuntimeWrapper(const std::string &name, ConvertToType(hostFunction->argumentTypes[i], std::move(args[i])) .value()); } + auto restorer{context.SetRealFlagWarningContext( + " after folding a call to '"s + name + "'"s)}; return Fold(context, ConvertToType( resultType, hostFolderWithChecks(context, std::move(args))) diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 6e72987..0f4b39a 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -4876,6 +4876,10 @@ private: mlir::Value shape = builder->genShape(loc, lbounds, extents); rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, shape, /*slice=*/mlir::Value{}); + } else if (fir::isClassStarType(lhsBoxType) && + !fir::ConvertOp::canBeConverted(rhsBoxType, lhsBoxType)) { + rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, + mlir::Value{}, mlir::Value{}); } return rhsBox; } diff --git a/flang/lib/Lower/OpenMP/Clauses.cpp b/flang/lib/Lower/OpenMP/Clauses.cpp index d39f9dd..0f60b47 100644 --- a/flang/lib/Lower/OpenMP/Clauses.cpp +++ b/flang/lib/Lower/OpenMP/Clauses.cpp @@ -1482,6 +1482,21 @@ ThreadLimit make(const parser::OmpClause::ThreadLimit &inp, return ThreadLimit{/*Threadlim=*/makeExpr(inp.v, semaCtx)}; } +Threadset make(const parser::OmpClause::Threadset &inp, + semantics::SemanticsContext &semaCtx) { + // inp.v -> parser::OmpThreadsetClause + using wrapped = parser::OmpThreadsetClause; + + CLAUSET_ENUM_CONVERT( // + convert, wrapped::ThreadsetPolicy, Threadset::ThreadsetPolicy, + // clang-format off + MS(Omp_Pool, Omp_Pool) + MS(Omp_Team, Omp_Team) + // clang-format on + ); + return Threadset{/*ThreadsetPolicy=*/convert(inp.v.v)}; +} + // Threadprivate: empty // Threads: empty diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index ca3e1cd..15ea845 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -3359,8 +3359,8 @@ void IntrinsicLibrary::genBarrierInit(llvm::ArrayRef<fir::ExtendedValue> args) { assert(args.size() == 2); mlir::Value barrier = convertPtrToNVVMSpace( builder, loc, fir::getBase(args[0]), mlir::NVVM::NVVMMemorySpace::Shared); - mlir::NVVM::MBarrierInitSharedOp::create(builder, loc, barrier, - fir::getBase(args[1]), {}); + mlir::NVVM::MBarrierInitOp::create(builder, loc, barrier, + fir::getBase(args[1]), {}); auto kind = mlir::NVVM::ProxyKindAttr::get( builder.getContext(), mlir::NVVM::ProxyKind::async_shared); auto space = mlir::NVVM::SharedSpaceAttr::get( diff --git a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp index 7e329e3..5db40af 100644 --- a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp +++ b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp @@ -258,13 +258,9 @@ void fir::factory::AnyVariableStack::pushValue(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value variable) { hlfir::Entity entity{variable}; - mlir::Type storageElementType = - hlfir::getFortranElementType(retValueBox.getType()); - auto [box, maybeCleanUp] = - hlfir::convertToBox(loc, builder, entity, storageElementType); + mlir::Value box = + hlfir::genVariableBox(loc, builder, entity, entity.getBoxType()); fir::runtime::genPushDescriptor(loc, builder, opaquePtr, fir::getBase(box)); - if (maybeCleanUp) - (*maybeCleanUp)(); } void fir::factory::AnyVariableStack::resetFetchPosition( diff --git a/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt b/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt index ef67ab1..898fb00 100644 --- a/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt +++ b/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt @@ -2,6 +2,7 @@ get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS) add_flang_library(FIROpenACCSupport FIROpenACCAttributes.cpp + FIROpenACCOpsInterfaces.cpp FIROpenACCTypeInterfaces.cpp RegisterOpenACCExtensions.cpp diff --git a/flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp new file mode 100644 index 0000000..c1734be --- /dev/null +++ b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp @@ -0,0 +1,62 @@ +//===-- FIROpenACCOpsInterfaces.cpp ---------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// +// +// Implementation of external operation interfaces for FIR. +// +//===----------------------------------------------------------------------===// + +#include "flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h" + +#include "flang/Optimizer/Dialect/FIROps.h" +#include "flang/Optimizer/HLFIR/HLFIROps.h" + +namespace fir::acc { + +template <> +mlir::Value PartialEntityAccessModel<fir::ArrayCoorOp>::getBaseEntity( + mlir::Operation *op) const { + return mlir::cast<fir::ArrayCoorOp>(op).getMemref(); +} + +template <> +mlir::Value PartialEntityAccessModel<fir::CoordinateOp>::getBaseEntity( + mlir::Operation *op) const { + return mlir::cast<fir::CoordinateOp>(op).getRef(); +} + +template <> +mlir::Value PartialEntityAccessModel<hlfir::DesignateOp>::getBaseEntity( + mlir::Operation *op) const { + return mlir::cast<hlfir::DesignateOp>(op).getMemref(); +} + +mlir::Value PartialEntityAccessModel<fir::DeclareOp>::getBaseEntity( + mlir::Operation *op) const { + return mlir::cast<fir::DeclareOp>(op).getStorage(); +} + +bool PartialEntityAccessModel<fir::DeclareOp>::isCompleteView( + mlir::Operation *op) const { + // Return false (partial view) only if storage is present + // Return true (complete view) if storage is absent + return !getBaseEntity(op); +} + +mlir::Value PartialEntityAccessModel<hlfir::DeclareOp>::getBaseEntity( + mlir::Operation *op) const { + return mlir::cast<hlfir::DeclareOp>(op).getStorage(); +} + +bool PartialEntityAccessModel<hlfir::DeclareOp>::isCompleteView( + mlir::Operation *op) const { + // Return false (partial view) only if storage is present + // Return true (complete view) if storage is absent + return !getBaseEntity(op); +} + +} // namespace fir::acc diff --git a/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp index ed9e41c..ae0f5fb8 100644 --- a/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp +++ b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp @@ -193,6 +193,28 @@ OpenACCMappableModel<fir::PointerType>::getOffsetInBytes( mlir::Type type, mlir::Value var, mlir::ValueRange accBounds, const mlir::DataLayout &dataLayout) const; +template <typename Ty> +bool OpenACCMappableModel<Ty>::hasUnknownDimensions(mlir::Type type) const { + assert(fir::isa_ref_type(type) && "expected FIR reference type"); + return fir::hasDynamicSize(fir::unwrapRefType(type)); +} + +template bool OpenACCMappableModel<fir::ReferenceType>::hasUnknownDimensions( + mlir::Type type) const; + +template bool OpenACCMappableModel<fir::HeapType>::hasUnknownDimensions( + mlir::Type type) const; + +template bool OpenACCMappableModel<fir::PointerType>::hasUnknownDimensions( + mlir::Type type) const; + +template <> +bool OpenACCMappableModel<fir::BaseBoxType>::hasUnknownDimensions( + mlir::Type type) const { + // Descriptor-based entities have dimensions encoded. + return false; +} + static llvm::SmallVector<mlir::Value> generateSeqTyAccBounds(fir::SequenceType seqType, mlir::Value var, mlir::OpBuilder &builder) { diff --git a/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp b/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp index 717bf34..d71c40d 100644 --- a/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp +++ b/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp @@ -11,8 +11,13 @@ //===----------------------------------------------------------------------===// #include "flang/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.h" + #include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Dialect/FIROps.h" #include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Optimizer/HLFIR/HLFIRDialect.h" +#include "flang/Optimizer/HLFIR/HLFIROps.h" +#include "flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h" #include "flang/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.h" namespace fir::acc { @@ -37,7 +42,24 @@ void registerOpenACCExtensions(mlir::DialectRegistry ®istry) { fir::LLVMPointerType::attachInterface< OpenACCPointerLikeModel<fir::LLVMPointerType>>(*ctx); + + fir::ArrayCoorOp::attachInterface< + PartialEntityAccessModel<fir::ArrayCoorOp>>(*ctx); + fir::CoordinateOp::attachInterface< + PartialEntityAccessModel<fir::CoordinateOp>>(*ctx); + fir::DeclareOp::attachInterface<PartialEntityAccessModel<fir::DeclareOp>>( + *ctx); }); + + // Register HLFIR operation interfaces + registry.addExtension( + +[](mlir::MLIRContext *ctx, hlfir::hlfirDialect *dialect) { + hlfir::DesignateOp::attachInterface< + PartialEntityAccessModel<hlfir::DesignateOp>>(*ctx); + hlfir::DeclareOp::attachInterface< + PartialEntityAccessModel<hlfir::DeclareOp>>(*ctx); + }); + registerAttrsExtensions(registry); } diff --git a/flang/lib/Parser/prescan.cpp b/flang/lib/Parser/prescan.cpp index 4739da0..efce8fc 100644 --- a/flang/lib/Parser/prescan.cpp +++ b/flang/lib/Parser/prescan.cpp @@ -557,7 +557,7 @@ bool Prescanner::MustSkipToEndOfLine() const { return true; // skip over ignored columns in right margin (73:80) } else if (*at_ == '!' && !inCharLiteral_ && (!inFixedForm_ || tabInCurrentLine_ || column_ != 6)) { - return !IsCompilerDirectiveSentinel(at_); + return !IsCompilerDirectiveSentinel(at_ + 1); } else { return false; } @@ -1642,6 +1642,17 @@ Prescanner::IsFixedFormCompilerDirectiveLine(const char *start) const { // This is a Continuation line, not an initial directive line. return std::nullopt; } + ++column, ++p; + } + if (isOpenMPConditional) { + for (; column <= fixedFormColumnLimit_; ++column, ++p) { + if (IsSpaceOrTab(p)) { + } else if (*p == '!') { + return std::nullopt; // !$ ! is a comment, not a directive + } else { + break; + } + } } if (const char *ss{IsCompilerDirectiveSentinel( sentinel, static_cast<std::size_t>(sp - sentinel))}) { @@ -1657,8 +1668,17 @@ Prescanner::IsFreeFormCompilerDirectiveLine(const char *start) const { p && *p++ == '!') { if (auto maybePair{IsCompilerDirectiveSentinel(p)}) { auto offset{static_cast<std::size_t>(p - start - 1)}; - return {LineClassification{LineClassification::Kind::CompilerDirective, - offset, maybePair->first}}; + const char *sentinel{maybePair->first}; + if ((sentinel[0] == '$' && sentinel[1] == '\0') || sentinel[1] == '@') { + if (const char *comment{IsFreeFormComment(maybePair->second)}) { + if (*comment == '!') { + // Conditional line comment - treat as comment + return std::nullopt; + } + } + } + return {LineClassification{ + LineClassification::Kind::CompilerDirective, offset, sentinel}}; } } return std::nullopt; diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp index e019bbd..a411e20 100644 --- a/flang/lib/Semantics/check-allocate.cpp +++ b/flang/lib/Semantics/check-allocate.cpp @@ -26,6 +26,10 @@ struct AllocateCheckerInfo { std::optional<evaluate::DynamicType> sourceExprType; std::optional<parser::CharBlock> sourceExprLoc; std::optional<parser::CharBlock> typeSpecLoc; + std::optional<parser::CharBlock> statSource; + std::optional<parser::CharBlock> msgSource; + const SomeExpr *statVar{nullptr}; + const SomeExpr *msgVar{nullptr}; int sourceExprRank{0}; // only valid if gotMold || gotSource bool gotStat{false}; bool gotMsg{false}; @@ -141,12 +145,15 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions( [&](const parser::StatOrErrmsg &statOrErr) { common::visit( common::visitors{ - [&](const parser::StatVariable &) { + [&](const parser::StatVariable &var) { if (info.gotStat) { // C943 context.Say( "STAT may not be duplicated in a ALLOCATE statement"_err_en_US); } info.gotStat = true; + info.statVar = GetExpr(context, var); + info.statSource = + parser::Unwrap<parser::Variable>(var)->GetSource(); }, [&](const parser::MsgVariable &var) { WarnOnDeferredLengthCharacterScalar(context, @@ -159,6 +166,9 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions( "ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US); } info.gotMsg = true; + info.msgVar = GetExpr(context, var); + info.msgSource = + parser::Unwrap<parser::Variable>(var)->GetSource(); }, }, statOrErr.u); @@ -460,6 +470,16 @@ static bool HaveCompatibleLengths( } } +bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path) { + if (root && path) { + // For now we just use equality of expressions. If we implement a more + // sophisticated alias analysis we should use it here. + return *root == *path; + } else { + return false; + } +} + bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { if (!ultimate_) { CHECK(context.AnyFatalError()); @@ -690,6 +710,17 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { "Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US); } } + + if (const SomeExpr *allocObj{GetExpr(context, allocateObject_)}) { + if (AreSameAllocation(allocObj, allocateInfo_.statVar)) { + context.Say(allocateInfo_.statSource.value_or(name_.source), + "STAT variable in ALLOCATE must not be the variable being allocated"_err_en_US); + } + if (AreSameAllocation(allocObj, allocateInfo_.msgVar)) { + context.Say(allocateInfo_.msgSource.value_or(name_.source), + "ERRMSG variable in ALLOCATE must not be the variable being allocated"_err_en_US); + } + } return RunCoarrayRelatedChecks(context); } diff --git a/flang/lib/Semantics/check-allocate.h b/flang/lib/Semantics/check-allocate.h index e3f7f07..54f7380 100644 --- a/flang/lib/Semantics/check-allocate.h +++ b/flang/lib/Semantics/check-allocate.h @@ -24,5 +24,6 @@ public: private: SemanticsContext &context_; }; +bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path); } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_CHECK_ALLOCATE_H_ diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp index c1ebc5f..e6ce1b3 100644 --- a/flang/lib/Semantics/check-deallocate.cpp +++ b/flang/lib/Semantics/check-deallocate.cpp @@ -7,51 +7,87 @@ //===----------------------------------------------------------------------===// #include "check-deallocate.h" +#include "check-allocate.h" #include "definable.h" #include "flang/Evaluate/type.h" #include "flang/Parser/message.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/expression.h" #include "flang/Semantics/tools.h" +#include <optional> namespace Fortran::semantics { void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) { + bool gotStat{false}, gotMsg{false}; + const SomeExpr *statVar{nullptr}, *msgVar{nullptr}; + std::optional<parser::CharBlock> statSource; + std::optional<parser::CharBlock> msgSource; + for (const parser::StatOrErrmsg &deallocOpt : + std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) { + common::visit( + common::visitors{ + [&](const parser::StatVariable &var) { + if (gotStat) { + context_.Say( + "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US); + } + gotStat = true; + statVar = GetExpr(context_, var); + statSource = parser::Unwrap<parser::Variable>(var)->GetSource(); + }, + [&](const parser::MsgVariable &var) { + WarnOnDeferredLengthCharacterScalar(context_, + GetExpr(context_, var), + parser::UnwrapRef<parser::Variable>(var).GetSource(), + "ERRMSG="); + if (gotMsg) { + context_.Say( + "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US); + } + gotMsg = true; + msgVar = GetExpr(context_, var); + msgSource = parser::Unwrap<parser::Variable>(var)->GetSource(); + }, + }, + deallocOpt.u); + } for (const parser::AllocateObject &allocateObject : std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) { + parser::CharBlock source; common::visit( common::visitors{ [&](const parser::Name &name) { const Symbol *symbol{ name.symbol ? &name.symbol->GetUltimate() : nullptr}; - ; + source = name.source; if (context_.HasError(symbol)) { // already reported an error } else if (!IsVariableName(*symbol)) { - context_.Say(name.source, + context_.Say(source, "Name in DEALLOCATE statement must be a variable name"_err_en_US); } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936 - context_.Say(name.source, + context_.Say(source, "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); - } else if (auto whyNot{WhyNotDefinable(name.source, - context_.FindScope(name.source), - {DefinabilityFlag::PointerDefinition, - DefinabilityFlag::AcceptAllocatable, - DefinabilityFlag::PotentialDeallocation}, - *symbol)}) { + } else if (auto whyNot{ + WhyNotDefinable(source, context_.FindScope(source), + {DefinabilityFlag::PointerDefinition, + DefinabilityFlag::AcceptAllocatable, + DefinabilityFlag::PotentialDeallocation}, + *symbol)}) { // Catch problems with non-definability of the // pointer/allocatable context_ - .Say(name.source, + .Say(source, "Name in DEALLOCATE statement is not definable"_err_en_US) .Attach(std::move( whyNot->set_severity(parser::Severity::Because))); - } else if (auto whyNot{WhyNotDefinable(name.source, - context_.FindScope(name.source), - DefinabilityFlags{}, *symbol)}) { + } else if (auto whyNot{ + WhyNotDefinable(source, context_.FindScope(source), + DefinabilityFlags{}, *symbol)}) { // Catch problems with non-definability of the dynamic object context_ - .Say(name.source, + .Say(source, "Object in DEALLOCATE statement is not deallocatable"_err_en_US) .Attach(std::move( whyNot->set_severity(parser::Severity::Because))); @@ -62,13 +98,12 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) { [&](const parser::StructureComponent &structureComponent) { // Only perform structureComponent checks if it was successfully // analyzed by expression analysis. - auto source{structureComponent.component.source}; + source = structureComponent.component.source; if (const auto *expr{GetExpr(context_, allocateObject)}) { - if (const Symbol * - symbol{structureComponent.component.symbol - ? &structureComponent.component.symbol - ->GetUltimate() - : nullptr}; + if (const Symbol *symbol{structureComponent.component.symbol + ? &structureComponent.component.symbol + ->GetUltimate() + : nullptr}; !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936 context_.Say(source, "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); @@ -99,32 +134,16 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) { }, }, allocateObject.u); - } - bool gotStat{false}, gotMsg{false}; - for (const parser::StatOrErrmsg &deallocOpt : - std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) { - common::visit( - common::visitors{ - [&](const parser::StatVariable &) { - if (gotStat) { - context_.Say( - "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US); - } - gotStat = true; - }, - [&](const parser::MsgVariable &var) { - WarnOnDeferredLengthCharacterScalar(context_, - GetExpr(context_, var), - parser::UnwrapRef<parser::Variable>(var).GetSource(), - "ERRMSG="); - if (gotMsg) { - context_.Say( - "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US); - } - gotMsg = true; - }, - }, - deallocOpt.u); + if (const SomeExpr *allocObj{GetExpr(context_, allocateObject)}) { + if (AreSameAllocation(allocObj, statVar)) { + context_.Say(statSource.value_or(source), + "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US); + } + if (AreSameAllocation(allocObj, msgVar)) { + context_.Say(msgSource.value_or(source), + "ERRMSG variable in DEALLOCATE must not be the variable being deallocated"_err_en_US); + } + } } } diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp index e094458f..aaaf1ec 100644 --- a/flang/lib/Semantics/check-omp-structure.cpp +++ b/flang/lib/Semantics/check-omp-structure.cpp @@ -3390,6 +3390,7 @@ CHECK_SIMPLE_CLAUSE(Read, OMPC_read) CHECK_SIMPLE_CLAUSE(Threadprivate, OMPC_threadprivate) CHECK_SIMPLE_CLAUSE(Groupprivate, OMPC_groupprivate) CHECK_SIMPLE_CLAUSE(Threads, OMPC_threads) +CHECK_SIMPLE_CLAUSE(Threadset, OMPC_threadset) CHECK_SIMPLE_CLAUSE(Inbranch, OMPC_inbranch) CHECK_SIMPLE_CLAUSE(Link, OMPC_link) CHECK_SIMPLE_CLAUSE(Indirect, OMPC_indirect) diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 32aa6b1..c8167fd 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -834,7 +834,7 @@ Constant<TYPE> ReadRealLiteral( auto valWithFlags{ Scalar<TYPE>::Read(p, context.targetCharacteristics().roundingMode())}; CHECK(p == source.end()); - RealFlagWarnings(context, valWithFlags.flags, "conversion of REAL literal"); + context.RealFlagWarnings(valWithFlags.flags, "conversion of REAL literal"); auto value{valWithFlags.value}; if (context.targetCharacteristics().areSubnormalsFlushedToZero()) { value = value.FlushSubnormalToZero(); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index f88af5f..220f1c9 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -9435,13 +9435,18 @@ bool ResolveNamesVisitor::SetProcFlag( SayWithDecl(name, symbol, "Implicit declaration of function '%s' has a different result type than in previous declaration"_err_en_US); return false; - } else if (symbol.has<ProcEntityDetails>()) { - symbol.set(flag); // in case it hasn't been set yet - if (flag == Symbol::Flag::Function) { - ApplyImplicitRules(symbol); - } - if (symbol.attrs().test(Attr::INTRINSIC)) { - AcquireIntrinsicProcedureFlags(symbol); + } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) { + if (IsPointer(symbol) && !proc->type() && !proc->procInterface()) { + // PROCEDURE(), POINTER -- errors will be emitted later about a lack + // of known characteristics if used as a function + } else { + symbol.set(flag); // in case it hasn't been set yet + if (flag == Symbol::Flag::Function) { + ApplyImplicitRules(symbol); + } + if (symbol.attrs().test(Attr::INTRINSIC)) { + AcquireIntrinsicProcedureFlags(symbol); + } } } else if (symbol.GetType() && flag == Symbol::Flag::Subroutine) { SayWithDecl( diff --git a/flang/test/Evaluate/folding33.f90 b/flang/test/Evaluate/folding33.f90 new file mode 100644 index 0000000..fb5a23cf --- /dev/null +++ b/flang/test/Evaluate/folding33.f90 @@ -0,0 +1,4 @@ +!RUN: %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s +!CHECK: warning: overflow on REAL(4) to REAL(2) conversion after folding a call to 'exp' [-Wfolding-exception] +print *, exp((11.265625_2,1._2)) +end diff --git a/flang/test/Fir/OpenACC/openacc-mappable.fir b/flang/test/Fir/OpenACC/openacc-mappable.fir index 05df35a..00fe257 100644 --- a/flang/test/Fir/OpenACC/openacc-mappable.fir +++ b/flang/test/Fir/OpenACC/openacc-mappable.fir @@ -21,11 +21,13 @@ module attributes {dlti.dl_spec = #dlti.dl_spec<f16 = dense<16> : vector<2xi64>, // CHECK: Mappable: !fir.box<!fir.array<10xf32>> // CHECK: Type category: array // CHECK: Size: 40 + // CHECK: Has unknown dimensions: false // CHECK: Visiting: %{{.*}} = acc.copyin varPtr(%{{.*}} : !fir.ref<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>> {name = "arr", structured = false} // CHECK: Pointer-like and Mappable: !fir.ref<!fir.array<10xf32>> // CHECK: Type category: array // CHECK: Size: 40 + // CHECK: Has unknown dimensions: false // This second test exercises argument of explicit-shape arrays in following forms: // `real :: arr1(nn), arr2(2:nn), arr3(10)` @@ -62,6 +64,7 @@ module attributes {dlti.dl_spec = #dlti.dl_spec<f16 = dense<16> : vector<2xi64>, // CHECK: Visiting: %{{.*}} = acc.copyin varPtr(%{{.*}} : !fir.ref<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>> {name = "arr1", structured = false} // CHECK: Pointer-like and Mappable: !fir.ref<!fir.array<?xf32>> // CHECK: Type category: array + // CHECK: Has unknown dimensions: true // CHECK: Shape: %{{.*}} = fir.shape %[[EXTENT1:.*]] : (index) -> !fir.shape<1> // CHECK: Bound[0]: %{{.*}} = acc.bounds lowerbound(%[[LB1:.*]] : index) upperbound(%[[UB1:.*]] : index) extent(%{{.*}} : index) stride(%c1{{.*}} : index) startIdx(%c1{{.*}} : index) // CHECK: Lower bound: %[[LB1]] = arith.constant 0 : index @@ -70,6 +73,7 @@ module attributes {dlti.dl_spec = #dlti.dl_spec<f16 = dense<16> : vector<2xi64>, // CHECK: Visiting: %{{.*}} = acc.copyin varPtr(%{{.*}} : !fir.ref<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>> {name = "arr2", structured = false} // CHECK: Pointer-like and Mappable: !fir.ref<!fir.array<?xf32>> // CHECK: Type category: array + // CHECK: Has unknown dimensions: true // CHECK: Shape: %{{.*}} = fir.shape_shift %c2{{.*}}, %[[EXTENT2:.*]] : (index, index) -> !fir.shapeshift<1> // CHECK: Bound[0]: %{{.*}} = acc.bounds lowerbound(%[[LB2:.*]] : index) upperbound(%[[UB2:.*]] : index) extent(%{{.*}} : index) stride(%c1{{.*}} : index) startIdx(%c2{{.*}} : index) // CHECK: Lower bound: %[[LB2]] = arith.constant 0 : index @@ -80,6 +84,7 @@ module attributes {dlti.dl_spec = #dlti.dl_spec<f16 = dense<16> : vector<2xi64>, // CHECK: Type category: array // CHECK: Size: 40 // CHECK: Offset: 0 + // CHECK: Has unknown dimensions: false // CHECK: Shape: %{{.*}} = fir.shape %[[EXTENT3:.*]] : (index) -> !fir.shape<1> // CHECK: Bound[0]: %{{.*}} = acc.bounds lowerbound(%[[LB3:.*]] : index) upperbound(%[[UB3:.*]] : index) extent(%c10{{.*}} : index) stride(%c1{{.*}} : index) startIdx(%c1{{.*}} : index) // CHECK: Lower bound: %[[LB3]] = arith.constant 0 : index diff --git a/flang/test/HLFIR/order_assignments/forall-pointer-assignment-codegen.fir b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-codegen.fir index 1d19876..855b62c 100644 --- a/flang/test/HLFIR/order_assignments/forall-pointer-assignment-codegen.fir +++ b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-codegen.fir @@ -91,10 +91,8 @@ func.func @test_need_to_save_rhs(%n: i64, %arg1: !fir.box<!fir.array<?x!ptr_wrap // CHECK: %[[VAL_21:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_20]]) : (!fir.box<!fir.array<?x!fir.type<ptr_wrapper{p:!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>}>>>, i64) -> !fir.ref<!fir.type<ptr_wrapper{p:!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>}>> // CHECK: %[[VAL_22:.*]] = hlfir.designate %[[VAL_21]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<ptr_wrapper{p:!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>}>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>> // CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_22]] : !fir.ref<!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>> -// CHECK: %[[VAL_24:.*]] = fir.box_addr %[[VAL_23]] : (!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>) -> !fir.ptr<!fir.type<t{i:i64}>> -// CHECK: %[[VAL_25:.*]] = fir.embox %[[VAL_24]] : (!fir.ptr<!fir.type<t{i:i64}>>) -> !fir.box<!fir.type<t{i:i64}>> -// CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (!fir.box<!fir.type<t{i:i64}>>) -> !fir.box<none> -// CHECK: fir.call @_FortranAPushDescriptor(%[[VAL_16]], %[[VAL_26]]) : (!fir.llvm_ptr<i8>, !fir.box<none>) -> () +// CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (!fir.box<!fir.ptr<!fir.type<t{i:i64}>>>) -> !fir.box<none> +// CHECK: fir.call @_FortranAPushDescriptor(%[[VAL_16]], %[[VAL_24]]) : (!fir.llvm_ptr<i8>, !fir.box<none>) -> () // CHECK: } // CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_4]] : (i64) -> index // CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_0]] : (i64) -> index diff --git a/flang/test/Lower/CUDA/cuda-device-proc.cuf b/flang/test/Lower/CUDA/cuda-device-proc.cuf index e5d3c43..09b4302 100644 --- a/flang/test/Lower/CUDA/cuda-device-proc.cuf +++ b/flang/test/Lower/CUDA/cuda-device-proc.cuf @@ -431,7 +431,7 @@ end subroutine ! CHECK: %[[COUNT:.*]] = arith.constant 256 : i32 ! CHECK: %[[LLVM_PTR:.*]] = fir.convert %[[DECL_SHARED]]#0 : (!fir.ref<i64>) -> !llvm.ptr ! CHECK: %[[SHARED_PTR:.*]] = llvm.addrspacecast %[[LLVM_PTR]] : !llvm.ptr to !llvm.ptr<3> -! CHECK: nvvm.mbarrier.init.shared %[[SHARED_PTR]], %[[COUNT]] : !llvm.ptr<3>, i32 +! CHECK: nvvm.mbarrier.init %[[SHARED_PTR]], %[[COUNT]] : !llvm.ptr<3>, i32 ! CHECK: nvvm.fence.proxy {kind = #nvvm.proxy_kind<async.shared>, space = #nvvm.shared_space<cta>} ! CHECK: %[[LLVM_PTR:.*]] = fir.convert %[[DECL_SHARED]]#0 : (!fir.ref<i64>) -> !llvm.ptr diff --git a/flang/test/Lower/forall-polymorphic.f90 b/flang/test/Lower/forall-pointer-assignment.f90 index 2b7a51f..ec142e3 100644 --- a/flang/test/Lower/forall-polymorphic.f90 +++ b/flang/test/Lower/forall-pointer-assignment.f90 @@ -1,6 +1,7 @@ -! Test lower of FORALL polymorphic pointer assignment +! Test lower of FORALL pointer assignment ! RUN: bbc -emit-fir %s -o - | FileCheck %s + !! Test when LHS is polymorphic and RHS is not polymorphic ! CHECK-LABEL: c.func @_QPforallpolymorphic subroutine forallPolymorphic() @@ -46,6 +47,7 @@ end subroutine forallPolymorphic + !! Test when LHS is not polymorphic but RHS is polymorphic ! CHECK-LABEL: c.func @_QPforallpolymorphic2( ! CHECK-SAME: %arg0: !fir.ref<!fir.class<!fir.heap<!fir.array<?x!fir.type<_QFforallpolymorphic2Tdt{ptr:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFforallpolymorphic2Tdt>>>>}>>>>> {fir.bindc_name = "tar1", fir.target}) { @@ -87,3 +89,86 @@ end subroutine forallPolymorphic2 + +!! Test when LHS is unlimited polymorphic and RHS non-polymorphic intrinsic +!! type target. +! CHECK-LABEL: c.func @_QPforallpolymorphic3 +subroutine forallPolymorphic3() + TYPE :: DT + CLASS(*), POINTER :: Ptr => NULL() + END TYPE + + TYPE(DT) :: D1(10) + CHARACTER*1, TARGET :: TAR1(10) + INTEGER :: I + + FORALL (I=1:10) + D1(I)%Ptr => Tar1(I) + END FORALL + +! CHECK: %[[V_7:[0-9]+]] = fir.alloca !fir.array<10x!fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}>> {bindc_name = "d1", uniq_name = "_QFforallpolymorphic3Ed1"} +! CHECK: %[[V_8:[0-9]+]] = fir.shape %c10 : (index) -> !fir.shape<1> +! CHECK: %[[V_9:[0-9]+]] = fir.declare %[[V_7]](%[[V_8]]) {uniq_name = "_QFforallpolymorphic3Ed1"} : (!fir.ref<!fir.array<10x!fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}>>>, !fir.shape<1>) -> !fir.ref<!fir.array<10x!fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}>>> +! CHECK: %[[V_16:[0-9]+]] = fir.alloca !fir.array<10x!fir.char<1>> {bindc_name = "tar1", fir.target, uniq_name = "_QFforallpolymorphic3Etar1"} +! CHECK: %[[V_17:[0-9]+]] = fir.declare %[[V_16]](%[[V_8]]) typeparams %c1 {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFforallpolymorphic3Etar1"} : (!fir.ref<!fir.array<10x!fir.char<1>>>, !fir.shape<1>, index) -> !fir.ref<!fir.array<10x!fir.char<1>>> +! CHECK: %[[V_24:[0-9]+]] = fir.convert %c1_i32 : (i32) -> index +! CHECK: %[[V_25:[0-9]+]] = fir.convert %c10_i32 : (i32) -> index +! CHECK: fir.do_loop %arg0 = %[[V_24]] to %[[V_25]] step %c1 +! CHECK: { +! CHECK: %[[V_26:[0-9]+]] = fir.convert %arg0 : (index) -> i32 +! CHECK: %[[V_27:[0-9]+]] = fir.convert %[[V_26]] : (i32) -> i64 +! CHECK: %[[V_28:[0-9]+]] = fir.array_coor %[[V_9]](%[[V_8]]) %[[V_27]] : (!fir.ref<!fir.array<10x!fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}>>>, !fir.shape<1>, i64) -> !fir.ref<!fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}>> +! CHECK: %[[V_29:[0-9]+]] = fir.field_index ptr, !fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}> +! CHECK: %[[V_30:[0-9]+]] = fir.coordinate_of %[[V_28]], ptr : (!fir.ref<!fir.type<_QFforallpolymorphic3Tdt{ptr:!fir.class<!fir.ptr<none>>}>>) -> !fir.ref<!fir.class<!fir.ptr<none>>> +! CHECK: %[[V_31:[0-9]+]] = fir.convert %[[V_26]] : (i32) -> i64 +! CHECK: %[[V_32:[0-9]+]] = fir.array_coor %[[V_17]](%[[V_8]]) %31 : (!fir.ref<!fir.array<10x!fir.char<1>>>, !fir.shape<1>, i64) -> !fir.ref<!fir.char<1>> +! CHECK: %[[V_33:[0-9]+]] = fir.embox %[[V_32]] : (!fir.ref<!fir.char<1>>) -> !fir.box<!fir.ptr<!fir.char<1>>> +! CHECK: %[[V_34:[0-9]+]] = fir.rebox %[[V_33]] : (!fir.box<!fir.ptr<!fir.char<1>>>) -> !fir.class<!fir.ptr<none>> +! CHECK: fir.store %[[V_34]] to %[[V_30]] : !fir.ref<!fir.class<!fir.ptr<none>>> +! CHECK: } + +end subroutine forallPolymorphic3 + + +!! Test the LHS of a pointer assignment gets the isPointer flag from the +!! RHS that is a reference to a function that returns a pointer. +! CHECK-LABEL: c.func @_QPforallpointerassignment1 + subroutine forallPointerAssignment1() + type base + real, pointer :: data => null() + end type + + interface + pure function makeData (i) + real, pointer :: makeData + integer*4, intent(in) :: i + end function + end interface + + type(base) :: co1(10) + + forall (i=1:10) + co1(i)%data => makeData (i) + end forall + +! CHECK: %[[V_3:[0-9]+]] = fir.alloca i64 +! CHECK: %[[V_3:[0-9]+]] = fir.alloca i32 {bindc_name = "i"} +! CHECK: %[[V_4:[0-9]+]] = fir.alloca !fir.box<!fir.ptr<f32>> {bindc_name = ".result"} +! CHECK: %[[V_25:[0-9]+]] = fir.convert %c1_i32 : (i32) -> index +! CHECK: %[[V_26:[0-9]+]] = fir.convert %c10_i32 : (i32) -> index +! CHECK: %[[V_27:[0-9]+]] = fir.address_of(@{{_QQcl.*}}) : !fir.ref<!fir.char<1,{{.*}}>> +! CHECK: %[[V_28:[0-9]+]] = fir.convert %[[V_27]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8> +! CHECK: %[[V_29:[0-9]+]] = fir.call @_FortranACreateDescriptorStack(%[[V_28]], %c{{.*}}) : (!fir.ref<i8>, i32) -> !fir.llvm_ptr<i8> +! CHECK: fir.do_loop %arg0 = %[[V_25]] to %[[V_26]] step %c1 +! CHECK: { +! CHECK: %[[V_32:[0-9]+]] = fir.convert %arg0 : (index) -> i32 +! CHECK: fir.store %[[V_32]] to %[[V_3]] : !fir.ref<i32> +! CHECK: %[[V_33:[0-9]+]] = fir.call @_QPmakedata(%[[V_3]]) proc_attrs<pure> fastmath<contract> : (!fir.ref<i32>) -> !fir.box<!fir.ptr<f32>> +! CHECK: fir.save_result %[[V_33]] to %[[V_4]] : !fir.box<!fir.ptr<f32>>, !fir.ref<!fir.box<!fir.ptr<f32>>> +! CHECK: %[[V_34:[0-9]+]] = fir.declare %[[V_4]] {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> !fir.ref<!fir.box<!fir.ptr<f32>>> +! CHECK: %[[V_35:[0-9]+]] = fir.load %[[V_34]] : !fir.ref<!fir.box<!fir.ptr<f32>>> +! CHECK: %[[V_36:[0-9]+]] = fir.convert %[[V_35]] : (!fir.box<!fir.ptr<f32>>) -> !fir.box<none> +! CHECK: fir.call @_FortranAPushDescriptor(%[[V_29]], %[[V_36]]) : (!fir.llvm_ptr<i8>, !fir.box<none>) -> () +! CHECK: } + + end subroutine forallPointerAssignment1 diff --git a/flang/test/Parser/inline-directives.f90 b/flang/test/Parser/inline-directives.f90 new file mode 100644 index 0000000..24d4f95 --- /dev/null +++ b/flang/test/Parser/inline-directives.f90 @@ -0,0 +1,29 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s + +! Test that checks whether compiler directives can be inlined without mistaking it as comment. + +module m +contains +#define MACRO(X) subroutine func1(X); real(2) :: X; !dir$ ignore_tkr(d) X; end subroutine func1; +MACRO(foo) + +!CHECK: SUBROUTINE func1 (foo) +!CHECK: !DIR$ IGNORE_TKR (d) foo +!CHECK: END SUBROUTINE func1 + + subroutine func2(foo) + real(2) :: foo; !dir$ ignore_tkr(d) foo; + end subroutine func2 + +!CHECK: SUBROUTINE func2 (foo) +!CHECK: !DIR$ IGNORE_TKR (d) foo +!CHECK: END SUBROUTINE func2 + + subroutine func3(foo) + real(2) :: foo; !dir$ ignore_tkr(d) foo; end subroutine func3; + +!CHECK: SUBROUTINE func3 (foo) +!CHECK: !DIR$ IGNORE_TKR (d) foo +!CHECK: END SUBROUTINE func3 + +end module diff --git a/flang/test/Preprocessing/bug136845.F b/flang/test/Preprocessing/bug136845.F index ce52c29..311ee0a 100644 --- a/flang/test/Preprocessing/bug136845.F +++ b/flang/test/Preprocessing/bug136845.F @@ -18,7 +18,6 @@ c$ !1 B *$1 continue end -!PREPRO:!$ & !PREPRO: continue !PREPRO: k=0 !PREPRO: k=0 diff --git a/flang/test/Preprocessing/cond-comment.f b/flang/test/Preprocessing/cond-comment.f new file mode 100644 index 0000000..a484fcb --- /dev/null +++ b/flang/test/Preprocessing/cond-comment.f @@ -0,0 +1,5 @@ +!RUN: %flang_fc1 -fopenmp -fdebug-unparse %s 2>&1 | FileCheck %s +!CHECK: END +!CHECK-NOT: error: + end +c$ ! diff --git a/flang/test/Preprocessing/cond-comment.f90 b/flang/test/Preprocessing/cond-comment.f90 new file mode 100644 index 0000000..457614a --- /dev/null +++ b/flang/test/Preprocessing/cond-comment.f90 @@ -0,0 +1,5 @@ +!RUN: %flang_fc1 -fopenmp -fdebug-unparse %s 2>&1 | FileCheck %s +!CHECK: END +!CHECK-NOT: error: +end +!$ ! diff --git a/flang/test/Semantics/allocate14.f90 b/flang/test/Semantics/allocate14.f90 new file mode 100644 index 0000000..a97cf5a --- /dev/null +++ b/flang/test/Semantics/allocate14.f90 @@ -0,0 +1,56 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for semantic errors in ALLOCATE statements + +program allocate14 + + integer, allocatable :: i1, i2 + character(200), allocatable :: msg1, msg2 + type t + integer, allocatable :: i + character(10), allocatable :: msg + end type t + type(t) :: tt(2) + type(t), allocatable :: ts(:) + + allocate(i1) + allocate(msg1) + + allocate(i2, stat=i1, errmsg=msg1) + allocate(msg2, stat=i1, errmsg=msg1) + deallocate(i2, stat=i1, errmsg=msg1) + deallocate(msg2, stat=i1, errmsg=msg1) + + !ERROR: STAT variable in ALLOCATE must not be the variable being allocated + allocate(i2, stat=i2, errmsg=msg2) + !ERROR: ERRMSG variable in ALLOCATE must not be the variable being allocated + allocate(msg2, stat=i2, errmsg=msg2) + !ERROR: STAT variable in DEALLOCATE must not be the variable being deallocated + deallocate(i2, stat=i2, errmsg=msg2) + !ERROR: ERRMSG variable in DEALLOCATE must not be the variable being deallocated + deallocate(msg2, stat=i2, errmsg=msg2) + + allocate(tt(1)%i) + allocate(tt(1)%msg) + + allocate(tt(2)%i, stat=tt(1)%i, errmsg=tt(1)%msg) + allocate(tt(2)%msg, stat=tt(1)%i, errmsg=tt(1)%msg) + deallocate(tt(2)%i, stat=tt(1)%i, errmsg=tt(1)%msg) + deallocate(tt(2)%msg, stat=tt(1)%i, errmsg=tt(1)%msg) + + !ERROR: STAT variable in ALLOCATE must not be the variable being allocated + allocate(tt(2)%i, stat=tt(2)%i, errmsg=tt(2)%msg) + !ERROR: ERRMSG variable in ALLOCATE must not be the variable being allocated + allocate(tt(2)%msg, stat=tt(2)%i, errmsg=tt(2)%msg) + !ERROR: STAT variable in DEALLOCATE must not be the variable being deallocated + deallocate(tt(2)%i, stat=tt(2)%i, errmsg=tt(2)%msg) + !ERROR: ERRMSG variable in DEALLOCATE must not be the variable being deallocated + deallocate(tt(2)%msg, stat=tt(2)%i, errmsg=tt(2)%msg) + + !TODO: STAT variable in ALLOCATE must not be the variable being allocated + !TODO: ERRMSG variable in ALLOCATE must not be the variable being allocated + allocate(ts(10), stat=ts(1)%i, errmsg=ts(1)%msg) + !TODO: STAT variable in DEALLOCATE must not be the variable being deallocated + !TODO: ERRMSG variable in DEALLOCATE must not be the variable being deallocated + deallocate(ts, stat=ts(1)%i, errmsg=ts(1)%msg) +end program + diff --git a/flang/test/Semantics/resolve09.f90 b/flang/test/Semantics/resolve09.f90 index 2fe21ae..3384b05 100644 --- a/flang/test/Semantics/resolve09.f90 +++ b/flang/test/Semantics/resolve09.f90 @@ -140,11 +140,11 @@ subroutine s9 procedure(), nopass, pointer :: p1, p2 end type type(t) x + !ERROR: Function result characteristics are not known print *, x%p1() - call x%p2 - !ERROR: Cannot call function 'p1' like a subroutine - call x%p1 - !ERROR: Cannot call subroutine 'p2' like a function + call x%p2 ! ok + call x%p1 ! ok + !ERROR: Function result characteristics are not known print *, x%p2() end subroutine diff --git a/flang/test/lib/OpenACC/TestOpenACCInterfaces.cpp b/flang/test/lib/OpenACC/TestOpenACCInterfaces.cpp index 9a80e3b..072aee5 100644 --- a/flang/test/lib/OpenACC/TestOpenACCInterfaces.cpp +++ b/flang/test/lib/OpenACC/TestOpenACCInterfaces.cpp @@ -100,6 +100,10 @@ struct TestFIROpenACCInterfaces } } + llvm::errs() << "\t\tHas unknown dimensions: " + << (mappableTy.hasUnknownDimensions() ? "true" : "false") + << "\n"; + if (auto declareOp = dyn_cast_if_present<hlfir::DeclareOp>(var.getDefiningOp())) { llvm::errs() << "\t\tShape: " << declareOp.getShape() << "\n"; |