Index: flang/include/flang/Lower/Allocatable.h =================================================================== --- flang/include/flang/Lower/Allocatable.h +++ flang/include/flang/Lower/Allocatable.h @@ -41,12 +41,14 @@ struct SymbolBox; class StatementContext; +class SymMap; bool isArraySectionWithoutVectorSubscript(const SomeExpr &expr); /// Lower an allocate statement to fir. void genAllocateStmt(AbstractConverter &converter, - const parser::AllocateStmt &stmt, mlir::Location loc); + const parser::AllocateStmt &stmt, mlir::Location loc, + Fortran::lower::SymMap &symMap); /// Lower a deallocate statement to fir. void genDeallocateStmt(AbstractConverter &converter, Index: flang/include/flang/Lower/ConvertExpr.h =================================================================== --- flang/include/flang/Lower/ConvertExpr.h +++ flang/include/flang/Lower/ConvertExpr.h @@ -88,6 +88,11 @@ const SomeExpr &expr, SymMap &symMap, StatementContext &stmtCtx); +/// Lower an assignment operation from \p rhs to \p lhs. +void createScalarAssignment(AbstractConverter &converter, const SomeExpr &lhs, + const SomeExpr &rhs, SymMap &symMap, + StatementContext &stmtCtx); + /// Lower an array assignment expression. /// /// 1. Evaluate the lhs to determine the rank and how to form the ArrayLoad @@ -216,6 +221,12 @@ SymMap &symMap, StatementContext &stmtCtx, bool isUserDefAssignment); +/// Lower an experssion to a value of type box if it is an array. +fir::ExtendedValue genExprAsBoxIfArray( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx); + // Attribute for an alloca that is a trivial adaptor for converting a value to // pass-by-ref semantics for a VALUE parameter. The optimizer may be able to // eliminate these. Index: flang/lib/Lower/Allocatable.cpp =================================================================== --- flang/lib/Lower/Allocatable.cpp +++ flang/lib/Lower/Allocatable.cpp @@ -13,6 +13,7 @@ #include "flang/Lower/Allocatable.h" #include "flang/Evaluate/tools.h" #include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/ConvertExpr.h" #include "flang/Lower/IterationSpace.h" #include "flang/Lower/Mangler.h" #include "flang/Lower/PFTBuilder.h" @@ -232,20 +233,24 @@ public: AllocateStmtHelper(Fortran::lower::AbstractConverter &converter, const Fortran::parser::AllocateStmt &stmt, - mlir::Location loc) + mlir::Location loc, Fortran::lower::SymMap &symMap) : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt}, - loc{loc} {} + loc{loc}, symMap{symMap} {} void lower() { visitAllocateOptions(); lowerAllocateLengthParameters(); errorManager.init(converter, loc, statExpr, errMsgExpr); - if (sourceExpr || moldExpr) - TODO(loc, "lower MOLD/SOURCE expr in allocate"); + Fortran::lower::StatementContext stmtCtx; + if (sourceExpr) + sourceExv = Fortran::lower::genExprAsBoxIfArray( + loc, converter, *sourceExpr, symMap, stmtCtx); + if (moldExpr) + TODO(loc, "lower MOLD expr in allocate"); mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint(); for (const auto &allocation : std::get>(stmt.t)) - lowerAllocation(unwrapAllocation(allocation)); + lowerAllocation(unwrapAllocation(allocation), stmtCtx); builder.restoreInsertionPoint(insertPt); } @@ -303,12 +308,13 @@ allocOption.u); } - void lowerAllocation(const Allocation &alloc) { + void lowerAllocation(const Allocation &alloc, + Fortran::lower::StatementContext &stmtCtx) { fir::MutableBoxValue boxAddr = genMutableBoxValue(converter, loc, alloc.getAllocObj()); if (sourceExpr) { - genSourceAllocation(alloc, boxAddr); + genSourceAllocation(alloc, boxAddr, stmtCtx); } else if (moldExpr) { genMoldAllocation(alloc, boxAddr); } else { @@ -364,20 +370,16 @@ extents.emplace_back(ub); } } + if (sourceExpr && alloc.getShapeSpecs().size() == 0) { + extents = fir::factory::getExtents(loc, builder, sourceExv); + for (size_t i = 0; i < extents.size(); ++i) + lbounds.emplace_back(one); + } fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents, lenParams, mangleAlloc(alloc)); } - void genSimpleAllocation(const Allocation &alloc, - const fir::MutableBoxValue &box) { - if (!box.isDerived() && !errorManager.hasStatSpec() && - !alloc.type.IsPolymorphic() && !alloc.hasCoarraySpec() && - !useAllocateRuntime) { - genInlinedAllocation(alloc, box); - return; - } - // Generate a sequence of runtime calls. - errorManager.genStatCheck(builder, loc); + void genAllocateObjectInit(const fir::MutableBoxValue &box) { if (box.isPointer()) { // For pointers, the descriptor may still be uninitialized (see Fortran // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor @@ -392,12 +394,10 @@ // calls in case it is tracked locally by a set of variables. fir::factory::getMutableIRBox(builder, loc, box); } - if (alloc.hasCoarraySpec()) - TODO(loc, "coarray allocation"); - if (alloc.type.IsPolymorphic()) - genSetType(alloc, box, loc); - genSetDeferredLengthParameters(alloc, box); - // Set bounds for arrays + } + + void genAllocateObjectBounds(const Allocation &alloc, + const fir::MutableBoxValue &box) { mlir::Type idxTy = builder.getIndexType(); mlir::Type i32Ty = builder.getIntegerType(32); Fortran::lower::StatementContext stmtCtx; @@ -417,6 +417,26 @@ // Runtime call genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); } + } + + void genSimpleAllocation(const Allocation &alloc, + const fir::MutableBoxValue &box) { + if (!box.isDerived() && !errorManager.hasStatSpec() && + !alloc.type.IsPolymorphic() && !alloc.hasCoarraySpec() && + !useAllocateRuntime) { + genInlinedAllocation(alloc, box); + return; + } + // Generate a sequence of runtime calls. + errorManager.genStatCheck(builder, loc); + genAllocateObjectInit(box); + if (alloc.hasCoarraySpec()) + TODO(loc, "coarray allocation"); + if (alloc.type.IsPolymorphic()) + genSetType(alloc, box, loc); + genSetDeferredLengthParameters(alloc, box); + // Set bounds for arrays + genAllocateObjectBounds(alloc, box); mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager); fir::factory::syncMutableBoxFromIRBox(builder, loc, box); errorManager.assignStat(builder, loc, stat); @@ -463,9 +483,76 @@ TODO(loc, "derived type length parameters in allocate"); } - void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) { - TODO(loc, "SOURCE allocation"); + void genSourceAllocation(const Allocation &alloc, + const fir::MutableBoxValue &box, + Fortran::lower::StatementContext &stmtCtx) { + if (alloc.hasCoarraySpec()) + TODO(loc, "coarray allocation with source"); + if (alloc.type.IsPolymorphic()) + TODO(loc, "allocate polymorphic with source"); + if (box.isDerived() && !lenParams.empty()) + TODO(loc, "derived type length parameters in allocate with source"); + + auto genAssignFromSource = [&]() { + if (sourceExpr->Rank() == 0) { + const Fortran::lower::SomeExpr *expr = + Fortran::semantics::GetExpr(alloc.getAllocObj()); + Fortran::lower::createScalarAssignment(converter, *expr, *sourceExpr, + symMap, stmtCtx); + } else { + auto load = fir::factory::genMutableBoxRead(builder, loc, box); + Fortran::lower::createSomeArrayAssignment(converter, load, sourceExv, + symMap, stmtCtx); + } + }; + + // Set length of the allocate object if it has. Otherwise, get the length + // from source for the deferred length parameter. + if (lenParams.empty() && box.isCharacter()) { + if (box.hasNonDeferredLenParams()) + lenParams.push_back(fir::factory::readCharLen(builder, loc, box)); + else + lenParams.push_back(fir::factory::readCharLen(builder, loc, sourceExv)); + } + + if (!box.isDerived() && !errorManager.hasStatSpec() && + !useAllocateRuntime) { + genInlinedAllocation(alloc, box); + genAssignFromSource(); + return; + } + + errorManager.genStatCheck(builder, loc); + genAllocateObjectInit(box); + genSetDeferredLengthParameters(alloc, box); + if (sourceExpr->Rank() > 0) { + // Set bounds for alloc object if it has. Otherwise, get the bounds from + // the source expression, and the lower bound is set to one, and the + // upper bound is set to the extent of the source expression. + if (alloc.getShapeSpecs().size() > 0) { + genAllocateObjectBounds(alloc, box); + } else { + llvm::SmallVector extents = + fir::factory::getExtents(loc, builder, sourceExv); + mlir::Type idxTy = builder.getIndexType(); + mlir::Type i32Ty = builder.getIntegerType(32); + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + for (size_t i = 0; i < extents.size(); ++i) { + mlir::Value lb = one; + mlir::Value extent = builder.createConvert(loc, idxTy, extents[i]); + mlir::Value ub = builder.create( + loc, builder.create(loc, extent, lb), one); + mlir::Value dimIndex = builder.createIntegerConstant(loc, i32Ty, i); + genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); + } + } + } + mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager); + fir::factory::syncMutableBoxFromIRBox(builder, loc, box); + errorManager.assignStat(builder, loc, stat); + genAssignFromSource(); } + void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) { TODO(loc, "MOLD allocation"); } @@ -539,15 +626,19 @@ // value of the length parameters that were specified inside. llvm::SmallVector lenParams; ErrorManager errorManager; + // 9.7.1.2 (7): The source-expr is evaluated only once for each AllocateStmt. + fir::ExtendedValue sourceExv; mlir::Location loc; + Fortran::lower::SymMap &symMap; }; } // namespace void Fortran::lower::genAllocateStmt( Fortran::lower::AbstractConverter &converter, - const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) { - AllocateStmtHelper{converter, stmt, loc}.lower(); + const Fortran::parser::AllocateStmt &stmt, mlir::Location loc, + Fortran::lower::SymMap &symMap) { + AllocateStmtHelper{converter, stmt, loc, symMap}.lower(); } //===----------------------------------------------------------------------===// Index: flang/lib/Lower/Bridge.cpp =================================================================== --- flang/lib/Lower/Bridge.cpp +++ flang/lib/Lower/Bridge.cpp @@ -834,12 +834,6 @@ genExprAddr(Fortran::evaluate::AsGenericExpr(sym).value(), stmtCtx)); } - static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { - return cat == Fortran::common::TypeCategory::Integer || - cat == Fortran::common::TypeCategory::Real || - cat == Fortran::common::TypeCategory::Complex || - cat == Fortran::common::TypeCategory::Logical; - } static bool isLogicalCategory(Fortran::common::TypeCategory cat) { return cat == Fortran::common::TypeCategory::Logical; } @@ -2212,7 +2206,7 @@ //===--------------------------------------------------------------------===// void genFIR(const Fortran::parser::AllocateStmt &stmt) { - Fortran::lower::genAllocateStmt(*this, stmt, toLocation()); + Fortran::lower::genAllocateStmt(*this, stmt, toLocation(), localSymbols); } void genFIR(const Fortran::parser::DeallocateStmt &stmt) { @@ -2328,14 +2322,6 @@ localSymbols, stmtCtx); } -#if !defined(NDEBUG) - static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) { - const Fortran::semantics::Symbol *sym = - Fortran::evaluate::GetFirstSymbol(expr); - return sym && sym->IsFuncResult(); - } -#endif - inline fir::MutableBoxValue genExprMutableBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr) override final { @@ -2381,70 +2367,8 @@ return; } - // Scalar assignment - const bool isNumericScalar = - isNumericScalarCategory(lhsType->category()); - fir::ExtendedValue rhs = isNumericScalar - ? genExprValue(assign.rhs, stmtCtx) - : genExprAddr(assign.rhs, stmtCtx); - const bool lhsIsWholeAllocatable = - Fortran::lower::isWholeAllocatable(assign.lhs); - llvm::Optional lhsRealloc; - llvm::Optional lhsMutableBox; - auto lhs = [&]() -> fir::ExtendedValue { - if (lhsIsWholeAllocatable) { - lhsMutableBox = genExprMutableBox(loc, assign.lhs); - llvm::SmallVector lengthParams; - if (const fir::CharBoxValue *charBox = rhs.getCharBox()) - lengthParams.push_back(charBox->getLen()); - else if (fir::isDerivedWithLenParameters(rhs)) - TODO(loc, "assignment to derived type allocatable with " - "LEN parameters"); - lhsRealloc = fir::factory::genReallocIfNeeded( - *builder, loc, *lhsMutableBox, - /*shape=*/llvm::None, lengthParams); - return lhsRealloc->newValue; - } - return genExprAddr(assign.lhs, stmtCtx); - }(); - - if (isNumericScalar) { - // Fortran 2018 10.2.1.3 p8 and p9 - // Conversions should have been inserted by semantic analysis, - // but they can be incorrect between the rhs and lhs. Correct - // that here. - mlir::Value addr = fir::getBase(lhs); - mlir::Value val = fir::getBase(rhs); - // A function with multiple entry points returning different - // types tags all result variables with one of the largest - // types to allow them to share the same storage. Assignment - // to a result variable of one of the other types requires - // conversion to the actual type. - mlir::Type toTy = genType(assign.lhs); - mlir::Value cast = - builder->convertWithSemantics(loc, toTy, val); - if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) { - assert(isFuncResultDesignator(assign.lhs) && "type mismatch"); - addr = builder->createConvert( - toLocation(), builder->getRefType(toTy), addr); - } - builder->create(loc, cast, addr); - } else if (isCharacterCategory(lhsType->category())) { - // Fortran 2018 10.2.1.3 p10 and p11 - fir::factory::CharacterExprHelper{*builder, loc}.createAssign( - lhs, rhs); - } else if (isDerivedCategory(lhsType->category())) { - // Fortran 2018 10.2.1.3 p13 and p14 - // Recursively gen an assignment on each element pair. - fir::factory::genRecordAssignment(*builder, loc, lhs, rhs); - } else { - llvm_unreachable("unknown category"); - } - if (lhsIsWholeAllocatable) - fir::factory::finalizeRealloc( - *builder, loc, lhsMutableBox.value(), - /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false, - lhsRealloc.value()); + Fortran::lower::createScalarAssignment( + *this, assign.lhs, assign.rhs, localSymbols, stmtCtx); }, // [2] User defined assignment. If the context is a scalar Index: flang/lib/Lower/ConvertExpr.cpp =================================================================== --- flang/lib/Lower/ConvertExpr.cpp +++ flang/lib/Lower/ConvertExpr.cpp @@ -7425,6 +7425,90 @@ .gen(expr); } +static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) { + const Fortran::semantics::Symbol *sym = + Fortran::evaluate::GetFirstSymbol(expr); + return sym && sym->IsFuncResult(); +} + +static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Integer || + cat == Fortran::common::TypeCategory::Real || + cat == Fortran::common::TypeCategory::Complex || + cat == Fortran::common::TypeCategory::Logical; +} + +void Fortran::lower::createScalarAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto scalar: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::Location loc = converter.getCurrentLocation(); + std::optional lhsType = lhs.GetType(); + assert(lhsType && "lhs cannot be typeless"); + const bool isNumericScalar = isNumericScalarCategory(lhsType->category()); + fir::ExtendedValue rhsExv = isNumericScalar + ? converter.genExprValue(rhs, stmtCtx) + : converter.genExprAddr(rhs, stmtCtx); + const bool lhsIsWholeAllocatable = Fortran::lower::isWholeAllocatable(lhs); + llvm::Optional lhsRealloc; + llvm::Optional lhsMutableBox; + auto lhsExv = [&]() -> fir::ExtendedValue { + if (lhsIsWholeAllocatable) { + lhsMutableBox = converter.genExprMutableBox(loc, lhs); + llvm::SmallVector lengthParams; + if (const fir::CharBoxValue *charBox = rhsExv.getCharBox()) + lengthParams.push_back(charBox->getLen()); + else if (fir::isDerivedWithLenParameters(rhsExv)) + TODO(loc, "assignment to derived type allocatable with " + "LEN parameters"); + lhsRealloc = + fir::factory::genReallocIfNeeded(builder, loc, *lhsMutableBox, + /*shape=*/llvm::None, lengthParams); + return lhsRealloc->newValue; + } + return converter.genExprAddr(lhs, stmtCtx); + }(); + + if (isNumericScalar) { + // Fortran 2018 10.2.1.3 p8 and p9 + // Conversions should have been inserted by semantic analysis, + // but they can be incorrect between the rhs and lhs. Correct + // that here. + mlir::Value addr = fir::getBase(lhsExv); + mlir::Value val = fir::getBase(rhsExv); + // A function with multiple entry points returning different + // types tags all result variables with one of the largest + // types to allow them to share the same storage. Assignment + // to a result variable of one of the other types requires + // conversion to the actual type. + mlir::Type toTy = converter.genType(lhs); + mlir::Value cast = builder.convertWithSemantics(loc, toTy, val); + if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) { + assert(isFuncResultDesignator(lhs) && "type mismatch"); + addr = builder.createConvert(loc, builder.getRefType(toTy), addr); + } + builder.create(loc, cast, addr); + } else if (lhsType->category() == Fortran::common::TypeCategory::Character) { + // Fortran 2018 10.2.1.3 p10 and p11 + fir::factory::CharacterExprHelper{builder, loc}.createAssign(lhsExv, + rhsExv); + } else if (lhsType->category() == Fortran::common::TypeCategory::Derived) { + // Fortran 2018 10.2.1.3 p13 and p14 + // Recursively gen an assignment on each element pair. + fir::factory::genRecordAssignment(builder, loc, lhsExv, rhsExv); + } else { + llvm_unreachable("unknown category"); + } + if (lhsIsWholeAllocatable) + fir::factory::finalizeRealloc(builder, loc, lhsMutableBox.value(), + /*lbounds=*/llvm::None, + /*takeLboundsIfRealloc=*/false, + lhsRealloc.value()); +} + void Fortran::lower::createSomeArrayAssignment( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, @@ -7782,3 +7866,15 @@ esp.resetBindings(); esp.incrementCounter(); } + +fir::ExtendedValue Fortran::lower::genExprAsBoxIfArray( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); + ScalarExprLowering sel(loc, converter, symMap, stmtCtx); + + if (expr.Rank() > 0) + return sel.genBoxArg(expr); + return sel.genExtAddr(expr); +} Index: flang/test/Lower/allocate-source-allocatables.f90 =================================================================== --- /dev/null +++ flang/test/Lower/allocate-source-allocatables.f90 @@ -0,0 +1,249 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test lowering of allocatables for allocate statements with source. + +! CHECK-LABEL: func.func @_QPtest_allocatable_scalar( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca i32 {bindc_name = "sss", uniq_name = "_QFtest_allocatable_scalarEsss"} +! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFtest_allocatable_scalarEx1) : !fir.ref>> +! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QFtest_allocatable_scalarEx2) : !fir.ref>> +! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QFtest_allocatable_scalarEx3) : !fir.ref>> +! CHECK: %[[VAL_5:.*]] = fir.address_of(@_QFtest_allocatable_scalarEx4) : !fir.ref>> +! CHECK: %[[VAL_6:.*]] = fir.allocmem f32 {uniq_name = "_QFtest_allocatable_scalarEx1.alloc"} +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_6]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_7]] to %[[VAL_2]] : !fir.ref>> +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_2]] : !fir.ref>> +! CHECK: %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box>) -> !fir.heap +! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.heap) -> i64 +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_13:.*]] = arith.cmpi ne, %[[VAL_11]], %[[VAL_12]] : i64 +! CHECK: %[[VAL_14:.*]]:2 = fir.if %[[VAL_13]] -> (i1, !fir.heap) { +! CHECK: %[[VAL_15:.*]] = arith.constant false +! CHECK: %[[VAL_16:.*]] = fir.if %[[VAL_15]] -> (!fir.heap) { +! CHECK: %[[VAL_17:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_17]] : !fir.heap +! CHECK: } else { +! CHECK: fir.result %[[VAL_10]] : !fir.heap +! CHECK: } +! CHECK: fir.result %[[VAL_15]], %[[VAL_18:.*]] : i1, !fir.heap +! CHECK: } else { +! CHECK: %[[VAL_19:.*]] = arith.constant true +! CHECK: %[[VAL_20:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_19]], %[[VAL_20]] : i1, !fir.heap +! CHECK: } +! CHECK: fir.store %[[VAL_8]] to %[[VAL_21:.*]]#1 : !fir.heap +! CHECK: fir.if %[[VAL_21]]#0 { +! CHECK: fir.if %[[VAL_13]] { +! CHECK: fir.freemem %[[VAL_10]] : !fir.heap +! CHECK: } +! CHECK: %[[VAL_22:.*]] = fir.embox %[[VAL_21]]#1 : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_22]] to %[[VAL_2]] : !fir.ref>> +! CHECK: } +! CHECK: %[[VAL_23:.*]] = fir.allocmem f32 {uniq_name = "_QFtest_allocatable_scalarEx2.alloc"} +! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_23]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_24]] to %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_25:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_27:.*]] = fir.box_addr %[[VAL_26]] : (!fir.box>) -> !fir.heap +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (!fir.heap) -> i64 +! CHECK: %[[VAL_29:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_30:.*]] = arith.cmpi ne, %[[VAL_28]], %[[VAL_29]] : i64 +! CHECK: %[[VAL_31:.*]]:2 = fir.if %[[VAL_30]] -> (i1, !fir.heap) { +! CHECK: %[[VAL_32:.*]] = arith.constant false +! CHECK: %[[VAL_33:.*]] = fir.if %[[VAL_32]] -> (!fir.heap) { +! CHECK: %[[VAL_34:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_34]] : !fir.heap +! CHECK: } else { +! CHECK: fir.result %[[VAL_27]] : !fir.heap +! CHECK: } +! CHECK: fir.result %[[VAL_32]], %[[VAL_35:.*]] : i1, !fir.heap +! CHECK: } else { +! CHECK: %[[VAL_36:.*]] = arith.constant true +! CHECK: %[[VAL_37:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_36]], %[[VAL_37]] : i1, !fir.heap +! CHECK: } +! CHECK: fir.store %[[VAL_25]] to %[[VAL_38:.*]]#1 : !fir.heap +! CHECK: fir.if %[[VAL_38]]#0 { +! CHECK: fir.if %[[VAL_30]] { +! CHECK: fir.freemem %[[VAL_27]] : !fir.heap +! CHECK: } +! CHECK: %[[VAL_39:.*]] = fir.embox %[[VAL_38]]#1 : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_39]] to %[[VAL_3]] : !fir.ref>> +! CHECK: } +! CHECK: %[[VAL_40:.*]] = fir.allocmem f32 {uniq_name = "_QFtest_allocatable_scalarEx3.alloc"} +! CHECK: %[[VAL_41:.*]] = fir.embox %[[VAL_40]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_41]] to %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_42:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_43:.*]] = fir.load %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_44:.*]] = fir.box_addr %[[VAL_43]] : (!fir.box>) -> !fir.heap +! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_44]] : (!fir.heap) -> i64 +! CHECK: %[[VAL_46:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_47:.*]] = arith.cmpi ne, %[[VAL_45]], %[[VAL_46]] : i64 +! CHECK: %[[VAL_48:.*]]:2 = fir.if %[[VAL_47]] -> (i1, !fir.heap) { +! CHECK: %[[VAL_49:.*]] = arith.constant false +! CHECK: %[[VAL_50:.*]] = fir.if %[[VAL_49]] -> (!fir.heap) { +! CHECK: %[[VAL_51:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_51]] : !fir.heap +! CHECK: } else { +! CHECK: fir.result %[[VAL_44]] : !fir.heap +! CHECK: } +! CHECK: fir.result %[[VAL_49]], %[[VAL_52:.*]] : i1, !fir.heap +! CHECK: } else { +! CHECK: %[[VAL_53:.*]] = arith.constant true +! CHECK: %[[VAL_54:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_53]], %[[VAL_54]] : i1, !fir.heap +! CHECK: } +! CHECK: fir.store %[[VAL_42]] to %[[VAL_55:.*]]#1 : !fir.heap +! CHECK: fir.if %[[VAL_55]]#0 { +! CHECK: fir.if %[[VAL_47]] { +! CHECK: fir.freemem %[[VAL_44]] : !fir.heap +! CHECK: } +! CHECK: %[[VAL_56:.*]] = fir.embox %[[VAL_55]]#1 : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_56]] to %[[VAL_4]] : !fir.ref>> +! CHECK: } +! CHECK: %[[VAL_57:.*]] = arith.constant true +! CHECK: %[[VAL_58:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_61:.*]] = fir.convert %[[VAL_5]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_63:.*]] = fir.call @_FortranAAllocatableAllocate(%[[VAL_61]], %[[VAL_57]], %[[VAL_58]], %[[VAL_62:.*]], %[[VAL_60:.*]]) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: fir.store %[[VAL_63]] to %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_64:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_65:.*]] = fir.load %[[VAL_5]] : !fir.ref>> +! CHECK: %[[VAL_66:.*]] = fir.box_addr %[[VAL_65]] : (!fir.box>) -> !fir.heap +! CHECK: %[[VAL_67:.*]] = fir.convert %[[VAL_66]] : (!fir.heap) -> i64 +! CHECK: %[[VAL_68:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_69:.*]] = arith.cmpi ne, %[[VAL_67]], %[[VAL_68]] : i64 +! CHECK: %[[VAL_70:.*]]:2 = fir.if %[[VAL_69]] -> (i1, !fir.heap) { +! CHECK: %[[VAL_71:.*]] = arith.constant false +! CHECK: %[[VAL_72:.*]] = fir.if %[[VAL_71]] -> (!fir.heap) { +! CHECK: %[[VAL_73:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_73]] : !fir.heap +! CHECK: } else { +! CHECK: fir.result %[[VAL_66]] : !fir.heap +! CHECK: } +! CHECK: fir.result %[[VAL_71]], %[[VAL_74:.*]] : i1, !fir.heap +! CHECK: } else { +! CHECK: %[[VAL_75:.*]] = arith.constant true +! CHECK: %[[VAL_76:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_75]], %[[VAL_76]] : i1, !fir.heap +! CHECK: } +! CHECK: fir.store %[[VAL_64]] to %[[VAL_77:.*]]#1 : !fir.heap +! CHECK: fir.if %[[VAL_77]]#0 { +! CHECK: fir.if %[[VAL_69]] { +! CHECK: fir.freemem %[[VAL_66]] : !fir.heap +! CHECK: } +! CHECK: %[[VAL_78:.*]] = fir.embox %[[VAL_77]]#1 : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_78]] to %[[VAL_5]] : !fir.ref>> +! CHECK: } +! CHECK: return +! CHECK: } + +subroutine test_allocatable_scalar(a) + real, save, allocatable :: x1, x2, x3, x4 + integer :: sss + real :: a + + allocate(x1, x2, source = a) + allocate(x3, source = a) + allocate(x4, source = a, stat=sss) +end + +subroutine test_allocatable_1d_array(n, a) + integer, allocatable :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss, a(n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)) + allocate(x4, source = a(2:5:2), stat=sss) + print *, sss +end + +subroutine test_allocatable_2d_array(n, a) + integer, allocatable :: x1(:,:), x2(:,:), x3(:,:), x4(:,:) + integer :: n, sss, a(n, n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(1:3:2, 2:3)) + allocate(x4, source = a(1:3:2, 2:3), stat=sss) +end + +subroutine test_allocatable_from_pointer(n, a) + integer, allocatable :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + integer, pointer :: a(:) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)) + allocate(x4, source = a(2:5:2), stat=sss) +end + +subroutine test_allocatable_from_allocatable(n, a) + integer, allocatable :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + integer, pointer :: a(:) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)) + allocate(x4, source = a(2:5:2), stat=sss) +end + +subroutine test_allocatable_with_shapespec(n, a, m) + integer, allocatable :: x1(:), x2(:), x3(:), x4(:) + integer :: n, m, sss, a(n) + + allocate(x1(2:m), x2(n), source = a) + allocate(x3(2:m), source = a(3:)) + allocate(x4(2:m), source = a(3:), stat=sss) +end + +subroutine test_allocatable_from_const(n, a) + integer, allocatable :: x1(:), x2(:), x3(:) + integer :: n, sss, a(n) + + allocate(x1, x2, source = [1, 2, 3, 4, 5]) + allocate(x3, source = [1, 2, 3, 4, 5]) + allocate(x3, source = [1, 2, 3, 4, 5], stat=sss) +end + +subroutine test_allocatable_chararray(n, a) + character(4), allocatable :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + character(3) :: a(n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)(2:)) + allocate(x4, source = a(2:5:2)(3:), stat=sss) +end + +subroutine test_allocatable_chararray_unknown_len(n, a) + character(:), allocatable :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + character(3) :: a(n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)(2:)) + allocate(x4, source = a(2:5:2)(3:), stat=sss) +end + +subroutine test_allocatable_char(n, a) + character(:), allocatable :: x1, x2, x3, x4 + integer :: n, sss + character(*) :: a + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5)) + allocate(x4, source = a(2:3), stat=sss) +end + +subroutine test_allocatable_derived_type(z1, z2) + type t + integer, allocatable :: x(:) + end type + type(t), allocatable :: x(:), y(:) + integer, allocatable :: z1(:), z2(:) + + allocate(y(2)) + allocate(y(1)%x(2), source = z1) + allocate(y(2)%x(2), source = z2) + allocate(x, source=y) +end Index: flang/test/Lower/allocate-source-pointers.f90 =================================================================== --- /dev/null +++ flang/test/Lower/allocate-source-pointers.f90 @@ -0,0 +1,155 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test lowering of pointers for allocate statements with source. + +! CHECK-LABEL: func.func @_QPtest_pointer_scalar( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca i32 {bindc_name = "sss", uniq_name = "_QFtest_pointer_scalarEsss"} +! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFtest_pointer_scalarEx1) : !fir.ref>> +! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QFtest_pointer_scalarEx2) : !fir.ref>> +! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QFtest_pointer_scalarEx3) : !fir.ref>> +! CHECK: %[[VAL_5:.*]] = fir.address_of(@_QFtest_pointer_scalarEx4) : !fir.ref>> +! CHECK: %[[VAL_6:.*]] = fir.allocmem f32 {uniq_name = "_QFtest_pointer_scalarEx1.alloc"} +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_6]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_7]] to %[[VAL_2]] : !fir.ref>> +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_2]] : !fir.ref>> +! CHECK: %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[VAL_8]] to %[[VAL_10]] : !fir.ptr +! CHECK: %[[VAL_11:.*]] = fir.allocmem f32 {uniq_name = "_QFtest_pointer_scalarEx2.alloc"} +! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_11]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_12]] to %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_15:.*]] = fir.box_addr %[[VAL_14]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[VAL_13]] to %[[VAL_15]] : !fir.ptr +! CHECK: %[[VAL_16:.*]] = fir.allocmem f32 {uniq_name = "_QFtest_pointer_scalarEx3.alloc"} +! CHECK: %[[VAL_17:.*]] = fir.embox %[[VAL_16]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[VAL_17]] to %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_20:.*]] = fir.box_addr %[[VAL_19]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[VAL_18]] to %[[VAL_20]] : !fir.ptr +! CHECK: %[[VAL_21:.*]] = arith.constant true +! CHECK: %[[VAL_22:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_25:.*]] = fir.zero_bits !fir.ptr +! CHECK: %[[VAL_26:.*]] = fir.embox %[[VAL_25]] : (!fir.ptr) -> !fir.box> +! CHECK: fir.store %[[VAL_26]] to %[[VAL_5]] : !fir.ref>> +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_5]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_29:.*]] = fir.call @_FortranAPointerAllocate(%[[VAL_27]], %[[VAL_21]], %[[VAL_22]], %[[VAL_28:.*]], %[[VAL_24:.*]]) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: fir.store %[[VAL_29]] to %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_5]] : !fir.ref>> +! CHECK: %[[VAL_32:.*]] = fir.box_addr %[[VAL_31]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[VAL_30]] to %[[VAL_32]] : !fir.ptr +! CHECK: return +! CHECK: } + +subroutine test_pointer_scalar(a) + real, save, pointer :: x1, x2, x3, x4 + integer :: sss + real :: a + + allocate(x1, x2, source = a) + allocate(x3, source = a) + allocate(x4, source = a, stat=sss) +end + +subroutine test_pointer_1d_array(n, a) + integer, pointer :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss, a(n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)) + allocate(x4, source = a(2:5:2), stat=sss) +end + +subroutine test_pointer_2d_array(n, a) + integer, pointer :: x1(:,:), x2(:,:), x3(:,:), x4(:,:) + integer :: n, sss, a(n, n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(1:3:2, 2:3)) + allocate(x4, source = a(1:3:2, 2:3), stat=sss) +end + +subroutine test_pointer_from_pointer(n, a) + integer, pointer :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + integer, pointer :: a(:) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)) + allocate(x4, source = a(2:5:2), stat=sss) +end + +subroutine test_pointer_from_allocatable(n, a) + integer, pointer :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + integer, pointer :: a(:) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)) + allocate(x4, source = a(2:5:2), stat=sss) +end + +subroutine test_pointer_with_shapespec(n, a, m) + integer, pointer :: x1(:), x2(:), x3(:), x4(:) + integer :: n, m, sss, a(n) + + allocate(x1(2:m), x2(n), source = a) + allocate(x3(2:m), source = a(3:)) + allocate(x4(2:m), source = a(3:), stat=sss) +end + +subroutine test_pointer_from_const(n, a) + integer, pointer :: x1(:), x2(:), x3(:) + integer :: n, sss, a(n) + + allocate(x1, x2, source = [1, 2, 3, 4, 5]) + allocate(x3, source = [1, 2, 3, 4, 5]) + allocate(x3, source = [1, 2, 3, 4, 5], stat=sss) +end + +subroutine test_pointer_chararray(n, a) + character(4), pointer :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + character(3) :: a(n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)(2:)) + allocate(x4, source = a(2:5:2)(3:), stat=sss) +end + +subroutine test_pointer_chararray_unknown_len(n, a) + character(:), pointer :: x1(:), x2(:), x3(:), x4(:) + integer :: n, sss + character(3) :: a(n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5:2)(2:)) + allocate(x4, source = a(2:5:2)(3:), stat=sss) +end + +subroutine test_pointer_char(n, a) + character(:), pointer :: x1, x2, x3, x4 + integer :: n, sss + character(*) :: a + + allocate(x1, x2, source = a) + allocate(x3, source = a(2:5)) + allocate(x4, source = a(2:3), stat=sss) +end + +subroutine test_pointer_derived_type(z1, z2) + type t + integer, pointer :: x(:) + end type + type(t), pointer :: x(:), y(:) + integer, pointer :: z1(:), z2(:) + + allocate(y(2)) + allocate(y(1)%x(2), source = z1) + allocate(y(2)%x(2), source = z2) + allocate(x, source=y) +end