diff --git a/flang/include/flang/Optimizer/Builder/Character.h b/flang/include/flang/Optimizer/Builder/Character.h index c83076ee81987..658118eddcc90 100644 --- a/flang/include/flang/Optimizer/Builder/Character.h +++ b/flang/include/flang/Optimizer/Builder/Character.h @@ -235,6 +235,11 @@ std::pair extractCharacterProcedureTuple(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value tuple, bool openBoxProc = true); +fir::CharBoxValue convertCharacterKind(fir::FirOpBuilder &builder, + mlir::Location loc, + fir::CharBoxValue srcBoxChar, + int toKind); + } // namespace fir::factory #endif // FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h index f0b66baddd960..07bb380320bf7 100644 --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -427,6 +427,29 @@ std::pair createTempFromMold(mlir::Location loc, fir::FirOpBuilder &builder, hlfir::Entity mold); +hlfir::EntityWithAttributes convertCharacterKind(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity scalarChar, + int toKind); + +/// Materialize an implicit Fortran type conversion from \p source to \p toType. +/// This is a no-op if the Fortran category and KIND of \p source are +/// the same as the one in \p toType. This is also a no-op if \p toType is an +/// unlimited polymorphic. For characters, this implies that a conversion is +/// only inserted in case of KIND mismatch (and not in case of length mismatch), +/// and that the resulting entity length is the same as the one from \p source. +/// It is valid to call this helper if \p source is an array. If a conversion is +/// inserted for arrays, a clean-up will be returned. If no conversion is +/// needed, the source is returned. +/// Beware that the resulting entity mlir type may not be toType: it will be a +/// Fortran entity with the same Fortran category and KIND. +/// If preserveLowerBounds is set, the returned entity will have the same lower +/// bounds as \p source. +std::pair> +genTypeAndKindConvert(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity source, mlir::Type toType, + bool preserveLowerBounds); + } // namespace hlfir #endif // FORTRAN_OPTIMIZER_BUILDER_HLFIRTOOLS_H diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 761cedb97fb95..9875e37393ef8 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -3372,47 +3372,25 @@ class FirConverter : public Fortran::lower::AbstractConverter { } } - /// Given converted LHS and RHS of the assignment, generate - /// explicit type conversion for implicit Logical<->Integer - /// conversion. Return Value representing the converted RHS, - /// if the implicit Logical<->Integer is detected, otherwise, - /// return nullptr. The caller is responsible for inserting - /// DestroyOp in case the returned value has hlfir::ExprType. - mlir::Value - genImplicitLogicalConvert(const Fortran::evaluate::Assignment &assign, - hlfir::Entity rhs, - Fortran::lower::StatementContext &stmtCtx) { - mlir::Type fromTy = rhs.getFortranElementType(); - if (!fromTy.isa()) - return nullptr; - - mlir::Type toTy = hlfir::getFortranElementType(genType(assign.lhs)); - if (fromTy == toTy) - return nullptr; - if (!toTy.isa()) - return nullptr; - + /// Given converted LHS and RHS of the assignment, materialize any + /// implicit conversion of the RHS to the LHS type. The front-end + /// usually already makes those explicit, except for non-standard + /// LOGICAL <-> INTEGER, or if the LHS is a whole allocatable + /// (making the conversion explicit in the front-end would prevent + /// propagation of the LHS lower bound in the reallocation). + /// If array temporaries or values are created, the cleanups are + /// added in the statement context. + hlfir::Entity genImplicitConvert(const Fortran::evaluate::Assignment &assign, + hlfir::Entity rhs, bool preserveLowerBounds, + Fortran::lower::StatementContext &stmtCtx) { mlir::Location loc = toLocation(); auto &builder = getFirOpBuilder(); - if (assign.rhs.Rank() == 0) - return builder.createConvert(loc, toTy, rhs); - - mlir::Value shape = hlfir::genShape(loc, builder, rhs); - auto genKernel = - [&rhs, &toTy](mlir::Location loc, fir::FirOpBuilder &builder, - mlir::ValueRange oneBasedIndices) -> hlfir::Entity { - auto elementPtr = hlfir::getElementAt(loc, builder, rhs, oneBasedIndices); - auto val = hlfir::loadTrivialScalar(loc, builder, elementPtr); - return hlfir::EntityWithAttributes{builder.createConvert(loc, toTy, val)}; - }; - mlir::Value convertedRhs = hlfir::genElementalOp( - loc, builder, toTy, shape, /*typeParams=*/{}, genKernel, - /*isUnordered=*/true); - fir::FirOpBuilder *bldr = &builder; - stmtCtx.attachCleanup([loc, bldr, convertedRhs]() { - bldr->create(loc, convertedRhs); - }); - return convertedRhs; + mlir::Type toType = genType(assign.lhs); + auto valueAndPair = hlfir::genTypeAndKindConvert(loc, builder, rhs, toType, + preserveLowerBounds); + if (valueAndPair.second) + stmtCtx.attachCleanup(*valueAndPair.second); + return hlfir::Entity{valueAndPair.first}; } static void @@ -3476,14 +3454,17 @@ class FirConverter : public Fortran::lower::AbstractConverter { // loops early if possible. This also dereferences pointer and // allocatable RHS: the target is being assigned from. rhs = hlfir::loadTrivialScalar(loc, builder, rhs); - // In intrinsic assignments, Logical<->Integer assignments are allowed as - // an extension, but there is no explicit Convert expression for the RHS. - // Recognize the type mismatch here and insert explicit scalar convert or - // ElementalOp for array assignment. + // In intrinsic assignments, the LHS type may not match the RHS type, in + // which case an implicit conversion of the LHS must be done. The + // front-end usually makes it explicit, unless it cannot (whole + // allocatable LHS or Logical<->Integer assignment extension). Recognize + // any type mismatches here and insert explicit scalar convert or + // ElementalOp for array assignment. Preserve the RHS lower bounds on the + // converted entity in case of assignment to whole allocatables so to + // propagate the lower bounds to the LHS in case of reallocation. if (!userDefinedAssignment) - if (mlir::Value conversion = - genImplicitLogicalConvert(assign, rhs, stmtCtx)) - rhs = hlfir::Entity{conversion}; + rhs = genImplicitConvert(assign, rhs, isWholeAllocatableAssignment, + stmtCtx); return rhs; }; diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index 1a2b3856c5267..76d810e9df6dc 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -1237,41 +1237,8 @@ class ScalarExprLowering { [&](const fir::CharBoxValue &boxchar) -> ExtValue { if constexpr (TC1 == Fortran::common::TypeCategory::Character && TC2 == TC1) { - // Use char_convert. Each code point is translated from a - // narrower/wider encoding to the target encoding. For example, 'A' - // may be translated from 0x41 : i8 to 0x0041 : i16. The symbol - // for euro (0x20AC : i16) may be translated from a wide character - // to "0xE2 0x82 0xAC" : UTF-8. - mlir::Value bufferSize = boxchar.getLen(); - auto kindMap = builder.getKindMap(); - mlir::Value boxCharAddr = boxchar.getAddr(); - auto fromTy = boxCharAddr.getType(); - if (auto charTy = fromTy.dyn_cast()) { - // boxchar is a value, not a variable. Turn it into a temporary. - // As a value, it ought to have a constant LEN value. - assert(charTy.hasConstantLen() && "must have constant length"); - mlir::Value tmp = builder.createTemporary(loc, charTy); - builder.create(loc, boxCharAddr, tmp); - boxCharAddr = tmp; - } - auto fromBits = - kindMap.getCharacterBitsize(fir::unwrapRefType(fromTy) - .cast() - .getFKind()); - auto toBits = kindMap.getCharacterBitsize( - ty.cast().getFKind()); - if (toBits < fromBits) { - // Scale by relative ratio to give a buffer of the same length. - auto ratio = builder.createIntegerConstant( - loc, bufferSize.getType(), fromBits / toBits); - bufferSize = - builder.create(loc, bufferSize, ratio); - } - auto dest = builder.create( - loc, ty, mlir::ValueRange{bufferSize}); - builder.create(loc, boxCharAddr, - boxchar.getLen(), dest); - return fir::CharBoxValue{dest, boxchar.getLen()}; + return fir::factory::convertCharacterKind(builder, loc, boxchar, + KIND); } else { fir::emitFatalError( loc, "unsupported evaluate::Convert between CHARACTER type " @@ -3965,7 +3932,7 @@ class ArrayExprLowering { auto castTo = builder.createConvert(loc, memrefTy, origVal); origVal = builder.create(loc, eleTy, castTo); } - mlir::Value val = builder.createConvert(loc, eleTy, origVal); + mlir::Value val = builder.convertWithSemantics(loc, eleTy, origVal); if (isBoundsSpec()) { assert(lbounds.has_value()); auto lbs = *lbounds; diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp index 1da6a5bdd5478..5a51493c9aaa5 100644 --- a/flang/lib/Lower/ConvertExprToHLFIR.cpp +++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -1367,37 +1367,7 @@ struct UnaryOp< hlfir::Entity lhs) { if constexpr (TC1 == Fortran::common::TypeCategory::Character && TC2 == TC1) { - auto kindMap = builder.getKindMap(); - mlir::Type fromTy = lhs.getFortranElementType(); - mlir::Value origBufferSize = genCharLength(loc, builder, lhs); - mlir::Value bufferSize{origBufferSize}; - auto fromBits = kindMap.getCharacterBitsize( - fir::unwrapRefType(fromTy).cast().getFKind()); - mlir::Type toTy = Fortran::lower::getFIRType( - builder.getContext(), TC1, KIND, /*params=*/std::nullopt); - auto toBits = kindMap.getCharacterBitsize( - toTy.cast().getFKind()); - if (toBits < fromBits) { - // Scale by relative ratio to give a buffer of the same length. - auto ratio = builder.createIntegerConstant(loc, bufferSize.getType(), - fromBits / toBits); - bufferSize = - builder.create(loc, bufferSize, ratio); - } - // allocate space on the stack for toBuffer - auto dest = builder.create(loc, toTy, - mlir::ValueRange{bufferSize}); - auto src = hlfir::convertToAddress(loc, builder, lhs, - lhs.getFortranElementType()); - builder.create(loc, src.first.getCharBox()->getAddr(), - origBufferSize, dest); - if (src.second.has_value()) - src.second.value()(); - - return hlfir::EntityWithAttributes{builder.create( - loc, dest, "ctor.temp", /*shape=*/nullptr, - /*typeparams=*/mlir::ValueRange{origBufferSize}, - fir::FortranVariableFlagsAttr{})}; + return hlfir::convertCharacterKind(loc, builder, lhs, KIND); } mlir::Type type = Fortran::lower::getFIRType(builder.getContext(), TC1, KIND, /*params=*/std::nullopt); @@ -1789,7 +1759,7 @@ class HlfirBuilder { // If it is allocatable, then using AssignOp for unallocated RHS // will cause illegal dereference. When an unallocated allocatable // value is used to construct an allocatable component, the component - // must just stay unallocated. + // must just stay unallocated (see Fortran 2018 7.5.10 point 7). // If the component is allocatable and RHS is NULL() expression, then // we can just skip it: the LHS must remain unallocated with its @@ -1798,56 +1768,44 @@ class HlfirBuilder { Fortran::evaluate::UnwrapExpr(expr)) continue; + bool keepLhsLength = false; + if (allowRealloc) + if (const Fortran::semantics::DeclTypeSpec *declType = sym.GetType()) + keepLhsLength = + declType->category() == + Fortran::semantics::DeclTypeSpec::Category::Character && + !declType->characterTypeSpec().length().isDeferred(); // Handle special case when the initializer expression is // '{%SET_LENGTH(x,const_kind)}'. In structure constructor, - // SET_LENGTH is used for initializers of character allocatable - // components with *explicit* length, because they have to keep - // their length regardless of the initializer expression's length. - // We cannot just lower SET_LENGTH into hlfir.set_length in case - // when 'x' is allocatable: if 'x' is unallocated, it is not clear - // what hlfir.expr should be produced by hlfir.set_length. - // So whenever the initializer expression is SET_LENGTH we - // recognize it as the directive to keep the explicit length - // of the LHS component, and we completely ignore 'const_kind' - // operand assuming that it matches the LHS component's explicit - // length. Note that in case when LHS component has deferred length, - // the FE does not produce SET_LENGTH expression. - // - // When SET_LENGTH is recognized, we use 'x' as the initializer - // for the LHS component. If 'x' is allocatable, the dynamic - // isAllocated check will guard the assign operation as usual. - bool keepLhsLength = false; - hlfir::Entity rhs = std::visit( - [&](const auto &x) -> hlfir::Entity { - using T = std::decay_t; - if constexpr (Fortran::common::HasMember< - T, Fortran::lower::CategoryExpression>) { - if constexpr (T::Result::category == - Fortran::common::TypeCategory::Character) { - return std::visit( - [&](const auto &someKind) -> hlfir::Entity { - using T = std::decay_t; - if (const auto *setLength = std::get_if< - Fortran::evaluate::SetLength>( - &someKind.u)) { - keepLhsLength = true; - return gen(setLength->left()); - } - - return gen(someKind); - }, - x.u); - } - } - return gen(x); - }, - expr.u); - - if (!allowRealloc || !rhs.isMutableBox()) { + // SET_LENGTH is used for initializers of non-allocatable character + // components so that the front-end can better + // fold and work with these structure constructors. + // Here, they are just noise since the assignment semantics will deal + // with any length mismatch, and creating an extra temp with the lhs + // length is useless. + // TODO: should this be moved into an hlfir.assign + hlfir.set_length + // pattern rewrite? + hlfir::Entity rhs = gen(expr); + if (auto set_length = rhs.getDefiningOp()) + rhs = hlfir::Entity{set_length.getString()}; + + // lambda to generate `lhs = rhs` and deal with potential rhs implicit + // cast + auto genAssign = [&] { rhs = hlfir::loadTrivialScalar(loc, builder, rhs); - builder.create(loc, rhs, lhs, allowRealloc, + auto rhsCastAndCleanup = + hlfir::genTypeAndKindConvert(loc, builder, rhs, lhs.getType(), + /*preserveLowerBounds=*/allowRealloc); + builder.create(loc, rhsCastAndCleanup.first, lhs, + allowRealloc, allowRealloc ? keepLhsLength : false, /*temporary_lhs=*/true); + if (rhsCastAndCleanup.second) + (*rhsCastAndCleanup.second)(); + }; + + if (!allowRealloc || !rhs.isMutableBox()) { + genAssign(); continue; } @@ -1860,14 +1818,7 @@ class HlfirBuilder { "to mutable box"); mlir::Value isAlloc = fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *fromBox); - builder.genIfThen(loc, isAlloc) - .genThen([&]() { - rhs = hlfir::loadTrivialScalar(loc, builder, rhs); - builder.create(loc, rhs, lhs, allowRealloc, - keepLhsLength, - /*temporary_lhs=*/true); - }) - .end(); + builder.genIfThen(loc, isAlloc).genThen(genAssign).end(); } return varOp; diff --git a/flang/lib/Optimizer/Builder/Character.cpp b/flang/lib/Optimizer/Builder/Character.cpp index 41cdd9a71c735..1a068b1313a6c 100644 --- a/flang/lib/Optimizer/Builder/Character.cpp +++ b/flang/lib/Optimizer/Builder/Character.cpp @@ -851,3 +851,42 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createCharExtremum( createAssign(toBuf, fromBuf); return temp; } + +fir::CharBoxValue +fir::factory::convertCharacterKind(fir::FirOpBuilder &builder, + mlir::Location loc, + fir::CharBoxValue srcBoxChar, int toKind) { + // Use char_convert. Each code point is translated from a + // narrower/wider encoding to the target encoding. For example, 'A' + // may be translated from 0x41 : i8 to 0x0041 : i16. The symbol + // for euro (0x20AC : i16) may be translated from a wide character + // to "0xE2 0x82 0xAC" : UTF-8. + mlir::Value bufferSize = srcBoxChar.getLen(); + auto kindMap = builder.getKindMap(); + mlir::Value boxCharAddr = srcBoxChar.getAddr(); + auto fromTy = boxCharAddr.getType(); + if (auto charTy = fromTy.dyn_cast()) { + // boxchar is a value, not a variable. Turn it into a temporary. + // As a value, it ought to have a constant LEN value. + assert(charTy.hasConstantLen() && "must have constant length"); + mlir::Value tmp = builder.createTemporary(loc, charTy); + builder.create(loc, boxCharAddr, tmp); + boxCharAddr = tmp; + } + auto fromBits = kindMap.getCharacterBitsize( + fir::unwrapRefType(fromTy).cast().getFKind()); + auto toBits = kindMap.getCharacterBitsize(toKind); + if (toBits < fromBits) { + // Scale by relative ratio to give a buffer of the same length. + auto ratio = builder.createIntegerConstant(loc, bufferSize.getType(), + fromBits / toBits); + bufferSize = builder.create(loc, bufferSize, ratio); + } + mlir::Type toType = + fir::CharacterType::getUnknownLen(builder.getContext(), toKind); + auto dest = builder.createTemporary(loc, toType, /*name=*/{}, /*shape=*/{}, + mlir::ValueRange{bufferSize}); + builder.create(loc, boxCharAddr, srcBoxChar.getLen(), + dest); + return fir::CharBoxValue{dest, srcBoxChar.getLen()}; +} diff --git a/flang/lib/Optimizer/Builder/HLFIRTools.cpp b/flang/lib/Optimizer/Builder/HLFIRTools.cpp index cc4bdf356ae9b..3d0a59b468ba7 100644 --- a/flang/lib/Optimizer/Builder/HLFIRTools.cpp +++ b/flang/lib/Optimizer/Builder/HLFIRTools.cpp @@ -1092,3 +1092,102 @@ hlfir::createTempFromMold(mlir::Location loc, fir::FirOpBuilder &builder, return {hlfir::Entity{declareOp.getBase()}, isHeapAlloc}; } + +hlfir::EntityWithAttributes +hlfir::convertCharacterKind(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity scalarChar, int toKind) { + auto src = hlfir::convertToAddress(loc, builder, scalarChar, + scalarChar.getFortranElementType()); + assert(src.first.getCharBox() && "must be scalar character"); + fir::CharBoxValue res = fir::factory::convertCharacterKind( + builder, loc, *src.first.getCharBox(), toKind); + if (src.second.has_value()) + src.second.value()(); + + return hlfir::EntityWithAttributes{builder.create( + loc, res.getAddr(), ".temp.kindconvert", /*shape=*/nullptr, + /*typeparams=*/mlir::ValueRange{res.getLen()}, + fir::FortranVariableFlagsAttr{})}; +} + +std::pair> +hlfir::genTypeAndKindConvert(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity source, mlir::Type toType, + bool preserveLowerBounds) { + mlir::Type fromType = source.getFortranElementType(); + toType = hlfir::getFortranElementType(toType); + if (!toType || fromType == toType || + !(fir::isa_trivial(toType) || mlir::isa(toType))) + return {source, std::nullopt}; + + std::optional toKindCharConvert; + if (auto toCharTy = mlir::dyn_cast(toType)) { + if (auto fromCharTy = mlir::dyn_cast(fromType)) + if (toCharTy.getFKind() != fromCharTy.getFKind()) + toKindCharConvert = toCharTy.getFKind(); + // Do not convert in case of character length mismatch only, hlfir.assign + // deals with it. + if (!toKindCharConvert) + return {source, std::nullopt}; + } + + if (source.getRank() == 0) { + mlir::Value cast = toKindCharConvert + ? mlir::Value{hlfir::convertCharacterKind( + loc, builder, source, *toKindCharConvert)} + : builder.convertWithSemantics(loc, toType, source); + return {hlfir::Entity{cast}, std::nullopt}; + } + + mlir::Value shape = hlfir::genShape(loc, builder, source); + auto genKernel = [source, toType, toKindCharConvert]( + mlir::Location loc, fir::FirOpBuilder &builder, + mlir::ValueRange oneBasedIndices) -> hlfir::Entity { + auto elementPtr = + hlfir::getElementAt(loc, builder, source, oneBasedIndices); + auto val = hlfir::loadTrivialScalar(loc, builder, elementPtr); + if (toKindCharConvert) + return hlfir::convertCharacterKind(loc, builder, val, *toKindCharConvert); + return hlfir::EntityWithAttributes{ + builder.convertWithSemantics(loc, toType, val)}; + }; + llvm::SmallVector lenParams; + hlfir::genLengthParameters(loc, builder, source, lenParams); + mlir::Value convertedRhs = + hlfir::genElementalOp(loc, builder, toType, shape, lenParams, genKernel, + /*isUnordered=*/true); + + if (preserveLowerBounds && source.hasNonDefaultLowerBounds()) { + hlfir::AssociateOp associate = + genAssociateExpr(loc, builder, hlfir::Entity{convertedRhs}, + convertedRhs.getType(), ".tmp.keeplbounds"); + fir::ShapeOp shapeOp = associate.getShape().getDefiningOp(); + assert(shapeOp && "associate shape must be a fir.shape"); + const unsigned rank = shapeOp.getExtents().size(); + llvm::SmallVector lbAndExtents; + for (unsigned dim = 0; dim < rank; ++dim) { + lbAndExtents.push_back(hlfir::genLBound(loc, builder, source, dim)); + lbAndExtents.push_back(shapeOp.getExtents()[dim]); + } + auto shapeShiftType = fir::ShapeShiftType::get(builder.getContext(), rank); + mlir::Value shapeShift = + builder.create(loc, shapeShiftType, lbAndExtents); + auto declareOp = builder.create( + loc, associate.getFirBase(), associate.getUniqName(), shapeShift, + associate.getTypeparams(), /*flags=*/fir::FortranVariableFlagsAttr{}); + hlfir::Entity castWithLbounds = + mlir::cast(declareOp.getOperation()); + fir::FirOpBuilder *bldr = &builder; + auto cleanup = [loc, bldr, convertedRhs, associate]() { + bldr->create(loc, associate); + bldr->create(loc, convertedRhs); + }; + return {castWithLbounds, cleanup}; + } + + fir::FirOpBuilder *bldr = &builder; + auto cleanup = [loc, bldr, convertedRhs]() { + bldr->create(loc, convertedRhs); + }; + return {hlfir::Entity{convertedRhs}, cleanup}; +} diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 4ccb2c3ef5d01..33baf56f202d3 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1857,6 +1857,23 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) { return acContext.ToExpr(); } +// Check if implicit conversion of expr to the symbol type is legal (if needed), +// and make it explicit if requested. +static MaybeExpr implicitConvertTo(const semantics::Symbol &sym, + Expr &&expr, bool keepConvertImplicit) { + if (!keepConvertImplicit) { + return ConvertToType(sym, std::move(expr)); + } else { + // Test if a convert could be inserted, but do not make it explicit to + // preserve the information that expr is a variable. + if (ConvertToType(sym, common::Clone(expr))) { + return MaybeExpr{std::move(expr)}; + } + } + // Illegal implicit convert. + return std::nullopt; +} + MaybeExpr ExpressionAnalyzer::Analyze( const parser::StructureConstructor &structure) { auto &parsedType{std::get(structure.t)}; @@ -2061,7 +2078,15 @@ MaybeExpr ExpressionAnalyzer::Analyze( visible->name(), symbol->name(), pointer->name()); } } - if (MaybeExpr converted{ConvertToType(*symbol, std::move(*value))}) { + // Make implicit conversion explicit to allow folding of the structure + // constructors and help semantic checking, unless the component is + // allocatable, in which case the value could be an unallocated + // allocatable (see Fortran 2018 7.5.10 point 7). The explicit + // convert would cause a segfault. Lowering will deal with + // conditionally converting and preserving the lower bounds in this + // case. + if (MaybeExpr converted{implicitConvertTo( + *symbol, std::move(*value), IsAllocatable(*symbol))}) { if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) { if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) { if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) { @@ -4180,7 +4205,12 @@ std::optional ArgumentAnalyzer::TryDefinedAssignment() { Tristate isDefined{ semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)}; if (isDefined == Tristate::No) { - if (lhsType && rhsType) { + // Make implicit conversion explicit, unless it is an assignment to a whole + // allocatable (the explicit conversion would prevent the propagation of the + // right hand side if it is a variable). Lowering will deal with the + // conversion in this case. + if (lhsType && rhsType && + (!IsAllocatableDesignator(lhs) || context_.inWhereBody())) { AddAssignmentConversion(*lhsType, *rhsType); } if (!fatalErrors_) { diff --git a/flang/test/Lower/HLFIR/charconvert.f90 b/flang/test/Lower/HLFIR/charconvert.f90 index 9b9c8670077dd..9a0ad1e455128 100644 --- a/flang/test/Lower/HLFIR/charconvert.f90 +++ b/flang/test/Lower/HLFIR/charconvert.f90 @@ -19,10 +19,10 @@ end subroutine charconvert1 ! CHECK: %[[C4_4:.*]] = arith.constant 4 : index ! CHECK: %[[VAL_38:.*]] = arith.divsi %[[VAL_37]], %[[C4_4]] : index ! CHECK: %[[VAL_39:.*]] = hlfir.designate %[[VAL_2]]#0 (%[[ARG2]]) typeparams %[[VAL_38]] : (!fir.box>>, index, index) -> !fir.boxchar<4> +! CHECK: %[[VAL_42:.*]]:2 = fir.unboxchar %[[VAL_39]] : (!fir.boxchar<4>) -> (!fir.ref>, index) ! CHECK: %[[C4_5:.*]] = arith.constant 4 : index ! CHECK: %[[VAL_40:.*]] = arith.muli %[[VAL_38]], %[[C4_5]] : index ! CHECK: %[[VAL_41:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_40]] : index) -! CHECK: %[[VAL_42:.*]]:2 = fir.unboxchar %[[VAL_39]] : (!fir.boxchar<4>) -> (!fir.ref>, index) ! CHECK: fir.char_convert %[[VAL_42]]#0 for %[[VAL_38:.*]] to %[[VAL_41]] : !fir.ref>, index, !fir.ref> subroutine charconvert2(x) @@ -63,9 +63,9 @@ subroutine charconvert3(c, c4) ! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]]#0 typeparams %[[VAL_2]]#1 {uniq_name = "_QFcharconvert3Ec4"} : (!fir.ref>, index) -> (!fir.boxchar<4>, !fir.ref>) ! CHECK: %[[VAL_4:.*]] = arith.addi %[[VAL_0]]#1, %[[VAL_0]]#1 : index ! CHECK: %[[VAL_5:.*]] = hlfir.concat %[[VAL_1]]#0, %[[VAL_1]]#0 len %[[VAL_4]] : (!fir.boxchar<1>, !fir.boxchar<1>, index) -> !hlfir.expr> -! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.char<4,?>(%[[VAL_4]] : index) ! CHECK: %[[VAL_7:.*]]:3 = hlfir.associate %[[VAL_5]] typeparams %[[VAL_4]] {uniq_name = "adapt.valuebyref"} : (!hlfir.expr>, index) -> (!fir.boxchar<1>, !fir.ref>, i1) +! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.char<4,?>(%[[VAL_4]] : index) ! CHECK: fir.char_convert %[[VAL_7]]#1 for %[[VAL_4:.*]] to %[[VAL_6]] : !fir.ref>, index, !fir.ref> ! CHECK: hlfir.end_associate %[[VAL_7]]#1, %[[VAL_7]]#2 : !fir.ref>, i1 -! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]] typeparams %[[VAL_4]] {uniq_name = "ctor.temp"} : (!fir.ref>, index) -> (!fir.boxchar<4>, !fir.ref>) -! CHECK: hlfir.assign %[[VAL_8]]#0 to %[[VAL_3]]#0 : !fir.boxchar<4>, !fir.boxchar<4> \ No newline at end of file +! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]] typeparams %[[VAL_4]] {uniq_name = ".temp.kindconvert"} : (!fir.ref>, index) -> (!fir.boxchar<4>, !fir.ref>) +! CHECK: hlfir.assign %[[VAL_8]]#0 to %[[VAL_3]]#0 : !fir.boxchar<4>, !fir.boxchar<4> diff --git a/flang/test/Lower/HLFIR/implicit-type-conversion-allocatable.f90 b/flang/test/Lower/HLFIR/implicit-type-conversion-allocatable.f90 new file mode 100644 index 0000000000000..7083a825dfd3b --- /dev/null +++ b/flang/test/Lower/HLFIR/implicit-type-conversion-allocatable.f90 @@ -0,0 +1,40 @@ +! Test implicit conversion in assignment to whole allocatables. It +! is special because care must be taken to propagate the RHS lower +! bounds to the LHS in case of re-allocation. +! RUN: bbc -emit-hlfir %s -o - | FileCheck %s + +subroutine preserve_lbounds(x, y) + integer, allocatable :: x(:) + complex, allocatable :: y(:) + x = y +end subroutine +! CHECK-LABEL: func.func @_QPpreserve_lbounds( +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare {{.*}}uniq_name = "_QFpreserve_lboundsEx" +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}uniq_name = "_QFpreserve_lboundsEy" +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]]#0 : !fir.ref>>>> +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_4]], %[[VAL_5]] : (!fir.box>>>, index) -> (index, index, index) +! CHECK: %[[VAL_7:.*]] = fir.shape %[[VAL_6]]#1 : (index) -> !fir.shape<1> +! CHECK: %[[VAL_8:.*]] = hlfir.elemental %[[VAL_7]] unordered : (!fir.shape<1>) -> !hlfir.expr { +! CHECK: ^bb0(%[[VAL_9:.*]]: index): +! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_4]], %[[VAL_10]] : (!fir.box>>>, index) -> (index, index, index) +! CHECK: %[[VAL_12:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_13:.*]] = arith.subi %[[VAL_11]]#0, %[[VAL_12]] : index +! CHECK: %[[VAL_14:.*]] = arith.addi %[[VAL_9]], %[[VAL_13]] : index +! CHECK: %[[VAL_15:.*]] = hlfir.designate %[[VAL_4]] (%[[VAL_14]]) : (!fir.box>>>, index) -> !fir.ref> +! CHECK: %[[VAL_16:.*]] = fir.load %[[VAL_15]] : !fir.ref> +! CHECK: %[[VAL_17:.*]] = fir.extract_value %[[VAL_16]], [0 : index] : (!fir.complex<4>) -> f32 +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_17]] : (f32) -> i32 +! CHECK: hlfir.yield_element %[[VAL_18]] : i32 +! CHECK: } +! CHECK: %[[VAL_19:.*]]:3 = hlfir.associate %[[VAL_8]](%[[VAL_7]]) {uniq_name = ".tmp.keeplbounds"} : (!hlfir.expr, !fir.shape<1>) -> (!fir.box>, !fir.ref>, i1) +! CHECK: %[[VAL_20:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_21:.*]]:3 = fir.box_dims %[[VAL_4]], %[[VAL_20]] : (!fir.box>>>, index) -> (index, index, index) +! CHECK: %[[VAL_22:.*]] = fir.shape_shift %[[VAL_21]]#0, %[[VAL_6]]#1 : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_23:.*]]:2 = hlfir.declare %[[VAL_19]]#1(%[[VAL_22]]) {uniq_name = ".tmp.keeplbounds"} : (!fir.ref>, !fir.shapeshift<1>) -> (!fir.box>, !fir.ref>) +! CHECK: hlfir.assign %[[VAL_23]]#0 to %[[VAL_2]]#0 realloc : !fir.box>, !fir.ref>>> +! CHECK: hlfir.end_associate %[[VAL_19]]#1, %[[VAL_19]]#2 : !fir.ref>, i1 +! CHECK: hlfir.destroy %[[VAL_8]] : !hlfir.expr +! CHECK: return +! CHECK: } diff --git a/flang/test/Lower/charconvert.f90 b/flang/test/Lower/charconvert.f90 index 693d5bf603788..c8ec254b6a541 100644 --- a/flang/test/Lower/charconvert.f90 +++ b/flang/test/Lower/charconvert.f90 @@ -29,4 +29,4 @@ subroutine test_c4_to_c1(c4, c1) ! CHECK: %[[VAL_4:.*]] = arith.muli %[[VAL_2]]#1, %[[C4]] : index ! CHECK: %[[VAL_5:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_4]] : index) ! CHECK: fir.char_convert %[[VAL_3]]#1 for %[[VAL_2]]#1 to %[[VAL_5:.*]] : !fir.ref>, index, !fir.ref> -! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_5]] typeparams %[[VAL_2]]#1 {uniq_name = "ctor.temp"} : (!fir.ref>, index) -> (!fir.boxchar<1>, !fir.ref>) \ No newline at end of file +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_5]] typeparams %[[VAL_2]]#1 {uniq_name = ".temp.kindconvert"} : (!fir.ref>, index) -> (!fir.boxchar<1>, !fir.ref>)