diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -79,6 +79,13 @@ /// Get the binding of an implied do variable by name. virtual mlir::Value impliedDoBinding(llvm::StringRef name) = 0; + /// Copy the binding of src to target symbol. + virtual void copySymbolBinding(SymbolRef src, SymbolRef target) = 0; + + /// Binds the symbol to an fir extended value. The symbol binding will be + /// added or replaced at the inner-most level of the local symbol map. + virtual void bindSymbol(SymbolRef sym, const fir::ExtendedValue &exval) = 0; + /// Get the label set associated with a symbol. virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0; diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h --- a/flang/include/flang/Lower/ConvertVariable.h +++ b/flang/include/flang/Lower/ConvertVariable.h @@ -85,5 +85,11 @@ genExtAddrInInitializer(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const SomeExpr &addr); +/// Create global variable from a compiler generated object symbol that +/// describes a derived type for the runtime. +void createRuntimeTypeInfoGlobal(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, + const Fortran::semantics::Symbol &typeInfoSym); + } // namespace Fortran::lower #endif // FORTRAN_LOWER_CONVERT_VARIABLE_H diff --git a/flang/include/flang/Lower/SymbolMap.h b/flang/include/flang/Lower/SymbolMap.h --- a/flang/include/flang/Lower/SymbolMap.h +++ b/flang/include/flang/Lower/SymbolMap.h @@ -295,6 +295,13 @@ return lookupSymbol(*sym); } + /// Find `symbol` and return its value if it appears in the inner-most level + /// map. + SymbolBox shallowLookupSymbol(semantics::SymbolRef sym); + SymbolBox shallowLookupSymbol(const semantics::Symbol *sym) { + return shallowLookupSymbol(*sym); + } + /// Add a new binding from the ac-do-variable `var` to `value`. void pushImpliedDoBinding(AcDoVar var, mlir::Value value) { impliedDoStack.emplace_back(var, value); @@ -326,12 +333,13 @@ private: /// Add `symbol` to the current map and bind a `box`. - void makeSym(semantics::SymbolRef sym, const SymbolBox &box, + void makeSym(semantics::SymbolRef symRef, const SymbolBox &box, bool force = false) { + const auto *sym = &symRef.get().GetUltimate(); if (force) - symbolMapStack.back().erase(&*sym); + symbolMapStack.back().erase(sym); assert(box && "cannot add an undefined symbol box"); - symbolMapStack.back().try_emplace(&*sym, box); + symbolMapStack.back().try_emplace(sym, box); } llvm::SmallVector> diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -64,32 +64,30 @@ /// Convert the PFT to FIR. void run(Fortran::lower::pft::Program &pft) { - // Primary translation pass. + // Preliminary translation pass. // - Declare all functions that have definitions so that definition // signatures prevail over call site signatures. // - Define module variables and OpenMP/OpenACC declarative construct so // that they are available before lowering any function that may use // them. + // - Translate block data programs so that common block definitions with + // data initializations take precedence over other definitions. for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) { - std::visit(Fortran::common::visitors{ - [&](Fortran::lower::pft::FunctionLikeUnit &f) { - declareFunction(f); - }, - [&](Fortran::lower::pft::ModuleLikeUnit &m) { - lowerModuleDeclScope(m); - for (Fortran::lower::pft::FunctionLikeUnit &f : - m.nestedFunctions) - declareFunction(f); - }, - [&](Fortran::lower::pft::BlockDataUnit &b) {}, - [&](Fortran::lower::pft::CompilerDirectiveUnit &d) { - setCurrentPosition( - d.get().source); - mlir::emitWarning(toLocation(), - "ignoring all compiler directives"); - }, - }, - u); + std::visit( + Fortran::common::visitors{ + [&](Fortran::lower::pft::FunctionLikeUnit &f) { + declareFunction(f); + }, + [&](Fortran::lower::pft::ModuleLikeUnit &m) { + lowerModuleDeclScope(m); + for (Fortran::lower::pft::FunctionLikeUnit &f : + m.nestedFunctions) + declareFunction(f); + }, + [&](Fortran::lower::pft::BlockDataUnit &b) { lowerBlockData(b); }, + [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, + }, + u); } // Primary translation pass. @@ -189,6 +187,26 @@ return val; } + void copySymbolBinding(Fortran::lower::SymbolRef src, + Fortran::lower::SymbolRef target) override final { + localSymbols.addSymbol(target, lookupSymbol(src).toExtendedValue()); + } + + /// Add the symbol binding to the inner-most level of the symbol map and + /// return true if it is not already present. Otherwise, return false. + bool bindIfNewSymbol(Fortran::lower::SymbolRef sym, + const fir::ExtendedValue &exval) { + if (shallowLookupSymbol(sym)) + return false; + bindSymbol(sym, exval); + return true; + } + + void bindSymbol(Fortran::lower::SymbolRef sym, + const fir::ExtendedValue &exval) override final { + localSymbols.addSymbol(sym, exval, /*forced=*/true); + } + bool lookupLabelSet(Fortran::lower::SymbolRef sym, Fortran::lower::pft::LabelSet &labelSet) override final { Fortran::lower::pft::FunctionLikeUnit &owningProc = @@ -381,6 +399,42 @@ localSymbols.clear(); } + /// Helper to generate GlobalOps when the builder is not positioned in any + /// region block. This is required because the FirOpBuilder assumes it is + /// always positioned inside a region block when creating globals, the easiest + /// way comply is to create a dummy function and to throw it afterwards. + void createGlobalOutsideOfFunctionLowering( + const std::function &createGlobals) { + // FIXME: get rid of the bogus function context and instantiate the + // globals directly into the module. + MLIRContext *context = &getMLIRContext(); + mlir::FuncOp func = fir::FirOpBuilder::createFunction( + mlir::UnknownLoc::get(context), getModuleOp(), + fir::NameUniquer::doGenerated("Sham"), + mlir::FunctionType::get(context, llvm::None, llvm::None)); + func.addEntryBlock(); + builder = new fir::FirOpBuilder(func, bridge.getKindMap()); + createGlobals(); + if (mlir::Region *region = func.getCallableRegion()) + region->dropAllReferences(); + func.erase(); + delete builder; + builder = nullptr; + localSymbols.clear(); + } + /// Instantiate the data from a BLOCK DATA unit. + void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) { + createGlobalOutsideOfFunctionLowering([&]() { + Fortran::lower::AggregateStoreMap fakeMap; + for (const auto &[_, sym] : bdunit.symTab) { + if (sym->has()) { + Fortran::lower::pft::Variable var(*sym, true); + instantiateVar(var, fakeMap); + } + } + }); + } + /// Map mlir function block arguments to the corresponding Fortran dummy /// variables. When the result is passed as a hidden argument, the Fortran /// result is also mapped. The symbol map is used to hold this mapping. @@ -611,30 +665,18 @@ /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC /// declarative construct. void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) { - // FIXME: get rid of the bogus function context and instantiate the - // globals directly into the module. - MLIRContext *context = &getMLIRContext(); setCurrentPosition(mod.getStartingSourceLoc()); - mlir::FuncOp func = fir::FirOpBuilder::createFunction( - mlir::UnknownLoc::get(context), getModuleOp(), - fir::NameUniquer::doGenerated("ModuleSham"), - mlir::FunctionType::get(context, llvm::None, llvm::None)); - func.addEntryBlock(); - builder = new fir::FirOpBuilder(func, bridge.getKindMap()); - for (const Fortran::lower::pft::Variable &var : - mod.getOrderedSymbolTable()) { - // Only define the variables owned by this module. - const Fortran::semantics::Scope *owningScope = var.getOwningScope(); - if (!owningScope || mod.getScope() == *owningScope) - Fortran::lower::defineModuleVariable(*this, var); - } - for (auto &eval : mod.evaluationList) - genFIR(eval); - if (mlir::Region *region = func.getCallableRegion()) - region->dropAllReferences(); - func.erase(); - delete builder; - builder = nullptr; + createGlobalOutsideOfFunctionLowering([&]() { + for (const Fortran::lower::pft::Variable &var : + mod.getOrderedSymbolTable()) { + // Only define the variables owned by this module. + const Fortran::semantics::Scope *owningScope = var.getOwningScope(); + if (!owningScope || mod.getScope() == *owningScope) + Fortran::lower::defineModuleVariable(*this, var); + } + for (auto &eval : mod.evaluationList) + genFIR(eval); + }); } /// Lower functions contained in a module. @@ -674,6 +716,14 @@ return {}; } + /// Find the symbol in the inner-most level of the local map or return null. + Fortran::lower::SymbolBox + shallowLookupSymbol(const Fortran::semantics::Symbol &sym) { + if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym)) + return v; + return {}; + } + /// Add the symbol to the local map and return `true`. If the symbol is /// already in the map and \p forced is `false`, the map is not updated. /// Instead the value `false` is returned. 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 @@ -58,6 +58,11 @@ // to the correct FIR representation in SSA form. //===----------------------------------------------------------------------===// +static llvm::cl::opt generateArrayCoordinate( + "gen-array-coor", + llvm::cl::desc("in lowering create ArrayCoorOp instead of CoordinateOp"), + llvm::cl::init(false)); + // The default attempts to balance a modest allocation size with expected user // input to minimize bounds checks and reallocations during dynamic array // construction. Some user codes may have very large array constructors for @@ -300,6 +305,12 @@ return temp; } +// An expression with non-zero rank is an array expression. +template +static bool isArray(const A &x) { + return x.Rank() != 0; +} + /// Is this a variable wrapped in parentheses? template static bool isParenthesizedVariable(const A &) { @@ -482,6 +493,21 @@ boxProc, charLen); } +// Helper to get the ultimate first symbol. This works around the fact that +// symbol resolution in the front end doesn't always resolve a symbol to its +// ultimate symbol but may leave placeholder indirections for use and host +// associations. +template +const Fortran::semantics::Symbol &getFirstSym(const A &obj) { + return obj.GetFirstSymbol().GetUltimate(); +} + +// Helper to get the ultimate last symbol. +template +const Fortran::semantics::Symbol &getLastSym(const A &obj) { + return obj.GetLastSymbol().GetUltimate(); +} + namespace { /// Lowering of Fortran::evaluate::Expr expressions @@ -643,7 +669,6 @@ [&val](auto &) { return val.toExtendedValue(); }); LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: " << symMap << '\n'); - llvm::errs() << "SYM: " << sym << "\n"; fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value"); } @@ -652,10 +677,23 @@ } ExtValue genval(Fortran::semantics::SymbolRef sym) { + mlir::Location loc = getLoc(); ExtValue var = gen(sym); if (const fir::UnboxedValue *s = var.getUnboxed()) - if (fir::isReferenceLike(s->getType())) - return genLoad(*s); + if (fir::isReferenceLike(s->getType())) { + // A function with multiple entry points returning different types + // tags all result variables with one of the largest types to allow + // them to share the same storage. A reference to a result variable + // of one of the other types requires conversion to the actual type. + fir::UnboxedValue addr = *s; + if (Fortran::semantics::IsFunctionResult(sym)) { + mlir::Type resultType = converter.genType(*sym); + if (addr.getType() != resultType) + addr = builder.createConvert(loc, builder.getRefType(resultType), + addr); + } + return genLoad(addr); + } return var; } @@ -851,7 +889,7 @@ } ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) { - ExtValue exv = desc.base().IsSymbol() ? gen(desc.base().GetLastSymbol()) + ExtValue exv = desc.base().IsSymbol() ? gen(getLastSym(desc.base())) : gen(desc.base().GetComponent()); mlir::IndexType idxTy = builder.getIndexType(); mlir::Location loc = getLoc(); @@ -990,6 +1028,30 @@ TODO(getLoc(), "genval Extremum"); } + // Change the dynamic length information without actually changing the + // underlying character storage. + fir::ExtendedValue + replaceScalarCharacterLength(const fir::ExtendedValue &scalarChar, + mlir::Value newLenValue) { + mlir::Location loc = getLoc(); + const fir::CharBoxValue *charBox = scalarChar.getCharBox(); + if (!charBox) + fir::emitFatalError(loc, "expected scalar character"); + mlir::Value charAddr = charBox->getAddr(); + auto charType = + fir::unwrapPassByRefType(charAddr.getType()).cast(); + if (charType.hasConstantLen()) { + // Erase previous constant length from the base type. + fir::CharacterType::LenType newLen = fir::CharacterType::unknownLen(); + mlir::Type newCharTy = fir::CharacterType::get( + builder.getContext(), charType.getFKind(), newLen); + mlir::Type newType = fir::ReferenceType::get(newCharTy); + charAddr = builder.createConvert(loc, newType, charAddr); + return fir::CharBoxValue{charAddr, newLenValue}; + } + return fir::CharBoxValue{charAddr, newLenValue}; + } + template ExtValue genval(const Fortran::evaluate::SetLength &x) { TODO(getLoc(), "genval SetLength"); @@ -1151,23 +1213,7 @@ inInitializer->rawVals.push_back(val); } - /// Convert a ascii scalar literal CHARACTER to IR. (specialization) - ExtValue - genAsciiScalarLit(const Fortran::evaluate::Scalar> &value, - int64_t len) { - assert(value.size() == static_cast(len)); - // Outline character constant in ro data if it is not in an initializer. - if (!inInitializer) - return fir::factory::createStringLiteral(builder, getLoc(), value); - // When in an initializer context, construct the literal op itself and do - // not construct another constant object in rodata. - fir::StringLitOp stringLit = builder.createStringLitOp(getLoc(), value); - mlir::Value lenp = builder.createIntegerConstant( - getLoc(), builder.getCharacterLengthType(), len); - return fir::CharBoxValue{stringLit.getResult(), lenp}; - } - /// Convert a non ascii scalar literal CHARACTER to IR. (specialization) + /// Convert a scalar literal CHARACTER to IR. template ExtValue genScalarLit(const Fortran::evaluate::Scalar::value_type; if constexpr (KIND == 1) { - return genAsciiScalarLit(value, len); + assert(value.size() == static_cast(len)); + // Outline character constant in ro data if it is not in an initializer. + if (!inInitializer) + return fir::factory::createStringLiteral(builder, getLoc(), value); + // When in an initializer context, construct the literal op itself and do + // not construct another constant object in rodata. + fir::StringLitOp stringLit = builder.createStringLitOp(getLoc(), value); + mlir::Value lenp = builder.createIntegerConstant( + getLoc(), builder.getCharacterLengthType(), len); + return fir::CharBoxValue{stringLit.getResult(), lenp}; } fir::CharacterType type = fir::CharacterType::get(builder.getContext(), KIND, len); auto consLit = [&]() -> fir::StringLitOp { mlir::MLIRContext *context = builder.getContext(); std::int64_t size = static_cast(value.size()); - mlir::ShapedType shape = mlir::VectorType::get( + mlir::ShapedType shape = mlir::RankedTensorType::get( llvm::ArrayRef{size}, mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8)); - auto strAttr = mlir::DenseElementsAttr::get( + auto denseAttr = mlir::DenseElementsAttr::get( shape, llvm::ArrayRef{value.data(), value.size()}); - auto valTag = mlir::StringAttr::get(context, fir::StringLitOp::value()); - mlir::NamedAttribute dataAttr(valTag, strAttr); + auto denseTag = mlir::StringAttr::get(context, fir::StringLitOp::xlist()); + mlir::NamedAttribute dataAttr(denseTag, denseAttr); auto sizeTag = mlir::StringAttr::get(context, fir::StringLitOp::size()); mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len)); llvm::SmallVector attrs = {dataAttr, sizeAttr}; @@ -1206,9 +1261,6 @@ // Otherwise, the string is in a plain old expression so "outline" the value // by hashconsing it to a constant literal object. - // FIXME: For wider char types, lowering ought to use an array of i16 or - // i32. But for now, lowering just fakes that the string value is a range of - // i8 to get it past the C++ compiler. std::string globalName = fir::factory::uniqueCGIdent("cl", (const char *)value.c_str()); fir::GlobalOp global = builder.getNamedGlobal(globalName); @@ -1390,11 +1442,52 @@ TODO(getLoc(), "genval ComplexPart"); } + /// Reference to a substring. ExtValue gen(const Fortran::evaluate::Substring &s) { - TODO(getLoc(), "gen Substring"); + // Get base string + auto baseString = std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::DataRef &x) { return gen(x); }, + [&](const Fortran::evaluate::StaticDataObject::Pointer &p) + -> ExtValue { + if (std::optional str = p->AsString()) + return fir::factory::createStringLiteral(builder, getLoc(), + *str); + // TODO: convert StaticDataObject to Constant and use normal + // constant path. Beware that StaticDataObject data() takes into + // account build machine endianness. + TODO(getLoc(), + "StaticDataObject::Pointer substring with kind > 1"); + }, + }, + s.parent()); + llvm::SmallVector bounds; + mlir::Value lower = genunbox(s.lower()); + bounds.push_back(lower); + if (Fortran::evaluate::MaybeExtentExpr upperBound = s.upper()) { + mlir::Value upper = genunbox(*upperBound); + bounds.push_back(upper); + } + fir::factory::CharacterExprHelper charHelper{builder, getLoc()}; + return baseString.match( + [&](const fir::CharBoxValue &x) -> ExtValue { + return charHelper.createSubstring(x, bounds); + }, + [&](const fir::CharArrayBoxValue &) -> ExtValue { + fir::emitFatalError( + getLoc(), + "array substring should be handled in array expression"); + }, + [&](const auto &) -> ExtValue { + fir::emitFatalError(getLoc(), "substring base is not a CharBox"); + }); } + + /// The value of a substring. ExtValue genval(const Fortran::evaluate::Substring &ss) { - TODO(getLoc(), "genval Substring"); + // FIXME: why is the value of a substring being lowered the same as the + // address of a substring? + return gen(ss); } ExtValue genval(const Fortran::evaluate::Subscript &subs) { @@ -1628,11 +1721,43 @@ }); } + /// Lower an ArrayRef to a fir.array_coor. + ExtValue genArrayCoorOp(const ExtValue &exv, + const Fortran::evaluate::ArrayRef &aref) { + mlir::Location loc = getLoc(); + mlir::Value addr = fir::getBase(exv); + mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType()); + mlir::Type eleTy = arrTy.cast().getEleTy(); + mlir::Type refTy = builder.getRefType(eleTy); + mlir::IndexType idxTy = builder.getIndexType(); + llvm::SmallVector arrayCoorArgs; + // The ArrayRef is expected to be scalar here, arrays are handled in array + // expression lowering. So no vector subscript or triplet is expected here. + for (const auto &sub : aref.subscript()) { + ExtValue subVal = genSubscript(sub); + assert(fir::isUnboxedValue(subVal)); + arrayCoorArgs.push_back( + builder.createConvert(loc, idxTy, fir::getBase(subVal))); + } + mlir::Value shape = builder.createShape(loc, exv); + mlir::Value elementAddr = builder.create( + loc, refTy, addr, shape, /*slice=*/mlir::Value{}, arrayCoorArgs, + fir::getTypeParams(exv)); + return fir::factory::arrayElementToExtendedValue(builder, loc, exv, + elementAddr); + } + + /// Return the coordinate of the array reference. ExtValue gen(const Fortran::evaluate::ArrayRef &aref) { - ExtValue base = aref.base().IsSymbol() ? gen(aref.base().GetFirstSymbol()) + ExtValue base = aref.base().IsSymbol() ? gen(getFirstSym(aref.base())) : gen(aref.base().GetComponent()); + // Check for command-line override to use array_coor op. + if (generateArrayCoordinate) + return genArrayCoorOp(base, aref); + // Otherwise, use coordinate_of op. return genCoordinateOp(base, aref); } + ExtValue genval(const Fortran::evaluate::ArrayRef &aref) { return genLoad(gen(aref)); } @@ -1690,6 +1815,59 @@ 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(); + assert(symbol && "expected symbol in ProcedureRef of statement functions"); + const auto &details = symbol->get(); + + // Statement functions have their own scope, we just need to associate + // the dummy symbols to argument expressions. They are no + // optional/alternate return arguments. Statement functions cannot be + // recursive (directly or indirectly) so it is safe to add dummy symbols to + // the local map here. + symMap.pushScope(); + for (auto [arg, bind] : + llvm::zip(details.dummyArgs(), procRef.arguments())) { + assert(arg && "alternate return in statement function"); + assert(bind && "optional argument in statement function"); + const auto *expr = bind->UnwrapExpr(); + // TODO: assumed type in statement function, that surprisingly seems + // allowed, probably because nobody thought of restricting this usage. + // gfortran/ifort compiles this. + assert(expr && "assumed type used as statement function argument"); + // As per Fortran 2018 C1580, statement function arguments can only be + // scalars, so just pass the box with the address. The only care is to + // to use the dummy character explicit length if any instead of the + // actual argument length (that can be bigger). + if (const Fortran::semantics::DeclTypeSpec *type = arg->GetType()) + if (type->category() == Fortran::semantics::DeclTypeSpec::Character) + if (const Fortran::semantics::MaybeIntExpr &lenExpr = + type->characterTypeSpec().length().GetExplicit()) { + mlir::Value len = fir::getBase(genval(*lenExpr)); + // F2018 7.4.4.2 point 5. + len = Fortran::lower::genMaxWithZero(builder, getLoc(), len); + symMap.addSymbol(*arg, + replaceScalarCharacterLength(gen(*expr), len)); + continue; + } + symMap.addSymbol(*arg, gen(*expr)); + } + + // Explicitly map statement function host associated symbols to their + // parent scope lowered symbol box. + for (const Fortran::semantics::SymbolRef &sym : + Fortran::evaluate::CollectSymbols(*details.stmtFunction())) + if (const auto *details = + sym->detailsIf()) + if (!symMap.lookupSymbol(*sym)) + symMap.addSymbol(*sym, gen(details->symbol())); + + ExtValue result = genval(details.stmtFunction().value()); + LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n'); + symMap.popScope(); + return result; + } /// Helper to package a Value and its properties into an ExtendedValue. static ExtValue toExtendedValue(mlir::Location loc, mlir::Value base, @@ -2152,6 +2330,25 @@ return temp; } + /// Generate copy-out if needed and free the temporary for an argument that + /// has been copied-in into a contiguous temp. + void genCopyOut(const CopyOutPair ©OutPair) { + mlir::Location loc = getLoc(); + if (!copyOutPair.restrictCopyAndFreeAtRuntime) { + if (copyOutPair.argMayBeModifiedByCall) + genArrayCopy(copyOutPair.var, copyOutPair.temp); + builder.create(loc, fir::getBase(copyOutPair.temp)); + return; + } + builder.genIfThen(loc, *copyOutPair.restrictCopyAndFreeAtRuntime) + .genThen([&]() { + if (copyOutPair.argMayBeModifiedByCall) + genArrayCopy(copyOutPair.var, copyOutPair.temp); + builder.create(loc, fir::getBase(copyOutPair.temp)); + }) + .end(); + } + /// Lower a non-elemental procedure reference. ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional resultType) { @@ -2164,7 +2361,7 @@ return genIntrinsicRef(procRef, *intrinsic, resultType); if (isStatementFunctionCall(procRef)) - TODO(loc, "Lower statement function call"); + return genStmtFunctionRef(procRef); Fortran::lower::CallerInterface caller(procRef, converter); using PassBy = Fortran::lower::CallerInterface::PassEntityBy; @@ -2229,6 +2426,28 @@ continue; } const bool actualArgIsVariable = Fortran::evaluate::IsVariable(*expr); + if (arg.passBy == PassBy::BaseAddressValueAttribute) { + mlir::Value temp; + if (isArray(*expr)) { + auto val = genBoxArg(*expr); + if (!actualArgIsVariable) + temp = getBase(val); + else { + ExtValue copy = genArrayTempFromMold(val, ".copy"); + genArrayCopy(copy, val); + temp = fir::getBase(copy); + } + } else { + mlir::Value val = fir::getBase(genval(*expr)); + temp = builder.createTemporary( + loc, val.getType(), + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + builder.create(loc, val, temp); + } + caller.placeInput(arg, temp); + continue; + } if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) { const bool actualIsSimplyContiguous = !actualArgIsVariable || Fortran::evaluate::IsSimplyContiguous( @@ -2238,13 +2457,50 @@ if (actualArgIsVariable && arg.isOptional()) { if (Fortran::evaluate::IsAllocatableOrPointerObject( *expr, converter.getFoldingContext())) { - TODO(loc, "Allocatable or pointer argument"); + // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, + // it is as if the argument was absent. The main care here is to + // not do a copy-in/copy-out because the temp address, even though + // pointing to a null size storage, would not be a nullptr and + // therefore the argument would not be considered absent on the + // callee side. Note: if wholeSymbol is optional, it cannot be + // absent as per 15.5.2.12 point 7. and 8. We rely on this to + // un-conditionally read the allocatable/pointer descriptor here. + if (actualIsSimplyContiguous) + return genBoxArg(*expr); + fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr); + mlir::Value isAssociated = + fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, + mutableBox); + fir::ExtendedValue actualExv = + fir::factory::genMutableBoxRead(builder, loc, mutableBox); + return genCopyIn(actualExv, arg, copyOutPairs, isAssociated); } if (const Fortran::semantics::Symbol *wholeSymbol = Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef( *expr)) if (Fortran::semantics::IsOptional(*wholeSymbol)) { - TODO(loc, "procedureref optional arg"); + ExtValue actualArg = gen(*expr); + mlir::Value actualArgBase = fir::getBase(actualArg); + if (!actualArgBase.getType().isa()) + return actualArg; + // Do not read wholeSymbol descriptor that may be a nullptr in + // case wholeSymbol is absent. + // Absent descriptor cannot be read. To avoid any issue in + // copy-in/copy-out, and when retrieving the address/length + // create an descriptor pointing to a null address here if the + // fir.box is absent. + mlir::Value isPresent = builder.create( + loc, builder.getI1Type(), actualArgBase); + mlir::Type boxType = actualArgBase.getType(); + mlir::Value emptyBox = fir::factory::createUnallocatedBox( + builder, loc, boxType, llvm::None); + auto safeToReadBox = builder.create( + loc, isPresent, actualArgBase, emptyBox); + fir::ExtendedValue safeToReadExv = + fir::substBase(actualArg, safeToReadBox); + if (actualIsSimplyContiguous) + return safeToReadExv; + return genCopyIn(safeToReadExv, arg, copyOutPairs, isPresent); } // Fall through: The actual argument can safely be // copied-in/copied-out without any care if needed. @@ -2309,7 +2565,25 @@ // (Fortran 2018 15.5.2.12 point 1). if (arg.isOptional() && Fortran::evaluate::IsAllocatableOrPointerObject( *expr, converter.getFoldingContext())) { - TODO(loc, "optional allocatable or pointer argument"); + // Note that passing an absent allocatable to a non-allocatable + // optional dummy argument is illegal (15.5.2.12 point 3 (8)). So + // nothing has to be done to generate an absent argument in this case, + // and it is OK to unconditionally read the mutable box here. + fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr); + mlir::Value isAllocated = + fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, + mutableBox); + auto absent = builder.create(loc, argTy); + /// For now, assume it is not OK to pass the allocatable/pointer + /// descriptor to a non pointer/allocatable dummy. That is a strict + /// interpretation of 18.3.6 point 4 that stipulates the descriptor + /// has the dummy attributes in BIND(C) contexts. + mlir::Value box = builder.createBox( + loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox)); + // Need the box types to be exactly similar for the selectOp. + mlir::Value convertedBox = builder.createConvert(loc, argTy, box); + caller.placeInput(arg, builder.create( + loc, isAllocated, convertedBox, absent)); } else { // Make sure a variable address is only passed if the expression is // actually a variable. @@ -2324,7 +2598,10 @@ caller.placeAddressAndLengthInput(arg, fir::getBase(argRef), fir::getLen(argRef)); } else if (arg.passBy == PassBy::CharProcTuple) { - TODO(loc, "procedureref CharProcTuple"); + ExtValue argRef = genExtAddr(*expr); + mlir::Value tuple = createBoxProcCharTuple( + converter, argTy, fir::getBase(argRef), fir::getLen(argRef)); + caller.placeInput(arg, tuple); } else { TODO(loc, "pass by value in non elemental function call"); } @@ -2332,11 +2609,16 @@ ExtValue result = genCallOpAndResult(caller, callSiteType, resultType); - // // Copy-out temps that were created for non contiguous variable arguments - // if - // // needed. - // for (const auto ©OutPair : copyOutPairs) - // genCopyOut(copyOutPair); + // Sync pointers and allocatables that may have been modified during the + // call. + for (const auto &mutableBox : mutableModifiedByCall) + fir::factory::syncMutableBoxFromIRBox(builder, loc, mutableBox); + // Handle case where result was passed as argument + + // Copy-out temps that were created for non contiguous variable arguments if + // needed. + for (const auto ©OutPair : copyOutPairs) + genCopyOut(copyOutPair); return result; } @@ -2453,11 +2735,8 @@ } template - ExtValue genval(const Fortran::evaluate::Expr &x) { - if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) || - inInitializer) - return std::visit([&](const auto &e) { return genval(e); }, x.u); - return asArray(x); + bool isScalar(const A &x) { + return x.Rank() == 0; } /// Helper to detect Transformational function reference. @@ -2519,10 +2798,12 @@ return asArrayArg(x); return asArray(x); } - template - bool isScalar(const A &x) { - return x.Rank() == 0; + ExtValue genval(const Fortran::evaluate::Expr &x) { + if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) || + inInitializer) + return std::visit([&](const auto &e) { return genval(e); }, x.u); + return asArray(x); } template @@ -2545,6 +2826,10 @@ } template ExtValue genref(const A &a) { + if (inInitializer) { + // Initialization expressions can never allocate memory. + return genval(a); + } mlir::Type storageType = converter.genType(toEvExpr(a)); return placeScalarValueInMemory(builder, getLoc(), genval(a), storageType); } @@ -5171,7 +5456,7 @@ }, [&](const Fortran::evaluate::Component *x) { auto fieldTy = fir::FieldType::get(builder.getContext()); - llvm::StringRef name = toStringRef(x->GetLastSymbol().name()); + llvm::StringRef name = toStringRef(getLastSym(*x).name()); auto recTy = ty.cast(); ty = recTy.getType(name); auto fld = builder.create( @@ -5298,7 +5583,7 @@ CC genImplicitArrayAccess(const A &x, ComponentPath &components) { components.reversePath.push_back(ImplicitSubscripts{}); ExtValue exv = asScalarRef(x); - // lowerPath(exv, components); + lowerPath(exv, components); auto lambda = genarr(exv, components); return [=](IterSpace iters) { return lambda(components.pc(iters)); }; } @@ -5805,8 +6090,8 @@ void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) { if (!destShape.empty()) return; - // if (explicitSpaceIsActive() && determineShapeWithSlice(lhs)) - // return; + if (explicitSpaceIsActive() && determineShapeWithSlice(lhs)) + return; mlir::Type idxTy = builder.getIndexType(); mlir::Location loc = getLoc(); if (std::optional constantShape = @@ -5816,6 +6101,79 @@ destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent)); } + bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) { + return false; + } + bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) { + TODO(getLoc(), "coarray ref"); + return false; + } + bool genShapeFromDataRef(const Fortran::evaluate::Component &x) { + return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false; + } + bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) { + if (x.Rank() == 0) + return false; + if (x.base().Rank() > 0) + if (genShapeFromDataRef(x.base())) + return true; + // x has rank and x.base did not produce a shape. + ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base())) + : asScalarRef(x.base().GetComponent()); + mlir::Location loc = getLoc(); + mlir::IndexType idxTy = builder.getIndexType(); + llvm::SmallVector definedShape = + fir::factory::getExtents(builder, loc, exv); + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + for (auto ss : llvm::enumerate(x.subscript())) { + std::visit(Fortran::common::visitors{ + [&](const Fortran::evaluate::Triplet &trip) { + // For a subscript of triple notation, we compute the + // range of this dimension of the iteration space. + auto lo = [&]() { + if (auto optLo = trip.lower()) + return fir::getBase(asScalar(*optLo)); + return getLBound(exv, ss.index(), one); + }(); + auto hi = [&]() { + if (auto optHi = trip.upper()) + return fir::getBase(asScalar(*optHi)); + return getUBound(exv, ss.index(), one); + }(); + auto step = builder.createConvert( + loc, idxTy, fir::getBase(asScalar(trip.stride()))); + auto extent = builder.genExtentFromTriplet(loc, lo, hi, + step, idxTy); + destShape.push_back(extent); + }, + [&](auto) {}}, + ss.value().u); + } + return true; + } + bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) { + if (x.IsSymbol()) + return genShapeFromDataRef(getFirstSym(x)); + return genShapeFromDataRef(x.GetComponent()); + } + bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) { + return std::visit([&](const auto &v) { return genShapeFromDataRef(v); }, + x.u); + } + + /// When in an explicit space, the ranked component must be evaluated to + /// determine the actual number of iterations when slicing triples are + /// present. Lower these expressions here. + bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) { + LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump( + llvm::dbgs() << "determine shape of:\n", lhs)); + // FIXME: We may not want to use ExtractDataRef here since it doesn't deal + // with substrings, etc. + std::optional dref = + Fortran::evaluate::ExtractDataRef(lhs); + return dref.has_value() ? genShapeFromDataRef(*dref) : false; + } + ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) { mlir::Type resTy = converter.genType(exp); return std::visit( @@ -5908,11 +6266,33 @@ return abstractArrayExtValue(iterSpace.outerResult()); } + /// Compute the shape of a slice. + llvm::SmallVector computeSliceShape(mlir::Value slice) { + llvm::SmallVector slicedShape; + auto slOp = mlir::cast(slice.getDefiningOp()); + mlir::Operation::operand_range triples = slOp.getTriples(); + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Location loc = getLoc(); + for (unsigned i = 0, end = triples.size(); i < end; i += 3) { + if (!mlir::isa_and_nonnull( + triples[i + 1].getDefiningOp())) { + // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0) + // See Fortran 2018 9.5.3.3.2 section for more details. + mlir::Value res = builder.genExtentFromTriplet( + loc, triples[i], triples[i + 1], triples[i + 2], idxTy); + slicedShape.emplace_back(res); + } else { + // do nothing. `..., i, ...` case, so dimension is dropped. + } + } + return slicedShape; + } + /// Get the shape from an ArrayOperand. The shape of the array is adjusted if /// the array was sliced. llvm::SmallVector getShape(ArrayOperand array) { - // if (array.slice) - // return computeSliceShape(array.slice); + if (array.slice) + return computeSliceShape(array.slice); if (array.memref.getType().isa()) return fir::factory::readExtents(builder, getLoc(), fir::BoxValue{array.memref}); diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -16,6 +16,7 @@ #include "flang/Lower/BoxAnalyzer.h" #include "flang/Lower/CallInterface.h" #include "flang/Lower/ConvertExpr.h" +#include "flang/Lower/IntrinsicCall.h" #include "flang/Lower/Mangler.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Lower/StatementContext.h" @@ -30,50 +31,12 @@ #include "flang/Optimizer/Dialect/FIROps.h" #include "flang/Optimizer/Support/FIRContext.h" #include "flang/Optimizer/Support/FatalError.h" +#include "flang/Semantics/runtime-type-info.h" #include "flang/Semantics/tools.h" #include "llvm/Support/Debug.h" #define DEBUG_TYPE "flang-lower-variable" -/// Helper to retrieve a copy of a character literal string from a SomeExpr. -/// Required to build character global initializers. -template -static llvm::Optional> -getCharacterLiteralCopy( - const Fortran::evaluate::Expr< - Fortran::evaluate::Type> - &x) { - if (const auto *con = - Fortran::evaluate::UnwrapConstantValue>(x)) - if (auto val = con->GetScalarValue()) - return std::tuple{ - std::string{(const char *)val->c_str(), - KIND * (std::size_t)con->LEN()}, - (std::size_t)con->LEN()}; - return llvm::None; -} -static llvm::Optional> -getCharacterLiteralCopy( - const Fortran::evaluate::Expr &x) { - return std::visit([](const auto &e) { return getCharacterLiteralCopy(e); }, - x.u); -} -static llvm::Optional> -getCharacterLiteralCopy(const Fortran::lower::SomeExpr &x) { - if (const auto *e = Fortran::evaluate::UnwrapExpr< - Fortran::evaluate::Expr>(x)) - return getCharacterLiteralCopy(*e); - return llvm::None; -} -template -static llvm::Optional> -getCharacterLiteralCopy(const std::optional &x) { - if (x) - return getCharacterLiteralCopy(*x); - return llvm::None; -} - /// Helper to lower a scalar expression using a specific symbol mapping. static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter, mlir::Location loc, @@ -123,6 +86,23 @@ sym.test(Fortran::semantics::Symbol::Flag::ReadOnly); } +/// Is this a compiler generated symbol to describe derived types ? +static bool isRuntimeTypeInfoData(const Fortran::semantics::Symbol &sym) { + // So far, use flags to detect if this symbol were generated during + // semantics::BuildRuntimeDerivedTypeTables(). Scope cannot be used since the + // symbols are injected in the user scopes defining the described derived + // types. A robustness improvement for this test could be to get hands on the + // semantics::RuntimeDerivedTypeTables and to check if the symbol names + // belongs to this structure. + return sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated) && + sym.test(Fortran::semantics::Symbol::Flag::ReadOnly); +} + +static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + llvm::StringRef globalName, + mlir::StringAttr linkage); + /// Create the global op declaration without any initializer static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, @@ -131,6 +111,11 @@ fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (fir::GlobalOp global = builder.getNamedGlobal(globalName)) return global; + // Always define linkonce data since it may be optimized out from the module + // that actually owns the variable if it does not refers to it. + if (linkage == builder.createLinkOnceODRLinkage() || + linkage == builder.createLinkOnceLinkage()) + return defineGlobal(converter, var, globalName, linkage); const Fortran::semantics::Symbol &sym = var.getSymbol(); mlir::Location loc = converter.genLocation(sym.name()); // Resolve potential host and module association before checking that this @@ -444,27 +429,16 @@ } else if (const auto *details = sym.detailsIf()) { if (details->init()) { - if (fir::isa_char(symTy)) { - // CHARACTER literal - if (auto chLit = getCharacterLiteralCopy(details->init().value())) { - mlir::StringAttr init = - builder.getStringAttr(std::get(*chLit)); - global->setAttr(global.getInitValAttrName(), init); - } else { - fir::emitFatalError(loc, "CHARACTER has unexpected initial value"); - } - } else { - createGlobalInitialization( - builder, global, [&](fir::FirOpBuilder &builder) { - Fortran::lower::StatementContext stmtCtx( - /*cleanupProhibited=*/true); - fir::ExtendedValue initVal = genInitializerExprValue( - converter, loc, details->init().value(), stmtCtx); - mlir::Value castTo = - builder.createConvert(loc, symTy, fir::getBase(initVal)); - builder.create(loc, castTo); - }); - } + createGlobalInitialization( + builder, global, [&](fir::FirOpBuilder &builder) { + Fortran::lower::StatementContext stmtCtx( + /*cleanupProhibited=*/true); + fir::ExtendedValue initVal = genInitializerExprValue( + converter, loc, details->init().value(), stmtCtx); + mlir::Value castTo = + builder.createConvert(loc, symTy, fir::getBase(initVal)); + builder.create(loc, castTo); + }); } else if (hasDefaultInitialization(sym)) { createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &builder) { @@ -498,6 +472,12 @@ static mlir::StringAttr getLinkageAttribute(fir::FirOpBuilder &builder, const Fortran::lower::pft::Variable &var) { + // Runtime type info for a same derived type is identical in each compilation + // unit. It desired to avoid having to link against module that only define a + // type. Therefore the runtime type info is generated everywhere it is needed + // with `linkonce_odr` LLVM linkage. + if (var.hasSymbol() && isRuntimeTypeInfoData(var.getSymbol())) + return builder.createLinkOnceODRLinkage(); if (var.isModuleVariable()) return {}; // external linkage // Otherwise, the variable is owned by a procedure and must not be visible in @@ -557,6 +537,49 @@ return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg); } +/// Must \p var be default initialized at runtime when entering its scope. +static bool +mustBeDefaultInitializedAtRuntime(const Fortran::lower::pft::Variable &var) { + if (!var.hasSymbol()) + return false; + const Fortran::semantics::Symbol &sym = var.getSymbol(); + if (var.isGlobal()) + // Global variables are statically initialized. + return false; + if (Fortran::semantics::IsDummy(sym) && !Fortran::semantics::IsIntentOut(sym)) + return false; + // Local variables (including function results), and intent(out) dummies must + // be default initialized at runtime if their type has default initialization. + return hasDefaultInitialization(sym); +} + +/// Call default initialization runtime routine to initialize \p var. +static void +defaultInitializeAtRuntime(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + Fortran::lower::SymMap &symMap) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::Location loc = converter.getCurrentLocation(); + const Fortran::semantics::Symbol &sym = var.getSymbol(); + fir::ExtendedValue exv = symMap.lookupSymbol(sym).toExtendedValue(); + if (Fortran::semantics::IsOptional(sym)) { + // 15.5.2.12 point 3, absent optional dummies are not initialized. + // Creating descriptor/passing null descriptor to the runtime would + // create runtime crashes. + auto isPresent = builder.create(loc, builder.getI1Type(), + fir::getBase(exv)); + builder.genIfThen(loc, isPresent) + .genThen([&]() { + auto box = builder.createBox(loc, exv); + fir::runtime::genDerivedTypeInitialize(builder, loc, box); + }) + .end(); + } else { + mlir::Value box = builder.createBox(loc, exv); + fir::runtime::genDerivedTypeInitialize(builder, loc, box); + } +} + /// Instantiate a local variable. Precondition: Each variable will be visited /// such that if its properties depend on other variables, the variables upon /// which its properties depend will already have been visited. @@ -566,6 +589,161 @@ assert(!var.isAlias()); Fortran::lower::StatementContext stmtCtx; mapSymbolAttributes(converter, var, symMap, stmtCtx); + if (mustBeDefaultInitializedAtRuntime(var)) + defaultInitializeAtRuntime(converter, var, symMap); +} + +//===----------------------------------------------------------------===// +// Aliased (EQUIVALENCE) variables instantiation +//===----------------------------------------------------------------===// + +/// Insert \p aggregateStore instance into an AggregateStoreMap. +static void insertAggregateStore(Fortran::lower::AggregateStoreMap &storeMap, + const Fortran::lower::pft::Variable &var, + mlir::Value aggregateStore) { + std::size_t off = var.getAggregateStore().getOffset(); + Fortran::lower::AggregateStoreKey key = {var.getOwningScope(), off}; + storeMap[key] = aggregateStore; +} + +/// Retrieve the aggregate store instance of \p alias from an +/// AggregateStoreMap. +static mlir::Value +getAggregateStore(Fortran::lower::AggregateStoreMap &storeMap, + const Fortran::lower::pft::Variable &alias) { + Fortran::lower::AggregateStoreKey key = {alias.getOwningScope(), + alias.getAlias()}; + auto iter = storeMap.find(key); + assert(iter != storeMap.end()); + return iter->second; +} + +/// Build the name for the storage of a global equivalence. +static std::string mangleGlobalAggregateStore( + const Fortran::lower::pft::Variable::AggregateStore &st) { + return Fortran::lower::mangle::mangleName(st.getNamingSymbol()); +} + +/// Build the type for the storage of an equivalence. +static mlir::Type +getAggregateType(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable::AggregateStore &st) { + if (const Fortran::semantics::Symbol *initSym = st.getInitialValueSymbol()) + return converter.genType(*initSym); + mlir::IntegerType byteTy = converter.getFirOpBuilder().getIntegerType(8); + return fir::SequenceType::get(std::get<1>(st.interval), byteTy); +} + +/// Define a GlobalOp for the storage of a global equivalence described +/// by \p aggregate. The global is named \p aggName and is created with +/// the provided \p linkage. +/// If any of the equivalence members are initialized, an initializer is +/// created for the equivalence. +/// This is to be used when lowering the scope that owns the equivalence +/// (as opposed to simply using it through host or use association). +/// This is not to be used for equivalence of common block members (they +/// already have the common block GlobalOp for them, see defineCommonBlock). +static fir::GlobalOp defineGlobalAggregateStore( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable::AggregateStore &aggregate, + llvm::StringRef aggName, mlir::StringAttr linkage) { + assert(aggregate.isGlobal() && "not a global interval"); + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + fir::GlobalOp global = builder.getNamedGlobal(aggName); + if (global && globalIsInitialized(global)) + return global; + mlir::Location loc = converter.getCurrentLocation(); + mlir::Type aggTy = getAggregateType(converter, aggregate); + if (!global) + global = builder.createGlobal(loc, aggTy, aggName, linkage); + + if (const Fortran::semantics::Symbol *initSym = + aggregate.getInitialValueSymbol()) + if (const auto *objectDetails = + initSym->detailsIf()) + if (objectDetails->init()) { + createGlobalInitialization( + builder, global, [&](fir::FirOpBuilder &builder) { + Fortran::lower::StatementContext stmtCtx; + mlir::Value initVal = fir::getBase(genInitializerExprValue( + converter, loc, objectDetails->init().value(), stmtCtx)); + builder.create(loc, initVal); + }); + return global; + } + // Equivalence has no Fortran initial value. Create an undefined FIR initial + // value to ensure this is consider an object definition in the IR regardless + // of the linkage. + createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &builder) { + Fortran::lower::StatementContext stmtCtx; + mlir::Value initVal = builder.create(loc, aggTy); + builder.create(loc, initVal); + }); + return global; +} + +/// Declare a GlobalOp for the storage of a global equivalence described +/// by \p aggregate. The global is named \p aggName and is created with +/// the provided \p linkage. +/// No initializer is built for the created GlobalOp. +/// This is to be used when lowering the scope that uses members of an +/// equivalence it through host or use association. +/// This is not to be used for equivalence of common block members (they +/// already have the common block GlobalOp for them, see defineCommonBlock). +static fir::GlobalOp declareGlobalAggregateStore( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const Fortran::lower::pft::Variable::AggregateStore &aggregate, + llvm::StringRef aggName, mlir::StringAttr linkage) { + assert(aggregate.isGlobal() && "not a global interval"); + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + if (fir::GlobalOp global = builder.getNamedGlobal(aggName)) + return global; + mlir::Type aggTy = getAggregateType(converter, aggregate); + return builder.createGlobal(loc, aggTy, aggName, linkage); +} + +/// This is an aggregate store for a set of EQUIVALENCED variables. Create the +/// storage on the stack or global memory and add it to the map. +static void +instantiateAggregateStore(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + Fortran::lower::AggregateStoreMap &storeMap) { + assert(var.isAggregateStore() && "not an interval"); + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::IntegerType i8Ty = builder.getIntegerType(8); + mlir::Location loc = converter.getCurrentLocation(); + std::string aggName = mangleGlobalAggregateStore(var.getAggregateStore()); + if (var.isGlobal()) { + fir::GlobalOp global; + auto &aggregate = var.getAggregateStore(); + mlir::StringAttr linkage = getLinkageAttribute(builder, var); + if (var.isModuleVariable()) { + // A module global was or will be defined when lowering the module. Emit + // only a declaration if the global does not exist at that point. + global = declareGlobalAggregateStore(converter, loc, aggregate, aggName, + linkage); + } else { + global = + defineGlobalAggregateStore(converter, aggregate, aggName, linkage); + } + auto addr = builder.create(loc, global.resultType(), + global.getSymbol()); + auto size = std::get<1>(var.getInterval()); + fir::SequenceType::Shape shape(1, size); + auto seqTy = fir::SequenceType::get(shape, i8Ty); + mlir::Type refTy = builder.getRefType(seqTy); + mlir::Value aggregateStore = builder.createConvert(loc, refTy, addr); + insertAggregateStore(storeMap, var, aggregateStore); + return; + } + // This is a local aggregate, allocate an anonymous block of memory. + auto size = std::get<1>(var.getInterval()); + fir::SequenceType::Shape shape(1, size); + auto seqTy = fir::SequenceType::get(shape, i8Ty); + mlir::Value local = + builder.allocateLocal(loc, seqTy, aggName, "", llvm::None, llvm::None, + /*target=*/false); + insertAggregateStore(storeMap, var, local); } /// Cast an alias address (variable part of an equivalence) to fir.ptr so that @@ -580,6 +758,40 @@ aliasAddr); } +/// Instantiate a member of an equivalence. Compute its address in its +/// aggregate storage and lower its attributes. +static void instantiateAlias(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + Fortran::lower::SymMap &symMap, + Fortran::lower::AggregateStoreMap &storeMap) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + assert(var.isAlias()); + const Fortran::semantics::Symbol &sym = var.getSymbol(); + const mlir::Location loc = converter.genLocation(sym.name()); + mlir::IndexType idxTy = builder.getIndexType(); + std::size_t aliasOffset = var.getAlias(); + mlir::Value store = getAggregateStore(storeMap, var); + mlir::IntegerType i8Ty = builder.getIntegerType(8); + mlir::Type i8Ptr = builder.getRefType(i8Ty); + mlir::Value offset = builder.createIntegerConstant( + loc, idxTy, sym.GetUltimate().offset() - aliasOffset); + auto ptr = builder.create(loc, i8Ptr, store, + mlir::ValueRange{offset}); + mlir::Value preAlloc = + castAliasToPointer(builder, loc, converter.genType(sym), ptr); + Fortran::lower::StatementContext stmtCtx; + mapSymbolAttributes(converter, var, symMap, stmtCtx, preAlloc); + // Default initialization is possible for equivalence members: see + // F2018 19.5.3.4. Note that if several equivalenced entities have + // default initialization, they must have the same type, and the standard + // allows the storage to be default initialized several times (this has + // no consequences other than wasting some execution time). For now, + // do not try optimizing this to single default initializations of + // the equivalenced storages. Keep lowering simple. + if (mustBeDefaultInitializedAtRuntime(var)) + defaultInitializeAtRuntime(converter, var, symMap); +} + //===--------------------------------------------------------------===// // COMMON blocks instantiation //===--------------------------------------------------------------===// @@ -1392,13 +1604,131 @@ //===--------------------------------------------------------------===// [&](const Fortran::lower::details::DynamicArrayStaticChar &x) { - TODO(loc, "DynamicArrayStaticChar variable lowering"); + mlir::Value addr; + mlir::Value len; + mlir::Value argBox; + auto charLen = x.charLen(); + // if element type is a CHARACTER, determine the LEN value + if (isDummy) { + mlir::Value actualArg = symMap.lookupSymbol(sym).getAddr(); + if (auto boxTy = actualArg.getType().dyn_cast()) { + argBox = actualArg; + mlir::Type refTy = builder.getRefType(boxTy.getEleTy()); + addr = builder.create(loc, refTy, argBox); + } else { + addr = charHelp.createUnboxChar(actualArg).first; + } + // Set/override LEN with a constant + len = builder.createIntegerConstant(loc, idxTy, charLen); + } else { + // local CHARACTER variable + len = builder.createIntegerConstant(loc, idxTy, charLen); + } + + // cast to the known constant parts from the declaration + mlir::Type castTy = builder.getRefType(converter.genType(var)); + if (addr) + addr = builder.createConvert(loc, castTy, addr); + if (x.lboundAllOnes()) { + // if lower bounds are all ones, build simple shaped object + llvm::SmallVector shape; + populateShape(shape, x.bounds, argBox); + if (isDummy) { + symMap.addCharSymbolWithShape(sym, addr, len, shape, true); + return; + } + // local CHARACTER array + mlir::Value local = + createNewLocal(converter, loc, var, preAlloc, shape); + symMap.addCharSymbolWithShape(sym, local, len, shape); + return; + } + // if object is an array process the lower bound and extent values + llvm::SmallVector extents; + llvm::SmallVector lbounds; + populateLBoundsExtents(lbounds, extents, x.bounds, argBox); + if (isDummy) { + symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds, + true); + return; + } + // local CHARACTER array with computed bounds + assert(Fortran::lower::isExplicitShape(sym)); + mlir::Value local = + createNewLocal(converter, loc, var, preAlloc, extents); + symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds); }, //===--------------------------------------------------------------===// [&](const Fortran::lower::details::DynamicArrayDynamicChar &x) { - TODO(loc, "DynamicArrayDynamicChar variable lowering"); + mlir::Value addr; + mlir::Value len; + mlir::Value argBox; + auto charLen = x.charLen(); + // if element type is a CHARACTER, determine the LEN value + if (isDummy) { + mlir::Value actualArg = symMap.lookupSymbol(sym).getAddr(); + if (auto boxTy = actualArg.getType().dyn_cast()) { + argBox = actualArg; + mlir::Type refTy = builder.getRefType(boxTy.getEleTy()); + addr = builder.create(loc, refTy, argBox); + if (charLen) + // Set/override LEN with an expression. + len = genExplicitCharLen(charLen); + else + // Get the length from the actual arguments. + len = charHelp.readLengthFromBox(argBox); + } else { + std::pair unboxchar = + charHelp.createUnboxChar(actualArg); + addr = unboxchar.first; + if (charLen) { + // Set/override LEN with an expression + len = genExplicitCharLen(charLen); + } else { + // Get the length from the actual arguments. + len = unboxchar.second; + } + } + } else { + // local CHARACTER variable + len = genExplicitCharLen(charLen); + } + llvm::SmallVector lengths = {len}; + + // cast to the known constant parts from the declaration + mlir::Type castTy = builder.getRefType(converter.genType(var)); + if (addr) + addr = builder.createConvert(loc, castTy, addr); + if (x.lboundAllOnes()) { + // if lower bounds are all ones, build simple shaped object + llvm::SmallVector shape; + populateShape(shape, x.bounds, argBox); + if (isDummy) { + symMap.addCharSymbolWithShape(sym, addr, len, shape, true); + return; + } + // local CHARACTER array + mlir::Value local = + createNewLocal(converter, loc, var, preAlloc, shape, lengths); + symMap.addCharSymbolWithShape(sym, local, len, shape); + return; + } + // Process the lower bound and extent values. + llvm::SmallVector extents; + llvm::SmallVector lbounds; + populateLBoundsExtents(lbounds, extents, x.bounds, argBox); + if (isDummy) { + symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds, + true); + return; + } + // local CHARACTER array with computed bounds + assert(Fortran::lower::isExplicitShape(sym)); + mlir::Value local = + createNewLocal(converter, loc, var, preAlloc, extents, lengths); + symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds); }, //===--------------------------------------------------------------===// @@ -1413,14 +1743,18 @@ AbstractConverter &converter, const Fortran::lower::pft::Variable &var) { // Use empty linkage for module variables, which makes them available // for use in another unit. - mlir::StringAttr externalLinkage; + mlir::StringAttr linkage = + getLinkageAttribute(converter.getFirOpBuilder(), var); if (!var.isGlobal()) fir::emitFatalError(converter.getCurrentLocation(), "attempting to lower module variable as local"); // Define aggregate storages for equivalenced objects. if (var.isAggregateStore()) { - const mlir::Location loc = converter.genLocation(var.getSymbol().name()); - TODO(loc, "defineModuleVariable aggregateStore"); + const Fortran::lower::pft::Variable::AggregateStore &aggregate = + var.getAggregateStore(); + std::string aggName = mangleGlobalAggregateStore(aggregate); + defineGlobalAggregateStore(converter, aggregate, aggName, linkage); + return; } const Fortran::semantics::Symbol &sym = var.getSymbol(); if (const Fortran::semantics::Symbol *common = @@ -1431,24 +1765,22 @@ // Do nothing. Mapping will be done on user side. } else { std::string globalName = Fortran::lower::mangle::mangleName(sym); - defineGlobal(converter, var, globalName, externalLinkage); + defineGlobal(converter, var, globalName, linkage); } } void Fortran::lower::instantiateVariable(AbstractConverter &converter, const pft::Variable &var, - SymMap &symMap, + Fortran::lower::SymMap &symMap, AggregateStoreMap &storeMap) { - const Fortran::semantics::Symbol &sym = var.getSymbol(); - const mlir::Location loc = converter.genLocation(sym.name()); if (var.isAggregateStore()) { - TODO(loc, "instantiateVariable AggregateStore"); + instantiateAggregateStore(converter, var, storeMap); } else if (const Fortran::semantics::Symbol *common = Fortran::semantics::FindCommonBlockContaining( var.getSymbol().GetUltimate())) { instantiateCommon(converter, *common, var, symMap); } else if (var.isAlias()) { - TODO(loc, "instantiateVariable Alias"); + instantiateAlias(converter, var, symMap, storeMap); } else if (var.isGlobal()) { instantiateGlobal(converter, var, symMap); } else { @@ -1503,3 +1835,13 @@ } } } + +void Fortran::lower::createRuntimeTypeInfoGlobal( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const Fortran::semantics::Symbol &typeInfoSym) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + std::string globalName = Fortran::lower::mangle::mangleName(typeInfoSym); + auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true); + mlir::StringAttr linkage = getLinkageAttribute(builder, var); + defineGlobal(converter, var, globalName, linkage); +} 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 @@ -105,6 +105,9 @@ return args.size() <= argIndex || isAbsent(args[argIndex]); } +/// Test if an ExtendedValue is present. +static bool isPresent(const fir::ExtendedValue &exv) { return !isAbsent(exv); } + /// Process calls to Maxval, Minval, Product, Sum intrinsic functions that /// take a DIM argument. template @@ -277,6 +280,7 @@ mlir::Value genIand(mlir::Type, llvm::ArrayRef); mlir::Value genIbits(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genLbound(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genSize(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef); @@ -390,6 +394,7 @@ {"iand", &I::genIand}, {"ibits", &I::genIbits}, {"min", &I::genExtremum}, + {"null", &I::genNull, {{{"mold", asInquired}}}, /*isElemental=*/false}, {"sum", &I::genSum, {{{"array", asBox}, @@ -1399,6 +1404,23 @@ return result; } +// NULL +fir::ExtendedValue +IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef args) { + // NULL() without MOLD must be handled in the contexts where it can appear + // (see table 16.5 of Fortran 2018 standard). + assert(args.size() == 1 && isPresent(args[0]) && + "MOLD argument required to lower NULL outside of any context"); + const auto *mold = args[0].getBoxOf(); + assert(mold && "MOLD must be a pointer or allocatable"); + fir::BoxType boxType = mold->getBoxTy(); + mlir::Value boxStorage = builder.createTemporary(loc, boxType); + mlir::Value box = fir::factory::createUnallocatedBox( + builder, loc, boxType, mold->nonDeferredLenParams()); + builder.create(loc, box, boxStorage); + return fir::MutableBoxValue(boxStorage, mold->nonDeferredLenParams(), {}); +} + // SUM fir::ExtendedValue IntrinsicLibrary::genSum(mlir::Type resultType, diff --git a/flang/lib/Lower/SymbolMap.cpp b/flang/lib/Lower/SymbolMap.cpp --- a/flang/lib/Lower/SymbolMap.cpp +++ b/flang/lib/Lower/SymbolMap.cpp @@ -31,7 +31,8 @@ } Fortran::lower::SymbolBox -Fortran::lower::SymMap::lookupSymbol(Fortran::semantics::SymbolRef sym) { +Fortran::lower::SymMap::lookupSymbol(Fortran::semantics::SymbolRef symRef) { + Fortran::semantics::SymbolRef sym = symRef.get().GetUltimate(); for (auto jmap = symbolMapStack.rbegin(), jend = symbolMapStack.rend(); jmap != jend; ++jmap) { auto iter = jmap->find(&*sym); @@ -41,6 +42,15 @@ return SymbolBox::None{}; } +Fortran::lower::SymbolBox Fortran::lower::SymMap::shallowLookupSymbol( + Fortran::semantics::SymbolRef symRef) { + auto &map = symbolMapStack.back(); + auto iter = map.find(&symRef.get().GetUltimate()); + if (iter != map.end()) + return iter->second; + return SymbolBox::None{}; +} + mlir::Value Fortran::lower::SymMap::lookupImpliedDo(Fortran::lower::SymMap::AcDoVar var) { for (auto [marker, binding] : llvm::reverse(impliedDoStack)) diff --git a/flang/test/Lower/nullify.f90 b/flang/test/Lower/nullify.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/nullify.f90 @@ -0,0 +1,51 @@ +! Test lowering of nullify-statement +! RUN: bbc -emit-fir %s -o - | FileCheck %s + + +! ----------------------------------------------------------------------------- +! Test NULLIFY(p) +! ----------------------------------------------------------------------------- + + +! CHECK-LABEL: func @_QPtest_scalar( +! CHECK-SAME: %[[p:.*]]: !fir.ref>>{{.*}}) +subroutine test_scalar(p) + real, pointer :: p + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr + ! CHECK: %[[box:.*]] = fir.embox %[[null]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>> + nullify(p) + end subroutine + + ! CHECK-LABEL: func @_QPtest_scalar_char( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}) + subroutine test_scalar_char(p) + character(:), pointer :: p + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[box:.*]] = fir.embox %[[null]] typeparams %c0{{.*}} : (!fir.ptr>, index) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + nullify(p) + end subroutine + + ! CHECK-LABEL: func @_QPtest_array( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}) + subroutine test_array(p) + real, pointer :: p(:) + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %[[null]](%[[shape]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + nullify(p) + end subroutine + + ! CHECK-LABEL: func @_QPtest_list( + ! CHECK-SAME: %[[p1:.*]]: !fir.ref>>{{.*}}, %[[p2:.*]]: !fir.ref>>>{{.*}}) + subroutine test_list(p1, p2) + real, pointer :: p1, p2(:) + ! CHECK: fir.zero_bits !fir.ptr + ! CHECK: fir.store %{{.*}} to %[[p1]] : !fir.ref>> + + ! CHECK: fir.zero_bits !fir.ptr> + ! CHECK: fir.store %{{.*}} to %[[p2]] : !fir.ref>>> + nullify(p1, p2) + end subroutine diff --git a/flang/test/Lower/pointer-assignments.f90 b/flang/test/Lower/pointer-assignments.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-assignments.f90 @@ -0,0 +1,356 @@ +! Test lowering of pointer assignments +! RUN: bbc -emit-fir %s -o - | FileCheck %s + + +! Note that p => NULL() are tested in pointer-disassociate.f90 + +! ----------------------------------------------------------------------------- +! Test simple pointer assignments to contiguous right-hand side +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func @_QPtest_scalar( +! CHECK-SAME: %[[p:.*]]: !fir.ref>>{{.*}}, %[[x:.*]]: !fir.ref {{{.*}}, fir.target}) +subroutine test_scalar(p, x) + real, target :: x + real, pointer :: p + ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref) -> !fir.box> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>> + p => x + end subroutine + + ! CHECK-LABEL: func @_QPtest_scalar_char( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target}) + subroutine test_scalar_char(p, x) + character(*), target :: x + character(:), pointer :: p + ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 : (!fir.boxchar<1>) -> (!fir.ref>, index) + ! CHECK: %[[box:.*]] = fir.embox %[[c]]#0 typeparams %[[c]]#1 : (!fir.ref>, index) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p => x + end subroutine + + ! CHECK-LABEL: func @_QPtest_array( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.ref> {{{.*}}, fir.target}) + subroutine test_array(p, x) + real, target :: x(100) + real, pointer :: p(:) + ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p => x + end subroutine + + ! CHECK-LABEL: func @_QPtest_array_char( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target}) { + subroutine test_array_char(p, x) + character(*), target :: x(100) + character(:), pointer :: p(:) + ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 : (!fir.boxchar<1>) -> (!fir.ref>, index) + ! CHECK: %[[xaddr:.*]] = fir.convert %[[c]]#0 : (!fir.ref>) -> !fir.ref>> + ! CHECK-DAG: %[[xaddr2:.*]] = fir.convert %[[xaddr]] : (!fir.ref>>) -> !fir.ref>> + ! CHECK-DAG: %[[shape:.*]] = fir.shape %c100{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %[[xaddr2]](%[[shape]]) typeparams %[[c]]#1 + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>>> + p => x + end subroutine + + ! Test 10.2.2.3 point 10: lower bounds requirements: + ! pointer takes lbounds from rhs if no bounds spec. + ! CHECK-LABEL: func @_QPtest_array_with_lbs( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>> + subroutine test_array_with_lbs(p, x) + real, target :: x(51:150) + real, pointer :: p(:) + ! CHECK: %[[shape:.*]] = fir.shape_shift %c51{{.*}}, %c100{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p => x + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test pointer assignments with bound specs to contiguous right-hand side + ! ----------------------------------------------------------------------------- + + ! Test 10.2.2.3 point 10: lower bounds requirements: + ! pointer takes lbounds from bound spec if specified + ! CHECK-LABEL: func @_QPtest_array_with_new_lbs( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>> + subroutine test_array_with_new_lbs(p, x) + real, target :: x(51:150) + real, pointer :: p(:) + ! CHECK: %[[shape:.*]] = fir.shape_shift %c4{{.*}}, %c100{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p(4:) => x + end subroutine + + ! Test F2018 10.2.2.3 point 9: bounds remapping + ! CHECK-LABEL: func @_QPtest_array_remap( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.ref> {{{.*}}, fir.target}) + subroutine test_array_remap(p, x) + real, target :: x(100) + real, pointer :: p(:, :) + ! CHECK-DAG: %[[c2_idx:.*]] = fir.convert %c2{{.*}} : (i64) -> index + ! CHECK-DAG: %[[c11_idx:.*]] = fir.convert %c11{{.*}} : (i64) -> index + ! CHECK-DAG: %[[diff0:.*]] = arith.subi %[[c11_idx]], %[[c2_idx]] : index + ! CHECK-DAG: %[[ext0:.*]] = arith.addi %[[diff0:.*]], %c1{{.*}} : index + ! CHECK-DAG: %[[c3_idx:.*]] = fir.convert %c3{{.*}} : (i64) -> index + ! CHECK-DAG: %[[c12_idx:.*]] = fir.convert %c12{{.*}} : (i64) -> index + ! CHECK-DAG: %[[diff1:.*]] = arith.subi %[[c12_idx]], %[[c3_idx]] : index + ! CHECK-DAG: %[[ext1:.*]] = arith.addi %[[diff1]], %c1{{.*}} : index + ! CHECK-DAG: %[[addrCast:.*]] = fir.convert %[[x]] : (!fir.ref>) -> !fir.ref> + ! CHECK: %[[shape:.*]] = fir.shape_shift %c2{{.*}}, %[[ext0]], %c3{{.*}}, %[[ext1]] + ! CHECK: %[[box:.*]] = fir.embox %[[addrCast]](%[[shape]]) : (!fir.ref>, !fir.shapeshift<2>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p(2:11, 3:12) => x + end subroutine + + ! CHECK-LABEL: func @_QPtest_array_char_remap( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target}) + subroutine test_array_char_remap(p, x) + ! CHECK: %[[unbox:.*]]:2 = fir.unboxchar %[[x]] + character(*), target :: x(100) + character(:), pointer :: p(:, :) + ! CHECK: subi + ! CHECK: %[[ext0:.*]] = arith.addi + ! CHECK: subi + ! CHECK: %[[ext1:.*]] = arith.addi + ! CHECK: %[[shape:.*]] = fir.shape_shift %c2{{.*}}, %[[ext0]], %c3{{.*}}, %[[ext1]] + ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) typeparams %[[unbox]]#1 : (!fir.ref>>, !fir.shapeshift<2>, index) -> !fir.box>>> + ! CHECK: fir.store %[[box]] to %[[p]] + p(2:11, 3:12) => x + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test simple pointer assignments to non contiguous right-hand side + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.box> {{{.*}}, fir.target}) + subroutine test_array_non_contig_rhs(p, x) + real, target :: x(:) + real, pointer :: p(:) + ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]] : (!fir.box>) -> !fir.box>> + ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref>>> + p => x + end subroutine + + ! Test 10.2.2.3 point 10: lower bounds requirements: + ! pointer takes lbounds from rhs if no bounds spec. + ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs_lbs( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.box> {{{.*}}, fir.target}) + subroutine test_array_non_contig_rhs_lbs(p, x) + real, target :: x(7:) + real, pointer :: p(:) + ! CHECK: %[[c7_idx:.*]] = fir.convert %c7{{.*}} : (i64) -> index + ! CHECK: %[[shift:.*]] = fir.shift %[[c7_idx]] : (index) -> !fir.shift<1> + ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shift]]) : (!fir.box>, !fir.shift<1>) -> !fir.box>> + + ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref>>> + p => x + end subroutine + + ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs2( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref> {{{.*}}, fir.target}) { + ! CHECK: %[[VAL_2:.*]] = arith.constant 200 : index + ! CHECK: %[[VAL_3:.*]] = arith.constant 10 : i64 + ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i64) -> index + ! CHECK: %[[VAL_5:.*]] = arith.constant 3 : i64 + ! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index + ! CHECK: %[[VAL_7:.*]] = arith.constant 160 : i64 + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index + ! CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_10:.*]] = fir.slice %[[VAL_4]], %[[VAL_8]], %[[VAL_6]] : (index, index, index) -> !fir.slice<1> + ! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_1]](%[[VAL_9]]) {{\[}}%[[VAL_10]]] : (!fir.ref>, !fir.shape<1>, !fir.slice<1>) -> !fir.box> + ! CHECK: %[[VAL_12:.*]] = fir.rebox %[[VAL_11]] : (!fir.box>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_12]] to %[[VAL_0]] : !fir.ref>>> + ! CHECK: return + ! CHECK: } + + subroutine test_array_non_contig_rhs2(p, x) + real, target :: x(200) + real, pointer :: p(:) + p => x(10:160:3) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test pointer assignments with bound specs to non contiguous right-hand side + ! ----------------------------------------------------------------------------- + + + ! Test 10.2.2.3 point 10: lower bounds requirements: + ! pointer takes lbounds from bound spec if specified + ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs_new_lbs( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.box> {{{.*}}, fir.target}) + subroutine test_array_non_contig_rhs_new_lbs(p, x) + real, target :: x(7:) + real, pointer :: p(:) + ! CHECK: %[[shift:.*]] = fir.shift %c4{{.*}} + ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shift]]) : (!fir.box>, !fir.shift<1>) -> !fir.box>> + + ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref>>> + p(4:) => x + end subroutine + + ! Test F2018 10.2.2.3 point 9: bounds remapping + ! CHECK-LABEL: func @_QPtest_array_non_contig_remap( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}, %[[x:.*]]: !fir.box> {{{.*}}, fir.target}) + subroutine test_array_non_contig_remap(p, x) + real, target :: x(:) + real, pointer :: p(:, :) + ! CHECK: subi + ! CHECK: %[[ext0:.*]] = arith.addi + ! CHECK: subi + ! CHECK: %[[ext1:.*]] = arith.addi + ! CHECK: %[[shape:.*]] = fir.shape_shift %{{.*}}, %[[ext0]], %{{.*}}, %[[ext1]] + ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shape]]) : (!fir.box>, !fir.shapeshift<2>) -> !fir.box>> + ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref>>> + p(2:11, 3:12) => x + end subroutine + + ! Test remapping a slice + + ! CHECK-LABEL: func @_QPtest_array_non_contig_remap_slice( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref> {{{.*}}, fir.target}) { + ! CHECK: %[[VAL_2:.*]] = arith.constant 400 : index + ! CHECK: %[[VAL_3:.*]] = arith.constant 2 : i64 + ! CHECK: %[[VAL_4:.*]] = arith.constant 11 : i64 + ! CHECK: %[[VAL_5:.*]] = arith.constant 3 : i64 + ! CHECK: %[[VAL_6:.*]] = arith.constant 12 : i64 + ! CHECK: %[[VAL_7:.*]] = arith.constant 51 : i64 + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index + ! CHECK: %[[VAL_9:.*]] = arith.constant 3 : i64 + ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i64) -> index + ! CHECK: %[[VAL_11:.*]] = arith.constant 350 : i64 + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index + ! CHECK: %[[VAL_13:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_14:.*]] = fir.slice %[[VAL_8]], %[[VAL_12]], %[[VAL_10]] : (index, index, index) -> !fir.slice<1> + ! CHECK: %[[VAL_15:.*]] = fir.embox %[[VAL_1]](%[[VAL_13]]) {{\[}}%[[VAL_14]]] : (!fir.ref>, !fir.shape<1>, !fir.slice<1>) -> !fir.box> + ! CHECK: %[[VAL_16:.*]] = arith.constant 1 : index + ! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_3]] : (i64) -> index + ! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_4]] : (i64) -> index + ! CHECK: %[[VAL_19:.*]] = arith.subi %[[VAL_18]], %[[VAL_17]] : index + ! CHECK: %[[VAL_20:.*]] = arith.addi %[[VAL_19]], %[[VAL_16]] : index + ! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_5]] : (i64) -> index + ! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_6]] : (i64) -> index + ! CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_21]] : index + ! CHECK: %[[VAL_24:.*]] = arith.addi %[[VAL_23]], %[[VAL_16]] : index + ! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_3]] : (i64) -> index + ! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_5]] : (i64) -> index + ! CHECK: %[[VAL_27:.*]] = fir.shape_shift %[[VAL_25]], %[[VAL_20]], %[[VAL_26]], %[[VAL_24]] : (index, index, index, index) -> !fir.shapeshift<2> + ! CHECK: %[[VAL_28:.*]] = fir.rebox %[[VAL_15]](%[[VAL_27]]) : (!fir.box>, !fir.shapeshift<2>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref>>> + ! CHECK: return + ! CHECK: } + subroutine test_array_non_contig_remap_slice(p, x) + real, target :: x(400) + real, pointer :: p(:, :) + p(2:11, 3:12) => x(51:350:3) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test pointer assignments that involves LHS pointers lowered to local variables + ! instead of a fir.ref, and RHS that are fir.box + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QPissue857( + ! CHECK-SAME: %[[rhs:.*]]: !fir.ref>>> + subroutine issue857(rhs) + type t + integer :: i + end type + type(t), pointer :: rhs, lhs + ! CHECK: %[[lhs:.*]] = fir.alloca !fir.ptr> + ! CHECK: %[[box_load:.*]] = fir.load %[[rhs]] : !fir.ref>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box_load]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: fir.store %[[addr]] to %[[lhs]] : !fir.ref>> + lhs => rhs + end subroutine + + ! CHECK-LABEL: func @_QPissue857_array( + ! CHECK-SAME: %[[rhs:.*]]: !fir.ref>>>> + subroutine issue857_array(rhs) + type t + integer :: i + end type + type(t), contiguous, pointer :: rhs(:), lhs(:) + ! CHECK-DAG: %[[lhs_addr:.*]] = fir.alloca !fir.ptr>> {uniq_name = "_QFissue857_arrayElhs.addr"} + ! CHECK-DAG: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_arrayElhs.lb0"} + ! CHECK-DAG: %[[lhs_ext:.*]] = fir.alloca index {uniq_name = "_QFissue857_arrayElhs.ext0"} + ! CHECK: %[[box:.*]] = fir.load %[[rhs]] : !fir.ref>>>> + ! CHECK: %[[lb:.*]]:3 = fir.box_dims %[[box]], %c{{.*}} : (!fir.box>>>, index) -> (index, index, index) + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>>) -> !fir.ptr>> + ! CHECK: %[[ext:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} : (!fir.box>>>, index) -> (index, index, index) + ! CHECK-DAG: fir.store %[[addr]] to %[[lhs_addr]] : !fir.ref>>> + ! CHECK-DAG: fir.store %[[ext]]#1 to %[[lhs_ext]] : !fir.ref + ! CHECK-DAG: fir.store %[[lb]]#0 to %[[lhs_lb]] : !fir.ref + lhs => rhs + end subroutine + + ! CHECK-LABEL: func @_QPissue857_array_shift( + subroutine issue857_array_shift(rhs) + ! Test lower bounds is the one from the shift + type t + integer :: i + end type + type(t), contiguous, pointer :: rhs(:), lhs(:) + ! CHECK: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_shiftElhs.lb0"} + ! CHECK: %[[c42:.*]] = fir.convert %c42{{.*}} : (i64) -> index + ! CHECK: fir.store %[[c42]] to %[[lhs_lb]] : !fir.ref + lhs(42:) => rhs + end subroutine + + ! CHECK-LABEL: func @_QPissue857_array_remap + subroutine issue857_array_remap(rhs) + ! Test lower bounds is the one from the shift + type t + integer :: i + end type + type(t), contiguous, pointer :: rhs(:, :), lhs(:) + ! CHECK-DAG: %[[lhs_addr:.*]] = fir.alloca !fir.ptr>> {uniq_name = "_QFissue857_array_remapElhs.addr"} + ! CHECK-DAG: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_remapElhs.lb0"} + ! CHECK-DAG: %[[lhs_ext:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_remapElhs.ext0"} + + ! CHECK: %[[c101:.*]] = fir.convert %c101_i64 : (i64) -> index + ! CHECK: %[[c200:.*]] = fir.convert %c200_i64 : (i64) -> index + ! CHECK: %[[sub:.*]] = arith.subi %[[c200]], %[[c101]] : index + ! CHECK: %[[extent:.*]] = arith.addi %[[sub]], %c1{{.*}} : index + ! CHECK: %[[addr:.*]] = fir.box_addr %{{.*}} : (!fir.box>>>) -> !fir.ptr>> + ! CHECK: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.ptr>>) -> !fir.ptr>> + ! CHECK: fir.store %[[addr_cast]] to %[[lhs_addr]] : !fir.ref>>> + ! CHECK: fir.store %[[extent]] to %[[lhs_ext]] : !fir.ref + ! CHECK: %[[c101_2:.*]] = fir.convert %c101{{.*}} : (i64) -> index + ! CHECK: fir.store %[[c101_2]] to %[[lhs_lb]] : !fir.ref + lhs(101:200) => rhs + end subroutine + + ! CHECK-LABEL: func @_QPissue857_char + subroutine issue857_char(rhs) + ! Only check that the length is taken from the fir.box created for the slice. + ! CHECK-DAG: %[[lhs1_len:.*]] = fir.alloca index {uniq_name = "_QFissue857_charElhs1.len"} + ! CHECK-DAG: %[[lhs2_len:.*]] = fir.alloca index {uniq_name = "_QFissue857_charElhs2.len"} + character(:), contiguous, pointer :: lhs1(:), lhs2(:, :) + character(*), target :: rhs(100) + ! CHECK: %[[len:.*]] = fir.box_elesize %{{.*}} : (!fir.box>>) -> index + ! CHECK: fir.store %[[len]] to %[[lhs1_len]] : !fir.ref + lhs1 => rhs(1:50:1) + ! CHECK: %[[len2:.*]] = fir.box_elesize %{{.*}} : (!fir.box>>) -> index + ! CHECK: fir.store %[[len2]] to %[[lhs2_len]] : !fir.ref + lhs2(1:2, 1:25) => rhs(1:50:1) + end subroutine + + ! CHECK-LABEL: func @_QPissue1180( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {{{.*}}, fir.target}) { + subroutine issue1180(x) + integer, target :: x + integer, pointer :: p + common /some_common/ p + ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBsome_common) : !fir.ref> + ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref>, index) -> !fir.ref + ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref) -> !fir.ref>> + ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_0]] : (!fir.ref) -> !fir.box> + ! CHECK: fir.store %[[VAL_6]] to %[[VAL_5]] : !fir.ref>> + p => x + end subroutine diff --git a/flang/test/Lower/pointer-disassociate.f90 b/flang/test/Lower/pointer-disassociate.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-disassociate.f90 @@ -0,0 +1,106 @@ +! Test lowering of pointer disassociation +! RUN: bbc -emit-fir %s -o - | FileCheck %s + + +! ----------------------------------------------------------------------------- +! Test p => NULL() +! ----------------------------------------------------------------------------- + + +! CHECK-LABEL: func @_QPtest_scalar( +! CHECK-SAME: %[[p:.*]]: !fir.ref>>{{.*}}) +subroutine test_scalar(p) + real, pointer :: p + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr + ! CHECK: %[[box:.*]] = fir.embox %[[null]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>> + p => NULL() + end subroutine + + ! CHECK-LABEL: func @_QPtest_scalar_char( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}) + subroutine test_scalar_char(p) + character(:), pointer :: p + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[box:.*]] = fir.embox %[[null]] typeparams %c0{{.*}} : (!fir.ptr>, index) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p => NULL() + end subroutine + + ! CHECK-LABEL: func @_QPtest_array( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}) + subroutine test_array(p) + real, pointer :: p(:) + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %[[null]](%[[shape]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p => NULL() + end subroutine + + ! Test p(lb, ub) => NULL() which is none sens but is not illegal. + ! CHECK-LABEL: func @_QPtest_array_remap( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{.*}}) + subroutine test_array_remap(p) + real, pointer :: p(:) + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}} + ! CHECK: %[[box:.*]] = fir.embox %[[null]](%[[shape]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref>>> + p(10:20) => NULL() + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test p => NULL(MOLD) + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QPtest_scalar_mold( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>{{[^,]*}}, + subroutine test_scalar_mold(p, x) + real, pointer :: p, x + ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box> + ! CHECK: %[[VAL_1:.*]] = fir.zero_bits !fir.ptr + ! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref>> + ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref>> + ! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box>) -> !fir.ptr + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_4]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.store %[[VAL_5]] to %[[p]] : !fir.ref>> + p => NULL(x) + end subroutine + + ! CHECK-LABEL: func @_QPtest_scalar_char_mold( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{[^,]*}}, + subroutine test_scalar_char_mold(p, x) + character(:), pointer :: p, x + ! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[VAL_8:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_10:.*]] = fir.embox %[[VAL_8]] typeparams %[[VAL_9]] : (!fir.ptr>, index) -> !fir.box>> + ! CHECK: fir.store %[[VAL_10]] to %[[VAL_7]] : !fir.ref>>> + ! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_7]] : !fir.ref>>> + ! CHECK: %[[VAL_12:.*]] = fir.box_elesize %[[VAL_11]] : (!fir.box>>) -> index + ! CHECK: %[[VAL_13:.*]] = fir.box_addr %[[VAL_11]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_13]] typeparams %[[VAL_12]] : (!fir.ptr>, index) -> !fir.box>> + ! CHECK: fir.store %[[VAL_14]] to %[[p]] : !fir.ref>>> + p => NULL(x) + end subroutine + + ! CHECK-LABEL: func @_QPtest_array_mold( + ! CHECK-SAME: %[[p:.*]]: !fir.ref>>>{{[^,]*}}, + subroutine test_array_mold(p, x) + real, pointer :: p(:), x(:) + ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[VAL_1:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[VAL_2:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_3:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_1]](%[[VAL_3]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_5]], %[[VAL_6]] : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[VAL_8:.*]] = fir.shift %[[VAL_7]]#0 : (index) -> !fir.shift<1> + ! CHECK: %[[VAL_9:.*]] = fir.rebox %[[VAL_5]](%[[VAL_8]]) : (!fir.box>>, !fir.shift<1>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_9]] to %[[p]] : !fir.ref>>> + p => NULL(x) + end subroutine diff --git a/flang/test/Lower/pointer-initial-target-2.f90 b/flang/test/Lower/pointer-initial-target-2.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-initial-target-2.f90 @@ -0,0 +1,79 @@ +! Test lowering of pointer initial target +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! This tests focus on the scope context of initial data target. +! More complete tests regarding the initial data target expression +! are done in pointer-initial-target.f90. + +! Test pointer initial data target in modules +module some_mod + real, target :: x(100) + real, pointer :: p(:) => x + ! CHECK-LABEL: fir.global @_QMsome_modEp : !fir.box>> { + ! CHECK: %[[x:.*]] = fir.address_of(@_QMsome_modEx) : !fir.ref> + ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end module + + ! Test initial data target in a common block + module some_mod_2 + real, target :: x(100), y(10:209) + common /com/ x, y + save :: /com/ + real, pointer :: p(:) => y + ! CHECK-LABEL: fir.global @_QMsome_mod_2Ep : !fir.box>> { + ! CHECK: %[[c:.*]] = fir.address_of(@_QBcom) : !fir.ref> + ! CHECK: %[[com:.*]] = fir.convert %[[c]] : (!fir.ref>) -> !fir.ref> + ! CHECK: %[[yRaw:.*]] = fir.coordinate_of %[[com]], %c400{{.*}} : (!fir.ref>, index) -> !fir.ref + ! CHECK: %[[y:.*]] = fir.convert %[[yRaw]] : (!fir.ref) -> !fir.ref> + ! CHECK: %[[shape:.*]] = fir.shape_shift %c10{{.*}}, %c200{{.*}} : (index, index) -> !fir.shapeshift<1> + ! CHECK: %[[box:.*]] = fir.embox %[[y]](%[[shape]]) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end module + + ! Test pointer initial data target with pointer in common blocks + block data + real, pointer :: p + real, save, target :: b + common /a/ p + data p /b/ + ! CHECK-LABEL: fir.global @_QBa : tuple>> + ! CHECK: %[[undef:.*]] = fir.undefined tuple>> + ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref + ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref) -> !fir.box> + ! CHECK: %[[a:.*]] = fir.insert_value %[[undef]], %[[box]], [0 : index] : (tuple>>, !fir.box>) -> tuple>> + ! CHECK: fir.has_value %[[a]] : tuple>> + end block data + + ! Test pointer in a common with initial target in the same common. + block data snake + integer, target :: b = 42 + integer, pointer :: p => b + common /snake/ p, b + ! CHECK-LABEL: fir.global @_QBsnake : tuple>, i32> + ! CHECK: %[[tuple0:.*]] = fir.undefined tuple>, i32> + ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref>, i32>> + ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref>, i32>>) -> !fir.ref> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref>, index) -> !fir.ref + ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref) -> !fir.ref + ! CHECK: %[[box:.*]] = fir.embox %[[bAddr]] : (!fir.ref) -> !fir.box> + ! CHECK: %[[tuple1:.*]] = fir.insert_value %[[tuple0]], %[[box]], [0 : index] : (tuple>, i32>, !fir.box>) -> tuple>, i32> + ! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple1]], %c42{{.*}}, [1 : index] : (tuple>, i32>, i32) -> tuple>, i32> + ! CHECK: fir.has_value %[[tuple2]] : tuple>, i32> + end block data + + ! Test two common depending on each others because of initial data + ! targets + block data tied + real, target :: x1 = 42 + real, target :: x2 = 43 + real, pointer :: p1 => x2 + real, pointer :: p2 => x1 + common /c1/ x1, p1 + common /c2/ x2, p2 + ! CHECK-LABEL: fir.global @_QBc1 : tuple, !fir.box>> + ! CHECK: fir.address_of(@_QBc2) : !fir.ref, !fir.box>>> + ! CHECK-LABEL: fir.global @_QBc2 : tuple, !fir.box>> + ! CHECK: fir.address_of(@_QBc1) : !fir.ref, !fir.box>>> + end block data diff --git a/flang/test/Lower/pointer-initial-target.f90 b/flang/test/Lower/pointer-initial-target.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-initial-target.f90 @@ -0,0 +1,186 @@ +! Test lowering of pointer initial target +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! ----------------------------------------------------------------------------- +! Test scalar initial data target that are simple names +! ----------------------------------------------------------------------------- + +subroutine scalar() + real, save, target :: x + real, pointer :: p => x + ! CHECK-LABEL: fir.global internal @_QFscalarEp : !fir.box> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalarEx) : !fir.ref + ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref) -> !fir.box> + ! CHECK: fir.has_value %[[box]] : !fir.box> + end subroutine + + subroutine scalar_char() + character(10), save, target :: x + character(:), pointer :: p => x + ! CHECK-LABEL: fir.global internal @_QFscalar_charEp : !fir.box>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_charEx) : !fir.ref> + ! CHECK: %[[xCast:.*]] = fir.convert %[[x]] : (!fir.ref>) -> !fir.ptr> + ! CHECK: %[[box:.*]] = fir.embox %[[xCast]] typeparams %c10{{.*}} : (!fir.ptr>, index) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end subroutine + + subroutine scalar_char_2() + character(10), save, target :: x + character(10), pointer :: p => x + ! CHECK-LABEL: fir.global internal @_QFscalar_char_2Ep : !fir.box>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_char_2Ex) : !fir.ref> + ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end subroutine + + subroutine scalar_derived() + type t + real :: x + integer :: i + end type + type(t), save, target :: x + type(t), pointer :: p => x + ! CHECK-LABEL: fir.global internal @_QFscalar_derivedEp : !fir.box>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_derivedEx) : !fir.ref> + ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end subroutine + + subroutine scalar_null() + real, pointer :: p => NULL() + ! CHECK-LABEL: fir.global internal @_QFscalar_nullEp : !fir.box> + ! CHECK: %[[zero:.*]] = fir.zero_bits !fir.ptr + ! CHECK: %[[box:.*]] = fir.embox %[[zero]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.has_value %[[box]] : !fir.box> + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test array initial data target that are simple names + ! ----------------------------------------------------------------------------- + + subroutine array() + real, save, target :: x(100) + real, pointer :: p(:) => x + ! CHECK-LABEL: fir.global internal @_QFarrayEp : !fir.box>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFarrayEx) : !fir.ref> + ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end subroutine + + subroutine array_char() + character(10), save, target :: x(20) + character(:), pointer :: p(:) => x + ! CHECK-LABEL: fir.global internal @_QFarray_charEp : !fir.box>>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFarray_charEx) : !fir.ref>> + ! CHECK: %[[shape:.*]] = fir.shape %c20{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[xCast:.*]] = fir.convert %[[x]] : (!fir.ref>>) -> !fir.ptr>> + ! CHECK: %[[box:.*]] = fir.embox %[[xCast]](%[[shape]]) typeparams %c10{{.*}} : (!fir.ptr>>, !fir.shape<1>, index) -> !fir.box>>> + ! CHECK: fir.has_value %[[box]] : !fir.box>>> + end subroutine + + subroutine array_char_2() + character(10), save, target :: x(20) + character(10), pointer :: p(:) => x + ! CHECK-LABEL: fir.global internal @_QFarray_char_2Ep : !fir.box>>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFarray_char_2Ex) : !fir.ref>> + ! CHECK: %[[shape:.*]] = fir.shape %c20{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref>>, !fir.shape<1>) -> !fir.box>>> + ! CHECK: fir.has_value %[[box]] : !fir.box>>> + end subroutine + + subroutine array_derived() + type t + real :: x + integer :: i + end type + type(t), save, target :: x(100) + type(t), pointer :: p(:) => x + ! CHECK-LABEL: fir.global internal @_QFarray_derivedEp : !fir.box>>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFarray_derivedEx) : !fir.ref>> + ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref>>, !fir.shape<1>) -> !fir.box>>> + ! CHECK: fir.has_value %[[box]] : !fir.box>>> + end subroutine + + subroutine array_null() + real, pointer :: p(:) => NULL() + ! CHECK-LABEL: fir.global internal @_QFarray_nullEp : !fir.box>> + ! CHECK: %[[zero:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[box:.*]] = fir.embox %[[zero]](%[[shape]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test scalar initial data target that are data references + ! ----------------------------------------------------------------------------- + + subroutine scalar_ref() + real, save, target :: x(4:100) + real, pointer :: p => x(50) + ! CHECK-LABEL: fir.global internal @_QFscalar_refEp : !fir.box> { + ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_refEx) : !fir.ref> + ! CHECK: %[[lb:.*]] = fir.convert %c4 : (index) -> i64 + ! CHECK: %[[idx:.*]] = arith.subi %c50{{.*}}, %[[lb]] : i64 + ! CHECK: %[[elt:.*]] = fir.coordinate_of %[[x]], %[[idx]] : (!fir.ref>, i64) -> !fir.ref + ! CHECK: %[[box:.*]] = fir.embox %[[elt]] : (!fir.ref) -> !fir.box> + ! CHECK: fir.has_value %[[box]] : !fir.box> + end subroutine + + subroutine scalar_char_ref() + character(20), save, target :: x(100) + character(10), pointer :: p => x(6)(7:16) + ! CHECK-LABEL: fir.global internal @_QFscalar_char_refEp : !fir.box>> + ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_char_refEx) : !fir.ref>> + ! CHECK: %[[idx:.*]] = arith.subi %c6{{.*}}, %c1{{.*}} : i64 + ! CHECK: %[[elt:.*]] = fir.coordinate_of %[[x]], %[[idx]] : (!fir.ref>>, i64) -> !fir.ref> + ! CHECK: %[[eltCast:.*]] = fir.convert %[[elt:.*]] : (!fir.ref>) -> !fir.ref>> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[eltCast]], %{{.*}} : (!fir.ref>>, index) -> !fir.ref> + ! CHECK: %[[substring:.*]] = fir.convert %[[coor]] : (!fir.ref>) -> !fir.ref> + ! CHECK: %[[substringCast:.*]] = fir.convert %[[substring]] : (!fir.ref>) -> !fir.ptr> + ! CHECK: %[[box:.*]] = fir.embox %[[substringCast]] : (!fir.ptr>) -> !fir.box>> + ! CHECK: fir.has_value %[[box]] : !fir.box>> + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test array initial data target that are data references + ! ----------------------------------------------------------------------------- + + + subroutine array_ref() + real, save, target :: x(4:103, 5:104) + real, pointer :: p(:) => x(10, 20:100:2) + end subroutine + + ! CHECK-LABEL: fir.global internal @_QFarray_refEp : !fir.box>> { + ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFarray_refEx) : !fir.ref> + ! CHECK: %[[VAL_1:.*]] = arith.constant 4 : index + ! CHECK: %[[VAL_2:.*]] = arith.constant 100 : index + ! CHECK: %[[VAL_3:.*]] = arith.constant 5 : index + ! CHECK: %[[VAL_4:.*]] = arith.constant 100 : index + ! CHECK: %[[VAL_5:.*]] = arith.constant 1 : index + ! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index + ! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i64 + ! CHECK: %[[VAL_8:.*]] = fir.undefined index + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_7]] : (i64) -> index + ! CHECK: %[[VAL_10:.*]] = arith.subi %[[VAL_9]], %[[VAL_1]] : index + ! CHECK: %[[VAL_11:.*]] = arith.constant 20 : i64 + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index + ! CHECK: %[[VAL_13:.*]] = arith.constant 2 : i64 + ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i64) -> index + ! CHECK: %[[VAL_15:.*]] = arith.constant 100 : i64 + ! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i64) -> index + ! CHECK: %[[VAL_17:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_18:.*]] = arith.subi %[[VAL_16]], %[[VAL_12]] : index + ! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_18]], %[[VAL_14]] : index + ! CHECK: %[[VAL_20:.*]] = arith.divsi %[[VAL_19]], %[[VAL_14]] : index + ! CHECK: %[[VAL_21:.*]] = arith.cmpi sgt, %[[VAL_20]], %[[VAL_17]] : index + ! CHECK: %[[VAL_22:.*]] = arith.select %[[VAL_21]], %[[VAL_20]], %[[VAL_17]] : index + ! CHECK: %[[VAL_23:.*]] = fir.shape_shift %[[VAL_1]], %[[VAL_2]], %[[VAL_3]], %[[VAL_4]] : (index, index, index, index) -> !fir.shapeshift<2> + ! CHECK: %[[VAL_24:.*]] = fir.slice %[[VAL_7]], %[[VAL_8]], %[[VAL_8]], %[[VAL_12]], %[[VAL_16]], %[[VAL_14]] : (i64, index, index, index, index, index) -> !fir.slice<2> + ! CHECK: %[[VAL_25:.*]] = fir.embox %[[VAL_0]](%[[VAL_23]]) {{\[}}%[[VAL_24]]] : (!fir.ref>, !fir.shapeshift<2>, !fir.slice<2>) -> !fir.box> + ! CHECK: %[[VAL_26:.*]] = fir.embox %[[VAL_0]](%[[VAL_23]]) {{\[}}%[[VAL_24]]] : (!fir.ref>, !fir.shapeshift<2>, !fir.slice<2>) -> !fir.box>> + ! CHECK: fir.has_value %[[VAL_26]] : !fir.box>> + ! CHECK: } + \ No newline at end of file diff --git a/flang/test/Lower/pointer-reference.f90 b/flang/test/Lower/pointer-reference.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-reference.f90 @@ -0,0 +1,180 @@ +! Test lowering of references to pointers +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Assigning/reading to scalar pointer target. +! CHECK-LABEL: func @_QPscal_ptr( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>{{.*}}) +subroutine scal_ptr(p) + real, pointer :: p + real :: x + ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]] + ! CHECK: %[[addr:.*]] = fir.box_addr %[[boxload]] + ! CHECK: fir.store %{{.*}} to %[[addr]] + p = 3. + + ! CHECK: %[[boxload2:.*]] = fir.load %[[arg0]] + ! CHECK: %[[addr2:.*]] = fir.box_addr %[[boxload2]] + ! CHECK: %[[val:.*]] = fir.load %[[addr2]] + ! CHECK: fir.store %[[val]] to %{{.*}} + x = p + end subroutine + + ! Assigning/reading scalar character pointer target. + ! CHECK-LABEL: func @_QPchar_ptr( + ! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) + subroutine char_ptr(p) + character(12), pointer :: p + character(12) :: x + + ! CHECK-DAG: %[[str:.*]] = fir.address_of(@_QQcl.68656C6C6F20776F726C6421) : !fir.ref> + ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]] + ! CHECK: %[[addr:.*]] = fir.box_addr %[[boxload]] + ! CHECK-DAG: %[[one:.*]] = arith.constant 1 + ! CHECK-DAG: %[[size:.*]] = fir.convert %{{.*}} : (index) -> i64 + ! CHECK: %[[count:.*]] = arith.muli %[[one]], %[[size]] : i64 + ! CHECK: %[[dst:.*]] = fir.convert %[[addr]] : (!fir.ptr>) -> !fir.ref + ! CHECK: %[[src:.*]] = fir.convert %[[str]] : (!fir.ref>) -> !fir.ref + ! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[dst]], %[[src]], %5, %false) : (!fir.ref, !fir.ref, i64, i1) -> () + p = "hello world!" + + ! CHECK: %[[boxload2:.*]] = fir.load %[[arg0]] + ! CHECK: %[[addr2:.*]] = fir.box_addr %[[boxload2]] + ! CHECK: %[[count:.*]] = arith.muli %{{.*}}, %{{.*}} : i64 + ! CHECK: %[[dst:.*]] = fir.convert %{{.*}} : (!fir.ref>) -> !fir.ref + ! CHECK: %[[src:.*]] = fir.convert %[[addr2]] : (!fir.ptr>) -> !fir.ref + ! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[dst]], %[[src]], %[[count]], %{{.*}}) : (!fir.ref, !fir.ref, i64, i1) -> () + x = p + end subroutine + + ! Reading from pointer in array expression + ! CHECK-LABEL: func @_QParr_ptr_read( + ! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) + subroutine arr_ptr_read(p) + real, pointer :: p(:) + real :: x(100) + ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]] + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[boxload]], %c0{{.*}} : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[lb:.*]] = fir.shift %[[dims]]#0 : (index) -> !fir.shift<1> + ! CHECK: fir.array_load %[[boxload]](%[[lb]]) : (!fir.box>>, !fir.shift<1>) -> !fir.array + x = p + end subroutine + + ! Reading from contiguous pointer in array expression + ! CHECK-LABEL: func @_QParr_contig_ptr_read( + ! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>> {{{.*}}, fir.contiguous}) + subroutine arr_contig_ptr_read(p) + real, pointer, contiguous :: p(:) + real :: x(100) + ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]] + ! CHECK-DAG: %[[dims:.*]]:3 = fir.box_dims %[[boxload]], %c0{{.*}} : (!fir.box>>, index) -> (index, index, index) + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[boxload]] : (!fir.box>>) -> !fir.ptr> + ! CHECK-DAG: %[[shape:.*]] = fir.shape_shift %[[dims]]#0, %[[dims]]#1 : (index, index) -> !fir.shapeshift<1> + ! CHECK: fir.array_load %[[addr]](%[[shape]]) : (!fir.ptr>, !fir.shapeshift<1>) -> !fir.array + x = p + end subroutine + + ! Assigning to pointer target in array expression + + ! CHECK-LABEL: func @_QParr_ptr_target_write( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}) { + ! CHECK: %[[VAL_1:.*]] = arith.constant 100 : index + ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<100xf32> {bindc_name = "x", uniq_name = "_QFarr_ptr_target_writeEx"} + ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[VAL_6:.*]] = arith.constant 2 : i64 + ! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> index + ! CHECK: %[[VAL_8:.*]] = arith.constant 6 : i64 + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i64) -> index + ! CHECK: %[[VAL_10:.*]] = arith.constant 601 : i64 + ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i64) -> index + ! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_13:.*]] = arith.subi %[[VAL_11]], %[[VAL_7]] : index + ! CHECK: %[[VAL_14:.*]] = arith.addi %[[VAL_13]], %[[VAL_9]] : index + ! CHECK: %[[VAL_15:.*]] = arith.divsi %[[VAL_14]], %[[VAL_9]] : index + ! CHECK: %[[VAL_16:.*]] = arith.cmpi sgt, %[[VAL_15]], %[[VAL_12]] : index + ! CHECK: %[[VAL_17:.*]] = arith.select %[[VAL_16]], %[[VAL_15]], %[[VAL_12]] : index + ! CHECK: %[[VAL_18:.*]] = fir.shift %[[VAL_5]]#0 : (index) -> !fir.shift<1> + ! CHECK: %[[VAL_19:.*]] = fir.slice %[[VAL_7]], %[[VAL_11]], %[[VAL_9]] : (index, index, index) -> !fir.slice<1> + ! CHECK: %[[VAL_20:.*]] = fir.array_load %[[VAL_3]](%[[VAL_18]]) {{\[}}%[[VAL_19]]] : (!fir.box>>, !fir.shift<1>, !fir.slice<1>) -> !fir.array + ! CHECK: %[[VAL_21:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_22:.*]] = fir.array_load %[[VAL_2]](%[[VAL_21]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<100xf32> + ! CHECK: %[[VAL_23:.*]] = arith.constant 1 : index + ! CHECK: %[[VAL_24:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_25:.*]] = arith.subi %[[VAL_17]], %[[VAL_23]] : index + ! CHECK: %[[VAL_26:.*]] = fir.do_loop %[[VAL_27:.*]] = %[[VAL_24]] to %[[VAL_25]] step %[[VAL_23]] unordered iter_args(%[[VAL_28:.*]] = %[[VAL_20]]) -> (!fir.array) { + ! CHECK: %[[VAL_29:.*]] = fir.array_fetch %[[VAL_22]], %[[VAL_27]] : (!fir.array<100xf32>, index) -> f32 + ! CHECK: %[[VAL_30:.*]] = fir.array_update %[[VAL_28]], %[[VAL_29]], %[[VAL_27]] : (!fir.array, f32, index) -> !fir.array + ! CHECK: fir.result %[[VAL_30]] : !fir.array + ! CHECK: } + ! CHECK: fir.array_merge_store %[[VAL_20]], %[[VAL_31:.*]] to %[[VAL_3]]{{\[}}%[[VAL_19]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> + ! CHECK: return + ! CHECK: } + + subroutine arr_ptr_target_write(p) + real, pointer :: p(:) + real :: x(100) + p(2:601:6) = x + end subroutine + + ! Assigning to contiguous pointer target in array expression + + ! CHECK-LABEL: func @_QParr_contig_ptr_target_write( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>> {{{.*}}, fir.contiguous}) { + ! CHECK: %[[VAL_1:.*]] = arith.constant 100 : index + ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<100xf32> {bindc_name = "x", uniq_name = "_QFarr_contig_ptr_target_writeEx"} + ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[VAL_6:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: %[[VAL_7:.*]] = arith.constant 2 : i64 + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index + ! CHECK: %[[VAL_9:.*]] = arith.constant 6 : i64 + ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i64) -> index + ! CHECK: %[[VAL_11:.*]] = arith.constant 601 : i64 + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index + ! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_14:.*]] = arith.subi %[[VAL_12]], %[[VAL_8]] : index + ! CHECK: %[[VAL_15:.*]] = arith.addi %[[VAL_14]], %[[VAL_10]] : index + ! CHECK: %[[VAL_16:.*]] = arith.divsi %[[VAL_15]], %[[VAL_10]] : index + ! CHECK: %[[VAL_17:.*]] = arith.cmpi sgt, %[[VAL_16]], %[[VAL_13]] : index + ! CHECK: %[[VAL_18:.*]] = arith.select %[[VAL_17]], %[[VAL_16]], %[[VAL_13]] : index + ! CHECK: %[[VAL_19:.*]] = fir.shape_shift %[[VAL_5]]#0, %[[VAL_5]]#1 : (index, index) -> !fir.shapeshift<1> + ! CHECK: %[[VAL_20:.*]] = fir.slice %[[VAL_8]], %[[VAL_12]], %[[VAL_10]] : (index, index, index) -> !fir.slice<1> + ! CHECK: %[[VAL_21:.*]] = fir.array_load %[[VAL_6]](%[[VAL_19]]) {{\[}}%[[VAL_20]]] : (!fir.ptr>, !fir.shapeshift<1>, !fir.slice<1>) -> !fir.array + ! CHECK: %[[VAL_22:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_23:.*]] = fir.array_load %[[VAL_2]](%[[VAL_22]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<100xf32> + ! CHECK: %[[VAL_24:.*]] = arith.constant 1 : index + ! CHECK: %[[VAL_25:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_26:.*]] = arith.subi %[[VAL_18]], %[[VAL_24]] : index + ! CHECK: %[[VAL_27:.*]] = fir.do_loop %[[VAL_28:.*]] = %[[VAL_25]] to %[[VAL_26]] step %[[VAL_24]] unordered iter_args(%[[VAL_29:.*]] = %[[VAL_21]]) -> (!fir.array) { + ! CHECK: %[[VAL_30:.*]] = fir.array_fetch %[[VAL_23]], %[[VAL_28]] : (!fir.array<100xf32>, index) -> f32 + ! CHECK: %[[VAL_31:.*]] = fir.array_update %[[VAL_29]], %[[VAL_30]], %[[VAL_28]] : (!fir.array, f32, index) -> !fir.array + ! CHECK: fir.result %[[VAL_31]] : !fir.array + ! CHECK: } + ! CHECK: fir.array_merge_store %[[VAL_21]], %[[VAL_32:.*]] to %[[VAL_6]]{{\[}}%[[VAL_20]]] : !fir.array, !fir.array, !fir.ptr>, !fir.slice<1> + ! CHECK: return + ! CHECK: } + + subroutine arr_contig_ptr_target_write(p) + real, pointer, contiguous :: p(:) + real :: x(100) + p(2:601:6) = x + end subroutine + + ! CHECK-LABEL: func @_QPpointer_result_as_value + subroutine pointer_result_as_value() + ! Test that function pointer results used as values are correctly loaded. + interface + function returns_int_pointer() + integer, pointer :: returns_int_pointer + end function + end interface + ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box> {bindc_name = ".result"} + ! CHECK: %[[VAL_6:.*]] = fir.call @_QPreturns_int_pointer() : () -> !fir.box> + ! CHECK: fir.save_result %[[VAL_6]] to %[[VAL_0]] : !fir.box>, !fir.ref>> + ! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_0]] : !fir.ref>> + ! CHECK: %[[VAL_8:.*]] = fir.box_addr %[[VAL_7]] : (!fir.box>) -> !fir.ptr + ! CHECK: fir.load %[[VAL_8]] : !fir.ptr + print *, returns_int_pointer() + end subroutine diff --git a/flang/test/Lower/pointer-results-as-arguments.f90 b/flang/test/Lower/pointer-results-as-arguments.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-results-as-arguments.f90 @@ -0,0 +1,85 @@ +! Test passing pointers results to pointer dummy arguments +! RUN: bbc %s -o - | FileCheck %s + +module presults + interface + subroutine bar_scalar(x) + real, pointer :: x + end subroutine + subroutine bar(x) + real, pointer :: x(:, :) + end subroutine + function get_scalar_pointer() + real, pointer :: get_scalar_pointer + end function + function get_pointer() + real, pointer :: get_pointer(:, :) + end function + end interface + real, pointer :: x + real, pointer :: xa(:, :) + contains + + ! CHECK-LABEL: test_scalar_null + subroutine test_scalar_null() + ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box> + ! CHECK: %[[VAL_1:.*]] = fir.zero_bits !fir.ptr + ! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref>> + ! CHECK: fir.call @_QPbar_scalar(%[[VAL_0]]) : (!fir.ref>>) -> () + call bar_scalar(null()) + end subroutine + + ! CHECK-LABEL: test_scalar_null_mold + subroutine test_scalar_null_mold() + ! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box> + ! CHECK: %[[VAL_4:.*]] = fir.zero_bits !fir.ptr + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_4]] : (!fir.ptr) -> !fir.box> + ! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]] : !fir.ref>> + ! CHECK: fir.call @_QPbar_scalar(%[[VAL_3]]) : (!fir.ref>>) -> () + call bar_scalar(null(x)) + end subroutine + + ! CHECK-LABEL: test_scalar_result + subroutine test_scalar_result() + ! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.box> {bindc_name = ".result"} + ! CHECK: %[[VAL_7:.*]] = fir.call @_QPget_scalar_pointer() : () -> !fir.box> + ! CHECK: fir.save_result %[[VAL_7]] to %[[VAL_6]] : !fir.box>, !fir.ref>> + ! CHECK: fir.call @_QPbar_scalar(%[[VAL_6]]) : (!fir.ref>>) -> () + call bar_scalar(get_scalar_pointer()) + end subroutine + + ! CHECK-LABEL: test_null + subroutine test_null() + ! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_9:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[VAL_10:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[VAL_11:.*]] = fir.shape %[[VAL_8]], %[[VAL_8]] : (index, index) -> !fir.shape<2> + ! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_10]](%[[VAL_11]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_12]] to %[[VAL_9]] : !fir.ref>>> + ! CHECK: fir.call @_QPbar(%[[VAL_9]]) : (!fir.ref>>>) -> () + call bar(null()) + end subroutine + + ! CHECK-LABEL: test_null_mold + subroutine test_null_mold() + ! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_14:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[VAL_15:.*]] = fir.zero_bits !fir.ptr> + ! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_13]], %[[VAL_13]] : (index, index) -> !fir.shape<2> + ! CHECK: %[[VAL_17:.*]] = fir.embox %[[VAL_15]](%[[VAL_16]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_17]] to %[[VAL_14]] : !fir.ref>>> + ! CHECK: fir.call @_QPbar(%[[VAL_14]]) : (!fir.ref>>>) -> () + call bar(null(xa)) + end subroutine + + ! CHECK-LABEL: test_result + subroutine test_result() + ! CHECK: %[[VAL_18:.*]] = fir.alloca !fir.box>> {bindc_name = ".result"} + ! CHECK: %[[VAL_19:.*]] = fir.call @_QPget_pointer() : () -> !fir.box>> + ! CHECK: fir.save_result %[[VAL_19]] to %[[VAL_18]] : !fir.box>>, !fir.ref>>> + ! CHECK: fir.call @_QPbar(%[[VAL_18]]) : (!fir.ref>>>) -> () + call bar(get_pointer()) + end subroutine + + end module diff --git a/flang/test/Lower/pointer-runtime.f90 b/flang/test/Lower/pointer-runtime.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-runtime.f90 @@ -0,0 +1,50 @@ +! RUN: bbc -emit-fir -use-alloc-runtime %s -o - | FileCheck %s + +! Test lowering of allocatables using runtime for allocate/deallocate statements. +! CHECK-LABEL: _QPpointer_runtime( +subroutine pointer_runtime(n) + integer :: n + character(:), pointer :: scalar, array(:) + ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFpointer_runtimeEscalar"} + ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.ptr> + ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.ptr>, index) -> !fir.box>> + ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> + + ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFpointer_runtimeEarray"} + ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.ptr>> + ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> + ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.ptr>>, !fir.shape<1>, index) -> !fir.box>>> + ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> + + allocate(character(10):: scalar, array(30)) + ! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64 + ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}}) + ! CHECK-NOT: PointerSetBounds + ! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerAllocate(%[[sBoxCast2]] + + ! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64 + ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}}) + ! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerSetBounds(%[[aBoxCast2]] + ! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerAllocate(%[[aBoxCast3]] + + deallocate(scalar, array) + ! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerDeallocate(%[[sBoxCast3]] + ! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerDeallocate(%[[aBoxCast4]] + + ! only testing that the correct length is set in the descriptor. + allocate(character(n):: scalar, array(40)) + ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref + ! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64 + ! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}}) + ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64 + ! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}}) + end subroutine diff --git a/flang/test/Lower/pointer.f90 b/flang/test/Lower/pointer.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer.f90 @@ -0,0 +1,45 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! TODO: Descriptor (fir.box) will most likely be used for pointers +! (at least for the character case below). This code is hitting a +! hard todo until pointers are handled correctly. +! XFAIL: true + +! CHECK-LABEL: func @_QPpointertests +subroutine pointerTests + ! CHECK: fir.global internal @_QFpointertestsEptr1 : !fir.ptr + integer, pointer :: ptr1 => NULL() + ! CHECK: %[[c0:.*]] = arith.constant 0 : index + ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref + ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref) -> !fir.ptr + ! CHECK: fir.has_value [[reg2]] : !fir.ptr + + ! CHECK: fir.global internal @_QFpointertestsEptr2 : !fir.ptr + real, pointer :: ptr2 => NULL() + ! CHECK: %[[c0:.*]] = arith.constant 0 : index + ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref + ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref) -> !fir.ptr + ! CHECK: fir.has_value [[reg2]] : !fir.ptr + + ! CHECK: fir.global internal @_QFpointertestsEptr3 : !fir.ptr> + complex, pointer :: ptr3 => NULL() + ! CHECK: %[[c0:.*]] = arith.constant 0 : index + ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref + ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref) -> !fir.ptr> + ! CHECK: fir.has_value [[reg2]] : !fir.ptr> + + ! CHECK: fir.global internal @_QFpointertestsEptr4 : !fir.ptr> + character(:), pointer :: ptr4 => NULL() + ! CHECK: %[[c0:.*]] = arith.constant 0 : index + ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref + ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref) -> !fir.ptr> + ! CHECK: fir.has_value [[reg2]] : !fir.ptr> + + ! CHECK: fir.global internal @_QFpointertestsEptr5 : !fir.ptr> + logical, pointer :: ptr5 => NULL() + ! CHECK: %[[c0:.*]] = arith.constant 0 : index + ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref + ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref) -> !fir.ptr> + ! CHECK: fir.has_value [[reg2]] : !fir.ptr> + + end subroutine pointerTests