diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h --- a/flang/include/flang/Lower/Allocatable.h +++ b/flang/include/flang/Lower/Allocatable.h @@ -60,11 +60,10 @@ /// Create a MutableBoxValue for an allocatable or pointer entity. /// If the variables is a local variable that is not a dummy, it will be /// initialized to unallocated/diassociated status. -fir::MutableBoxValue createMutableBox(AbstractConverter &converter, - mlir::Location loc, - const pft::Variable &var, - mlir::Value boxAddr, - mlir::ValueRange nonDeferredParams); +fir::MutableBoxValue +createMutableBox(AbstractConverter &converter, mlir::Location loc, + const pft::Variable &var, mlir::Value boxAddr, + mlir::ValueRange nonDeferredParams, bool alwaysUseBox); /// Assign a boxed value to a boxed variable, \p box (known as a /// MutableBoxValue). Expression \p source will be lowered to build the diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -77,13 +77,20 @@ bool isBoxAddressOrValue() const { return hlfir::isBoxAddressOrValueType(getType()); } - bool isArray() const { + /// Is this an array or an assumed ranked entity? + bool isArray() const { return getRank() != 0; } + + /// Return the rank of this entity or -1 if it is an assumed rank. + int getRank() const { mlir::Type type = fir::unwrapPassByRefType(fir::unwrapRefType(getType())); - if (type.isa()) - return true; + if (auto seqTy = type.dyn_cast()) { + if (seqTy.hasUnknownShape()) + return -1; + return seqTy.getDimension(); + } if (auto exprType = type.dyn_cast()) - return exprType.isArray(); - return false; + return exprType.getRank(); + return 0; } bool isScalar() const { return !isArray(); } @@ -107,6 +114,10 @@ return getFortranElementType().isa(); } + bool isDerivedWithLengthParameters() const { + return fir::isRecordWithTypeParameters(getFortranElementType()); + } + bool hasNonDefaultLowerBounds() const { if (!isBoxAddressOrValue() || isScalar()) return false; @@ -123,10 +134,37 @@ return true; } + // Is this entity known to be contiguous at compile time? + // Note that when this returns false, the entity may still + // turn-out to be contiguous at runtime. + bool isSimplyContiguous() const { + // If this can be described without a fir.box in FIR, this must + // be contiguous. + if (!hlfir::isBoxAddressOrValueType(getFirBase().getType())) + return true; + // Otherwise, if this entity has a visible declaration in FIR, + // or is the dereference of an allocatable or contiguous pointer + // it is simply contiguous. + if (auto varIface = getMaybeDereferencedVariableInterface()) + return varIface.isAllocatable() || varIface.hasContiguousAttr(); + return false; + } + fir::FortranVariableOpInterface getIfVariableInterface() const { return this->getDefiningOp(); } + // Return a "declaration" operation for this variable if visible, + // or the "declaration" operation of the allocatable/pointer this + // variable was dereferenced from (if it is visible). + fir::FortranVariableOpInterface + getMaybeDereferencedVariableInterface() const { + mlir::Value base = *this; + if (auto loadOp = base.getDefiningOp()) + base = loadOp.getMemref(); + return base.getDefiningOp(); + } + // Get the entity as an mlir SSA value containing all the shape, type // parameters and dynamic shape information. mlir::Value getBase() const { return *this; } diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -979,6 +979,8 @@ let results = (outs AnyCodeOrDataRefLike); let hasFolder = 1; + + let builders = [OpBuilder<(ins "mlir::Value":$val)>]; } def fir_BoxCharLenOp : fir_SimpleOp<"boxchar_len", [NoMemoryEffect]> { diff --git a/flang/include/flang/Optimizer/Dialect/FortranVariableInterface.td b/flang/include/flang/Optimizer/Dialect/FortranVariableInterface.td --- a/flang/include/flang/Optimizer/Dialect/FortranVariableInterface.td +++ b/flang/include/flang/Optimizer/Dialect/FortranVariableInterface.td @@ -122,6 +122,15 @@ fir::FortranVariableFlagsEnum::optional); } + /// Does this variable have the Fortran CONTIGUOUS attribute? + /// Note that not having this attribute does not imply the + /// variable is not contiguous. + bool hasContiguousAttr() { + auto attrs = getFortranAttrs(); + return attrs && bitEnumContainsAny(*attrs, + fir::FortranVariableFlagsEnum::contiguous); + } + /// Is this a Fortran character variable? bool isCharacter() { return getElementType().isa(); 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 @@ -836,7 +836,7 @@ createMutableProperties(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::pft::Variable &var, - mlir::ValueRange nonDeferredParams) { + mlir::ValueRange nonDeferredParams, bool alwaysUseBox) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const Fortran::semantics::Symbol &sym = var.getSymbol(); // Globals and dummies may be associated, creating local variables would @@ -850,7 +850,7 @@ // Pointer/Allocatable in internal procedure are descriptors in the host link, // and it would increase complexity to sync this descriptor with the local // values every time the host link is escaping. - if (var.isGlobal() || Fortran::semantics::IsDummy(sym) || + if (alwaysUseBox || var.isGlobal() || Fortran::semantics::IsDummy(sym) || Fortran::semantics::IsFunctionResult(sym) || sym.attrs().test(Fortran::semantics::Attr::VOLATILE) || isNonContiguousArrayPointer(sym) || useAllocateRuntime || @@ -903,10 +903,10 @@ fir::MutableBoxValue Fortran::lower::createMutableBox( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::pft::Variable &var, mlir::Value boxAddr, - mlir::ValueRange nonDeferredParams) { + mlir::ValueRange nonDeferredParams, bool alwaysUseBox) { - fir::MutableProperties mutableProperties = - createMutableProperties(converter, loc, var, nonDeferredParams); + fir::MutableProperties mutableProperties = createMutableProperties( + converter, loc, var, nonDeferredParams, alwaysUseBox); fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol())) 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 @@ -637,7 +637,41 @@ TODO(loc, "HLFIR PassBy::Box"); } break; case PassBy::MutableBox: { - TODO(loc, "HLFIR PassBy::MutableBox"); + if (Fortran::evaluate::UnwrapExpr( + *expr)) { + // If expr is NULL(), the mutableBox created must be a deallocated + // pointer with the dummy argument characteristics (see table 16.5 + // in Fortran 2018 standard). + // No length parameters are set for the created box because any non + // deferred type parameters of the dummy will be evaluated on the + // callee side, and it is illegal to use NULL without a MOLD if any + // dummy length parameters are assumed. + mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy); + assert(boxTy && boxTy.isa() && "must be a fir.box type"); + mlir::Value boxStorage = builder.createTemporary(loc, boxTy); + mlir::Value nullBox = fir::factory::createUnallocatedBox( + builder, loc, boxTy, /*nonDeferredParams=*/{}); + builder.create(loc, nullBox, boxStorage); + caller.placeInput(arg, boxStorage); + continue; + } + if (fir::isPointerType(argTy) && + !Fortran::evaluate::IsObjectPointer( + *expr, callContext.converter.getFoldingContext())) { + // Passing a non POINTER actual argument to a POINTER dummy argument. + // Create a pointer of the dummy argument type and assign the actual + // argument to it. + TODO(loc, "Associate POINTER dummy to TARGET argument in HLFIR"); + continue; + } + // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE. + assert(actual.isMutableBox() && "actual must be a mutable box"); + caller.placeInput(arg, actual); + if (fir::isAllocatableType(argTy) && arg.isIntentOut() && + Fortran::semantics::IsBindCProcedure( + *callContext.procRef.proc().GetSymbol())) { + TODO(loc, "BIND(C) INTENT(OUT) allocatable deallocation in HLFIR"); + } } break; } } diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -1428,10 +1428,23 @@ Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, fir::MutableBoxValue box, bool force = false) { - if (converter.getLoweringOptions().getLowerToHighLevelFIR()) - TODO(genLocation(converter, sym), - "generate fir.declare for allocatable or pointers"); - symMap.addAllocatableOrPointer(sym, box, force); + if (!converter.getLoweringOptions().getLowerToHighLevelFIR()) { + symMap.addAllocatableOrPointer(sym, box, force); + return; + } + assert(!box.isDescribedByVariables() && + "HLFIR alloctables/pointers must be fir.ref"); + mlir::Value base = box.getAddr(); + mlir::Value explictLength; + if (box.hasNonDeferredLenParams()) { + if (!box.isCharacter()) + TODO(genLocation(converter, sym), + "Pointer or Allocatable parametrized derived type"); + explictLength = box.nonDeferredLenParams()[0]; + } + genDeclareSymbol(converter, symMap, sym, base, explictLength, + /*shape=*/std::nullopt, + /*lbounds=*/std::nullopt, force); } /// Map a symbol represented with a runtime descriptor to its FIR fir.box and @@ -1522,7 +1535,9 @@ "derived type allocatable or pointer with length parameters"); } fir::MutableBoxValue box = Fortran::lower::createMutableBox( - converter, loc, var, boxAlloc, nonDeferredLenParams); + converter, loc, var, boxAlloc, nonDeferredLenParams, + /*alwaysUseBox=*/ + converter.getLoweringOptions().getLowerToHighLevelFIR()); genAllocatableOrPointerDeclare(converter, symMap, var.getSymbol(), box, replace); return; diff --git a/flang/lib/Optimizer/Builder/HLFIRTools.cpp b/flang/lib/Optimizer/Builder/HLFIRTools.cpp --- a/flang/lib/Optimizer/Builder/HLFIRTools.cpp +++ b/flang/lib/Optimizer/Builder/HLFIRTools.cpp @@ -11,6 +11,7 @@ //===----------------------------------------------------------------------===// #include "flang/Optimizer/Builder/HLFIRTools.h" +#include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/MutableBox.h" #include "flang/Optimizer/Builder/Todo.h" @@ -20,7 +21,8 @@ // Return explicit extents. If the base is a fir.box, this won't read it to // return the extents and will instead return an empty vector. -static llvm::SmallVector getExplicitExtents(mlir::Value shape) { +static llvm::SmallVector +getExplicitExtentsFromShape(mlir::Value shape) { llvm::SmallVector result; auto *shapeOp = shape.getDefiningOp(); if (auto s = mlir::dyn_cast_or_null(shapeOp)) { @@ -39,13 +41,14 @@ static llvm::SmallVector getExplicitExtents(fir::FortranVariableOpInterface var) { if (mlir::Value shape = var.getShape()) - return getExplicitExtents(var.getShape()); + return getExplicitExtentsFromShape(var.getShape()); return {}; } // Return explicit lower bounds. For pointers and allocatables, this will not // read the lower bounds and instead return an empty vector. -static llvm::SmallVector getExplicitLbounds(mlir::Value shape) { +static llvm::SmallVector +getExplicitLboundsFromShape(mlir::Value shape) { llvm::SmallVector result; auto *shapeOp = shape.getDefiningOp(); if (auto s = mlir::dyn_cast_or_null(shapeOp)) { @@ -64,41 +67,97 @@ static llvm::SmallVector getExplicitLbounds(fir::FortranVariableOpInterface var) { if (mlir::Value shape = var.getShape()) - return getExplicitLbounds(shape); + return getExplicitLboundsFromShape(shape); return {}; } +static void +genLboundsAndExtentsFromBox(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity boxEntity, + llvm::SmallVectorImpl &lbounds, + llvm::SmallVectorImpl *extents) { + assert(boxEntity.getType().isa() && "must be a box"); + mlir::Type idxTy = builder.getIndexType(); + const int rank = boxEntity.getRank(); + for (int i = 0; i < rank; ++i) { + mlir::Value dim = builder.createIntegerConstant(loc, idxTy, i); + auto dimInfo = builder.create(loc, idxTy, idxTy, idxTy, + boxEntity, dim); + lbounds.push_back(dimInfo.getLowerBound()); + if (extents) + extents->push_back(dimInfo.getExtent()); + } +} + static llvm::SmallVector -getExplicitTypeParams(fir::FortranVariableOpInterface var) { +getNonDefaultLowerBounds(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity entity) { + if (!entity.hasNonDefaultLowerBounds()) + return {}; + if (auto varIface = entity.getIfVariableInterface()) { + llvm::SmallVector lbounds = getExplicitLbounds(varIface); + if (!lbounds.empty()) + return lbounds; + } + if (entity.isMutableBox()) + entity = hlfir::derefPointersAndAllocatables(loc, builder, entity); + llvm::SmallVector lowerBounds; + genLboundsAndExtentsFromBox(loc, builder, entity, lowerBounds, + /*extents=*/nullptr); + return lowerBounds; +} + +static llvm::SmallVector toSmallVector(mlir::ValueRange range) { llvm::SmallVector res; - mlir::OperandRange range = var.getExplicitTypeParams(); res.append(range.begin(), range.end()); return res; } -std::pair> -hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder, - hlfir::Entity entity) { - if (auto variable = entity.getIfVariableInterface()) - return {hlfir::translateToExtendedValue(loc, builder, variable), {}}; - if (entity.isVariable()) { - if (entity.isScalar() && !entity.hasLengthParameters() && - !hlfir::isBoxAddressOrValueType(entity.getType())) - return {fir::ExtendedValue{entity.getBase()}, std::nullopt}; - TODO(loc, "HLFIR variable to fir::ExtendedValue without a " - "FortranVariableOpInterface"); - } - if (entity.getType().isa()) { - hlfir::AssociateOp associate = hlfir::genAssociateExpr( - loc, builder, entity, entity.getType(), "adapt.valuebyref"); - auto *bldr = &builder; - hlfir::CleanupFunction cleanup = [bldr, loc, associate]() -> void { - bldr->create(loc, associate); - }; - hlfir::Entity temp{associate.getBase()}; - return {translateToExtendedValue(loc, builder, temp).first, cleanup}; - } - return {{static_cast(entity)}, {}}; +static llvm::SmallVector getExplicitTypeParams(hlfir::Entity var) { + if (auto varIface = var.getMaybeDereferencedVariableInterface()) + return toSmallVector(varIface.getExplicitTypeParams()); + return {}; +} + +static mlir::Value tryGettingNonDeferredCharLen(hlfir::Entity var) { + if (auto varIface = var.getMaybeDereferencedVariableInterface()) + if (!varIface.getExplicitTypeParams().empty()) + return varIface.getExplicitTypeParams()[0]; + return mlir::Value{}; +} + +static mlir::Value genCharacterVariableLength(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity var) { + if (mlir::Value len = tryGettingNonDeferredCharLen(var)) + return len; + auto charType = var.getFortranElementType().cast(); + if (charType.hasConstantLen()) + return builder.createIntegerConstant(loc, builder.getIndexType(), + charType.getLen()); + if (var.isMutableBox()) + var = hlfir::Entity{builder.create(loc, var)}; + mlir::Value len = fir::factory::CharacterExprHelper{builder, loc}.getLength( + var.getFirBase()); + assert(len && "failed to retrieve length"); + return len; +} + +static fir::CharBoxValue genUnboxChar(mlir::Location loc, + fir::FirOpBuilder &builder, + mlir::Value boxChar) { + if (auto emboxChar = boxChar.getDefiningOp()) + return {emboxChar.getMemref(), emboxChar.getLen()}; + mlir::Type refType = fir::ReferenceType::get( + boxChar.getType().cast().getEleTy()); + auto unboxed = builder.create( + loc, refType, builder.getIndexType(), boxChar); + mlir::Value addr = unboxed.getResult(0); + mlir::Value len = unboxed.getResult(1); + if (auto varIface = boxChar.getDefiningOp()) + if (mlir::Value explicitlen = varIface.getExplicitCharLen()) + len = explicitlen; + return {addr, len}; } mlir::Value hlfir::Entity::getFirBase() const { @@ -113,39 +172,6 @@ return getBase(); } -fir::ExtendedValue -hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder, - fir::FortranVariableOpInterface variable) { - /// When going towards FIR, use the original base value to avoid - /// introducing descriptors at runtime when they are not required. - mlir::Value firBase = Entity{variable}.getFirBase(); - if (variable.isPointer() || variable.isAllocatable()) - TODO(variable->getLoc(), "pointer or allocatable " - "FortranVariableOpInterface to extendedValue"); - if (firBase.getType().isa()) - return fir::BoxValue(firBase, getExplicitLbounds(variable), - getExplicitTypeParams(variable)); - - if (variable.isCharacter()) { - if (variable.isArray()) - return fir::CharArrayBoxValue(firBase, variable.getExplicitCharLen(), - getExplicitExtents(variable), - getExplicitLbounds(variable)); - if (auto boxCharType = firBase.getType().dyn_cast()) { - auto unboxed = builder.create( - loc, fir::ReferenceType::get(boxCharType.getEleTy()), - builder.getIndexType(), firBase); - return fir::CharBoxValue(unboxed.getResult(0), - variable.getExplicitCharLen()); - } - return fir::CharBoxValue(firBase, variable.getExplicitCharLen()); - } - if (variable.isArray()) - return fir::ArrayBoxValue(firBase, getExplicitExtents(variable), - getExplicitLbounds(variable)); - return firBase; -} - fir::FortranVariableOpInterface hlfir::genDeclare(mlir::Location loc, fir::FirOpBuilder &builder, const fir::ExtendedValue &exv, llvm::StringRef name, @@ -222,11 +248,8 @@ if (var.isMutableBox()) baseAddr = builder.create(loc, baseAddr); // Get raw address. - if (baseAddr.getType().isa()) { - auto addrType = - fir::ReferenceType::get(fir::unwrapPassByRefType(baseAddr.getType())); - baseAddr = builder.create(loc, addrType, baseAddr); - } + if (baseAddr.getType().isa()) + baseAddr = builder.create(loc, baseAddr); return baseAddr; } @@ -260,19 +283,6 @@ return entity; } -static std::optional> -getNonDefaultLowerBounds(mlir::Location loc, fir::FirOpBuilder &builder, - hlfir::Entity entity) { - if (!entity.hasNonDefaultLowerBounds()) - return std::nullopt; - if (auto varIface = entity.getIfVariableInterface()) { - llvm::SmallVector lbounds = getExplicitLbounds(varIface); - if (!lbounds.empty()) - return lbounds; - } - TODO(loc, "get non default lower bounds without FortranVariableInterface"); -} - hlfir::Entity hlfir::getElementAt(mlir::Location loc, fir::FirOpBuilder &builder, Entity entity, mlir::ValueRange oneBasedIndices) { @@ -288,11 +298,13 @@ // based on the array operand lower bounds. mlir::Type resultType = hlfir::getVariableElementType(entity); hlfir::DesignateOp designate; - if (auto lbounds = getNonDefaultLowerBounds(loc, builder, entity)) { + llvm::SmallVector lbounds = + getNonDefaultLowerBounds(loc, builder, entity); + if (!lbounds.empty()) { llvm::SmallVector indices; mlir::Type idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); - for (auto [oneBased, lb] : llvm::zip(oneBasedIndices, *lbounds)) { + for (auto [oneBased, lb] : llvm::zip(oneBasedIndices, lbounds)) { auto lbIdx = builder.createConvert(loc, idxTy, lb); auto oneBasedIdx = builder.createConvert(loc, idxTy, oneBased); auto shift = builder.create(loc, lbIdx, one); @@ -348,8 +360,8 @@ assert((shape.getType().isa() || shape.getType().isa()) && "shape must contain extents"); - auto extents = getExplicitExtents(shape); - auto lowers = getExplicitLbounds(shape); + auto extents = getExplicitExtentsFromShape(shape); + auto lowers = getExplicitLboundsFromShape(shape); assert(lowers.empty() || lowers.size() == extents.size()); mlir::Type idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); @@ -379,13 +391,44 @@ return entity; } +llvm::SmallVector getVariableExtents(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity variable) { + llvm::SmallVector extents; + if (fir::FortranVariableOpInterface varIface = + variable.getIfVariableInterface()) { + extents = getExplicitExtents(varIface); + if (!extents.empty()) + return extents; + } + + if (variable.isMutableBox()) + variable = hlfir::derefPointersAndAllocatables(loc, builder, variable); + // Use the type shape information, and/or the fir.box/fir.class shape + // information if any extents are not static. + fir::SequenceType seqTy = + hlfir::getFortranElementOrSequenceType(variable.getType()) + .cast(); + mlir::Type idxTy = builder.getIndexType(); + for (auto typeExtent : seqTy.getShape()) + if (typeExtent != fir::SequenceType::getUnknownExtent()) { + extents.push_back(builder.createIntegerConstant(loc, idxTy, typeExtent)); + } else { + assert(variable.getType().isa() && + "array variable with dynamic extent must be boxed"); + mlir::Value dim = + builder.createIntegerConstant(loc, idxTy, extents.size()); + auto dimInfo = builder.create(loc, idxTy, idxTy, idxTy, + variable, dim); + extents.push_back(dimInfo.getExtent()); + } + return extents; +} + mlir::Value hlfir::genShape(mlir::Location loc, fir::FirOpBuilder &builder, hlfir::Entity entity) { assert(entity.isArray() && "entity must be an array"); - if (entity.isMutableBox()) - entity = hlfir::derefPointersAndAllocatables(loc, builder, entity); - else - entity = followEntitySource(entity); + entity = followEntitySource(entity); if (entity.getType().isa()) { if (auto elemental = entity.getDefiningOp()) @@ -402,43 +445,16 @@ return builder.create(loc, s.getExtents()); } } - // There is no shape lying around for this entity: build one using - // the type shape information, and/or the fir.box/fir.class shape - // information if any extents are not static. - fir::SequenceType seqTy = - hlfir::getFortranElementOrSequenceType(entity.getType()) - .cast(); - llvm::SmallVector extents; - mlir::Type idxTy = builder.getIndexType(); - for (auto typeExtent : seqTy.getShape()) - if (typeExtent != fir::SequenceType::getUnknownExtent()) { - extents.push_back(builder.createIntegerConstant(loc, idxTy, typeExtent)); - } else { - assert(entity.getType().isa() && - "array variable with dynamic extent must be boxes"); - mlir::Value dim = - builder.createIntegerConstant(loc, idxTy, extents.size()); - auto dimInfo = - builder.create(loc, idxTy, idxTy, idxTy, entity, dim); - extents.push_back(dimInfo.getExtent()); - } - return builder.create(loc, extents); + // There is no shape lying around for this entity. Retrieve the extents and + // build a new fir.shape. + return builder.create(loc, + getVariableExtents(loc, builder, entity)); } llvm::SmallVector hlfir::getIndexExtents(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value shape) { - llvm::SmallVector extents; - if (auto s = shape.getDefiningOp()) { - auto e = s.getExtents(); - extents.insert(extents.end(), e.begin(), e.end()); - } else if (auto s = shape.getDefiningOp()) { - auto e = s.getExtents(); - extents.insert(extents.end(), e.begin(), e.end()); - } else { - // TODO: add fir.get_extent ops on fir.shape<> ops. - TODO(loc, "get extents from fir.shape without fir::ShapeOp parent op"); - } + llvm::SmallVector extents = getExplicitExtentsFromShape(shape); mlir::Type indexType = builder.getIndexType(); for (auto &extent : extents) extent = builder.createConvert(loc, indexType, extent); @@ -478,9 +494,7 @@ } if (entity.isCharacter()) { - auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity); - assert(!cleanup && "translation of entity should not yield cleanup"); - result.push_back(fir::factory::readCharLen(builder, loc, exv)); + result.push_back(genCharacterVariableLength(loc, builder, entity)); return; } TODO(loc, "inquire PDTs length parameters in HLFIR"); @@ -530,8 +544,27 @@ hlfir::Entity hlfir::derefPointersAndAllocatables(mlir::Location loc, fir::FirOpBuilder &builder, Entity entity) { - if (entity.isMutableBox()) - return hlfir::Entity{builder.create(loc, entity).getResult()}; + if (entity.isMutableBox()) { + hlfir::Entity boxLoad{builder.create(loc, entity)}; + if (entity.isScalar()) { + mlir::Type elementType = boxLoad.getFortranElementType(); + if (fir::isa_trivial(elementType)) + return hlfir::Entity{builder.create(loc, boxLoad)}; + if (auto charType = elementType.dyn_cast()) { + mlir::Value base = builder.create(loc, boxLoad); + if (charType.hasConstantLen()) + return hlfir::Entity{base}; + mlir::Value len = genCharacterVariableLength(loc, builder, entity); + auto boxCharType = + fir::BoxCharType::get(builder.getContext(), charType.getFKind()); + return hlfir::Entity{ + builder.create(loc, boxCharType, base, len) + .getResult()}; + } + } + // Keep the entity boxed for now. + return boxLoad; + } return entity; } @@ -623,3 +656,81 @@ builder.restoreInsertionPoint(insPt); return {innerLoop, indices}; } + +static fir::ExtendedValue +translateVariableToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity variable) { + assert(variable.isVariable() && "must be a variable"); + /// When going towards FIR, use the original base value to avoid + /// introducing descriptors at runtime when they are not required. + mlir::Value firBase = variable.getFirBase(); + if (variable.isMutableBox()) + return fir::MutableBoxValue(firBase, getExplicitTypeParams(variable), + fir::MutableProperties{}); + + if (firBase.getType().isa()) { + if (!variable.isSimplyContiguous() || variable.isPolymorphic() || + variable.isDerivedWithLengthParameters()) { + llvm::SmallVector nonDefaultLbounds = + getNonDefaultLowerBounds(loc, builder, variable); + return fir::BoxValue(firBase, nonDefaultLbounds, + getExplicitTypeParams(variable)); + } + // Otherwise, the variable can be represented in a fir::ExtendedValue + // without the overhead of a fir.box. + firBase = genVariableRawAddress(loc, builder, variable); + } + + if (variable.isScalar()) { + if (variable.isCharacter()) { + if (firBase.getType().isa()) + return genUnboxChar(loc, builder, firBase); + mlir::Value len = genCharacterVariableLength(loc, builder, variable); + return fir::CharBoxValue{firBase, len}; + } + return firBase; + } + llvm::SmallVector extents; + llvm::SmallVector nonDefaultLbounds; + if (variable.getType().isa() && + !variable.getIfVariableInterface()) { + // This special case avoids generating two generating to sets of identical + // fir.box_dim to get both the lower bounds and extents. + genLboundsAndExtentsFromBox(loc, builder, variable, nonDefaultLbounds, + &extents); + } else { + extents = getVariableExtents(loc, builder, variable); + nonDefaultLbounds = getNonDefaultLowerBounds(loc, builder, variable); + } + if (variable.isCharacter()) + return fir::CharArrayBoxValue{ + firBase, genCharacterVariableLength(loc, builder, variable), extents, + nonDefaultLbounds}; + return fir::ArrayBoxValue{firBase, extents, nonDefaultLbounds}; +} + +fir::ExtendedValue +hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder, + fir::FortranVariableOpInterface var) { + return translateVariableToExtendedValue(loc, builder, var); +} + +std::pair> +hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity entity) { + if (entity.isVariable()) + return {translateVariableToExtendedValue(loc, builder, entity), + std::nullopt}; + + if (entity.getType().isa()) { + hlfir::AssociateOp associate = hlfir::genAssociateExpr( + loc, builder, entity, entity.getType(), "adapt.valuebyref"); + auto *bldr = &builder; + hlfir::CleanupFunction cleanup = [bldr, loc, associate]() -> void { + bldr->create(loc, associate); + }; + hlfir::Entity temp{associate.getBase()}; + return {translateToExtendedValue(loc, builder, temp).first, cleanup}; + } + return {{static_cast(entity)}, {}}; +} diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -600,6 +600,26 @@ // BoxAddrOp //===----------------------------------------------------------------------===// +void fir::BoxAddrOp::build(mlir::OpBuilder &builder, + mlir::OperationState &result, mlir::Value val) { + mlir::Type type = + llvm::TypeSwitch(val.getType()) + .Case([&](fir::BoxType ty) -> mlir::Type { + mlir::Type eleTy = ty.getEleTy(); + if (fir::isa_ref_type(eleTy)) + return eleTy; + return fir::ReferenceType::get(eleTy); + }) + .Case([&](fir::BoxCharType ty) -> mlir::Type { + return fir::ReferenceType::get(ty.getEleTy()); + }) + .Case( + [&](fir::BoxProcType ty) { return ty.getEleTy(); }) + .Default([&](const auto &) { return mlir::Type{}; }); + assert(type && "bad val type"); + build(builder, result, type, val); +} + mlir::OpFoldResult fir::BoxAddrOp::fold(FoldAdaptor adaptor) { if (auto *v = getVal().getDefiningOp()) { if (auto box = mlir::dyn_cast(v)) { diff --git a/flang/test/Lower/HLFIR/allocatables-and-pointers.f90 b/flang/test/Lower/HLFIR/allocatables-and-pointers.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/allocatables-and-pointers.f90 @@ -0,0 +1,156 @@ +! Test lowering of whole allocatable and pointers to HLFIR +! RUN: bbc -emit-fir -hlfir -o - %s 2>&1 | FileCheck %s + +subroutine passing_allocatable(x) + interface + subroutine takes_allocatable(y) + real, allocatable :: y(:) + end subroutine + subroutine takes_array(y) + real :: y(*) + end subroutine + end interface + real, allocatable :: x(:) + call takes_allocatable(x) + call takes_array(x) +end subroutine +! CHECK-LABEL: func.func @_QPpassing_allocatable( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: fir.call @_QPtakes_allocatable(%[[VAL_1]]#0) {{.*}} : (!fir.ref>>>) -> () +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap>) -> !fir.ref> +! CHECK: fir.call @_QPtakes_array(%[[VAL_4]]) {{.*}} : (!fir.ref>) -> () + +subroutine passing_pointer(x) + interface + subroutine takes_pointer(y) + real, pointer :: y(:) + end subroutine + end interface + real, pointer :: x(:) + call takes_pointer(x) + call takes_pointer(NULL()) +end subroutine +! CHECK-LABEL: func.func @_QPpassing_pointer( +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>> +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: fir.call @_QPtakes_pointer(%[[VAL_2]]#0) {{.*}} : (!fir.ref>>>) -> () +! CHECK: %[[VAL_3:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_3]](%[[VAL_5]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_1]] : !fir.ref>>> +! CHECK: fir.call @_QPtakes_pointer(%[[VAL_1]]) {{.*}} : (!fir.ref>>>) -> () + +subroutine passing_contiguous_pointer(x) + interface + subroutine takes_array(y) + real :: y(*) + end subroutine + end interface + real, pointer, contiguous :: x(:) + call takes_array(x) +end subroutine +! CHECK-LABEL: func.func @_QPpassing_contiguous_pointer( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>>) -> !fir.ptr> +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ptr>) -> !fir.ref> +! CHECK: fir.call @_QPtakes_array(%[[VAL_4]]) {{.*}} : (!fir.ref>) -> () + +subroutine character_allocatable_cst_len(x) + character(10), allocatable :: x + call takes_char(x) + call takes_char(x//"hello") +end subroutine +! CHECK-LABEL: func.func @_QPcharacter_allocatable_cst_len( +! CHECK: %[[VAL_1:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] typeparams %[[VAL_1:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]]#0 : !fir.ref>>> +! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_4]] : (!fir.heap>) -> !fir.ref> +! CHECK: %[[VAL_7:.*]] = fir.emboxchar %[[VAL_6]], %[[VAL_5]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: fir.call @_QPtakes_char(%[[VAL_7]]) {{.*}} : (!fir.boxchar<1>) -> () +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_2]]#0 : !fir.ref>>> +! CHECK: %[[VAL_9:.*]] = fir.box_addr %[[VAL_8]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_12:.*]]:2 = hlfir.declare %[[VAL_10:[a-z0-9]*]] typeparams %[[VAL_11:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs +! CHECK: %[[VAL_13:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_14:.*]] = arith.addi %[[VAL_13]], %[[VAL_11]] : index +! CHECK: %[[VAL_15:.*]] = hlfir.concat %[[VAL_9]], %[[VAL_12]]#0 len %[[VAL_14]] : (!fir.heap>, !fir.ref>, index) -> !hlfir.expr> + +subroutine character_allocatable_dyn_len(x, l) + integer(8) :: l + character(l), allocatable :: x + call takes_char(x) + call takes_char(x//"hello") +end subroutine +! CHECK-LABEL: func.func @_QPcharacter_allocatable_dyn_len( +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]] {uniq_name = {{.*}}El"} +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]]#0 : !fir.ref +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_5:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[VAL_4]] : i64 +! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_5]], %[[VAL_3]], %[[VAL_4]] : i64 +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] typeparams %[[VAL_6:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_7]]#0 : !fir.ref>>> +! CHECK: %[[VAL_9:.*]] = fir.box_addr %[[VAL_8]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_10:.*]] = fir.emboxchar %[[VAL_9]], %[[VAL_6]] : (!fir.heap>, i64) -> !fir.boxchar<1> +! CHECK: fir.call @_QPtakes_char(%[[VAL_10]]) {{.*}} : (!fir.boxchar<1>) -> () +! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_7]]#0 : !fir.ref>>> +! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_13:.*]] = fir.emboxchar %[[VAL_12]], %[[VAL_6]] : (!fir.heap>, i64) -> !fir.boxchar<1> +! CHECK: %[[VAL_16:.*]]:2 = hlfir.declare %[[VAL_14:[a-z0-9]*]] typeparams %[[VAL_15:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_6]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = arith.addi %[[VAL_17]], %[[VAL_15]] : index +! CHECK: %[[VAL_19:.*]] = hlfir.concat %[[VAL_13]], %[[VAL_16]]#0 len %[[VAL_18]] : (!fir.boxchar<1>, !fir.ref>, index) -> !hlfir.expr> + +subroutine print_allocatable(x) + real, allocatable :: x(:) + print *, x +end subroutine +! CHECK-LABEL: func.func @_QPprint_allocatable( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]]#1 : !fir.ref>>> +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box>>) -> !fir.box +! CHECK: %[[VAL_9:.*]] = fir.call @_FortranAioOutputDescriptor(%{{.*}}, %[[VAL_8]]) + +subroutine print_pointer(x) + real, pointer :: x(:) + print *, x +end subroutine +! CHECK-LABEL: func.func @_QPprint_pointer( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]]#1 : !fir.ref>>> +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box>>) -> !fir.box +! CHECK: %[[VAL_9:.*]] = fir.call @_FortranAioOutputDescriptor(%{{.*}}, %[[VAL_8]]) + +subroutine elemental_expr(x) + integer, pointer :: x(:, :) + call takes_array_2(x+42) +end subroutine +! CHECK-LABEL: func.func @_QPelemental_expr( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = {{.*}}Ex"} +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = arith.constant 42 : i32 +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_4]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_6]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_8:.*]] = fir.shape %[[VAL_5]]#1, %[[VAL_7]]#1 : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_9:.*]] = hlfir.elemental %[[VAL_8]] : (!fir.shape<2>) -> !hlfir.expr { +! CHECK: ^bb0(%[[VAL_10:.*]]: index, %[[VAL_11:.*]]: index): +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_13:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_12]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_15:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_14]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_16:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_17:.*]] = arith.subi %[[VAL_13]]#0, %[[VAL_16]] : index +! CHECK: %[[VAL_18:.*]] = arith.addi %[[VAL_10]], %[[VAL_17]] : index +! CHECK: %[[VAL_19:.*]] = arith.subi %[[VAL_15]]#0, %[[VAL_16]] : index +! CHECK: %[[VAL_20:.*]] = arith.addi %[[VAL_11]], %[[VAL_19]] : index +! CHECK: %[[VAL_21:.*]] = hlfir.designate %[[VAL_2]] (%[[VAL_18]], %[[VAL_20]]) : (!fir.box>>, index, index) -> !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_21]] : !fir.ref +! CHECK: %[[VAL_23:.*]] = arith.addi %[[VAL_22]], %[[VAL_3]] : i32 +! CHECK: hlfir.yield_element %[[VAL_23]] : i32 +! CHECK: }