flang/lib/Optimizer/Builder/HLFIRTools.cpp

   1 //===-- HLFIRTools.cpp ----------------------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8 //
   9 // Tools to manipulate HLFIR variable and expressions
  10 //
  11 //===----------------------------------------------------------------------===//
  12
  13 #include "flang/Optimizer/Builder/HLFIRTools.h"
  14 #include "flang/Optimizer/Builder/Character.h"
  15 #include "flang/Optimizer/Builder/FIRBuilder.h"
  16 #include "flang/Optimizer/Builder/MutableBox.h"
  17 #include "flang/Optimizer/Builder/Runtime/Allocatable.h"
  18 #include "flang/Optimizer/Builder/Todo.h"
  19 #include "flang/Optimizer/HLFIR/HLFIROps.h"
  20 #include "mlir/IR/IRMapping.h"
  21 #include "mlir/Support/LLVM.h"
  22 #include "llvm/ADT/TypeSwitch.h"
  23 #include <optional>
  24
  25 // Return explicit extents. If the base is a fir.box, this won't read it to
  26 // return the extents and will instead return an empty vector.
  27 llvm::SmallVector<mlir::Value>
  28 hlfir::getExplicitExtentsFromShape(mlir::Value shape,
  29                                    fir::FirOpBuilder &builder) {
  30   llvm::SmallVector<mlir::Value> result;
  31   auto *shapeOp = shape.getDefiningOp();
  32   if (auto s = mlir::dyn_cast_or_null<fir::ShapeOp>(shapeOp)) {
  33     auto e = s.getExtents();
  34     result.append(e.begin(), e.end());
  35   } else if (auto s = mlir::dyn_cast_or_null<fir::ShapeShiftOp>(shapeOp)) {
  36     auto e = s.getExtents();
  37     result.append(e.begin(), e.end());
  38   } else if (mlir::dyn_cast_or_null<fir::ShiftOp>(shapeOp)) {
  39     return {};
  40   } else if (auto s = mlir::dyn_cast_or_null<hlfir::ShapeOfOp>(shapeOp)) {
  41     hlfir::ExprType expr = s.getExpr().getType().cast<hlfir::ExprType>();
  42     llvm::ArrayRef<int64_t> exprShape = expr.getShape();
  43     mlir::Type indexTy = builder.getIndexType();
  44     fir::ShapeType shapeTy = shape.getType().cast<fir::ShapeType>();
  45     result.reserve(shapeTy.getRank());
  46     for (unsigned i = 0; i < shapeTy.getRank(); ++i) {
  47       int64_t extent = exprShape[i];
  48       mlir::Value extentVal;
  49       if (extent == expr.getUnknownExtent()) {
  50         auto op = builder.create<hlfir::GetExtentOp>(shape.getLoc(), shape, i);
  51         extentVal = op.getResult();
  52       } else {
  53         extentVal =
  54             builder.createIntegerConstant(shape.getLoc(), indexTy, extent);
  55       }
  56       result.emplace_back(extentVal);
  57     }
  58   } else {
  59     TODO(shape.getLoc(), "read fir.shape to get extents");
  60   }
  61   return result;
  62 }
  63 static llvm::SmallVector<mlir::Value>
  64 getExplicitExtents(fir::FortranVariableOpInterface var,
  65                    fir::FirOpBuilder &builder) {
  66   if (mlir::Value shape = var.getShape())
  67     return hlfir::getExplicitExtentsFromShape(var.getShape(), builder);
  68   return {};
  69 }
  70
  71 // Return explicit lower bounds. For pointers and allocatables, this will not
  72 // read the lower bounds and instead return an empty vector.
  73 static llvm::SmallVector<mlir::Value>
  74 getExplicitLboundsFromShape(mlir::Value shape) {
  75   llvm::SmallVector<mlir::Value> result;
  76   auto *shapeOp = shape.getDefiningOp();
  77   if (auto s = mlir::dyn_cast_or_null<fir::ShapeOp>(shapeOp)) {
  78     return {};
  79   } else if (auto s = mlir::dyn_cast_or_null<fir::ShapeShiftOp>(shapeOp)) {
  80     auto e = s.getOrigins();
  81     result.append(e.begin(), e.end());
  82   } else if (auto s = mlir::dyn_cast_or_null<fir::ShiftOp>(shapeOp)) {
  83     auto e = s.getOrigins();
  84     result.append(e.begin(), e.end());
  85   } else {
  86     TODO(shape.getLoc(), "read fir.shape to get lower bounds");
  87   }
  88   return result;
  89 }
  90 static llvm::SmallVector<mlir::Value>
  91 getExplicitLbounds(fir::FortranVariableOpInterface var) {
  92   if (mlir::Value shape = var.getShape())
  93     return getExplicitLboundsFromShape(shape);
  94   return {};
  95 }
  96
  97 static void
  98 genLboundsAndExtentsFromBox(mlir::Location loc, fir::FirOpBuilder &builder,
  99                             hlfir::Entity boxEntity,
 100                             llvm::SmallVectorImpl<mlir::Value> &lbounds,
 101                             llvm::SmallVectorImpl<mlir::Value> *extents) {
 102   assert(boxEntity.getType().isa<fir::BaseBoxType>() && "must be a box");
 103   mlir::Type idxTy = builder.getIndexType();
 104   const int rank = boxEntity.getRank();
 105   for (int i = 0; i < rank; ++i) {
 106     mlir::Value dim = builder.createIntegerConstant(loc, idxTy, i);
 107     auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
 108                                                   boxEntity, dim);
 109     lbounds.push_back(dimInfo.getLowerBound());
 110     if (extents)
 111       extents->push_back(dimInfo.getExtent());
 112   }
 113 }
 114
 115 static llvm::SmallVector<mlir::Value>
 116 getNonDefaultLowerBounds(mlir::Location loc, fir::FirOpBuilder &builder,
 117                          hlfir::Entity entity) {
 118   if (!entity.hasNonDefaultLowerBounds())
 119     return {};
 120   if (auto varIface = entity.getIfVariableInterface()) {
 121     llvm::SmallVector<mlir::Value> lbounds = getExplicitLbounds(varIface);
 122     if (!lbounds.empty())
 123       return lbounds;
 124   }
 125   if (entity.isMutableBox())
 126     entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
 127   llvm::SmallVector<mlir::Value> lowerBounds;
 128   genLboundsAndExtentsFromBox(loc, builder, entity, lowerBounds,
 129                               /*extents=*/nullptr);
 130   return lowerBounds;
 131 }
 132
 133 static llvm::SmallVector<mlir::Value> toSmallVector(mlir::ValueRange range) {
 134   llvm::SmallVector<mlir::Value> res;
 135   res.append(range.begin(), range.end());
 136   return res;
 137 }
 138
 139 static llvm::SmallVector<mlir::Value> getExplicitTypeParams(hlfir::Entity var) {
 140   if (auto varIface = var.getMaybeDereferencedVariableInterface())
 141     return toSmallVector(varIface.getExplicitTypeParams());
 142   return {};
 143 }
 144
 145 static mlir::Value tryGettingNonDeferredCharLen(hlfir::Entity var) {
 146   if (auto varIface = var.getMaybeDereferencedVariableInterface())
 147     if (!varIface.getExplicitTypeParams().empty())
 148       return varIface.getExplicitTypeParams()[0];
 149   return mlir::Value{};
 150 }
 151
 152 static mlir::Value genCharacterVariableLength(mlir::Location loc,
 153                                               fir::FirOpBuilder &builder,
 154                                               hlfir::Entity var) {
 155   if (mlir::Value len = tryGettingNonDeferredCharLen(var))
 156     return len;
 157   auto charType = var.getFortranElementType().cast<fir::CharacterType>();
 158   if (charType.hasConstantLen())
 159     return builder.createIntegerConstant(loc, builder.getIndexType(),
 160                                          charType.getLen());
 161   if (var.isMutableBox())
 162     var = hlfir::Entity{builder.create<fir::LoadOp>(loc, var)};
 163   mlir::Value len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
 164       var.getFirBase());
 165   assert(len && "failed to retrieve length");
 166   return len;
 167 }
 168
 169 static fir::CharBoxValue genUnboxChar(mlir::Location loc,
 170                                       fir::FirOpBuilder &builder,
 171                                       mlir::Value boxChar) {
 172   if (auto emboxChar = boxChar.getDefiningOp<fir::EmboxCharOp>())
 173     return {emboxChar.getMemref(), emboxChar.getLen()};
 174   mlir::Type refType = fir::ReferenceType::get(
 175       boxChar.getType().cast<fir::BoxCharType>().getEleTy());
 176   auto unboxed = builder.create<fir::UnboxCharOp>(
 177       loc, refType, builder.getIndexType(), boxChar);
 178   mlir::Value addr = unboxed.getResult(0);
 179   mlir::Value len = unboxed.getResult(1);
 180   if (auto varIface = boxChar.getDefiningOp<fir::FortranVariableOpInterface>())
 181     if (mlir::Value explicitlen = varIface.getExplicitCharLen())
 182       len = explicitlen;
 183   return {addr, len};
 184 }
 185
 186 mlir::Value hlfir::Entity::getFirBase() const {
 187   if (fir::FortranVariableOpInterface variable = getIfVariableInterface()) {
 188     if (auto declareOp =
 189             mlir::dyn_cast<hlfir::DeclareOp>(variable.getOperation()))
 190       return declareOp.getOriginalBase();
 191     if (auto associateOp =
 192             mlir::dyn_cast<hlfir::AssociateOp>(variable.getOperation()))
 193       return associateOp.getFirBase();
 194   }
 195   return getBase();
 196 }
 197
 198 fir::FortranVariableOpInterface
 199 hlfir::genDeclare(mlir::Location loc, fir::FirOpBuilder &builder,
 200                   const fir::ExtendedValue &exv, llvm::StringRef name,
 201                   fir::FortranVariableFlagsAttr flags) {
 202
 203   mlir::Value base = fir::getBase(exv);
 204   assert(fir::conformsWithPassByRef(base.getType()) &&
 205          "entity being declared must be in memory");
 206   mlir::Value shapeOrShift;
 207   llvm::SmallVector<mlir::Value> lenParams;
 208   exv.match(
 209       [&](const fir::CharBoxValue &box) {
 210         lenParams.emplace_back(box.getLen());
 211       },
 212       [&](const fir::ArrayBoxValue &) {
 213         shapeOrShift = builder.createShape(loc, exv);
 214       },
 215       [&](const fir::CharArrayBoxValue &box) {
 216         shapeOrShift = builder.createShape(loc, exv);
 217         lenParams.emplace_back(box.getLen());
 218       },
 219       [&](const fir::BoxValue &box) {
 220         if (!box.getLBounds().empty())
 221           shapeOrShift = builder.createShape(loc, exv);
 222         lenParams.append(box.getExplicitParameters().begin(),
 223                          box.getExplicitParameters().end());
 224       },
 225       [&](const fir::MutableBoxValue &box) {
 226         lenParams.append(box.nonDeferredLenParams().begin(),
 227                          box.nonDeferredLenParams().end());
 228       },
 229       [](const auto &) {});
 230   auto declareOp = builder.create<hlfir::DeclareOp>(
 231       loc, base, name, shapeOrShift, lenParams, flags);
 232   return mlir::cast<fir::FortranVariableOpInterface>(declareOp.getOperation());
 233 }
 234
 235 hlfir::AssociateOp hlfir::genAssociateExpr(mlir::Location loc,
 236                                            fir::FirOpBuilder &builder,
 237                                            hlfir::Entity value,
 238                                            mlir::Type variableType,
 239                                            llvm::StringRef name) {
 240   assert(value.isValue() && "must not be a variable");
 241   mlir::Value shape{};
 242   if (value.isArray())
 243     shape = genShape(loc, builder, value);
 244
 245   mlir::Value source = value;
 246   // Lowered scalar expression values for numerical and logical may have a
 247   // different type than what is required for the type in memory (logical
 248   // expressions are typically manipulated as i1, but needs to be stored
 249   // according to the fir.logical<kind> so that the storage size is correct).
 250   // Character length mismatches are ignored (it is ok for one to be dynamic
 251   // and the other static).
 252   mlir::Type varEleTy = getFortranElementType(variableType);
 253   mlir::Type valueEleTy = getFortranElementType(value.getType());
 254   if (varEleTy != valueEleTy && !(valueEleTy.isa<fir::CharacterType>() &&
 255                                   varEleTy.isa<fir::CharacterType>())) {
 256     assert(value.isScalar() && fir::isa_trivial(value.getType()));
 257     source = builder.createConvert(loc, fir::unwrapPassByRefType(variableType),
 258                                    value);
 259   }
 260   llvm::SmallVector<mlir::Value> lenParams;
 261   genLengthParameters(loc, builder, value, lenParams);
 262   return builder.create<hlfir::AssociateOp>(loc, source, name, shape, lenParams,
 263                                             fir::FortranVariableFlagsAttr{});
 264 }
 265
 266 mlir::Value hlfir::genVariableRawAddress(mlir::Location loc,
 267                                          fir::FirOpBuilder &builder,
 268                                          hlfir::Entity var) {
 269   assert(var.isVariable() && "only address of variables can be taken");
 270   mlir::Value baseAddr = var.getFirBase();
 271   if (var.isMutableBox())
 272     baseAddr = builder.create<fir::LoadOp>(loc, baseAddr);
 273   // Get raw address.
 274   if (var.getType().isa<fir::BoxCharType>())
 275     baseAddr = genUnboxChar(loc, builder, var.getBase()).getAddr();
 276   if (baseAddr.getType().isa<fir::BaseBoxType>())
 277     baseAddr = builder.create<fir::BoxAddrOp>(loc, baseAddr);
 278   return baseAddr;
 279 }
 280
 281 mlir::Value hlfir::genVariableBoxChar(mlir::Location loc,
 282                                       fir::FirOpBuilder &builder,
 283                                       hlfir::Entity var) {
 284   assert(var.isVariable() && "only address of variables can be taken");
 285   if (var.getType().isa<fir::BoxCharType>())
 286     return var;
 287   mlir::Value addr = genVariableRawAddress(loc, builder, var);
 288   llvm::SmallVector<mlir::Value> lengths;
 289   genLengthParameters(loc, builder, var, lengths);
 290   assert(lengths.size() == 1);
 291   auto charType = var.getFortranElementType().cast<fir::CharacterType>();
 292   auto boxCharType =
 293       fir::BoxCharType::get(builder.getContext(), charType.getFKind());
 294   auto scalarAddr =
 295       builder.createConvert(loc, fir::ReferenceType::get(charType), addr);
 296   return builder.create<fir::EmboxCharOp>(loc, boxCharType, scalarAddr,
 297                                           lengths[0]);
 298 }
 299
 300 hlfir::Entity hlfir::genVariableBox(mlir::Location loc,
 301                                     fir::FirOpBuilder &builder,
 302                                     hlfir::Entity var) {
 303   assert(var.isVariable() && "must be a variable");
 304   var = hlfir::derefPointersAndAllocatables(loc, builder, var);
 305   if (var.getType().isa<fir::BaseBoxType>())
 306     return var;
 307   // Note: if the var is not a fir.box/fir.class at that point, it has default
 308   // lower bounds and is not polymorphic.
 309   mlir::Value shape =
 310       var.isArray() ? hlfir::genShape(loc, builder, var) : mlir::Value{};
 311   llvm::SmallVector<mlir::Value> typeParams;
 312   auto maybeCharType =
 313       var.getFortranElementType().dyn_cast<fir::CharacterType>();
 314   if (!maybeCharType || maybeCharType.hasDynamicLen())
 315     hlfir::genLengthParameters(loc, builder, var, typeParams);
 316   mlir::Value addr = var.getBase();
 317   if (var.getType().isa<fir::BoxCharType>())
 318     addr = genVariableRawAddress(loc, builder, var);
 319   mlir::Type boxType = fir::BoxType::get(var.getElementOrSequenceType());
 320   auto embox =
 321       builder.create<fir::EmboxOp>(loc, boxType, addr, shape,
 322                                    /*slice=*/mlir::Value{}, typeParams);
 323   return hlfir::Entity{embox.getResult()};
 324 }
 325
 326 hlfir::Entity hlfir::loadTrivialScalar(mlir::Location loc,
 327                                        fir::FirOpBuilder &builder,
 328                                        Entity entity) {
 329   entity = derefPointersAndAllocatables(loc, builder, entity);
 330   if (entity.isVariable() && entity.isScalar() &&
 331       fir::isa_trivial(entity.getFortranElementType())) {
 332     return Entity{builder.create<fir::LoadOp>(loc, entity)};
 333   }
 334   return entity;
 335 }
 336
 337 hlfir::Entity hlfir::getElementAt(mlir::Location loc,
 338                                   fir::FirOpBuilder &builder, Entity entity,
 339                                   mlir::ValueRange oneBasedIndices) {
 340   if (entity.isScalar())
 341     return entity;
 342   llvm::SmallVector<mlir::Value> lenParams;
 343   genLengthParameters(loc, builder, entity, lenParams);
 344   if (entity.getType().isa<hlfir::ExprType>())
 345     return hlfir::Entity{builder.create<hlfir::ApplyOp>(
 346         loc, entity, oneBasedIndices, lenParams)};
 347   // Build hlfir.designate. The lower bounds may need to be added to
 348   // the oneBasedIndices since hlfir.designate expect indices
 349   // based on the array operand lower bounds.
 350   mlir::Type resultType = hlfir::getVariableElementType(entity);
 351   hlfir::DesignateOp designate;
 352   llvm::SmallVector<mlir::Value> lbounds =
 353       getNonDefaultLowerBounds(loc, builder, entity);
 354   if (!lbounds.empty()) {
 355     llvm::SmallVector<mlir::Value> indices;
 356     mlir::Type idxTy = builder.getIndexType();
 357     mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
 358     for (auto [oneBased, lb] : llvm::zip(oneBasedIndices, lbounds)) {
 359       auto lbIdx = builder.createConvert(loc, idxTy, lb);
 360       auto oneBasedIdx = builder.createConvert(loc, idxTy, oneBased);
 361       auto shift = builder.create<mlir::arith::SubIOp>(loc, lbIdx, one);
 362       mlir::Value index =
 363           builder.create<mlir::arith::AddIOp>(loc, oneBasedIdx, shift);
 364       indices.push_back(index);
 365     }
 366     designate = builder.create<hlfir::DesignateOp>(loc, resultType, entity,
 367                                                    indices, lenParams);
 368   } else {
 369     designate = builder.create<hlfir::DesignateOp>(loc, resultType, entity,
 370                                                    oneBasedIndices, lenParams);
 371   }
 372   return mlir::cast<fir::FortranVariableOpInterface>(designate.getOperation());
 373 }
 374
 375 static mlir::Value genUBound(mlir::Location loc, fir::FirOpBuilder &builder,
 376                              mlir::Value lb, mlir::Value extent,
 377                              mlir::Value one) {
 378   if (auto constantLb = fir::getIntIfConstant(lb))
 379     if (*constantLb == 1)
 380       return extent;
 381   extent = builder.createConvert(loc, one.getType(), extent);
 382   lb = builder.createConvert(loc, one.getType(), lb);
 383   auto add = builder.create<mlir::arith::AddIOp>(loc, lb, extent);
 384   return builder.create<mlir::arith::SubIOp>(loc, add, one);
 385 }
 386
 387 llvm::SmallVector<std::pair<mlir::Value, mlir::Value>>
 388 hlfir::genBounds(mlir::Location loc, fir::FirOpBuilder &builder,
 389                  Entity entity) {
 390   if (entity.getType().isa<hlfir::ExprType>())
 391     TODO(loc, "bounds of expressions in hlfir");
 392   auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
 393   assert(!cleanup && "translation of entity should not yield cleanup");
 394   if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
 395     exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
 396   mlir::Type idxTy = builder.getIndexType();
 397   mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
 398   llvm::SmallVector<std::pair<mlir::Value, mlir::Value>> result;
 399   for (unsigned dim = 0; dim < exv.rank(); ++dim) {
 400     mlir::Value extent = fir::factory::readExtent(builder, loc, exv, dim);
 401     mlir::Value lb = fir::factory::readLowerBound(builder, loc, exv, dim, one);
 402     mlir::Value ub = genUBound(loc, builder, lb, extent, one);
 403     result.push_back({lb, ub});
 404   }
 405   return result;
 406 }
 407
 408 llvm::SmallVector<std::pair<mlir::Value, mlir::Value>>
 409 hlfir::genBounds(mlir::Location loc, fir::FirOpBuilder &builder,
 410                  mlir::Value shape) {
 411   assert((shape.getType().isa<fir::ShapeShiftType>() ||
 412           shape.getType().isa<fir::ShapeType>()) &&
 413          "shape must contain extents");
 414   auto extents = hlfir::getExplicitExtentsFromShape(shape, builder);
 415   auto lowers = getExplicitLboundsFromShape(shape);
 416   assert(lowers.empty() || lowers.size() == extents.size());
 417   mlir::Type idxTy = builder.getIndexType();
 418   mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
 419   llvm::SmallVector<std::pair<mlir::Value, mlir::Value>> result;
 420   for (auto extent : llvm::enumerate(extents)) {
 421     mlir::Value lb = lowers.empty() ? one : lowers[extent.index()];
 422     mlir::Value ub = lowers.empty()
 423                          ? extent.value()
 424                          : genUBound(loc, builder, lb, extent.value(), one);
 425     result.push_back({lb, ub});
 426   }
 427   return result;
 428 }
 429
 430 llvm::SmallVector<mlir::Value> hlfir::genLowerbounds(mlir::Location loc,
 431                                                      fir::FirOpBuilder &builder,
 432                                                      mlir::Value shape,
 433                                                      unsigned rank) {
 434   llvm::SmallVector<mlir::Value> lbounds;
 435   if (shape)
 436     lbounds = getExplicitLboundsFromShape(shape);
 437   if (!lbounds.empty())
 438     return lbounds;
 439   mlir::Value one =
 440       builder.createIntegerConstant(loc, builder.getIndexType(), 1);
 441   return llvm::SmallVector<mlir::Value>(rank, one);
 442 }
 443
 444 static hlfir::Entity followShapeInducingSource(hlfir::Entity entity) {
 445   while (true) {
 446     if (auto reassoc = entity.getDefiningOp<hlfir::NoReassocOp>()) {
 447       entity = hlfir::Entity{reassoc.getVal()};
 448       continue;
 449     }
 450     if (auto asExpr = entity.getDefiningOp<hlfir::AsExprOp>()) {
 451       entity = hlfir::Entity{asExpr.getVar()};
 452       continue;
 453     }
 454     break;
 455   }
 456   return entity;
 457 }
 458
 459 static mlir::Value computeVariableExtent(mlir::Location loc,
 460                                          fir::FirOpBuilder &builder,
 461                                          hlfir::Entity variable,
 462                                          fir::SequenceType seqTy,
 463                                          unsigned dim) {
 464   mlir::Type idxTy = builder.getIndexType();
 465   if (seqTy.getShape().size() > dim) {
 466     fir::SequenceType::Extent typeExtent = seqTy.getShape()[dim];
 467     if (typeExtent != fir::SequenceType::getUnknownExtent())
 468       return builder.createIntegerConstant(loc, idxTy, typeExtent);
 469   }
 470   assert(variable.getType().isa<fir::BaseBoxType>() &&
 471          "array variable with dynamic extent must be boxed");
 472   mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
 473   auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
 474                                                 variable, dimVal);
 475   return dimInfo.getExtent();
 476 }
 477 llvm::SmallVector<mlir::Value> getVariableExtents(mlir::Location loc,
 478                                                   fir::FirOpBuilder &builder,
 479                                                   hlfir::Entity variable) {
 480   llvm::SmallVector<mlir::Value> extents;
 481   if (fir::FortranVariableOpInterface varIface =
 482           variable.getIfVariableInterface()) {
 483     extents = getExplicitExtents(varIface, builder);
 484     if (!extents.empty())
 485       return extents;
 486   }
 487
 488   if (variable.isMutableBox())
 489     variable = hlfir::derefPointersAndAllocatables(loc, builder, variable);
 490   // Use the type shape information, and/or the fir.box/fir.class shape
 491   // information if any extents are not static.
 492   fir::SequenceType seqTy =
 493       hlfir::getFortranElementOrSequenceType(variable.getType())
 494           .cast<fir::SequenceType>();
 495   unsigned rank = seqTy.getShape().size();
 496   for (unsigned dim = 0; dim < rank; ++dim)
 497     extents.push_back(
 498         computeVariableExtent(loc, builder, variable, seqTy, dim));
 499   return extents;
 500 }
 501
 502 static mlir::Value tryRetrievingShapeOrShift(hlfir::Entity entity) {
 503   if (entity.getType().isa<hlfir::ExprType>()) {
 504     if (auto elemental = entity.getDefiningOp<hlfir::ElementalOp>())
 505       return elemental.getShape();
 506     return mlir::Value{};
 507   }
 508   if (auto varIface = entity.getIfVariableInterface())
 509     return varIface.getShape();
 510   return {};
 511 }
 512
 513 mlir::Value hlfir::genShape(mlir::Location loc, fir::FirOpBuilder &builder,
 514                             hlfir::Entity entity) {
 515   assert(entity.isArray() && "entity must be an array");
 516   entity = followShapeInducingSource(entity);
 517   assert(entity && "what?");
 518   if (auto shape = tryRetrievingShapeOrShift(entity)) {
 519     if (shape.getType().isa<fir::ShapeType>())
 520       return shape;
 521     if (shape.getType().isa<fir::ShapeShiftType>())
 522       if (auto s = shape.getDefiningOp<fir::ShapeShiftOp>())
 523         return builder.create<fir::ShapeOp>(loc, s.getExtents());
 524   }
 525   if (entity.getType().isa<hlfir::ExprType>())
 526     return builder.create<hlfir::ShapeOfOp>(loc, entity.getBase());
 527   // There is no shape lying around for this entity. Retrieve the extents and
 528   // build a new fir.shape.
 529   return builder.create<fir::ShapeOp>(loc,
 530                                       getVariableExtents(loc, builder, entity));
 531 }
 532
 533 llvm::SmallVector<mlir::Value>
 534 hlfir::getIndexExtents(mlir::Location loc, fir::FirOpBuilder &builder,
 535                        mlir::Value shape) {
 536   llvm::SmallVector<mlir::Value> extents =
 537       hlfir::getExplicitExtentsFromShape(shape, builder);
 538   mlir::Type indexType = builder.getIndexType();
 539   for (auto &extent : extents)
 540     extent = builder.createConvert(loc, indexType, extent);
 541   return extents;
 542 }
 543
 544 mlir::Value hlfir::genExtent(mlir::Location loc, fir::FirOpBuilder &builder,
 545                              hlfir::Entity entity, unsigned dim) {
 546   entity = followShapeInducingSource(entity);
 547   if (auto shape = tryRetrievingShapeOrShift(entity)) {
 548     auto extents = hlfir::getExplicitExtentsFromShape(shape, builder);
 549     if (!extents.empty()) {
 550       assert(extents.size() > dim && "bad inquiry");
 551       return extents[dim];
 552     }
 553   }
 554   if (entity.isVariable()) {
 555     if (entity.isMutableBox())
 556       entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
 557     // Use the type shape information, and/or the fir.box/fir.class shape
 558     // information if any extents are not static.
 559     fir::SequenceType seqTy =
 560         hlfir::getFortranElementOrSequenceType(entity.getType())
 561             .cast<fir::SequenceType>();
 562     return computeVariableExtent(loc, builder, entity, seqTy, dim);
 563   }
 564   TODO(loc, "get extent from HLFIR expr without producer holding the shape");
 565 }
 566
 567 mlir::Value hlfir::genLBound(mlir::Location loc, fir::FirOpBuilder &builder,
 568                              hlfir::Entity entity, unsigned dim) {
 569   if (!entity.hasNonDefaultLowerBounds())
 570     return builder.createIntegerConstant(loc, builder.getIndexType(), 1);
 571   if (auto shape = tryRetrievingShapeOrShift(entity)) {
 572     auto lbounds = getExplicitLboundsFromShape(shape);
 573     if (!lbounds.empty()) {
 574       assert(lbounds.size() > dim && "bad inquiry");
 575       return lbounds[dim];
 576     }
 577   }
 578   if (entity.isMutableBox())
 579     entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
 580   assert(entity.getType().isa<fir::BaseBoxType>() && "must be a box");
 581   mlir::Type idxTy = builder.getIndexType();
 582   mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
 583   auto dimInfo =
 584       builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, entity, dimVal);
 585   return dimInfo.getLowerBound();
 586 }
 587
 588 void hlfir::genLengthParameters(mlir::Location loc, fir::FirOpBuilder &builder,
 589                                 Entity entity,
 590                                 llvm::SmallVectorImpl<mlir::Value> &result) {
 591   if (!entity.hasLengthParameters())
 592     return;
 593   if (entity.getType().isa<hlfir::ExprType>()) {
 594     mlir::Value expr = entity;
 595     if (auto reassoc = expr.getDefiningOp<hlfir::NoReassocOp>())
 596       expr = reassoc.getVal();
 597     // Going through fir::ExtendedValue would create a temp,
 598     // which is not desired for an inquiry.
 599     // TODO: make this an interface when adding further character producing ops.
 600     if (auto concat = expr.getDefiningOp<hlfir::ConcatOp>()) {
 601       result.push_back(concat.getLength());
 602       return;
 603     } else if (auto concat = expr.getDefiningOp<hlfir::SetLengthOp>()) {
 604       result.push_back(concat.getLength());
 605       return;
 606     } else if (auto asExpr = expr.getDefiningOp<hlfir::AsExprOp>()) {
 607       hlfir::genLengthParameters(loc, builder, hlfir::Entity{asExpr.getVar()},
 608                                  result);
 609       return;
 610     } else if (auto elemental = expr.getDefiningOp<hlfir::ElementalOp>()) {
 611       result.append(elemental.getTypeparams().begin(),
 612                     elemental.getTypeparams().end());
 613       return;
 614     } else if (auto apply = expr.getDefiningOp<hlfir::ApplyOp>()) {
 615       result.append(apply.getTypeparams().begin(), apply.getTypeparams().end());
 616       return;
 617     }
 618     if (entity.isCharacter()) {
 619       result.push_back(builder.create<hlfir::GetLengthOp>(loc, expr));
 620       return;
 621     }
 622     TODO(loc, "inquire PDTs length parameters of hlfir.expr");
 623   }
 624
 625   if (entity.isCharacter()) {
 626     result.push_back(genCharacterVariableLength(loc, builder, entity));
 627     return;
 628   }
 629   TODO(loc, "inquire PDTs length parameters in HLFIR");
 630 }
 631
 632 mlir::Value hlfir::genCharLength(mlir::Location loc, fir::FirOpBuilder &builder,
 633                                  hlfir::Entity entity) {
 634   llvm::SmallVector<mlir::Value, 1> lenParams;
 635   genLengthParameters(loc, builder, entity, lenParams);
 636   assert(lenParams.size() == 1 && "characters must have one length parameters");
 637   return lenParams[0];
 638 }
 639
 640 // Return a "shape" that can be used in fir.embox/fir.rebox with \p exv base.
 641 static mlir::Value asEmboxShape(mlir::Location loc, fir::FirOpBuilder &builder,
 642                                 const fir::ExtendedValue &exv,
 643                                 mlir::Value shape) {
 644   if (!shape)
 645     return shape;
 646   // fir.rebox does not need and does not accept extents (fir.shape or
 647   // fir.shape_shift) since this information is already in the input fir.box,
 648   // it only accepts fir.shift because local lower bounds may not be reflected
 649   // in the fir.box.
 650   if (fir::getBase(exv).getType().isa<fir::BaseBoxType>() &&
 651       !shape.getType().isa<fir::ShiftType>())
 652     return builder.createShape(loc, exv);
 653   return shape;
 654 }
 655
 656 std::pair<mlir::Value, mlir::Value> hlfir::genVariableFirBaseShapeAndParams(
 657     mlir::Location loc, fir::FirOpBuilder &builder, Entity entity,
 658     llvm::SmallVectorImpl<mlir::Value> &typeParams) {
 659   auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
 660   assert(!cleanup && "variable to Exv should not produce cleanup");
 661   if (entity.hasLengthParameters()) {
 662     auto params = fir::getTypeParams(exv);
 663     typeParams.append(params.begin(), params.end());
 664   }
 665   if (entity.isScalar())
 666     return {fir::getBase(exv), mlir::Value{}};
 667   if (auto variableInterface = entity.getIfVariableInterface())
 668     return {fir::getBase(exv),
 669             asEmboxShape(loc, builder, exv, variableInterface.getShape())};
 670   return {fir::getBase(exv), builder.createShape(loc, exv)};
 671 }
 672
 673 hlfir::Entity hlfir::derefPointersAndAllocatables(mlir::Location loc,
 674                                                   fir::FirOpBuilder &builder,
 675                                                   Entity entity) {
 676   if (entity.isMutableBox()) {
 677     hlfir::Entity boxLoad{builder.create<fir::LoadOp>(loc, entity)};
 678     if (entity.isScalar()) {
 679       if (!entity.isPolymorphic() && !entity.hasLengthParameters())
 680         return hlfir::Entity{builder.create<fir::BoxAddrOp>(loc, boxLoad)};
 681       mlir::Type elementType = boxLoad.getFortranElementType();
 682       if (auto charType = elementType.dyn_cast<fir::CharacterType>()) {
 683         mlir::Value base = builder.create<fir::BoxAddrOp>(loc, boxLoad);
 684         if (charType.hasConstantLen())
 685           return hlfir::Entity{base};
 686         mlir::Value len = genCharacterVariableLength(loc, builder, entity);
 687         auto boxCharType =
 688             fir::BoxCharType::get(builder.getContext(), charType.getFKind());
 689         return hlfir::Entity{
 690             builder.create<fir::EmboxCharOp>(loc, boxCharType, base, len)
 691                 .getResult()};
 692       }
 693     }
 694     // Otherwise, the entity is either an array, a polymorphic entity, or a
 695     // derived type with length parameters. All these entities require a fir.box
 696     // or fir.class to hold bounds, dynamic type or length parameter
 697     // information. Keep them boxed.
 698     return boxLoad;
 699   }
 700   return entity;
 701 }
 702
 703 mlir::Type hlfir::getVariableElementType(hlfir::Entity variable) {
 704   assert(variable.isVariable() && "entity must be a variable");
 705   if (variable.isScalar())
 706     return variable.getType();
 707   mlir::Type eleTy = variable.getFortranElementType();
 708   if (variable.isPolymorphic())
 709     return fir::ClassType::get(eleTy);
 710   if (auto charType = eleTy.dyn_cast<fir::CharacterType>()) {
 711     if (charType.hasDynamicLen())
 712       return fir::BoxCharType::get(charType.getContext(), charType.getFKind());
 713   } else if (fir::isRecordWithTypeParameters(eleTy)) {
 714     return fir::BoxType::get(eleTy);
 715   }
 716   return fir::ReferenceType::get(eleTy);
 717 }
 718
 719 mlir::Type hlfir::getEntityElementType(hlfir::Entity entity) {
 720   if (entity.isVariable())
 721     return getVariableElementType(entity);
 722   if (entity.isScalar())
 723     return entity.getType();
 724   auto exprType = mlir::dyn_cast<hlfir::ExprType>(entity.getType());
 725   assert(exprType && "array value must be an hlfir.expr");
 726   return exprType.getElementExprType();
 727 }
 728
 729 static hlfir::ExprType getArrayExprType(mlir::Type elementType,
 730                                         mlir::Value shape, bool isPolymorphic) {
 731   unsigned rank = shape.getType().cast<fir::ShapeType>().getRank();
 732   hlfir::ExprType::Shape typeShape(rank, hlfir::ExprType::getUnknownExtent());
 733   if (auto shapeOp = shape.getDefiningOp<fir::ShapeOp>())
 734     for (auto extent : llvm::enumerate(shapeOp.getExtents()))
 735       if (auto cstExtent = fir::getIntIfConstant(extent.value()))
 736         typeShape[extent.index()] = *cstExtent;
 737   return hlfir::ExprType::get(elementType.getContext(), typeShape, elementType,
 738                               isPolymorphic);
 739 }
 740
 741 hlfir::ElementalOp hlfir::genElementalOp(
 742     mlir::Location loc, fir::FirOpBuilder &builder, mlir::Type elementType,
 743     mlir::Value shape, mlir::ValueRange typeParams,
 744     const ElementalKernelGenerator &genKernel, bool isUnordered,
 745     mlir::Value polymorphicMold, mlir::Type exprType) {
 746   if (!exprType)
 747     exprType = getArrayExprType(elementType, shape, !!polymorphicMold);
 748   auto elementalOp = builder.create<hlfir::ElementalOp>(
 749       loc, exprType, shape, polymorphicMold, typeParams, isUnordered);
 750   auto insertPt = builder.saveInsertionPoint();
 751   builder.setInsertionPointToStart(elementalOp.getBody());
 752   mlir::Value elementResult = genKernel(loc, builder, elementalOp.getIndices());
 753   // Numerical and logical scalars may be lowered to another type than the
 754   // Fortran expression type (e.g i1 instead of fir.logical). Array expression
 755   // values are typed according to their Fortran type. Insert a cast if needed
 756   // here.
 757   if (fir::isa_trivial(elementResult.getType()))
 758     elementResult = builder.createConvert(loc, elementType, elementResult);
 759   builder.create<hlfir::YieldElementOp>(loc, elementResult);
 760   builder.restoreInsertionPoint(insertPt);
 761   return elementalOp;
 762 }
 763
 764 // TODO: we do not actually need to clone the YieldElementOp,
 765 // because returning its getElementValue() operand should be enough
 766 // for all callers of this function.
 767 hlfir::YieldElementOp
 768 hlfir::inlineElementalOp(mlir::Location loc, fir::FirOpBuilder &builder,
 769                          hlfir::ElementalOp elemental,
 770                          mlir::ValueRange oneBasedIndices) {
 771   // hlfir.elemental region is a SizedRegion<1>.
 772   assert(elemental.getRegion().hasOneBlock() &&
 773          "expect elemental region to have one block");
 774   mlir::IRMapping mapper;
 775   mapper.map(elemental.getIndices(), oneBasedIndices);
 776   mlir::Operation *newOp;
 777   for (auto &op : elemental.getRegion().back().getOperations())
 778     newOp = builder.clone(op, mapper);
 779   auto yield = mlir::dyn_cast_or_null<hlfir::YieldElementOp>(newOp);
 780   assert(yield && "last ElementalOp operation must be am hlfir.yield_element");
 781   return yield;
 782 }
 783
 784 mlir::Value hlfir::inlineElementalOp(
 785     mlir::Location loc, fir::FirOpBuilder &builder,
 786     hlfir::ElementalOpInterface elemental, mlir::ValueRange oneBasedIndices,
 787     mlir::IRMapping &mapper,
 788     const std::function<bool(hlfir::ElementalOp)> &mustRecursivelyInline) {
 789   mlir::Region &region = elemental.getElementalRegion();
 790   // hlfir.elemental region is a SizedRegion<1>.
 791   assert(region.hasOneBlock() && "elemental region must have one block");
 792   mapper.map(elemental.getIndices(), oneBasedIndices);
 793   for (auto &op : region.front().without_terminator()) {
 794     if (auto apply = mlir::dyn_cast<hlfir::ApplyOp>(op))
 795       if (auto appliedElemental =
 796               apply.getExpr().getDefiningOp<hlfir::ElementalOp>())
 797         if (mustRecursivelyInline(appliedElemental)) {
 798           llvm::SmallVector<mlir::Value> clonedApplyIndices;
 799           for (auto indice : apply.getIndices())
 800             clonedApplyIndices.push_back(mapper.lookupOrDefault(indice));
 801           hlfir::ElementalOpInterface elementalIface =
 802               mlir::cast<hlfir::ElementalOpInterface>(
 803                   appliedElemental.getOperation());
 804           mlir::Value inlined = inlineElementalOp(loc, builder, elementalIface,
 805                                                   clonedApplyIndices, mapper,
 806                                                   mustRecursivelyInline);
 807           mapper.map(apply.getResult(), inlined);
 808           continue;
 809         }
 810     (void)builder.clone(op, mapper);
 811   }
 812   return mapper.lookupOrDefault(elemental.getElementEntity());
 813 }
 814
 815 hlfir::LoopNest hlfir::genLoopNest(mlir::Location loc,
 816                                    fir::FirOpBuilder &builder,
 817                                    mlir::ValueRange extents, bool isUnordered) {
 818   hlfir::LoopNest loopNest;
 819   assert(!extents.empty() && "must have at least one extent");
 820   auto insPt = builder.saveInsertionPoint();
 821   loopNest.oneBasedIndices.assign(extents.size(), mlir::Value{});
 822   // Build loop nest from column to row.
 823   auto one = builder.create<mlir::arith::ConstantIndexOp>(loc, 1);
 824   mlir::Type indexType = builder.getIndexType();
 825   unsigned dim = extents.size() - 1;
 826   for (auto extent : llvm::reverse(extents)) {
 827     auto ub = builder.createConvert(loc, indexType, extent);
 828     loopNest.innerLoop =
 829         builder.create<fir::DoLoopOp>(loc, one, ub, one, isUnordered);
 830     builder.setInsertionPointToStart(loopNest.innerLoop.getBody());
 831     // Reverse the indices so they are in column-major order.
 832     loopNest.oneBasedIndices[dim--] = loopNest.innerLoop.getInductionVar();
 833     if (!loopNest.outerLoop)
 834       loopNest.outerLoop = loopNest.innerLoop;
 835   }
 836   builder.restoreInsertionPoint(insPt);
 837   return loopNest;
 838 }
 839
 840 static fir::ExtendedValue
 841 translateVariableToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
 842                                  hlfir::Entity variable) {
 843   assert(variable.isVariable() && "must be a variable");
 844   /// When going towards FIR, use the original base value to avoid
 845   /// introducing descriptors at runtime when they are not required.
 846   mlir::Value firBase = variable.getFirBase();
 847   if (variable.isMutableBox())
 848     return fir::MutableBoxValue(firBase, getExplicitTypeParams(variable),
 849                                 fir::MutableProperties{});
 850
 851   if (firBase.getType().isa<fir::BaseBoxType>()) {
 852     if (!variable.isSimplyContiguous() || variable.isPolymorphic() ||
 853         variable.isDerivedWithLengthParameters() || variable.isOptional()) {
 854       llvm::SmallVector<mlir::Value> nonDefaultLbounds =
 855           getNonDefaultLowerBounds(loc, builder, variable);
 856       return fir::BoxValue(firBase, nonDefaultLbounds,
 857                            getExplicitTypeParams(variable));
 858     }
 859     // Otherwise, the variable can be represented in a fir::ExtendedValue
 860     // without the overhead of a fir.box.
 861     firBase = genVariableRawAddress(loc, builder, variable);
 862   }
 863
 864   if (variable.isScalar()) {
 865     if (variable.isCharacter()) {
 866       if (firBase.getType().isa<fir::BoxCharType>())
 867         return genUnboxChar(loc, builder, firBase);
 868       mlir::Value len = genCharacterVariableLength(loc, builder, variable);
 869       return fir::CharBoxValue{firBase, len};
 870     }
 871     return firBase;
 872   }
 873   llvm::SmallVector<mlir::Value> extents;
 874   llvm::SmallVector<mlir::Value> nonDefaultLbounds;
 875   if (variable.getType().isa<fir::BaseBoxType>() &&
 876       !variable.getIfVariableInterface()) {
 877     // This special case avoids generating two sets of identical
 878     // fir.box_dim to get both the lower bounds and extents.
 879     genLboundsAndExtentsFromBox(loc, builder, variable, nonDefaultLbounds,
 880                                 &extents);
 881   } else {
 882     extents = getVariableExtents(loc, builder, variable);
 883     nonDefaultLbounds = getNonDefaultLowerBounds(loc, builder, variable);
 884   }
 885   if (variable.isCharacter())
 886     return fir::CharArrayBoxValue{
 887         firBase, genCharacterVariableLength(loc, builder, variable), extents,
 888         nonDefaultLbounds};
 889   return fir::ArrayBoxValue{firBase, extents, nonDefaultLbounds};
 890 }
 891
 892 fir::ExtendedValue
 893 hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
 894                                 fir::FortranVariableOpInterface var) {
 895   return translateVariableToExtendedValue(loc, builder, var);
 896 }
 897
 898 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 899 hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
 900                                 hlfir::Entity entity) {
 901   if (entity.isVariable())
 902     return {translateVariableToExtendedValue(loc, builder, entity),
 903             std::nullopt};
 904
 905   if (entity.isProcedure()) {
 906     if (fir::isCharacterProcedureTuple(entity.getType())) {
 907       auto [boxProc, len] = fir::factory::extractCharacterProcedureTuple(
 908           builder, loc, entity, /*openBoxProc=*/false);
 909       return {fir::CharBoxValue{boxProc, len}, std::nullopt};
 910     }
 911     return {static_cast<mlir::Value>(entity), std::nullopt};
 912   }
 913
 914   if (entity.getType().isa<hlfir::ExprType>()) {
 915     hlfir::AssociateOp associate = hlfir::genAssociateExpr(
 916         loc, builder, entity, entity.getType(), "adapt.valuebyref");
 917     auto *bldr = &builder;
 918     hlfir::CleanupFunction cleanup = [bldr, loc, associate]() -> void {
 919       bldr->create<hlfir::EndAssociateOp>(loc, associate);
 920     };
 921     hlfir::Entity temp{associate.getBase()};
 922     return {translateToExtendedValue(loc, builder, temp).first, cleanup};
 923   }
 924   return {{static_cast<mlir::Value>(entity)}, {}};
 925 }
 926
 927 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 928 hlfir::convertToValue(mlir::Location loc, fir::FirOpBuilder &builder,
 929                       const hlfir::Entity &entity) {
 930   // Load scalar references to integer, logical, real, or complex value
 931   // to an mlir value, dereference allocatable and pointers, and get rid
 932   // of fir.box that are not needed or create a copy into contiguous memory.
 933   auto derefedAndLoadedEntity = loadTrivialScalar(loc, builder, entity);
 934   return translateToExtendedValue(loc, builder, derefedAndLoadedEntity);
 935 }
 936
 937 static fir::ExtendedValue placeTrivialInMemory(mlir::Location loc,
 938                                                fir::FirOpBuilder &builder,
 939                                                mlir::Value val,
 940                                                mlir::Type targetType) {
 941   auto temp = builder.createTemporary(loc, targetType);
 942   if (targetType != val.getType())
 943     builder.createStoreWithConvert(loc, val, temp);
 944   else
 945     builder.create<fir::StoreOp>(loc, val, temp);
 946   return temp;
 947 }
 948
 949 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 950 hlfir::convertToBox(mlir::Location loc, fir::FirOpBuilder &builder,
 951                     const hlfir::Entity &entity, mlir::Type targetType) {
 952   auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
 953   // Procedure entities should not go through createBoxValue that embox
 954   // object entities. Return the fir.boxproc directly.
 955   if (entity.isProcedure())
 956     return {exv, cleanup};
 957   mlir::Value base = fir::getBase(exv);
 958   if (fir::isa_trivial(base.getType()))
 959     exv = placeTrivialInMemory(loc, builder, base, targetType);
 960   fir::BoxValue box = fir::factory::createBoxValue(builder, loc, exv);
 961   return {box, cleanup};
 962 }
 963
 964 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 965 hlfir::convertToAddress(mlir::Location loc, fir::FirOpBuilder &builder,
 966                         const hlfir::Entity &entity, mlir::Type targetType) {
 967   hlfir::Entity derefedEntity =
 968       hlfir::derefPointersAndAllocatables(loc, builder, entity);
 969   auto [exv, cleanup] =
 970       hlfir::translateToExtendedValue(loc, builder, derefedEntity);
 971   mlir::Value base = fir::getBase(exv);
 972   if (fir::isa_trivial(base.getType()))
 973     exv = placeTrivialInMemory(loc, builder, base, targetType);
 974   return {exv, cleanup};
 975 }
 976
 977 /// Clone:
 978 /// ```
 979 /// hlfir.elemental_addr %shape : !fir.shape<1> {
 980 ///   ^bb0(%i : index)
 981 ///    .....
 982 ///    %hlfir.yield %scalarAddress : fir.ref<T>
 983 /// }
 984 /// ```
 985 //
 986 /// into
 987 ///
 988 /// ```
 989 /// %expr = hlfir.elemental %shape : (!fir.shape<1>) -> hlfir.expr<?xT> {
 990 ///   ^bb0(%i : index)
 991 ///    .....
 992 ///    %value = fir.load %scalarAddress : fir.ref<T>
 993 ///    %hlfir.yield_element %value : T
 994 ///  }
 995 /// ```
 996 hlfir::ElementalOp
 997 hlfir::cloneToElementalOp(mlir::Location loc, fir::FirOpBuilder &builder,
 998                           hlfir::ElementalAddrOp elementalAddrOp) {
 999   hlfir::Entity scalarAddress =
1000       hlfir::Entity{mlir::cast<hlfir::YieldOp>(
1001                         elementalAddrOp.getBody().back().getTerminator())
1002                         .getEntity()};
1003   llvm::SmallVector<mlir::Value, 1> typeParams;
1004   hlfir::genLengthParameters(loc, builder, scalarAddress, typeParams);
1005
1006   builder.setInsertionPointAfter(elementalAddrOp);
1007   auto genKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
1008                        mlir::ValueRange oneBasedIndices) -> hlfir::Entity {
1009     mlir::IRMapping mapper;
1010     mapper.map(elementalAddrOp.getIndices(), oneBasedIndices);
1011     mlir::Operation *newOp = nullptr;
1012     for (auto &op : elementalAddrOp.getBody().back().getOperations())
1013       newOp = b.clone(op, mapper);
1014     auto newYielOp = mlir::dyn_cast_or_null<hlfir::YieldOp>(newOp);
1015     assert(newYielOp && "hlfir.elemental_addr is ill formed");
1016     hlfir::Entity newAddr{newYielOp.getEntity()};
1017     newYielOp->erase();
1018     return hlfir::loadTrivialScalar(l, b, newAddr);
1019   };
1020   mlir::Type elementType = scalarAddress.getFortranElementType();
1021   return hlfir::genElementalOp(loc, builder, elementType,
1022                                elementalAddrOp.getShape(), typeParams,
1023                                genKernel, !elementalAddrOp.isOrdered());
1024 }
1025
1026 bool hlfir::elementalOpMustProduceTemp(hlfir::ElementalOp elemental) {
1027   for (mlir::Operation *useOp : elemental->getUsers())
1028     if (auto destroy = mlir::dyn_cast<hlfir::DestroyOp>(useOp))
1029       if (destroy.mustFinalizeExpr())
1030         return true;
1031
1032   return false;
1033 }
1034
1035 std::pair<hlfir::Entity, mlir::Value>
1036 hlfir::createTempFromMold(mlir::Location loc, fir::FirOpBuilder &builder,
1037                           hlfir::Entity mold) {
1038   llvm::SmallVector<mlir::Value> lenParams;
1039   hlfir::genLengthParameters(loc, builder, mold, lenParams);
1040   llvm::StringRef tmpName{".tmp"};
1041   mlir::Value alloc;
1042   mlir::Value isHeapAlloc;
1043   mlir::Value shape{};
1044   fir::FortranVariableFlagsAttr declAttrs;
1045
1046   if (mold.isPolymorphic()) {
1047     // Create unallocated polymorphic temporary using the dynamic type
1048     // of the mold. The static type of the temporary matches
1049     // the static type of the mold, but then the dynamic type
1050     // of the mold is applied to the temporary's descriptor.
1051
1052     if (mold.isArray())
1053       hlfir::genShape(loc, builder, mold);
1054
1055     // Create polymorphic allocatable box on the stack.
1056     mlir::Type boxHeapType = fir::HeapType::get(fir::unwrapRefType(
1057         mlir::cast<fir::BaseBoxType>(mold.getType()).getEleTy()));
1058     // The box must be initialized, because AllocatableApplyMold
1059     // may read its contents (e.g. for checking whether it is allocated).
1060     alloc = fir::factory::genNullBoxStorage(builder, loc,
1061                                             fir::ClassType::get(boxHeapType));
1062     // The temporary is unallocated even after AllocatableApplyMold below.
1063     // If the temporary is used as assignment LHS it will be automatically
1064     // allocated on the heap, as long as we use Assign family
1065     // runtime functions. So set MustFree to true.
1066     isHeapAlloc = builder.createBool(loc, true);
1067     declAttrs = fir::FortranVariableFlagsAttr::get(
1068         builder.getContext(), fir::FortranVariableFlagsEnum::allocatable);
1069   } else if (mold.isArray()) {
1070     mlir::Type sequenceType =
1071         hlfir::getFortranElementOrSequenceType(mold.getType());
1072     shape = hlfir::genShape(loc, builder, mold);
1073     auto extents = hlfir::getIndexExtents(loc, builder, shape);
1074     alloc = builder.createHeapTemporary(loc, sequenceType, tmpName, extents,
1075                                         lenParams);
1076     isHeapAlloc = builder.createBool(loc, true);
1077   } else {
1078     alloc = builder.createTemporary(loc, mold.getFortranElementType(), tmpName,
1079                                     /*shape=*/std::nullopt, lenParams);
1080     isHeapAlloc = builder.createBool(loc, false);
1081   }
1082   auto declareOp = builder.create<hlfir::DeclareOp>(loc, alloc, tmpName, shape,
1083                                                     lenParams, declAttrs);
1084   if (mold.isPolymorphic()) {
1085     int rank = mold.getRank();
1086     // TODO: should probably read rank from the mold.
1087     if (rank < 0)
1088       TODO(loc, "create temporary for assumed rank polymorphic");
1089     fir::runtime::genAllocatableApplyMold(builder, loc, alloc,
1090                                           mold.getFirBase(), rank);
1091   }
1092
1093   return {hlfir::Entity{declareOp.getBase()}, isHeapAlloc};
1094 }