diff --git a/flang/include/flang/Lower/ConvertExprToHLFIR.h b/flang/include/flang/Lower/ConvertExprToHLFIR.h --- a/flang/include/flang/Lower/ConvertExprToHLFIR.h +++ b/flang/include/flang/Lower/ConvertExprToHLFIR.h @@ -59,9 +59,29 @@ hlfir::Entity entity, Fortran::lower::StatementContext &); -/// Lower an evaluate::Expr to fir::ExtendedValue raw address. -/// Beware that this will create a temporary for non simply contiguous -/// designator expressions. +/// Lower an evaluate::Expr to fir::ExtendedValue address. +/// The address may be a raw fir.ref, or a fir.box/fir.class, (pointer +/// and allocatable are dereferenced). +/// - If expression is not a variable, or is a designator with vector +/// subscripts, a temporary is created to hold the expression value and +/// is returned as: +/// - a fir.class if the expression is polymorphic. +/// - otherwise, a fir.box if it is a derived type with length +/// parameters (not yet implemented). +/// - otherwise, a fir.ref +/// - If the expression is a variable that is not a designator with +/// vector subscripts, it is lowered without creating a temporary and +/// is returned as: +/// - a fir.class if the variable is polymorphic. +/// - otherwise, a fir.box if it is a derived type with length +/// parameters (not yet implemented), or if it is not a simply +/// contiguous. +/// - otherwise, a fir.ref +/// +/// Beware that this is different from the previous createSomeExtendedAddress +/// that had a non-trivial behaviour and would create contiguous temporary for +/// array sections `x(:, :)`, but not for `x` even if x is not simply +/// contiguous. fir::ExtendedValue convertExprToAddress(mlir::Location loc, Fortran::lower::AbstractConverter &, const Fortran::lower::SomeExpr &, @@ -70,7 +90,6 @@ fir::ExtendedValue convertToAddress(mlir::Location loc, Fortran::lower::AbstractConverter &, hlfir::Entity entity, - bool isSimplyContiguous, Fortran::lower::StatementContext &); /// Lower an evaluate::Expr to a fir::ExtendedValue value. @@ -83,6 +102,14 @@ Fortran::lower::AbstractConverter &, hlfir::Entity entity, Fortran::lower::StatementContext &); + +/// Lower an evaluate::Expr to a fir::MutableBoxValue value. +/// This can only be called if the Expr is a POINTER or ALLOCATABLE, +/// otherwise, this will crash. +fir::MutableBoxValue +convertExprToMutableBox(mlir::Location loc, Fortran::lower::AbstractConverter &, + const Fortran::lower::SomeExpr &, + Fortran::lower::SymMap &); } // namespace Fortran::lower #endif // FORTRAN_LOWER_CONVERTEXPRTOHLFIR_H diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -935,7 +935,11 @@ fir::factory::disassociateMutableBox(builder, loc, box); return; } - + if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { + fir::ExtendedValue rhs = converter.genExprAddr(loc, source, stmtCtx); + fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds); + return; + } // The right hand side is not be evaluated into a temp. Array sections can // typically be represented as a value of type `!fir.box`. However, an // expression that uses vector subscripts cannot be emboxed. In that case, 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 @@ -429,7 +429,7 @@ void copySymbolBinding(Fortran::lower::SymbolRef src, Fortran::lower::SymbolRef target) override final { - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) { + if (lowerToHighLevelFIR()) { auto srcDef = localSymbols.lookupVariableDefinition(src); assert(srcDef && "source binding does not exists"); localSymbols.addVariableDefinition(target, *srcDef); @@ -479,7 +479,7 @@ Fortran::lower::StatementContext &context, mlir::Location *locPtr = nullptr) override final { mlir::Location loc = locPtr ? *locPtr : toLocation(); - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) + if (lowerToHighLevelFIR()) return Fortran::lower::convertExprToAddress(loc, *this, expr, localSymbols, context); return Fortran::lower::createSomeExtendedAddress(loc, *this, expr, @@ -491,7 +491,7 @@ Fortran::lower::StatementContext &context, mlir::Location *locPtr = nullptr) override final { mlir::Location loc = locPtr ? *locPtr : toLocation(); - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) + if (lowerToHighLevelFIR()) return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols, context); return Fortran::lower::createSomeExtendedExpression(loc, *this, expr, @@ -501,7 +501,7 @@ fir::ExtendedValue genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr, Fortran::lower::StatementContext &stmtCtx) override final { - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) + if (lowerToHighLevelFIR()) return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols, stmtCtx); return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols, @@ -769,7 +769,7 @@ /// Find the symbol in the local map or return null. Fortran::lower::SymbolBox lookupSymbol(const Fortran::semantics::Symbol &sym) { - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) { + if (lowerToHighLevelFIR()) { if (std::optional var = localSymbols.lookupVariableDefinition(sym)) { auto exv = @@ -1044,7 +1044,7 @@ setCurrentPosition(stmt.v.source); assert(stmt.typedCall && "Call was not analyzed"); mlir::Value res{}; - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) { + if (lowerToHighLevelFIR()) { std::optional resultType; if (stmt.typedCall->hasAlternateReturns()) resultType = builder->getIndexType(); @@ -2571,14 +2571,138 @@ inline fir::MutableBoxValue genExprMutableBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr) override final { + if (lowerToHighLevelFIR()) + return Fortran::lower::convertExprToMutableBox(loc, *this, expr, + localSymbols); return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols); } + // Generate pointer assignment with possibly empty bounds-spec. R1035: a + // bounds-spec is a lower bound value. + void genPointerAssignment( + mlir::Location loc, const Fortran::evaluate::Assignment &assign, + const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { + Fortran::lower::StatementContext stmtCtx; + if (Fortran::evaluate::IsProcedure(assign.rhs)) + TODO(loc, "procedure pointer assignment"); + + std::optional lhsType = + assign.lhs.GetType(); + // Delegate pointer association to unlimited polymorphic pointer + // to the runtime. element size, type code, attribute and of + // course base_addr might need to be updated. + if (lhsType && lhsType->IsPolymorphic()) { + if (!lowerToHighLevelFIR() && explicitIterationSpace()) + TODO(loc, "polymorphic pointer assignment in FORALL"); + mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr(); + mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); + Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs); + return; + } + + llvm::SmallVector lbounds; + for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) + lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); + if (!lowerToHighLevelFIR() && explicitIterationSpace()) { + // Pointer assignment in FORALL context. Copy the rhs box value + // into the lhs box variable. + genArrayAssignment(assign, stmtCtx, lbounds); + return; + } + fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); + Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, lbounds, + stmtCtx); + } + // Pointer assignment with bounds-remapping. R1036: a bounds-remapping is a + // pair, lower bound and upper bound. + void genPointerAssignment( + mlir::Location loc, const Fortran::evaluate::Assignment &assign, + const Fortran::evaluate::Assignment::BoundsRemapping &boundExprs) { + Fortran::lower::StatementContext stmtCtx; + llvm::SmallVector lbounds; + llvm::SmallVector ubounds; + for (const std::pair &pair : boundExprs) { + const Fortran::evaluate::ExtentExpr &lbExpr = pair.first; + const Fortran::evaluate::ExtentExpr &ubExpr = pair.second; + lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); + ubounds.push_back(fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx))); + } + + std::optional lhsType = + assign.lhs.GetType(); + std::optional rhsType = + assign.rhs.GetType(); + // Polymorphic lhs/rhs need more care. See F2018 10.2.2.3. + if ((lhsType && lhsType->IsPolymorphic()) || + (rhsType && rhsType->IsPolymorphic())) { + if (!lowerToHighLevelFIR() && explicitIterationSpace()) + TODO(loc, "polymorphic pointer assignment in FORALL"); + + mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr(); + mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); + + // Create the newRank x 2 array with the bounds to be passed to + // the runtime as a descriptor. + assert(lbounds.size() && ubounds.size()); + mlir::Type indexTy = builder->getIndexType(); + mlir::Type boundArrayTy = fir::SequenceType::get( + {static_cast(lbounds.size()) * 2}, builder->getI64Type()); + mlir::Value boundArray = + builder->create(loc, boundArrayTy); + mlir::Value array = builder->create(loc, boundArrayTy); + for (unsigned i = 0; i < lbounds.size(); ++i) { + array = builder->create( + loc, boundArrayTy, array, lbounds[i], + builder->getArrayAttr({builder->getIntegerAttr( + builder->getIndexType(), static_cast(i * 2))})); + array = builder->create( + loc, boundArrayTy, array, ubounds[i], + builder->getArrayAttr({builder->getIntegerAttr( + builder->getIndexType(), static_cast(i * 2 + 1))})); + } + builder->create(loc, array, boundArray); + mlir::Type boxTy = fir::BoxType::get(boundArrayTy); + mlir::Value ext = + builder->createIntegerConstant(loc, indexTy, lbounds.size() * 2); + mlir::Value shapeOp = builder->genShape(loc, {ext}); + mlir::Value boundsDesc = + builder->create(loc, boxTy, boundArray, shapeOp); + Fortran::lower::genPointerAssociateRemapping(*builder, loc, lhs, rhs, + boundsDesc); + return; + } + if (!lowerToHighLevelFIR() && explicitIterationSpace()) { + // Pointer assignment in FORALL context. Copy the rhs box value + // into the lhs box variable. + genArrayAssignment(assign, stmtCtx, lbounds, ubounds); + return; + } + fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); + if (Fortran::evaluate::UnwrapExpr( + assign.rhs)) { + fir::factory::disassociateMutableBox(*builder, loc, lhs); + return; + } + // Do not generate a temp in case rhs is an array section. + fir::ExtendedValue rhs = + Fortran::lower::isArraySectionWithoutVectorSubscript(assign.rhs) + ? Fortran::lower::createSomeArrayBox(*this, assign.rhs, + localSymbols, stmtCtx) + : genExprAddr(assign.rhs, stmtCtx); + fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, rhs, lbounds, + ubounds); + if (!lowerToHighLevelFIR() && explicitIterationSpace()) { + mlir::ValueRange inners = explicitIterSpace.getInnerArgs(); + if (!inners.empty()) + builder->create(loc, inners); + } + } + /// Shared for both assignments and pointer assignments. void genAssignment(const Fortran::evaluate::Assignment &assign) { - Fortran::lower::StatementContext stmtCtx; mlir::Location loc = toLocation(); - if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) { + if (lowerToHighLevelFIR()) { if (explicitIterationSpace() || !implicitIterSpace.empty()) TODO(loc, "HLFIR assignment inside FORALL or WHERE"); auto &builder = getFirOpBuilder(); @@ -2586,6 +2710,7 @@ Fortran::common::visitors{ // [1] Plain old assignment. [&](const Fortran::evaluate::Assignment::Intrinsic &) { + Fortran::lower::StatementContext stmtCtx; if (Fortran::lower::isWholeAllocatable(assign.lhs)) TODO(loc, "HLFIR assignment to whole allocatable"); hlfir::EntityWithAttributes rhs = @@ -2601,15 +2726,12 @@ [&](const Fortran::evaluate::ProcedureRef &procRef) { TODO(loc, "HLFIR user defined assignment"); }, - // [3] Pointer assignment with possibly empty bounds-spec. R1035: - // a bounds-spec is a lower bound value. [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { - TODO(loc, "HLFIR pointer assignment"); + genPointerAssignment(loc, assign, lbExprs); }, - // [4] Pointer assignment with bounds-remapping. R1036: a - // bounds-remapping is a pair, lower bound and upper bound. - [&](const Fortran::evaluate::Assignment::BoundsRemapping) { - TODO(loc, "HLFIR pointer assignment with bounds remapping"); + [&](const Fortran::evaluate::Assignment::BoundsRemapping + &boundExprs) { + genPointerAssignment(loc, assign, boundExprs); }, }, assign.u); @@ -2619,6 +2741,7 @@ Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols); explicitIterSpace.genLoopNest(); } + Fortran::lower::StatementContext stmtCtx; std::visit( Fortran::common::visitors{ // [1] Plain old assignment. @@ -2734,132 +2857,12 @@ localSymbols, ctx, /*isUserDefAssignment=*/true); }, - // [3] Pointer assignment with possibly empty bounds-spec. R1035: a - // bounds-spec is a lower bound value. [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { - if (Fortran::evaluate::IsProcedure(assign.rhs)) - TODO(loc, "procedure pointer assignment"); - - std::optional lhsType = - assign.lhs.GetType(); - // Delegate pointer association to unlimited polymorphic pointer - // to the runtime. element size, type code, attribute and of - // course base_addr might need to be updated. - if (lhsType && lhsType->IsPolymorphic()) { - if (explicitIterationSpace()) - TODO(loc, "polymorphic pointer assignment in FORALL"); - mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr(); - mlir::Value rhs = - fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); - Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs); - return; - } - - llvm::SmallVector lbounds; - for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) - lbounds.push_back( - fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); - if (explicitIterationSpace()) { - // Pointer assignment in FORALL context. Copy the rhs box value - // into the lhs box variable. - genArrayAssignment(assign, stmtCtx, lbounds); - return; - } - fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); - Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, - lbounds, stmtCtx); + return genPointerAssignment(loc, assign, lbExprs); }, - - // [4] Pointer assignment with bounds-remapping. R1036: a - // bounds-remapping is a pair, lower bound and upper bound. [&](const Fortran::evaluate::Assignment::BoundsRemapping &boundExprs) { - llvm::SmallVector lbounds; - llvm::SmallVector ubounds; - for (const std::pair &pair : - boundExprs) { - const Fortran::evaluate::ExtentExpr &lbExpr = pair.first; - const Fortran::evaluate::ExtentExpr &ubExpr = pair.second; - lbounds.push_back( - fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); - ubounds.push_back( - fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx))); - } - - std::optional lhsType = - assign.lhs.GetType(); - std::optional rhsType = - assign.rhs.GetType(); - // Polymorphic lhs/rhs need more care. See F2018 10.2.2.3. - if ((lhsType && lhsType->IsPolymorphic()) || - (rhsType && rhsType->IsPolymorphic())) { - if (explicitIterationSpace()) - TODO(loc, "polymorphic pointer assignment in FORALL"); - - mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr(); - mlir::Value rhs = - fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); - - // Create the newRank x 2 array with the bounds to be passed to - // the runtime as a descriptor. - assert(lbounds.size() && ubounds.size()); - mlir::Type indexTy = builder->getIndexType(); - mlir::Type boundArrayTy = fir::SequenceType::get( - {static_cast(lbounds.size()) * 2}, - builder->getI64Type()); - mlir::Value boundArray = - builder->create(loc, boundArrayTy); - mlir::Value array = - builder->create(loc, boundArrayTy); - for (unsigned i = 0; i < lbounds.size(); ++i) { - array = builder->create( - loc, boundArrayTy, array, lbounds[i], - builder->getArrayAttr({builder->getIntegerAttr( - builder->getIndexType(), static_cast(i * 2))})); - array = builder->create( - loc, boundArrayTy, array, ubounds[i], - builder->getArrayAttr({builder->getIntegerAttr( - builder->getIndexType(), - static_cast(i * 2 + 1))})); - } - builder->create(loc, array, boundArray); - mlir::Type boxTy = fir::BoxType::get(boundArrayTy); - mlir::Value ext = builder->createIntegerConstant( - loc, indexTy, lbounds.size() * 2); - mlir::Value shapeOp = builder->genShape(loc, {ext}); - mlir::Value boundsDesc = builder->create( - loc, boxTy, boundArray, shapeOp); - Fortran::lower::genPointerAssociateRemapping(*builder, loc, lhs, - rhs, boundsDesc); - return; - } - if (explicitIterationSpace()) { - // Pointer assignment in FORALL context. Copy the rhs box value - // into the lhs box variable. - genArrayAssignment(assign, stmtCtx, lbounds, ubounds); - return; - } - fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); - if (Fortran::evaluate::UnwrapExpr( - assign.rhs)) { - fir::factory::disassociateMutableBox(*builder, loc, lhs); - return; - } - // Do not generate a temp in case rhs is an array section. - fir::ExtendedValue rhs = - Fortran::lower::isArraySectionWithoutVectorSubscript( - assign.rhs) - ? Fortran::lower::createSomeArrayBox( - *this, assign.rhs, localSymbols, stmtCtx) - : genExprAddr(assign.rhs, stmtCtx); - fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, - rhs, lbounds, ubounds); - if (explicitIterationSpace()) { - mlir::ValueRange inners = explicitIterSpace.getInnerArgs(); - if (!inners.empty()) - builder->create(loc, inners); - } + return genPointerAssignment(loc, assign, boundExprs); }, }, assign.u); @@ -3732,6 +3735,10 @@ void createRuntimeTypeInfoGlobals() {} + bool lowerToHighLevelFIR() const { + return bridge.getLoweringOptions().getLowerToHighLevelFIR(); + } + //===--------------------------------------------------------------------===// Fortran::lower::LoweringBridge &bridge; diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -724,16 +724,10 @@ operands.emplace_back( Fortran::lower::convertToValue(loc, converter, actual, stmtCtx)); continue; - case Fortran::lower::LowerIntrinsicArgAs::Addr: { - const auto *argExpr = callContext.procRef.UnwrapArgExpr(arg.index()); - bool isSimplyContiguous = - actual.isScalar() || - (argExpr && Fortran::evaluate::IsSimplyContiguous( - *argExpr, converter.getFoldingContext())); - operands.emplace_back(Fortran::lower::convertToAddress( - loc, converter, actual, isSimplyContiguous, stmtCtx)); + case Fortran::lower::LowerIntrinsicArgAs::Addr: + operands.emplace_back( + Fortran::lower::convertToAddress(loc, converter, actual, stmtCtx)); continue; - } case Fortran::lower::LowerIntrinsicArgAs::Box: operands.emplace_back( Fortran::lower::convertToBox(loc, converter, actual, stmtCtx)); diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp --- a/flang/lib/Lower/ConvertExprToHLFIR.cpp +++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -1272,20 +1272,15 @@ return convertToBox(loc, converter, loweredExpr, stmtCtx); } -fir::ExtendedValue -Fortran::lower::convertToAddress(mlir::Location loc, - Fortran::lower::AbstractConverter &converter, - hlfir::Entity entity, bool isSimplyContiguous, - Fortran::lower::StatementContext &stmtCtx) { - if (!isSimplyContiguous) - TODO(loc, "genExprAddr of non contiguous variables in HLFIR"); - fir::ExtendedValue exv = Fortran::lower::translateToExtendedValue( - loc, converter.getFirOpBuilder(), entity, stmtCtx); +fir::ExtendedValue Fortran::lower::convertToAddress( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + hlfir::Entity entity, Fortran::lower::StatementContext &stmtCtx) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + entity = hlfir::derefPointersAndAllocatables(loc, builder, entity); + fir::ExtendedValue exv = + Fortran::lower::translateToExtendedValue(loc, builder, entity, stmtCtx); if (fir::isa_trivial(fir::getBase(exv).getType())) TODO(loc, "place trivial in memory"); - if (const auto *mutableBox = exv.getBoxOf()) - exv = fir::factory::genMutableBoxRead(converter.getFirOpBuilder(), loc, - *mutableBox); return exv; } fir::ExtendedValue Fortran::lower::convertExprToAddress( @@ -1294,11 +1289,7 @@ Fortran::lower::StatementContext &stmtCtx) { hlfir::EntityWithAttributes loweredExpr = HlfirBuilder(loc, converter, symMap, stmtCtx).gen(expr); - bool isSimplyContiguous = - expr.Rank() == 0 || Fortran::evaluate::IsSimplyContiguous( - expr, converter.getFoldingContext()); - return convertToAddress(loc, converter, loweredExpr, isSimplyContiguous, - stmtCtx); + return convertToAddress(loc, converter, loweredExpr, stmtCtx); } fir::ExtendedValue Fortran::lower::convertToValue( @@ -1335,3 +1326,20 @@ HlfirBuilder(loc, converter, symMap, stmtCtx).gen(expr); return convertToValue(loc, converter, loweredExpr, stmtCtx); } + +fir::MutableBoxValue Fortran::lower::convertExprToMutableBox( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) { + // Pointers and Allocatable cannot be temporary expressions. Temporaries may + // be created while lowering it (e.g. if any indices expression of a + // designator create temporaries), but they can be destroyed before using the + // lowered pointer or allocatable; + Fortran::lower::StatementContext localStmtCtx; + hlfir::EntityWithAttributes loweredExpr = + HlfirBuilder(loc, converter, symMap, localStmtCtx).gen(expr); + fir::ExtendedValue exv = Fortran::lower::translateToExtendedValue( + loc, converter.getFirOpBuilder(), loweredExpr, localStmtCtx); + auto *mutableBox = exv.getBoxOf(); + assert(mutableBox && "expression could not be lowered to mutable box"); + return *mutableBox; +} diff --git a/flang/test/Lower/HLFIR/allocatable-and-pointer-status-change.f90 b/flang/test/Lower/HLFIR/allocatable-and-pointer-status-change.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/allocatable-and-pointer-status-change.f90 @@ -0,0 +1,111 @@ +! Test lowering of allocate, deallocate and pointer assignment statements to +! HLFIR. +! RUN: bbc -emit-fir -hlfir -o - %s -I nw | FileCheck %s + +subroutine allocation(x) + character(*), allocatable :: x(:) +! CHECK-LABEL: func.func @_QPallocation( +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] typeparams %[[VAL_2:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, {{.*}}Ex + deallocate(x) +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref>>>> +! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box>>>) -> !fir.heap>> +! CHECK: fir.freemem %[[VAL_5]] : !fir.heap>> +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.heap>> +! CHECK: %[[VAL_7:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_8:.*]] = fir.shape %[[VAL_7]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_6]](%[[VAL_8]]) typeparams %[[VAL_2]] : (!fir.heap>>, !fir.shape<1>, index) -> !fir.box>>> + allocate(x(100)) +! CHECK: %[[VAL_10:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i32) -> index +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_13:.*]] = arith.cmpi sgt, %[[VAL_11]], %[[VAL_12]] : index +! CHECK: %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_11]], %[[VAL_12]] : index +! CHECK: %[[VAL_15:.*]] = fir.allocmem !fir.array>(%[[VAL_2]] : index), %[[VAL_14]] {uniq_name = "_QFallocationEx.alloc"} +! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_14]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_17:.*]] = fir.embox %[[VAL_15]](%[[VAL_16]]) typeparams %[[VAL_2]] : (!fir.heap>>, !fir.shape<1>, index) -> !fir.box>>> +! CHECK: fir.store %[[VAL_17]] to %[[VAL_3]]#1 : !fir.ref>>>> +end subroutine + +subroutine pointer_assignment(p, ziel) + real, pointer :: p(:) + real, target :: ziel(42:) +! CHECK-LABEL: func.func @_QPpointer_assignment( +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, {{.*}}Ep +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]](%[[VAL_5:[a-z0-9]*]]) {fortran_attrs = #fir.var_attrs, {{.*}}Eziel + p => ziel +! CHECK: %[[VAL_7:.*]] = fir.shift %[[VAL_4:.*]] : (index) -> !fir.shift<1> +! CHECK: %[[VAL_8:.*]] = fir.rebox %[[VAL_6]]#1(%[[VAL_7]]) : (!fir.box>, !fir.shift<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_8]] to %[[VAL_2]]#1 : !fir.ref>>> + p => ziel(42:77:3) +! CHECK: %[[VAL_14:.*]] = hlfir.designate %{{.*}}#0 (%{{.*}}:%{{.*}}:%{{.*}}) shape %{{.*}} : (!fir.box>, index, index, index, !fir.shape<1>) -> !fir.box> +! CHECK: %[[VAL_15:.*]] = fir.rebox %[[VAL_14]] : (!fir.box>) -> !fir.box>> +! CHECK: fir.store %[[VAL_15]] to %[[VAL_2]]#1 : !fir.ref>>> +end subroutine + +subroutine pointer_remapping(p, ziel) + real, pointer :: p(:, :) + real, target :: ziel(10, 20, 30) +! CHECK-LABEL: func.func @_QPpointer_remapping( +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, {{.*}}Ep +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]](%[[VAL_6:[a-z0-9]*]]) {fortran_attrs = #fir.var_attrs, {{.*}}Eziel + p(2:7, 3:102) => ziel +! CHECK: %[[VAL_8:.*]] = arith.constant 2 : i64 +! CHECK: %[[VAL_9:.*]] = arith.constant 7 : i64 +! CHECK: %[[VAL_10:.*]] = arith.constant 3 : i64 +! CHECK: %[[VAL_11:.*]] = arith.constant 102 : i64 +! CHECK: %[[VAL_12:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_8]] : (i64) -> index +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_9]] : (i64) -> index +! CHECK: %[[VAL_15:.*]] = arith.subi %[[VAL_14]], %[[VAL_13]] : index +! CHECK: %[[VAL_16:.*]] = arith.addi %[[VAL_15]], %[[VAL_12]] : index +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_10]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_11]] : (i64) -> index +! CHECK: %[[VAL_19:.*]] = arith.subi %[[VAL_18]], %[[VAL_17]] : index +! CHECK: %[[VAL_20:.*]] = arith.addi %[[VAL_19]], %[[VAL_12]] : index +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_7]]#1 : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_22:.*]] = fir.shape_shift %[[VAL_8]], %[[VAL_16]], %[[VAL_10]], %[[VAL_20]] : (i64, index, i64, index) -> !fir.shapeshift<2> +! CHECK: %[[VAL_23:.*]] = fir.embox %[[VAL_21]](%[[VAL_22]]) : (!fir.ref>, !fir.shapeshift<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_23]] to %[[VAL_2]]#1 : !fir.ref>>> +end subroutine + +subroutine alloc_comp(x) + type t + real, allocatable :: a(:) + end type + type(t) :: x(10) +! CHECK-LABEL: func.func @_QPalloc_comp( +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]](%[[VAL_2:[a-z0-9]*]]) {{.*}}Ex + allocate(x(10_8)%a(100_8)) +! CHECK: %[[VAL_4:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_5:.*]] = hlfir.designate %[[VAL_3]]#0 (%[[VAL_4]]) : (!fir.ref>>}>>>, index) -> !fir.ref>>}>> +! CHECK: %[[VAL_6:.*]] = hlfir.designate %[[VAL_5]]{"a"} {fortran_attrs = #fir.var_attrs} : (!fir.ref>>}>>) -> !fir.ref>>> +! CHECK: %[[VAL_7:.*]] = arith.constant 100 : i64 +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_10:.*]] = arith.cmpi sgt, %[[VAL_8]], %[[VAL_9]] : index +! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_10]], %[[VAL_8]], %[[VAL_9]] : index +! CHECK: %[[VAL_12:.*]] = fir.allocmem !fir.array, %[[VAL_11]] {uniq_name = "_QEa.alloc"} +! CHECK: %[[VAL_13:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_12]](%[[VAL_13]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_14]] to %[[VAL_6]] : !fir.ref>>> +end subroutine + +subroutine ptr_comp_assign(x, ziel) + type t + real, pointer :: p(:) + end type + type(t) :: x(10) +! CHECK-LABEL: func.func @_QPptr_comp_assign( +! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]](%[[VAL_3:[a-z0-9]*]]) {{.*}}Ex + real, target :: ziel(100) + x(9_8)%p => ziel +! CHECK: %[[VAL_5:.*]] = arith.constant 100 : index +! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]](%[[VAL_6:[a-z0-9]*]]) {fortran_attrs = #fir.var_attrs, {{.*}}Eziel +! CHECK: %[[VAL_8:.*]] = arith.constant 9 : index +! CHECK: %[[VAL_9:.*]] = hlfir.designate %[[VAL_4]]#0 (%[[VAL_8]]) : (!fir.ref>>}>>>, index) -> !fir.ref>>}>> +! CHECK: %[[VAL_10:.*]] = hlfir.designate %[[VAL_9]]{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref>>}>>) -> !fir.ref>>> +! CHECK: %[[VAL_11:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_7]]#1(%[[VAL_11]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_12]] to %[[VAL_10]] : !fir.ref>>> +end subroutine