diff options
author | Valentin Clement <clementval@gmail.com> | 2022-03-10 22:19:57 +0300 |
---|---|---|
committer | Valentin Clement <clementval@gmail.com> | 2022-03-10 22:20:55 +0300 |
commit | 72276bdaff931910f62a84336b3e864ab48bac06 (patch) | |
tree | 240a0f6ff244e46dfa7c85af88875270ec3d0c58 /flang | |
parent | deb359aab33ed52ee167b5875c6e97bf6dbded15 (diff) |
[flang] Lower pointer component in derived type
This patch lowers pointer component part of derived types to
FIR.
This patch is part of the upstreaming effort from fir-dev branch.
Depends on D121383
Reviewed By: PeteSteinfeld, schweitz
Differential Revision: https://reviews.llvm.org/D121384
Co-authored-by: V Donaldson <vdonaldson@nvidia.com>
Co-authored-by: Jean Perier <jperier@nvidia.com>
Co-authored-by: Eric Schweitz <eschweitz@nvidia.com>
Diffstat (limited to 'flang')
-rw-r--r-- | flang/include/flang/Lower/BuiltinModules.h | 26 | ||||
-rw-r--r-- | flang/include/flang/Lower/ConvertExpr.h | 13 | ||||
-rw-r--r-- | flang/include/flang/Lower/ConvertVariable.h | 15 | ||||
-rw-r--r-- | flang/include/flang/Lower/Runtime.h | 12 | ||||
-rw-r--r-- | flang/include/flang/Optimizer/Builder/BoxValue.h | 21 | ||||
-rw-r--r-- | flang/lib/Lower/Bridge.cpp | 15 | ||||
-rw-r--r-- | flang/lib/Lower/ConvertExpr.cpp | 218 | ||||
-rw-r--r-- | flang/lib/Lower/ConvertVariable.cpp | 21 | ||||
-rw-r--r-- | flang/lib/Lower/IntrinsicCall.cpp | 47 | ||||
-rw-r--r-- | flang/lib/Lower/Runtime.cpp | 13 | ||||
-rw-r--r-- | flang/lib/Optimizer/Builder/BoxValue.cpp | 6 | ||||
-rw-r--r-- | flang/test/Lower/Intrinsics/associated.f90 | 137 | ||||
-rw-r--r-- | flang/test/Lower/derived-pointer-components.f90 | 675 | ||||
-rw-r--r-- | flang/test/Lower/derived-types-kind-params.f90 | 56 |
14 files changed, 1258 insertions, 17 deletions
diff --git a/flang/include/flang/Lower/BuiltinModules.h b/flang/include/flang/Lower/BuiltinModules.h new file mode 100644 index 000000000000..5e251d6060c4 --- /dev/null +++ b/flang/include/flang/Lower/BuiltinModules.h @@ -0,0 +1,26 @@ +//===-- BuiltinModules.h --------------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// +/// +/// Define information about builtin derived types from flang/module/xxx.f90 +/// files so that these types can be manipulated by lowering. +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_BUILTINMODULES_H +#define FORTRAN_LOWER_BUILTINMODULES_H + +namespace Fortran::lower::builtin { +/// Address field name of __builtin_c_f_pointer and __builtin_c_ptr types. +constexpr char cptrFieldName[] = "__address"; +} // namespace Fortran::lower::builtin + +#endif // FORTRAN_LOWER_BUILTINMODULES_H diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h index dd246ab3b2e3..12af639daceb 100644 --- a/flang/include/flang/Lower/ConvertExpr.h +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -135,6 +135,19 @@ void createSomeArrayAssignment(AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs, SymMap &symMap, StatementContext &stmtCtx); +/// Lower an array assignment expression with a pre-evaluated left hand side. +/// +/// 1. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to +/// be added to the map. +/// 2. Create the loop nest and evaluate the elemental expression, threading the +/// results. +/// 3. Copy the resulting array back with ArrayMergeStore to the lhs as +/// determined per step 1. +void createSomeArrayAssignment(AbstractConverter &converter, + const fir::ExtendedValue &lhs, + const SomeExpr &rhs, SymMap &symMap, + StatementContext &stmtCtx); + /// Lower an array assignment expression with pre-evaluated left and right /// hand sides. This implements an array copy taking into account /// non-contiguity and potential overlaps. diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h index 0c1c69faa2ab..a0f277aa62fd 100644 --- a/flang/include/flang/Lower/ConvertVariable.h +++ b/flang/include/flang/Lower/ConvertVariable.h @@ -21,6 +21,10 @@ #include "mlir/IR/Value.h" #include "llvm/ADT/DenseMap.h" +namespace fir { +class ExtendedValue; +} // namespace fir + namespace Fortran ::lower { class AbstractConverter; class CallerInterface; @@ -64,11 +68,22 @@ void mapCallInterfaceSymbols(AbstractConverter &, const Fortran::lower::CallerInterface &caller, SymMap &symMap); +// TODO: consider saving the initial expression symbol dependence analysis in +// in the PFT variable and dealing with the dependent symbols instantiation in +// the fir::GlobalOp body at the fir::GlobalOp creation point rather than by +// having genExtAddrInInitializer and genInitialDataTarget custom entry points +// here to deal with this while lowering the initial expression value. + /// Create initial-data-target fir.box in a global initializer region. /// This handles the local instantiation of the target variable. mlir::Value genInitialDataTarget(Fortran::lower::AbstractConverter &, mlir::Location, mlir::Type boxType, const SomeExpr &initialTarget); +/// Generate address \p addr inside an initializer. +fir::ExtendedValue +genExtAddrInInitializer(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, const SomeExpr &addr); + } // namespace Fortran::lower #endif // FORTRAN_LOWER_CONVERT_VARIABLE_H diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h index dcfce8ff63c3..11aa5bb1c287 100644 --- a/flang/include/flang/Lower/Runtime.h +++ b/flang/include/flang/Lower/Runtime.h @@ -16,6 +16,15 @@ #ifndef FORTRAN_LOWER_RUNTIME_H #define FORTRAN_LOWER_RUNTIME_H +namespace mlir { +class Location; +class Value; +} // namespace mlir + +namespace fir { +class FirOpBuilder; +} // namespace fir + namespace Fortran { namespace parser { @@ -51,6 +60,9 @@ void genSyncTeamStatement(AbstractConverter &, const parser::SyncTeamStmt &); void genUnlockStatement(AbstractConverter &, const parser::UnlockStmt &); void genPauseStatement(AbstractConverter &, const parser::PauseStmt &); +mlir::Value genAssociated(fir::FirOpBuilder &, mlir::Location, + mlir::Value pointer, mlir::Value target); + } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Optimizer/Builder/BoxValue.h b/flang/include/flang/Optimizer/Builder/BoxValue.h index b2bb80eea29e..c81b7e61aadb 100644 --- a/flang/include/flang/Optimizer/Builder/BoxValue.h +++ b/flang/include/flang/Optimizer/Builder/BoxValue.h @@ -28,10 +28,11 @@ class FirOpBuilder; class CharBoxValue; class ArrayBoxValue; +class BoxValue; +class CharBoxValue; class CharArrayBoxValue; -class ProcBoxValue; class MutableBoxValue; -class BoxValue; +class ProcBoxValue; llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &); llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ArrayBoxValue &); @@ -86,6 +87,7 @@ public: mlir::Value getBuffer() const { return getAddr(); } mlir::Value getLen() const { return len; } + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &); LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } @@ -112,7 +114,7 @@ public: } // An array expression may have user-defined lower bound values. - // If this vector is empty, the default in all dimensions is `1`. + // If this vector is empty, the default in all dimensions in `1`. const llvm::SmallVectorImpl<mlir::Value> &getLBounds() const { return lbounds; } @@ -272,6 +274,11 @@ public: // TODO: check contiguous attribute of addr bool isContiguous() const { return false; } + // Replace the fir.box, keeping any non-deferred parameters. + BoxValue clone(mlir::Value newBox) const { + return {newBox, lbounds, explicitParams, extents}; + } + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } @@ -404,6 +411,9 @@ bool isArray(const ExtendedValue &exv); /// Get the type parameters for `exv`. llvm::SmallVector<mlir::Value> getTypeParams(const ExtendedValue &exv); +// The generalized function to get a vector of extents is +// fir::factory::getExtents(). See FIRBuilder.h. + /// Get exactly one extent for any array-like extended value, \p exv. If \p exv /// is not an array or has rank less then \p dim, the result will be a nullptr. mlir::Value getExtentAtDimension(const ExtendedValue &exv, @@ -430,10 +440,7 @@ public: auto type = b->getType(); if (type.template isa<fir::BoxCharType>()) fir::emitFatalError(b->getLoc(), "BoxChar should be unboxed"); - if (auto refType = type.template dyn_cast<fir::ReferenceType>()) - type = refType.getEleTy(); - if (auto seqType = type.template dyn_cast<fir::SequenceType>()) - type = seqType.getEleTy(); + type = fir::unwrapSequenceType(fir::unwrapRefType(type)); if (fir::isa_char(type)) fir::emitFatalError(b->getLoc(), "character buffer should be in CharBoxValue"); diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 204fecad4901..dd818759cf0c 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -1720,8 +1720,19 @@ private: Fortran::lower::genDeallocateStmt(*this, stmt, toLocation()); } + /// Nullify pointer object list + /// + /// For each pointer object, reset the pointer to a disassociated status. + /// We do this by setting each pointer to null. void genFIR(const Fortran::parser::NullifyStmt &stmt) { - TODO(toLocation(), "NullifyStmt lowering"); + mlir::Location loc = toLocation(); + for (auto &pointerObject : stmt.v) { + const Fortran::lower::SomeExpr *expr = + Fortran::semantics::GetExpr(pointerObject); + assert(expr); + fir::MutableBoxValue box = genExprMutableBox(loc, *expr); + fir::factory::disassociateMutableBox(*builder, loc, box); + } } //===--------------------------------------------------------------------===// @@ -1868,7 +1879,7 @@ private: } void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) { - TODO(toLocation(), "PointerAssignmentStmt lowering"); + genAssignment(*stmt.typedAssignment->v); } void genFIR(const Fortran::parser::AssignmentStmt &stmt) { diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index 15d6ba614dc8..2585087b1518 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -14,6 +14,8 @@ #include "flang/Evaluate/fold.h" #include "flang/Evaluate/traverse.h" #include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/Allocatable.h" +#include "flang/Lower/BuiltinModules.h" #include "flang/Lower/CallInterface.h" #include "flang/Lower/ComponentPath.h" #include "flang/Lower/ConvertType.h" @@ -34,6 +36,7 @@ #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Optimizer/Builder/Runtime/Ragged.h" #include "flang/Optimizer/Dialect/FIROpsSupport.h" +#include "flang/Optimizer/Support/Matcher.h" #include "flang/Semantics/expression.h" #include "flang/Semantics/symbol.h" #include "flang/Semantics/tools.h" @@ -650,8 +653,175 @@ public: TODO(getLoc(), "genval NullPointer"); } + static bool + isDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) { + if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) + if (const Fortran::semantics::DerivedTypeSpec *derived = + declTy->AsDerived()) + return Fortran::semantics::CountLenParameters(*derived) > 0; + return false; + } + + static bool isBuiltinCPtr(const Fortran::semantics::Symbol &sym) { + if (const Fortran::semantics::DeclTypeSpec *declType = sym.GetType()) + if (const Fortran::semantics::DerivedTypeSpec *derived = + declType->AsDerived()) + return Fortran::semantics::IsIsoCType(derived); + return false; + } + + /// Lower structure constructor without a temporary. This can be used in + /// fir::GloablOp, and assumes that the structure component is a constant. + ExtValue genStructComponentInInitializer( + const Fortran::evaluate::StructureConstructor &ctor) { + mlir::Location loc = getLoc(); + mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor)); + auto recTy = ty.cast<fir::RecordType>(); + auto fieldTy = fir::FieldType::get(ty.getContext()); + mlir::Value res = builder.create<fir::UndefOp>(loc, recTy); + + for (const auto &[sym, expr] : ctor.values()) { + // Parent components need more work because they do not appear in the + // fir.rec type. + if (sym->test(Fortran::semantics::Symbol::Flag::ParentComp)) + TODO(loc, "parent component in structure constructor"); + + llvm::StringRef name = toStringRef(sym->name()); + mlir::Type componentTy = recTy.getType(name); + // FIXME: type parameters must come from the derived-type-spec + auto field = builder.create<fir::FieldIndexOp>( + loc, fieldTy, name, ty, + /*typeParams=*/mlir::ValueRange{} /*TODO*/); + + if (Fortran::semantics::IsAllocatable(sym)) + TODO(loc, "allocatable component in structure constructor"); + + if (Fortran::semantics::IsPointer(sym)) { + mlir::Value initialTarget = Fortran::lower::genInitialDataTarget( + converter, loc, componentTy, expr.value()); + res = builder.create<fir::InsertValueOp>( + loc, recTy, res, initialTarget, + builder.getArrayAttr(field.getAttributes())); + continue; + } + + if (isDerivedTypeWithLengthParameters(sym)) + TODO(loc, "component with length parameters in structure constructor"); + + if (isBuiltinCPtr(sym)) { + // Builtin c_ptr and c_funptr have special handling because initial + // value are handled for them as an extension. + mlir::Value addr = fir::getBase(Fortran::lower::genExtAddrInInitializer( + converter, loc, expr.value())); + if (addr.getType() == componentTy) { + // Do nothing. The Ev::Expr was returned as a value that can be + // inserted directly to the component without an intermediary. + } else { + // The Ev::Expr returned is an initializer that is a pointer (e.g., + // null) that must be inserted into an intermediate cptr record + // value's address field, which ought to be an intptr_t on the target. + assert((fir::isa_ref_type(addr.getType()) || + addr.getType().isa<mlir::FunctionType>()) && + "expect reference type for address field"); + assert(fir::isa_derived(componentTy) && + "expect C_PTR, C_FUNPTR to be a record"); + auto cPtrRecTy = componentTy.cast<fir::RecordType>(); + llvm::StringRef addrFieldName = + Fortran::lower::builtin::cptrFieldName; + mlir::Type addrFieldTy = cPtrRecTy.getType(addrFieldName); + auto addrField = builder.create<fir::FieldIndexOp>( + loc, fieldTy, addrFieldName, componentTy, + /*typeParams=*/mlir::ValueRange{}); + mlir::Value castAddr = builder.createConvert(loc, addrFieldTy, addr); + auto undef = builder.create<fir::UndefOp>(loc, componentTy); + addr = builder.create<fir::InsertValueOp>( + loc, componentTy, undef, castAddr, + builder.getArrayAttr(addrField.getAttributes())); + } + res = builder.create<fir::InsertValueOp>( + loc, recTy, res, addr, builder.getArrayAttr(field.getAttributes())); + continue; + } + + mlir::Value val = fir::getBase(genval(expr.value())); + assert(!fir::isa_ref_type(val.getType()) && "expecting a constant value"); + mlir::Value castVal = builder.createConvert(loc, componentTy, val); + res = builder.create<fir::InsertValueOp>( + loc, recTy, res, castVal, + builder.getArrayAttr(field.getAttributes())); + } + return res; + } + + /// A structure constructor is lowered two ways. In an initializer context, + /// the entire structure must be constant, so the aggregate value is + /// constructed inline. This allows it to be the body of a GlobalOp. + /// Otherwise, the structure constructor is in an expression. In that case, a + /// temporary object is constructed in the stack frame of the procedure. ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) { - TODO(getLoc(), "genval StructureConstructor"); + if (inInitializer) + return genStructComponentInInitializer(ctor); + mlir::Location loc = getLoc(); + mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor)); + auto recTy = ty.cast<fir::RecordType>(); + auto fieldTy = fir::FieldType::get(ty.getContext()); + mlir::Value res = builder.createTemporary(loc, recTy); + + for (const auto &value : ctor.values()) { + const Fortran::semantics::Symbol &sym = *value.first; + const Fortran::lower::SomeExpr &expr = value.second.value(); + // Parent components need more work because they do not appear in the + // fir.rec type. + if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) + TODO(loc, "parent component in structure constructor"); + + if (isDerivedTypeWithLengthParameters(sym)) + TODO(loc, "component with length parameters in structure constructor"); + + llvm::StringRef name = toStringRef(sym.name()); + // FIXME: type parameters must come from the derived-type-spec + mlir::Value field = builder.create<fir::FieldIndexOp>( + loc, fieldTy, name, ty, + /*typeParams=*/mlir::ValueRange{} /*TODO*/); + mlir::Type coorTy = builder.getRefType(recTy.getType(name)); + auto coor = builder.create<fir::CoordinateOp>(loc, coorTy, + fir::getBase(res), field); + ExtValue to = fir::factory::componentToExtendedValue(builder, loc, coor); + to.match( + [&](const fir::UnboxedValue &toPtr) { + ExtValue value = genval(expr); + fir::factory::genScalarAssignment(builder, loc, to, value); + }, + [&](const fir::CharBoxValue &) { + ExtValue value = genval(expr); + fir::factory::genScalarAssignment(builder, loc, to, value); + }, + [&](const fir::ArrayBoxValue &) { + Fortran::lower::createSomeArrayAssignment(converter, to, expr, + symMap, stmtCtx); + }, + [&](const fir::CharArrayBoxValue &) { + Fortran::lower::createSomeArrayAssignment(converter, to, expr, + symMap, stmtCtx); + }, + [&](const fir::BoxValue &toBox) { + fir::emitFatalError(loc, "derived type components must not be " + "represented by fir::BoxValue"); + }, + [&](const fir::MutableBoxValue &toBox) { + if (toBox.isPointer()) { + Fortran::lower::associateMutableBox( + converter, loc, toBox, expr, /*lbounds=*/llvm::None, stmtCtx); + return; + } + // For allocatable components, a deep copy is needed. + TODO(loc, "allocatable components in derived type assignment"); + }, + [&](const fir::ProcBoxValue &toBox) { + TODO(loc, "procedure pointer component in derived type assignment"); + }); + } + return res; } /// Lowering of an <i>ac-do-variable</i>, which is not a Symbol. @@ -1124,6 +1294,36 @@ public: } } + fir::ExtendedValue genArrayLit( + const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) { + mlir::Location loc = getLoc(); + mlir::IndexType idxTy = builder.getIndexType(); + Fortran::evaluate::ConstantSubscript size = + Fortran::evaluate::GetSize(con.shape()); + fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end()); + mlir::Type eleTy = converter.genType(con.GetType().GetDerivedTypeSpec()); + auto arrayTy = fir::SequenceType::get(shape, eleTy); + mlir::Value array = builder.create<fir::UndefOp>(loc, arrayTy); + llvm::SmallVector<mlir::Value> lbounds; + llvm::SmallVector<mlir::Value> extents; + for (auto [lb, extent] : llvm::zip(con.lbounds(), con.shape())) { + lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1)); + extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); + } + if (size == 0) + return fir::ArrayBoxValue{array, extents, lbounds}; + Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds(); + do { + mlir::Value derivedVal = fir::getBase(genval(con.At(subscripts))); + llvm::SmallVector<mlir::Attribute> idx; + for (auto [dim, lb] : llvm::zip(subscripts, con.lbounds())) + idx.push_back(builder.getIntegerAttr(idxTy, dim - lb)); + array = builder.create<fir::InsertValueOp>( + loc, arrayTy, array, derivedVal, builder.getArrayAttr(idx)); + } while (con.IncrementSubscripts(subscripts)); + return fir::ArrayBoxValue{array, extents, lbounds}; + } + template <Fortran::common::TypeCategory TC, int KIND> ExtValue genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>> @@ -1142,7 +1342,12 @@ public: fir::ExtendedValue genval( const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) { - TODO(getLoc(), "genval constant derived"); + if (con.Rank() > 0) + return genArrayLit(con); + if (auto ctor = con.GetScalarValue()) + return genval(ctor.value()); + fir::emitFatalError(getLoc(), + "constant of derived type has no constructor"); } template <typename A> @@ -5834,6 +6039,15 @@ void Fortran::lower::createSomeArrayAssignment( void Fortran::lower::createSomeArrayAssignment( Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, + const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} + +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp index 029ea16d78ba..302a1eaedb49 100644 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -162,6 +162,27 @@ static mlir::Type unwrapElementType(mlir::Type type) { return type; } +fir::ExtendedValue Fortran::lower::genExtAddrInInitializer( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const Fortran::lower::SomeExpr &addr) { + Fortran::lower::SymMap globalOpSymMap; + Fortran::lower::AggregateStoreMap storeMap; + Fortran::lower::StatementContext stmtCtx; + if (const Fortran::semantics::Symbol *sym = + Fortran::evaluate::GetFirstSymbol(addr)) { + // Length parameters processing will need care in global initializer + // context. + if (hasDerivedTypeWithLengthParameters(*sym)) + TODO(loc, "initial-data-target with derived type length parameters"); + + auto var = Fortran::lower::pft::Variable(*sym, /*global=*/true); + Fortran::lower::instantiateVariable(converter, var, globalOpSymMap, + storeMap); + } + return Fortran::lower::createInitializerAddress(loc, converter, addr, + globalOpSymMap, stmtCtx); +} + /// create initial-data-target fir.box in a global initializer region. mlir::Value Fortran::lower::genInitialDataTarget( Fortran::lower::AbstractConverter &converter, mlir::Location loc, diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp index 3d99fcafd116..3f2f036d7f12 100644 --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -16,6 +16,7 @@ #include "flang/Lower/IntrinsicCall.h" #include "flang/Common/static-multimap-view.h" #include "flang/Lower/Mangler.h" +#include "flang/Lower/Runtime.h" #include "flang/Lower/StatementContext.h" #include "flang/Lower/SymbolMap.h" #include "flang/Lower/Todo.h" @@ -26,6 +27,7 @@ #include "flang/Optimizer/Builder/Runtime/Inquiry.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Optimizer/Builder/Runtime/Reduction.h" +#include "flang/Optimizer/Dialect/FIROpsSupport.h" #include "flang/Optimizer/Support/FatalError.h" #include "mlir/Dialect/LLVMIR/LLVMDialect.h" #include "llvm/Support/CommandLine.h" @@ -232,6 +234,8 @@ struct IntrinsicLibrary { /// if the argument is an integer, into llvm intrinsics if the argument is /// real and to the `hypot` math routine if the argument is of complex type. mlir::Value genAbs(mlir::Type, llvm::ArrayRef<mlir::Value>); + fir::ExtendedValue genAssociated(mlir::Type, + llvm::ArrayRef<fir::ExtendedValue>); template <Extremum, ExtremumBehavior> mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>); /// Lowering for the IAND intrinsic. The IAND intrinsic expects two arguments @@ -311,6 +315,7 @@ struct IntrinsicHandler { constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value; constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box; +constexpr auto asInquired = Fortran::lower::LowerIntrinsicArgAs::Inquired; using I = IntrinsicLibrary; /// Flag to indicate that an intrinsic argument has to be handled as @@ -327,6 +332,10 @@ static constexpr bool handleDynamicOptional = true; /// should be provided for all the intrinsic arguments for completeness. static constexpr IntrinsicHandler handlers[]{ {"abs", &I::genAbs}, + {"associated", + &I::genAssociated, + {{{"pointer", asInquired}, {"target", asInquired}}}, + /*isElemental=*/false}, {"iand", &I::genIand}, {"sum", &I::genSum, @@ -1045,6 +1054,44 @@ mlir::Value IntrinsicLibrary::genAbs(mlir::Type resultType, llvm_unreachable("unexpected type in ABS argument"); } +// ASSOCIATED +fir::ExtendedValue +IntrinsicLibrary::genAssociated(mlir::Type resultType, + llvm::ArrayRef<fir::ExtendedValue> args) { + assert(args.size() == 2); + auto *pointer = + args[0].match([&](const fir::MutableBoxValue &x) { return &x; }, + [&](const auto &) -> const fir::MutableBoxValue * { + fir::emitFatalError(loc, "pointer not a MutableBoxValue"); + }); + const fir::ExtendedValue &target = args[1]; + if (isAbsent(target)) + return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *pointer); + + mlir::Value targetBox = builder.createBox(loc, target); + if (fir::valueHasFirAttribute(fir::getBase(target), + fir::getOptionalAttrName())) { + // Subtle: contrary to other intrinsic optional arguments, disassociated + // POINTER and unallocated ALLOCATABLE actual argument are not considered + // absent here. This is because ASSOCIATED has special requirements for + // TARGET actual arguments that are POINTERs. There is no precise + // requirements for ALLOCATABLEs, but all existing Fortran compilers treat + // them similarly to POINTERs. That is: unallocated TARGETs cause ASSOCIATED + // to rerun false. The runtime deals with the disassociated/unallocated + // case. Simply ensures that TARGET that are OPTIONAL get conditionally + // emboxed here to convey the optional aspect to the runtime. + auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), + fir::getBase(target)); + auto absentBox = builder.create<fir::AbsentOp>(loc, targetBox.getType()); + targetBox = builder.create<mlir::arith::SelectOp>(loc, isPresent, targetBox, + absentBox); + } + mlir::Value pointerBoxRef = + fir::factory::getMutableIRBox(builder, loc, *pointer); + auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef); + return Fortran::lower::genAssociated(builder, loc, pointerBox, targetBox); +} + // IAND mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType, llvm::ArrayRef<mlir::Value> args) { diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp index b35ae660ea8a..a246633e450e 100644 --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -13,6 +13,7 @@ #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Parser/parse-tree.h" +#include "flang/Runtime/pointer.h" #include "flang/Runtime/stop.h" #include "flang/Semantics/tools.h" #include "llvm/Support/Debug.h" @@ -112,3 +113,15 @@ void Fortran::lower::genPauseStatement( fir::runtime::getRuntimeFunc<mkRTKey(PauseStatement)>(loc, builder); builder.create<fir::CallOp>(loc, callee, llvm::None); } + +mlir::Value Fortran::lower::genAssociated(fir::FirOpBuilder &builder, + mlir::Location loc, + mlir::Value pointer, + mlir::Value target) { + mlir::FuncOp func = + fir::runtime::getRuntimeFunc<mkRTKey(PointerIsAssociatedWith)>(loc, + builder); + llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments( + builder, loc, func.getType(), pointer, target); + return builder.create<fir::CallOp>(loc, func, args).getResult(0); +} diff --git a/flang/lib/Optimizer/Builder/BoxValue.cpp b/flang/lib/Optimizer/Builder/BoxValue.cpp index 8cb9fbd61c73..dc64276621b8 100644 --- a/flang/lib/Optimizer/Builder/BoxValue.cpp +++ b/flang/lib/Optimizer/Builder/BoxValue.cpp @@ -39,12 +39,6 @@ fir::ExtendedValue fir::substBase(const fir::ExtendedValue &exv, mlir::Value base) { return exv.match( [=](const fir::UnboxedValue &x) { return fir::ExtendedValue(base); }, - [=](const fir::BoxValue &) -> fir::ExtendedValue { - llvm::report_fatal_error("TODO: substbase of BoxValue"); - }, - [=](const fir::MutableBoxValue &) -> fir::ExtendedValue { - llvm::report_fatal_error("TODO: substbase of MutableBoxValue"); - }, [=](const auto &x) { return fir::ExtendedValue(x.clone(base)); }); } diff --git a/flang/test/Lower/Intrinsics/associated.f90 b/flang/test/Lower/Intrinsics/associated.f90 new file mode 100644 index 000000000000..5c784574e73f --- /dev/null +++ b/flang/test/Lower/Intrinsics/associated.f90 @@ -0,0 +1,137 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: associated_test +! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}}, %[[arg1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}) +subroutine associated_test(scalar, array) + real, pointer :: scalar, array(:) + real, target :: ziel + ! CHECK: %[[ziel:.*]] = fir.alloca f32 {bindc_name = "ziel" + ! CHECK: %[[scalar:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<f32>>> + ! CHECK: %[[addr0:.*]] = fir.box_addr %[[scalar]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32> + ! CHECK: %[[addrToInt0:.*]] = fir.convert %[[addr0]] + ! CHECK: cmpi ne, %[[addrToInt0]], %c0{{.*}} + print *, associated(scalar) + ! CHECK: %[[array:.*]] = fir.load %[[arg1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[addr1:.*]] = fir.box_addr %[[array]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.ptr<!fir.array<?xf32>> + ! CHECK: %[[addrToInt1:.*]] = fir.convert %[[addr1]] + ! CHECK: cmpi ne, %[[addrToInt1]], %c0{{.*}} + print *, associated(array) + ! CHECK: %[[zbox0:.*]] = fir.embox %[[ziel]] : (!fir.ref<f32>) -> !fir.box<f32> + ! CHECK: %[[scalar:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<f32>>> + ! CHECK: %[[sbox:.*]] = fir.convert %[[scalar]] : (!fir.box<!fir.ptr<f32>>) -> !fir.box<none> + ! CHECK: %[[zbox:.*]] = fir.convert %[[zbox0]] : (!fir.box<f32>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[sbox]], %[[zbox]]) : (!fir.box<none>, !fir.box<none>) -> i1 + print *, associated(scalar, ziel) + end subroutine + + subroutine test_func_results() + interface + function get_pointer() + real, pointer :: get_pointer(:) + end function + end interface + ! CHECK: %[[result:.*]] = fir.call @_QPget_pointer() : () -> !fir.box<!fir.ptr<!fir.array<?xf32>>> + ! CHECK: fir.save_result %[[result]] to %[[box_storage:.*]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[box:.*]] = fir.load %[[box_storage]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.ptr<!fir.array<?xf32>> + ! CHECK: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<!fir.array<?xf32>>) -> i64 + ! CHECK: arith.cmpi ne, %[[addr_cast]], %c0{{.*}} : i64 + print *, associated(get_pointer()) + end subroutine + + ! CHECK-LABEL: func @_QPtest_optional_target_1( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"}, + ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.array<10xf32>> {fir.bindc_name = "optionales_ziel", fir.optional, fir.target}) { + subroutine test_optional_target_1(p, optionales_ziel) + real, pointer :: p(:) + real, optional, target :: optionales_ziel(10) + print *, associated(p, optionales_ziel) + ! CHECK: %[[VAL_2:.*]] = arith.constant 10 : index + ! CHECK: %[[VAL_8:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_1]](%[[VAL_8]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>> + ! CHECK: %[[VAL_10:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.array<10xf32>>) -> i1 + ! CHECK: %[[VAL_11:.*]] = fir.absent !fir.box<!fir.array<10xf32>> + ! CHECK: %[[VAL_12:.*]] = arith.select %[[VAL_10]], %[[VAL_9]], %[[VAL_11]] : !fir.box<!fir.array<10xf32>> + ! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.box<!fir.array<10xf32>>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_14]], %[[VAL_15]]) : (!fir.box<none>, !fir.box<none>) -> i1 + end subroutine + + ! CHECK-LABEL: func @_QPtest_optional_target_2( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"}, + ! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "optionales_ziel", fir.optional, fir.target}) { + subroutine test_optional_target_2(p, optionales_ziel) + real, pointer :: p(:) + real, optional, target :: optionales_ziel(:) + print *, associated(p, optionales_ziel) + ! CHECK: %[[VAL_7:.*]] = fir.is_present %[[VAL_1]] : (!fir.box<!fir.array<?xf32>>) -> i1 + ! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box<!fir.array<?xf32>> + ! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_7]], %[[VAL_1]], %[[VAL_8]] : !fir.box<!fir.array<?xf32>> + ! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_9]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_11]], %[[VAL_12]]) : (!fir.box<none>, !fir.box<none>) -> i1 + end subroutine + + ! CHECK-LABEL: func @_QPtest_optional_target_3( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"}, + ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "optionales_ziel", fir.optional}) { + subroutine test_optional_target_3(p, optionales_ziel) + real, pointer :: p(:) + real, optional, pointer :: optionales_ziel(:) + print *, associated(p, optionales_ziel) + ! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_8:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> i1 + ! CHECK: %[[VAL_9:.*]] = fir.absent !fir.box<!fir.ptr<!fir.array<?xf32>>> + ! CHECK: %[[VAL_10:.*]] = arith.select %[[VAL_8]], %[[VAL_7]], %[[VAL_9]] : !fir.box<!fir.ptr<!fir.array<?xf32>>> + ! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_13]]) : (!fir.box<none>, !fir.box<none>) -> i1 + end subroutine + + ! CHECK-LABEL: func @_QPtest_optional_target_4( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"}, + ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>> {fir.bindc_name = "optionales_ziel", fir.optional, fir.target}) { + subroutine test_optional_target_4(p, optionales_ziel) + real, pointer :: p(:) + real, optional, allocatable, target :: optionales_ziel(:) + print *, associated(p, optionales_ziel) + ! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_8:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> i1 + ! CHECK: %[[VAL_9:.*]] = fir.absent !fir.box<!fir.heap<!fir.array<?xf32>>> + ! CHECK: %[[VAL_10:.*]] = arith.select %[[VAL_8]], %[[VAL_7]], %[[VAL_9]] : !fir.box<!fir.heap<!fir.array<?xf32>>> + ! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_13]]) : (!fir.box<none>, !fir.box<none>) -> i1 + end subroutine + + ! CHECK-LABEL: func @_QPtest_pointer_target( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"}, + ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "pointer_ziel"}) { + subroutine test_pointer_target(p, pointer_ziel) + real, pointer :: p(:) + real, pointer :: pointer_ziel(:) + print *, associated(p, pointer_ziel) + ! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_9]], %[[VAL_10]]) : (!fir.box<none>, !fir.box<none>) -> i1 + end subroutine + + ! CHECK-LABEL: func @_QPtest_allocatable_target( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"}, + ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>> {fir.bindc_name = "allocatable_ziel", fir.target}) { + subroutine test_allocatable_target(p, allocatable_ziel) + real, pointer :: p(:) + real, allocatable, target :: allocatable_ziel(:) + ! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.box<none> + ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_9]], %[[VAL_10]]) : (!fir.box<none>, !fir.box<none>) -> i1 + print *, associated(p, allocatable_ziel) + end subroutine diff --git a/flang/test/Lower/derived-pointer-components.f90 b/flang/test/Lower/derived-pointer-components.f90 new file mode 100644 index 000000000000..d16e543cf611 --- /dev/null +++ b/flang/test/Lower/derived-pointer-components.f90 @@ -0,0 +1,675 @@ +! Test lowering of pointer components +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +module pcomp + implicit none + type t + real :: x + integer :: i + end type + interface + subroutine takes_real_scalar(x) + real :: x + end subroutine + subroutine takes_char_scalar(x) + character(*) :: x + end subroutine + subroutine takes_derived_scalar(x) + import t + type(t) :: x + end subroutine + subroutine takes_real_array(x) + real :: x(:) + end subroutine + subroutine takes_char_array(x) + character(*) :: x(:) + end subroutine + subroutine takes_derived_array(x) + import t + type(t) :: x(:) + end subroutine + subroutine takes_real_scalar_pointer(x) + real, pointer :: x + end subroutine + subroutine takes_real_array_pointer(x) + real, pointer :: x(:) + end subroutine + subroutine takes_logical(x) + logical :: x + end subroutine + end interface + + type real_p0 + real, pointer :: p + end type + type real_p1 + real, pointer :: p(:) + end type + type cst_char_p0 + character(10), pointer :: p + end type + type cst_char_p1 + character(10), pointer :: p(:) + end type + type def_char_p0 + character(:), pointer :: p + end type + type def_char_p1 + character(:), pointer :: p(:) + end type + type derived_p0 + type(t), pointer :: p + end type + type derived_p1 + type(t), pointer :: p(:) + end type + + real, target :: real_target, real_array_target(100) + character(10), target :: char_target, char_array_target(100) + + contains + + ! ----------------------------------------------------------------------------- + ! Test pointer component references + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPref_scalar_real_p( + ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>{{.*}}, %[[arg1:.*]]: !fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>{{.*}}, %[[arg2:.*]]: !fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>>{{.*}}, %[[arg3:.*]]: !fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>{{.*}}) { + subroutine ref_scalar_real_p(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(real_p1) :: p1_0, p1_1(100) + + ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[arg0]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<f32>>> + ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<f32>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32> + ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<f32>) -> !fir.ref<f32> + ! CHECK: fir.call @_QPtakes_real_scalar(%[[cast]]) : (!fir.ref<f32>) -> () + call takes_real_scalar(p0_0%p) + + ! CHECK: %[[p0_1_coor:.*]] = fir.coordinate_of %[[arg2]], %{{.*}} : (!fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>>, i64) -> !fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>> + ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_1_coor]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<f32>>> + ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<f32>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32> + ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<f32>) -> !fir.ref<f32> + ! CHECK: fir.call @_QPtakes_real_scalar(%[[cast]]) : (!fir.ref<f32>) -> () + call takes_real_scalar(p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[arg1]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[load]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index) + ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] : i64 + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[load]], %[[index]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i64) -> !fir.ref<f32> + ! CHECK: fir.call @_QPtakes_real_scalar(%[[coor]]) : (!fir.ref<f32>) -> () + call takes_real_scalar(p1_0%p(7)) + + ! CHECK: %[[p1_1_coor:.*]] = fir.coordinate_of %[[arg3]], %{{.*}} : (!fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>, i64) -> !fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>> + ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_1_coor]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[load]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index) + ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] : i64 + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[load]], %[[index]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i64) -> !fir.ref<f32> + ! CHECK: fir.call @_QPtakes_real_scalar(%[[coor]]) : (!fir.ref<f32>) -> () + call takes_real_scalar(p1_1(5)%p(7)) + end subroutine + + ! CHECK-LABEL: func @_QMpcompPassign_scalar_real + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine assign_scalar_real_p(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(real_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] + ! CHECK: fir.store {{.*}} to %[[addr]] + p0_0%p = 1. + + ! CHECK: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] + ! CHECK: fir.store {{.*}} to %[[addr]] + p0_1(5)%p = 2. + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], {{.*}} + ! CHECK: fir.store {{.*}} to %[[addr]] + p1_0%p(7) = 3. + + ! CHECK: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], {{.*}} + ! CHECK: fir.store {{.*}} to %[[addr]] + p1_1(5)%p(7) = 4. + end subroutine + + ! CHECK-LABEL: func @_QMpcompPref_scalar_cst_char_p + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine ref_scalar_cst_char_p(p0_0, p1_0, p0_1, p1_1) + type(cst_char_p0) :: p0_0, p0_1(100) + type(cst_char_p1) :: p1_0, p1_1(100) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] + ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}} + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] + ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}} + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p0_1(5)%p) + + + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} + ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]] + ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}} + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p1_0%p(7)) + + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} + ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]] + ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}} + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p1_1(5)%p(7)) + + end subroutine + + ! CHECK-LABEL: func @_QMpcompPref_scalar_def_char_p + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine ref_scalar_def_char_p(p0_0, p1_0, p0_1, p1_1) + type(def_char_p0) :: p0_0, p0_1(100) + type(def_char_p1) :: p1_0, p1_1(100) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] + ! CHECK-DAG: %[[cast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %[[len]] + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] + ! CHECK-DAG: %[[cast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %[[len]] + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p0_1(5)%p) + + + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] + ! CHECK-DAG: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} + ! CHECK-DAG: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK-DAG: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK-DAG: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr]], %[[len]] + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p1_0%p(7)) + + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] + ! CHECK-DAG: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} + ! CHECK-DAG: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK-DAG: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK-DAG: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]] + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr]], %[[len]] + ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]]) + call takes_char_scalar(p1_1(5)%p(7)) + + end subroutine + + ! CHECK-LABEL: func @_QMpcompPref_scalar_derived + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine ref_scalar_derived(p0_0, p1_0, p0_1, p1_1) + type(derived_p0) :: p0_0, p0_1(100) + type(derived_p1) :: p1_0, p1_1(100) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[fldx:.*]] = fir.field_index x + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[fldx]] + ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]]) + call takes_real_scalar(p0_0%p%x) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[fldx:.*]] = fir.field_index x + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[fldx]] + ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]]) + call takes_real_scalar(p0_1(5)%p%x) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} + ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK: %[[elem:.*]] = fir.coordinate_of %[[box]], %[[index]] + ! CHECK: %[[fldx:.*]] = fir.field_index x + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[elem]], %[[fldx]] + ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]]) + call takes_real_scalar(p1_0%p(7)%x) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} + ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK: %[[elem:.*]] = fir.coordinate_of %[[box]], %[[index]] + ! CHECK: %[[fldx:.*]] = fir.field_index x + ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[elem]], %[[fldx]] + ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]]) + call takes_real_scalar(p1_1(5)%p(7)%x) + + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test passing pointer component references as pointers + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPpass_real_p + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine pass_real_p(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(real_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.call @_QPtakes_real_scalar_pointer(%[[coor]]) + call takes_real_scalar_pointer(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.call @_QPtakes_real_scalar_pointer(%[[coor]]) + call takes_real_scalar_pointer(p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.call @_QPtakes_real_array_pointer(%[[coor]]) + call takes_real_array_pointer(p1_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.call @_QPtakes_real_array_pointer(%[[coor]]) + call takes_real_array_pointer(p1_1(5)%p) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test usage in intrinsics where pointer aspect matters + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPassociated_p + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine associated_p(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(def_char_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: fir.box_addr %[[box]] + call takes_logical(associated(p0_0%p)) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: fir.box_addr %[[box]] + call takes_logical(associated(p0_1(5)%p)) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: fir.box_addr %[[box]] + call takes_logical(associated(p1_0%p)) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: %[[box:.*]] = fir.load %[[coor]] + ! CHECK: fir.box_addr %[[box]] + call takes_logical(associated(p1_1(5)%p)) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test pointer assignment of components + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPpassoc_real + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine passoc_real(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(real_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p0_0%p => real_target + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p0_1(5)%p => real_target + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p1_0%p => real_array_target + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p1_1(5)%p => real_array_target + end subroutine + + ! CHECK-LABEL: func @_QMpcompPpassoc_char + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine passoc_char(p0_0, p1_0, p0_1, p1_1) + type(cst_char_p0) :: p0_0, p0_1(100) + type(def_char_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p0_0%p => char_target + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p0_1(5)%p => char_target + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p1_0%p => char_array_target + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + p1_1(5)%p => char_array_target + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test nullify of components + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPnullify_test + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine nullify_test(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(def_char_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + nullify(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + nullify(p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + nullify(p1_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + nullify(p1_1(5)%p) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test allocation + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPallocate_real + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine allocate_real(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(real_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p1_0%p(100)) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p1_1(5)%p(100)) + end subroutine + + ! CHECK-LABEL: func @_QMpcompPallocate_cst_char + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine allocate_cst_char(p0_0, p1_0, p0_1, p1_1) + type(cst_char_p0) :: p0_0, p0_1(100) + type(cst_char_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p1_0%p(100)) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(p1_1(5)%p(100)) + end subroutine + + ! CHECK-LABEL: func @_QMpcompPallocate_def_char + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine allocate_def_char(p0_0, p1_0, p0_1, p1_1) + type(def_char_p0) :: p0_0, p0_1(100) + type(def_char_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(character(18)::p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(character(18)::p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(character(18)::p1_0%p(100)) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + allocate(character(18)::p1_1(5)%p(100)) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test deallocation + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPdeallocate_real + ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}}) + subroutine deallocate_real(p0_0, p1_0, p0_1, p1_1) + type(real_p0) :: p0_0, p0_1(100) + type(real_p1) :: p1_0, p1_1(100) + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + deallocate(p0_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + deallocate(p0_1(5)%p) + + ! CHECK: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + deallocate(p1_0%p) + + ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}} + ! CHECK-DAG: %[[fld:.*]] = fir.field_index p + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]] + ! CHECK: fir.store {{.*}} to %[[coor]] + deallocate(p1_1(5)%p) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test a very long component + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMpcompPvery_long + ! CHECK-SAME: (%[[x:.*]]: {{.*}}) + subroutine very_long(x) + type t0 + real :: f + end type + type t1 + type(t0), allocatable :: e(:) + end type + type t2 + type(t1) :: d(10) + end type + type t3 + type(t2) :: c + end type + type t4 + type(t3), pointer :: b + end type + type t5 + type(t4) :: a + end type + type(t5) :: x(:, :, :, :, :) + + ! CHECK: %[[coor0:.*]] = fir.coordinate_of %[[x]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.}} + ! CHECK-DAG: %[[flda:.*]] = fir.field_index a + ! CHECK-DAG: %[[fldb:.*]] = fir.field_index b + ! CHECK: %[[coor1:.*]] = fir.coordinate_of %[[coor0]], %[[flda]], %[[fldb]] + ! CHECK: %[[b_box:.*]] = fir.load %[[coor1]] + ! CHECK-DAG: %[[fldc:.*]] = fir.field_index c + ! CHECK-DAG: %[[fldd:.*]] = fir.field_index d + ! CHECK: %[[coor2:.*]] = fir.coordinate_of %[[b_box]], %[[fldc]], %[[fldd]] + ! CHECK: %[[index:.*]] = arith.subi %c6{{.*}}, %c1{{.*}} : i64 + ! CHECK: %[[coor3:.*]] = fir.coordinate_of %[[coor2]], %[[index]] + ! CHECK: %[[flde:.*]] = fir.field_index e + ! CHECK: %[[coor4:.*]] = fir.coordinate_of %[[coor3]], %[[flde]] + ! CHECK: %[[e_box:.*]] = fir.load %[[coor4]] + ! CHECK: %[[edims:.*]]:3 = fir.box_dims %[[e_box]], %c0{{.*}} + ! CHECK: %[[lb:.*]] = fir.convert %[[edims]]#0 : (index) -> i64 + ! CHECK: %[[index2:.*]] = arith.subi %c7{{.*}}, %[[lb]] + ! CHECK: %[[coor5:.*]] = fir.coordinate_of %[[e_box]], %[[index2]] + ! CHECK: %[[fldf:.*]] = fir.field_index f + ! CHECK: %[[coor6:.*]] = fir.coordinate_of %[[coor5]], %[[fldf:.*]] + ! CHECK: fir.load %[[coor6]] : !fir.ref<f32> + print *, x(1,2,3,4,5)%a%b%c%d(6)%e(7)%f + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test a recursive derived type reference + ! ----------------------------------------------------------------------------- + + ! CHECK: func @_QMpcompPtest_recursive + ! CHECK-SAME: (%[[x:.*]]: {{.*}}) + subroutine test_recursive(x) + type t + integer :: i + type(t), pointer :: next + end type + type(t) :: x + + ! CHECK: %[[fldNext1:.*]] = fir.field_index next + ! CHECK: %[[next1:.*]] = fir.coordinate_of %[[x]], %[[fldNext1]] + ! CHECK: %[[nextBox1:.*]] = fir.load %[[next1]] + ! CHECK: %[[fldNext2:.*]] = fir.field_index next + ! CHECK: %[[next2:.*]] = fir.coordinate_of %[[nextBox1]], %[[fldNext2]] + ! CHECK: %[[nextBox2:.*]] = fir.load %[[next2]] + ! CHECK: %[[fldNext3:.*]] = fir.field_index next + ! CHECK: %[[next3:.*]] = fir.coordinate_of %[[nextBox2]], %[[fldNext3]] + ! CHECK: %[[nextBox3:.*]] = fir.load %[[next3]] + ! CHECK: %[[fldi:.*]] = fir.field_index i + ! CHECK: %[[i:.*]] = fir.coordinate_of %[[nextBox3]], %[[fldi]] + ! CHECK: %[[nextBox3:.*]] = fir.load %[[i]] : !fir.ref<i32> + print *, x%next%next%next%i + end subroutine + + end module diff --git a/flang/test/Lower/derived-types-kind-params.f90 b/flang/test/Lower/derived-types-kind-params.f90 new file mode 100644 index 000000000000..c19df07f575c --- /dev/null +++ b/flang/test/Lower/derived-types-kind-params.f90 @@ -0,0 +1,56 @@ +! Test lowering of derived type with kind parameters +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +module m + type t(k1, k2) + integer(4), kind :: k1 = 7 + integer(8), kind :: k2 + character(k1) :: c(k2) + end type + + type t2(k1, k2) + integer(4), kind :: k1 + integer(8), kind :: k2 + type(t(k1+3, k2+4)) :: at + end type + + type t3(k) + integer, kind :: k + type(t3(k)), pointer :: at3 + end type + + type t4(k) + integer, kind :: k + real(-k) :: i + end type + + contains + + ! ----------------------------------------------------------------------------- + ! Test mangling of derived type with kind parameters + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QMmPfoo + ! CHECK-SAME: !fir.ref<!fir.type<_QMmTtK7K12{c:!fir.array<12x!fir.char<1,?>> + subroutine foo(at) + type(t(k2=12)) :: at + end subroutine + + ! CHECK-LABEL: func @_QMmPfoo2 + ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt2K12K13{at:!fir.type<_QMmTtK15K17{c:!fir.array<17x!fir.char<1,?>>}>}>> + subroutine foo2(at2) + type(t2(12, 13)) :: at2 + end subroutine + + ! CHECK-LABEL: func @_QMmPfoo3 + ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt3K7{at3:!fir.box<!fir.ptr<!fir.type<_QMmTt3K7>>>}>> + subroutine foo3(at3) + type(t3(7)) :: at3 + end subroutine + + ! CHECK-LABEL: func @_QMmPfoo4 + ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt4KN4{i:f32}>> + subroutine foo4(at4) + type(t4(-4)) :: at4 + end subroutine + end module |