flang/lib/Optimizer/Builder/MutableBox.cpp

   1 //===-- MutableBox.cpp -- MutableBox utilities ----------------------------===//
   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 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
  10 //
  11 //===----------------------------------------------------------------------===//
  12
  13 #include "flang/Optimizer/Builder/MutableBox.h"
  14 #include "flang/Optimizer/Builder/Character.h"
  15 #include "flang/Optimizer/Builder/FIRBuilder.h"
  16 #include "flang/Optimizer/Builder/Runtime/Derived.h"
  17 #include "flang/Optimizer/Builder/Runtime/Stop.h"
  18 #include "flang/Optimizer/Builder/Todo.h"
  19 #include "flang/Optimizer/Dialect/FIRAttr.h"
  20 #include "flang/Optimizer/Dialect/FIROps.h"
  21 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
  22 #include "flang/Optimizer/Support/FatalError.h"
  23
  24 /// Create a fir.box describing the new address, bounds, and length parameters
  25 /// for a MutableBox \p box.
  26 static mlir::Value
  27 createNewFirBox(fir::FirOpBuilder &builder, mlir::Location loc,
  28                 const fir::MutableBoxValue &box, mlir::Value addr,
  29                 mlir::ValueRange lbounds, mlir::ValueRange extents,
  30                 mlir::ValueRange lengths, mlir::Value tdesc = {}) {
  31   if (mlir::isa<fir::BaseBoxType>(addr.getType()))
  32     // The entity is already boxed.
  33     return builder.createConvert(loc, box.getBoxTy(), addr);
  34
  35   mlir::Value shape;
  36   if (!extents.empty()) {
  37     if (lbounds.empty()) {
  38       shape = builder.create<fir::ShapeOp>(loc, extents);
  39     } else {
  40       llvm::SmallVector<mlir::Value> shapeShiftBounds;
  41       for (auto [lb, extent] : llvm::zip(lbounds, extents)) {
  42         shapeShiftBounds.emplace_back(lb);
  43         shapeShiftBounds.emplace_back(extent);
  44       }
  45       auto shapeShiftType =
  46           fir::ShapeShiftType::get(builder.getContext(), extents.size());
  47       shape = builder.create<fir::ShapeShiftOp>(loc, shapeShiftType,
  48                                                 shapeShiftBounds);
  49     }
  50   } // Otherwise, this a scalar. Leave the shape empty.
  51
  52   // Ignore lengths if already constant in the box type (this would trigger an
  53   // error in the embox).
  54   llvm::SmallVector<mlir::Value> cleanedLengths;
  55   auto cleanedAddr = addr;
  56   if (auto charTy = mlir::dyn_cast<fir::CharacterType>(box.getEleTy())) {
  57     // Cast address to box type so that both input and output type have
  58     // unknown or constant lengths.
  59     auto bt = box.getBaseTy();
  60     auto addrTy = addr.getType();
  61     auto type = mlir::isa<fir::HeapType>(addrTy) ? fir::HeapType::get(bt)
  62                 : mlir::isa<fir::PointerType>(addrTy)
  63                     ? fir::PointerType::get(bt)
  64                     : builder.getRefType(bt);
  65     cleanedAddr = builder.createConvert(loc, type, addr);
  66     if (charTy.getLen() == fir::CharacterType::unknownLen())
  67       cleanedLengths.append(lengths.begin(), lengths.end());
  68   } else if (fir::isUnlimitedPolymorphicType(box.getBoxTy())) {
  69     if (auto charTy = mlir::dyn_cast<fir::CharacterType>(
  70             fir::dyn_cast_ptrEleTy(addr.getType()))) {
  71       if (charTy.getLen() == fir::CharacterType::unknownLen())
  72         cleanedLengths.append(lengths.begin(), lengths.end());
  73     }
  74   } else if (box.isDerivedWithLenParameters()) {
  75     TODO(loc, "updating mutablebox of derived type with length parameters");
  76     cleanedLengths = lengths;
  77   }
  78   mlir::Value emptySlice;
  79   return builder.create<fir::EmboxOp>(loc, box.getBoxTy(), cleanedAddr, shape,
  80                                       emptySlice, cleanedLengths, tdesc);
  81 }
  82
  83 //===----------------------------------------------------------------------===//
  84 // MutableBoxValue writer and reader
  85 //===----------------------------------------------------------------------===//
  86
  87 namespace {
  88 /// MutablePropertyWriter and MutablePropertyReader implementations are the only
  89 /// places that depend on how the properties of MutableBoxValue (pointers and
  90 /// allocatables) that can be modified in the lifetime of the entity (address,
  91 /// extents, lower bounds, length parameters) are represented.
  92 /// That is, the properties may be only stored in a fir.box in memory if we
  93 /// need to enforce a single point of truth for the properties across calls.
  94 /// Or, they can be tracked as independent local variables when it is safe to
  95 /// do so. Using bare variables benefits from all optimization passes, even
  96 /// when they are not aware of what a fir.box is and fir.box have not been
  97 /// optimized out yet.
  98
  99 /// MutablePropertyWriter allows reading the properties of a MutableBoxValue.
 100 class MutablePropertyReader {
 101 public:
 102   MutablePropertyReader(fir::FirOpBuilder &builder, mlir::Location loc,
 103                         const fir::MutableBoxValue &box,
 104                         bool forceIRBoxRead = false)
 105       : builder{builder}, loc{loc}, box{box} {
 106     if (forceIRBoxRead || !box.isDescribedByVariables())
 107       irBox = builder.create<fir::LoadOp>(loc, box.getAddr());
 108   }
 109   /// Get base address of allocated/associated entity.
 110   mlir::Value readBaseAddress() {
 111     if (irBox) {
 112       auto memrefTy = box.getBoxTy().getEleTy();
 113       if (!fir::isa_ref_type(memrefTy))
 114         memrefTy = builder.getRefType(memrefTy);
 115       return builder.create<fir::BoxAddrOp>(loc, memrefTy, irBox);
 116     }
 117     auto addrVar = box.getMutableProperties().addr;
 118     return builder.create<fir::LoadOp>(loc, addrVar);
 119   }
 120   /// Return {lbound, extent} values read from the MutableBoxValue given
 121   /// the dimension.
 122   std::pair<mlir::Value, mlir::Value> readShape(unsigned dim) {
 123     auto idxTy = builder.getIndexType();
 124     if (irBox) {
 125       auto dimVal = builder.createIntegerConstant(loc, idxTy, dim);
 126       auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
 127                                                     irBox, dimVal);
 128       return {dimInfo.getResult(0), dimInfo.getResult(1)};
 129     }
 130     const auto &mutableProperties = box.getMutableProperties();
 131     auto lb = builder.create<fir::LoadOp>(loc, mutableProperties.lbounds[dim]);
 132     auto ext = builder.create<fir::LoadOp>(loc, mutableProperties.extents[dim]);
 133     return {lb, ext};
 134   }
 135
 136   /// Return the character length. If the length was not deferred, the value
 137   /// that was specified is returned (The mutable fields is not read).
 138   mlir::Value readCharacterLength() {
 139     if (box.hasNonDeferredLenParams())
 140       return box.nonDeferredLenParams()[0];
 141     if (irBox)
 142       return fir::factory::CharacterExprHelper{builder, loc}.readLengthFromBox(
 143           irBox);
 144     const auto &deferred = box.getMutableProperties().deferredParams;
 145     if (deferred.empty())
 146       fir::emitFatalError(loc, "allocatable entity has no length property");
 147     return builder.create<fir::LoadOp>(loc, deferred[0]);
 148   }
 149
 150   /// Read and return all extents. If \p lbounds vector is provided, lbounds are
 151   /// also read into it.
 152   llvm::SmallVector<mlir::Value>
 153   readShape(llvm::SmallVectorImpl<mlir::Value> *lbounds = nullptr) {
 154     llvm::SmallVector<mlir::Value> extents;
 155     auto rank = box.rank();
 156     for (decltype(rank) dim = 0; dim < rank; ++dim) {
 157       auto [lb, extent] = readShape(dim);
 158       if (lbounds)
 159         lbounds->push_back(lb);
 160       extents.push_back(extent);
 161     }
 162     return extents;
 163   }
 164
 165   /// Read all mutable properties. Return the base address.
 166   mlir::Value read(llvm::SmallVectorImpl<mlir::Value> &lbounds,
 167                    llvm::SmallVectorImpl<mlir::Value> &extents,
 168                    llvm::SmallVectorImpl<mlir::Value> &lengths) {
 169     extents = readShape(&lbounds);
 170     if (box.isCharacter())
 171       lengths.emplace_back(readCharacterLength());
 172     else if (box.isDerivedWithLenParameters())
 173       TODO(loc, "read allocatable or pointer derived type LEN parameters");
 174     return readBaseAddress();
 175   }
 176
 177   /// Return the loaded fir.box.
 178   mlir::Value getIrBox() const {
 179     assert(irBox);
 180     return irBox;
 181   }
 182
 183   /// Read the lower bounds
 184   void getLowerBounds(llvm::SmallVectorImpl<mlir::Value> &lbounds) {
 185     auto rank = box.rank();
 186     for (decltype(rank) dim = 0; dim < rank; ++dim)
 187       lbounds.push_back(std::get<0>(readShape(dim)));
 188   }
 189
 190 private:
 191   fir::FirOpBuilder &builder;
 192   mlir::Location loc;
 193   fir::MutableBoxValue box;
 194   mlir::Value irBox;
 195 };
 196
 197 /// MutablePropertyWriter allows modifying the properties of a MutableBoxValue.
 198 class MutablePropertyWriter {
 199 public:
 200   MutablePropertyWriter(fir::FirOpBuilder &builder, mlir::Location loc,
 201                         const fir::MutableBoxValue &box,
 202                         mlir::Value typeSourceBox = {}, unsigned allocator = 0)
 203       : builder{builder}, loc{loc}, box{box}, typeSourceBox{typeSourceBox},
 204         allocator{allocator} {}
 205   /// Update MutableBoxValue with new address, shape and length parameters.
 206   /// Extents and lbounds must all have index type.
 207   /// lbounds can be empty in which case all ones is assumed.
 208   /// Length parameters must be provided for the length parameters that are
 209   /// deferred.
 210   void updateMutableBox(mlir::Value addr, mlir::ValueRange lbounds,
 211                         mlir::ValueRange extents, mlir::ValueRange lengths,
 212                         mlir::Value tdesc = {}) {
 213     if (box.isDescribedByVariables())
 214       updateMutableProperties(addr, lbounds, extents, lengths);
 215     else
 216       updateIRBox(addr, lbounds, extents, lengths, tdesc);
 217   }
 218
 219   /// Update MutableBoxValue with a new fir.box. This requires that the mutable
 220   /// box is not described by a set of variables, since they could not describe
 221   /// all that can be described in the new fir.box (e.g. non contiguous entity).
 222   void updateWithIrBox(mlir::Value newBox) {
 223     assert(!box.isDescribedByVariables());
 224     builder.create<fir::StoreOp>(loc, newBox, box.getAddr());
 225   }
 226   /// Set unallocated/disassociated status for the entity described by
 227   /// MutableBoxValue. Deallocation is not performed by this helper.
 228   void setUnallocatedStatus() {
 229     if (box.isDescribedByVariables()) {
 230       auto addrVar = box.getMutableProperties().addr;
 231       auto nullTy = fir::dyn_cast_ptrEleTy(addrVar.getType());
 232       builder.create<fir::StoreOp>(loc, builder.createNullConstant(loc, nullTy),
 233                                    addrVar);
 234     } else {
 235       // Note that the dynamic type of polymorphic entities must be reset to the
 236       // declaration type of the mutable box. See Fortran 2018 7.8.2 NOTE 1.
 237       // For those, we cannot simply set the address to zero. The way we are
 238       // currently unallocating fir.box guarantees that we are resetting the
 239       // type to the declared type. Beware if changing this.
 240       // Note: the standard is not clear in Deallocate and p => NULL semantics
 241       // regarding the new dynamic type the entity must have. So far, assume
 242       // this is just like NULLIFY and the dynamic type must be set to the
 243       // declared type, not retain the previous dynamic type.
 244       auto deallocatedBox = fir::factory::createUnallocatedBox(
 245           builder, loc, box.getBoxTy(), box.nonDeferredLenParams(),
 246           typeSourceBox, allocator);
 247       builder.create<fir::StoreOp>(loc, deallocatedBox, box.getAddr());
 248     }
 249   }
 250
 251   /// Copy Values from the fir.box into the property variables if any.
 252   void syncMutablePropertiesFromIRBox() {
 253     if (!box.isDescribedByVariables())
 254       return;
 255     llvm::SmallVector<mlir::Value> lbounds;
 256     llvm::SmallVector<mlir::Value> extents;
 257     llvm::SmallVector<mlir::Value> lengths;
 258     auto addr =
 259         MutablePropertyReader{builder, loc, box, /*forceIRBoxRead=*/true}.read(
 260             lbounds, extents, lengths);
 261     updateMutableProperties(addr, lbounds, extents, lengths);
 262   }
 263
 264   /// Copy Values from property variables, if any, into the fir.box.
 265   void syncIRBoxFromMutableProperties() {
 266     if (!box.isDescribedByVariables())
 267       return;
 268     llvm::SmallVector<mlir::Value> lbounds;
 269     llvm::SmallVector<mlir::Value> extents;
 270     llvm::SmallVector<mlir::Value> lengths;
 271     auto addr = MutablePropertyReader{builder, loc, box}.read(lbounds, extents,
 272                                                               lengths);
 273     updateIRBox(addr, lbounds, extents, lengths);
 274   }
 275
 276 private:
 277   /// Update the IR box (fir.ref<fir.box<T>>) of the MutableBoxValue.
 278   void updateIRBox(mlir::Value addr, mlir::ValueRange lbounds,
 279                    mlir::ValueRange extents, mlir::ValueRange lengths,
 280                    mlir::Value tdesc = {},
 281                    unsigned allocator = kDefaultAllocator) {
 282     mlir::Value irBox = createNewFirBox(builder, loc, box, addr, lbounds,
 283                                         extents, lengths, tdesc);
 284     builder.create<fir::StoreOp>(loc, irBox, box.getAddr());
 285   }
 286
 287   /// Update the set of property variables of the MutableBoxValue.
 288   void updateMutableProperties(mlir::Value addr, mlir::ValueRange lbounds,
 289                                mlir::ValueRange extents,
 290                                mlir::ValueRange lengths) {
 291     auto castAndStore = [&](mlir::Value val, mlir::Value addr) {
 292       auto type = fir::dyn_cast_ptrEleTy(addr.getType());
 293       builder.create<fir::StoreOp>(loc, builder.createConvert(loc, type, val),
 294                                    addr);
 295     };
 296     const auto &mutableProperties = box.getMutableProperties();
 297     castAndStore(addr, mutableProperties.addr);
 298     for (auto [extent, extentVar] :
 299          llvm::zip(extents, mutableProperties.extents))
 300       castAndStore(extent, extentVar);
 301     if (!mutableProperties.lbounds.empty()) {
 302       if (lbounds.empty()) {
 303         auto one =
 304             builder.createIntegerConstant(loc, builder.getIndexType(), 1);
 305         for (auto lboundVar : mutableProperties.lbounds)
 306           castAndStore(one, lboundVar);
 307       } else {
 308         for (auto [lbound, lboundVar] :
 309              llvm::zip(lbounds, mutableProperties.lbounds))
 310           castAndStore(lbound, lboundVar);
 311       }
 312     }
 313     if (box.isCharacter())
 314       // llvm::zip account for the fact that the length only needs to be stored
 315       // when it is specified in the allocation and deferred in the
 316       // MutableBoxValue.
 317       for (auto [len, lenVar] :
 318            llvm::zip(lengths, mutableProperties.deferredParams))
 319         castAndStore(len, lenVar);
 320     else if (box.isDerivedWithLenParameters())
 321       TODO(loc, "update allocatable derived type length parameters");
 322   }
 323   fir::FirOpBuilder &builder;
 324   mlir::Location loc;
 325   fir::MutableBoxValue box;
 326   mlir::Value typeSourceBox;
 327   unsigned allocator;
 328 };
 329
 330 } // namespace
 331
 332 mlir::Value fir::factory::createUnallocatedBox(
 333     fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType,
 334     mlir::ValueRange nonDeferredParams, mlir::Value typeSourceBox,
 335     unsigned allocator) {
 336   auto baseBoxType = mlir::cast<fir::BaseBoxType>(boxType);
 337   // Giving unallocated/disassociated status to assumed-rank POINTER/
 338   // ALLOCATABLE is not directly possible to a Fortran user. But the
 339   // compiler may need to create such temporary descriptor to deal with
 340   // cases like ENTRY or host association. In such case, all that mater
 341   // is that the base address is set to zero and the rank is set to
 342   // some defined value. Hence, a scalar descriptor is created and
 343   // cast to assumed-rank.
 344   const bool isAssumedRank = baseBoxType.isAssumedRank();
 345   if (isAssumedRank)
 346     baseBoxType = baseBoxType.getBoxTypeWithNewShape(/*rank=*/0);
 347   auto baseAddrType = baseBoxType.getEleTy();
 348   if (!fir::isa_ref_type(baseAddrType))
 349     baseAddrType = builder.getRefType(baseAddrType);
 350   auto type = fir::unwrapRefType(baseAddrType);
 351   auto eleTy = fir::unwrapSequenceType(type);
 352   if (auto recTy = mlir::dyn_cast<fir::RecordType>(eleTy))
 353     if (recTy.getNumLenParams() > 0)
 354       TODO(loc, "creating unallocated fir.box of derived type with length "
 355                 "parameters");
 356   auto nullAddr = builder.createNullConstant(loc, baseAddrType);
 357   mlir::Value shape;
 358   if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(type)) {
 359     auto zero = builder.createIntegerConstant(loc, builder.getIndexType(), 0);
 360     llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), zero);
 361     shape = builder.createShape(
 362         loc, fir::ArrayBoxValue{nullAddr, extents, /*lbounds=*/std::nullopt});
 363   }
 364   // Provide dummy length parameters if they are dynamic. If a length parameter
 365   // is deferred. It is set to zero here and will be set on allocation.
 366   llvm::SmallVector<mlir::Value> lenParams;
 367   if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
 368     if (charTy.getLen() == fir::CharacterType::unknownLen()) {
 369       if (!nonDeferredParams.empty()) {
 370         lenParams.push_back(nonDeferredParams[0]);
 371       } else {
 372         auto zero = builder.createIntegerConstant(
 373             loc, builder.getCharacterLengthType(), 0);
 374         lenParams.push_back(zero);
 375       }
 376     }
 377   }
 378   mlir::Value emptySlice;
 379   auto embox = builder.create<fir::EmboxOp>(
 380       loc, baseBoxType, nullAddr, shape, emptySlice, lenParams, typeSourceBox);
 381   if (allocator != 0)
 382     embox.setAllocatorIdx(allocator);
 383   if (isAssumedRank)
 384     return builder.createConvert(loc, boxType, embox);
 385   return embox;
 386 }
 387
 388 fir::MutableBoxValue fir::factory::createTempMutableBox(
 389     fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type type,
 390     llvm::StringRef name, mlir::Value typeSourceBox, bool isPolymorphic) {
 391   mlir::Type boxType;
 392   if (typeSourceBox || isPolymorphic)
 393     boxType = fir::ClassType::get(fir::HeapType::get(type));
 394   else
 395     boxType = fir::BoxType::get(fir::HeapType::get(type));
 396   auto boxAddr = builder.createTemporary(loc, boxType, name);
 397   auto box =
 398       fir::MutableBoxValue(boxAddr, /*nonDeferredParams=*/mlir::ValueRange(),
 399                            /*mutableProperties=*/{});
 400   MutablePropertyWriter{builder, loc, box, typeSourceBox}
 401       .setUnallocatedStatus();
 402   return box;
 403 }
 404
 405 /// Helper to decide if a MutableBoxValue must be read to a BoxValue or
 406 /// can be read to a reified box value.
 407 static bool readToBoxValue(const fir::MutableBoxValue &box,
 408                            bool mayBePolymorphic) {
 409   // If this is described by a set of local variables, the value
 410   // should not be tracked as a fir.box.
 411   if (box.isDescribedByVariables())
 412     return false;
 413   // Polymorphism might be a source of discontiguity, even on allocatables.
 414   // Track value as fir.box
 415   if ((box.isDerived() && mayBePolymorphic) || box.isUnlimitedPolymorphic())
 416     return true;
 417   if (box.hasAssumedRank())
 418     return true;
 419   // Intrinsic allocatables are contiguous, no need to track the value by
 420   // fir.box.
 421   if (box.isAllocatable() || box.rank() == 0)
 422     return false;
 423   // Pointers are known to be contiguous at compile time iff they have the
 424   // CONTIGUOUS attribute.
 425   return !fir::valueHasFirAttribute(box.getAddr(),
 426                                     fir::getContiguousAttrName());
 427 }
 428
 429 fir::ExtendedValue
 430 fir::factory::genMutableBoxRead(fir::FirOpBuilder &builder, mlir::Location loc,
 431                                 const fir::MutableBoxValue &box,
 432                                 bool mayBePolymorphic,
 433                                 bool preserveLowerBounds) {
 434   llvm::SmallVector<mlir::Value> lbounds;
 435   llvm::SmallVector<mlir::Value> extents;
 436   llvm::SmallVector<mlir::Value> lengths;
 437   if (readToBoxValue(box, mayBePolymorphic)) {
 438     auto reader = MutablePropertyReader(builder, loc, box);
 439     if (preserveLowerBounds && !box.hasAssumedRank())
 440       reader.getLowerBounds(lbounds);
 441     return fir::BoxValue{reader.getIrBox(), lbounds,
 442                          box.nonDeferredLenParams()};
 443   }
 444   // Contiguous intrinsic type entity: all the data can be extracted from the
 445   // fir.box.
 446   auto addr =
 447       MutablePropertyReader(builder, loc, box).read(lbounds, extents, lengths);
 448   if (!preserveLowerBounds)
 449     lbounds.clear();
 450   auto rank = box.rank();
 451   if (box.isCharacter()) {
 452     auto len = lengths.empty() ? mlir::Value{} : lengths[0];
 453     if (rank)
 454       return fir::CharArrayBoxValue{addr, len, extents, lbounds};
 455     return fir::CharBoxValue{addr, len};
 456   }
 457   mlir::Value sourceBox;
 458   if (box.isPolymorphic())
 459     sourceBox = builder.create<fir::LoadOp>(loc, box.getAddr());
 460   if (rank)
 461     return fir::ArrayBoxValue{addr, extents, lbounds, sourceBox};
 462   if (box.isPolymorphic())
 463     return fir::PolymorphicValue(addr, sourceBox);
 464   return addr;
 465 }
 466
 467 mlir::Value
 468 fir::factory::genIsAllocatedOrAssociatedTest(fir::FirOpBuilder &builder,
 469                                              mlir::Location loc,
 470                                              const fir::MutableBoxValue &box) {
 471   auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
 472   return builder.genIsNotNullAddr(loc, addr);
 473 }
 474
 475 mlir::Value fir::factory::genIsNotAllocatedOrAssociatedTest(
 476     fir::FirOpBuilder &builder, mlir::Location loc,
 477     const fir::MutableBoxValue &box) {
 478   auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
 479   return builder.genIsNullAddr(loc, addr);
 480 }
 481
 482 /// Call freemem. This does not check that the
 483 /// address was allocated.
 484 static void genFreemem(fir::FirOpBuilder &builder, mlir::Location loc,
 485                        mlir::Value addr) {
 486   // A heap (ALLOCATABLE) object may have been converted to a ptr (POINTER),
 487   // so make sure the heap type is restored before deallocation.
 488   auto cast = builder.createConvert(
 489       loc, fir::HeapType::get(fir::dyn_cast_ptrEleTy(addr.getType())), addr);
 490   builder.create<fir::FreeMemOp>(loc, cast);
 491 }
 492
 493 void fir::factory::genFreememIfAllocated(fir::FirOpBuilder &builder,
 494                                          mlir::Location loc,
 495                                          const fir::MutableBoxValue &box) {
 496   auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
 497   auto isAllocated = builder.genIsNotNullAddr(loc, addr);
 498   auto ifOp = builder.create<fir::IfOp>(loc, isAllocated,
 499                                         /*withElseRegion=*/false);
 500   auto insPt = builder.saveInsertionPoint();
 501   builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
 502   ::genFreemem(builder, loc, addr);
 503   builder.restoreInsertionPoint(insPt);
 504 }
 505
 506 //===----------------------------------------------------------------------===//
 507 // MutableBoxValue writing interface implementation
 508 //===----------------------------------------------------------------------===//
 509
 510 void fir::factory::associateMutableBox(fir::FirOpBuilder &builder,
 511                                        mlir::Location loc,
 512                                        const fir::MutableBoxValue &box,
 513                                        const fir::ExtendedValue &source,
 514                                        mlir::ValueRange lbounds) {
 515   MutablePropertyWriter writer(builder, loc, box);
 516   source.match(
 517       [&](const fir::PolymorphicValue &p) {
 518         mlir::Value sourceBox;
 519         if (auto polyBox = source.getBoxOf<fir::PolymorphicValue>())
 520           sourceBox = polyBox->getSourceBox();
 521         writer.updateMutableBox(p.getAddr(), /*lbounds=*/std::nullopt,
 522                                 /*extents=*/std::nullopt,
 523                                 /*lengths=*/std::nullopt, sourceBox);
 524       },
 525       [&](const fir::UnboxedValue &addr) {
 526         writer.updateMutableBox(addr, /*lbounds=*/std::nullopt,
 527                                 /*extents=*/std::nullopt,
 528                                 /*lengths=*/std::nullopt);
 529       },
 530       [&](const fir::CharBoxValue &ch) {
 531         writer.updateMutableBox(ch.getAddr(), /*lbounds=*/std::nullopt,
 532                                 /*extents=*/std::nullopt, {ch.getLen()});
 533       },
 534       [&](const fir::ArrayBoxValue &arr) {
 535         writer.updateMutableBox(arr.getAddr(),
 536                                 lbounds.empty() ? arr.getLBounds() : lbounds,
 537                                 arr.getExtents(), /*lengths=*/std::nullopt);
 538       },
 539       [&](const fir::CharArrayBoxValue &arr) {
 540         writer.updateMutableBox(arr.getAddr(),
 541                                 lbounds.empty() ? arr.getLBounds() : lbounds,
 542                                 arr.getExtents(), {arr.getLen()});
 543       },
 544       [&](const fir::BoxValue &arr) {
 545         // Rebox array fir.box to the pointer type and apply potential new lower
 546         // bounds.
 547         mlir::ValueRange newLbounds = lbounds.empty()
 548                                           ? mlir::ValueRange{arr.getLBounds()}
 549                                           : mlir::ValueRange{lbounds};
 550         if (box.hasAssumedRank()) {
 551           assert(arr.hasAssumedRank() &&
 552                  "expect both arr and box to be assumed-rank");
 553           mlir::Value reboxed = builder.create<fir::ReboxAssumedRankOp>(
 554               loc, box.getBoxTy(), arr.getAddr(),
 555               fir::LowerBoundModifierAttribute::Preserve);
 556           writer.updateWithIrBox(reboxed);
 557         } else if (box.isDescribedByVariables()) {
 558           // LHS is a contiguous pointer described by local variables. Open RHS
 559           // fir.box to update the LHS.
 560           auto rawAddr = builder.create<fir::BoxAddrOp>(loc, arr.getMemTy(),
 561                                                         arr.getAddr());
 562           auto extents = fir::factory::getExtents(loc, builder, source);
 563           llvm::SmallVector<mlir::Value> lenParams;
 564           if (arr.isCharacter()) {
 565             lenParams.emplace_back(
 566                 fir::factory::readCharLen(builder, loc, source));
 567           } else if (arr.isDerivedWithLenParameters()) {
 568             TODO(loc, "pointer assignment to derived with length parameters");
 569           }
 570           writer.updateMutableBox(rawAddr, newLbounds, extents, lenParams);
 571         } else {
 572           mlir::Value shift;
 573           if (!newLbounds.empty()) {
 574             auto shiftType =
 575                 fir::ShiftType::get(builder.getContext(), newLbounds.size());
 576             shift = builder.create<fir::ShiftOp>(loc, shiftType, newLbounds);
 577           }
 578           auto reboxed =
 579               builder.create<fir::ReboxOp>(loc, box.getBoxTy(), arr.getAddr(),
 580                                            shift, /*slice=*/mlir::Value());
 581           writer.updateWithIrBox(reboxed);
 582         }
 583       },
 584       [&](const fir::MutableBoxValue &) {
 585         // No point implementing this, if right-hand side is a
 586         // pointer/allocatable, the related MutableBoxValue has been read into
 587         // another ExtendedValue category.
 588         fir::emitFatalError(loc,
 589                             "Cannot write MutableBox to another MutableBox");
 590       },
 591       [&](const fir::ProcBoxValue &) {
 592         TODO(loc, "procedure pointer assignment");
 593       });
 594 }
 595
 596 void fir::factory::associateMutableBoxWithRemap(
 597     fir::FirOpBuilder &builder, mlir::Location loc,
 598     const fir::MutableBoxValue &box, const fir::ExtendedValue &source,
 599     mlir::ValueRange lbounds, mlir::ValueRange ubounds) {
 600   // Compute new extents
 601   llvm::SmallVector<mlir::Value> extents;
 602   auto idxTy = builder.getIndexType();
 603   if (!lbounds.empty()) {
 604     auto one = builder.createIntegerConstant(loc, idxTy, 1);
 605     for (auto [lb, ub] : llvm::zip(lbounds, ubounds)) {
 606       auto lbi = builder.createConvert(loc, idxTy, lb);
 607       auto ubi = builder.createConvert(loc, idxTy, ub);
 608       auto diff = builder.create<mlir::arith::SubIOp>(loc, idxTy, ubi, lbi);
 609       extents.emplace_back(
 610           builder.create<mlir::arith::AddIOp>(loc, idxTy, diff, one));
 611     }
 612   } else {
 613     // lbounds are default. Upper bounds and extents are the same.
 614     for (auto ub : ubounds) {
 615       auto cast = builder.createConvert(loc, idxTy, ub);
 616       extents.emplace_back(cast);
 617     }
 618   }
 619   const auto newRank = extents.size();
 620   auto cast = [&](mlir::Value addr) -> mlir::Value {
 621     // Cast base addr to new sequence type.
 622     auto ty = fir::dyn_cast_ptrEleTy(addr.getType());
 623     if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(ty)) {
 624       fir::SequenceType::Shape shape(newRank,
 625                                      fir::SequenceType::getUnknownExtent());
 626       ty = fir::SequenceType::get(shape, seqTy.getEleTy());
 627     }
 628     return builder.createConvert(loc, builder.getRefType(ty), addr);
 629   };
 630   MutablePropertyWriter writer(builder, loc, box);
 631   source.match(
 632       [&](const fir::PolymorphicValue &p) {
 633         writer.updateMutableBox(cast(p.getAddr()), lbounds, extents,
 634                                 /*lengths=*/std::nullopt);
 635       },
 636       [&](const fir::UnboxedValue &addr) {
 637         writer.updateMutableBox(cast(addr), lbounds, extents,
 638                                 /*lengths=*/std::nullopt);
 639       },
 640       [&](const fir::CharBoxValue &ch) {
 641         writer.updateMutableBox(cast(ch.getAddr()), lbounds, extents,
 642                                 {ch.getLen()});
 643       },
 644       [&](const fir::ArrayBoxValue &arr) {
 645         writer.updateMutableBox(cast(arr.getAddr()), lbounds, extents,
 646                                 /*lengths=*/std::nullopt);
 647       },
 648       [&](const fir::CharArrayBoxValue &arr) {
 649         writer.updateMutableBox(cast(arr.getAddr()), lbounds, extents,
 650                                 {arr.getLen()});
 651       },
 652       [&](const fir::BoxValue &arr) {
 653         // Rebox right-hand side fir.box with a new shape and type.
 654         if (box.isDescribedByVariables()) {
 655           // LHS is a contiguous pointer described by local variables. Open RHS
 656           // fir.box to update the LHS.
 657           auto rawAddr = builder.create<fir::BoxAddrOp>(loc, arr.getMemTy(),
 658                                                         arr.getAddr());
 659           llvm::SmallVector<mlir::Value> lenParams;
 660           if (arr.isCharacter()) {
 661             lenParams.emplace_back(
 662                 fir::factory::readCharLen(builder, loc, source));
 663           } else if (arr.isDerivedWithLenParameters()) {
 664             TODO(loc, "pointer assignment to derived with length parameters");
 665           }
 666           writer.updateMutableBox(rawAddr, lbounds, extents, lenParams);
 667         } else {
 668           auto shapeType =
 669               fir::ShapeShiftType::get(builder.getContext(), extents.size());
 670           llvm::SmallVector<mlir::Value> shapeArgs;
 671           auto idxTy = builder.getIndexType();
 672           for (auto [lbnd, ext] : llvm::zip(lbounds, extents)) {
 673             auto lb = builder.createConvert(loc, idxTy, lbnd);
 674             shapeArgs.push_back(lb);
 675             shapeArgs.push_back(ext);
 676           }
 677           auto shape =
 678               builder.create<fir::ShapeShiftOp>(loc, shapeType, shapeArgs);
 679           auto reboxed =
 680               builder.create<fir::ReboxOp>(loc, box.getBoxTy(), arr.getAddr(),
 681                                            shape, /*slice=*/mlir::Value());
 682           writer.updateWithIrBox(reboxed);
 683         }
 684       },
 685       [&](const fir::MutableBoxValue &) {
 686         // No point implementing this, if right-hand side is a pointer or
 687         // allocatable, the related MutableBoxValue has already been read into
 688         // another ExtendedValue category.
 689         fir::emitFatalError(loc,
 690                             "Cannot write MutableBox to another MutableBox");
 691       },
 692       [&](const fir::ProcBoxValue &) {
 693         TODO(loc, "procedure pointer assignment");
 694       });
 695 }
 696
 697 void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
 698                                           mlir::Location loc,
 699                                           const fir::MutableBoxValue &box,
 700                                           bool polymorphicSetType,
 701                                           unsigned allocator) {
 702   if (box.isPolymorphic() && polymorphicSetType) {
 703     // 7.3.2.3 point 7. The dynamic type of a disassociated pointer is the
 704     // same as its declared type.
 705     auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(box.getBoxTy());
 706     auto eleTy = fir::unwrapPassByRefType(boxTy.getEleTy());
 707     mlir::Type derivedType = fir::getDerivedType(eleTy);
 708     if (auto recTy = mlir::dyn_cast<fir::RecordType>(derivedType)) {
 709       fir::runtime::genNullifyDerivedType(builder, loc, box.getAddr(), recTy,
 710                                           box.rank());
 711       return;
 712     }
 713   }
 714   MutablePropertyWriter{builder, loc, box, {}, allocator}
 715       .setUnallocatedStatus();
 716 }
 717
 718 static llvm::SmallVector<mlir::Value>
 719 getNewLengths(fir::FirOpBuilder &builder, mlir::Location loc,
 720               const fir::MutableBoxValue &box, mlir::ValueRange lenParams) {
 721   llvm::SmallVector<mlir::Value> lengths;
 722   auto idxTy = builder.getIndexType();
 723   if (auto charTy = mlir::dyn_cast<fir::CharacterType>(box.getEleTy())) {
 724     if (charTy.getLen() == fir::CharacterType::unknownLen()) {
 725       if (box.hasNonDeferredLenParams()) {
 726         lengths.emplace_back(
 727             builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0]));
 728       } else if (!lenParams.empty()) {
 729         mlir::Value len =
 730             fir::factory::genMaxWithZero(builder, loc, lenParams[0]);
 731         lengths.emplace_back(builder.createConvert(loc, idxTy, len));
 732       } else {
 733         fir::emitFatalError(
 734             loc, "could not deduce character lengths in character allocation");
 735       }
 736     }
 737   }
 738   return lengths;
 739 }
 740
 741 static mlir::Value allocateAndInitNewStorage(fir::FirOpBuilder &builder,
 742                                              mlir::Location loc,
 743                                              const fir::MutableBoxValue &box,
 744                                              mlir::ValueRange extents,
 745                                              mlir::ValueRange lenParams,
 746                                              llvm::StringRef allocName) {
 747   auto lengths = getNewLengths(builder, loc, box, lenParams);
 748   auto newStorage = builder.create<fir::AllocMemOp>(
 749       loc, box.getBaseTy(), allocName, lengths, extents);
 750   if (mlir::isa<fir::RecordType>(box.getEleTy())) {
 751     // TODO: skip runtime initialization if this is not required. Currently,
 752     // there is no way to know here if a derived type needs it or not. But the
 753     // information is available at compile time and could be reflected here
 754     // somehow.
 755     mlir::Value irBox = createNewFirBox(builder, loc, box, newStorage,
 756                                         std::nullopt, extents, lengths);
 757     fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
 758   }
 759   return newStorage;
 760 }
 761
 762 void fir::factory::genInlinedAllocation(
 763     fir::FirOpBuilder &builder, mlir::Location loc,
 764     const fir::MutableBoxValue &box, mlir::ValueRange lbounds,
 765     mlir::ValueRange extents, mlir::ValueRange lenParams,
 766     llvm::StringRef allocName, bool mustBeHeap) {
 767   auto lengths = getNewLengths(builder, loc, box, lenParams);
 768   llvm::SmallVector<mlir::Value> safeExtents;
 769   for (mlir::Value extent : extents)
 770     safeExtents.push_back(fir::factory::genMaxWithZero(builder, loc, extent));
 771   auto heap = builder.create<fir::AllocMemOp>(loc, box.getBaseTy(), allocName,
 772                                               lengths, safeExtents);
 773   MutablePropertyWriter{builder, loc, box}.updateMutableBox(
 774       heap, lbounds, safeExtents, lengths);
 775   if (mlir::isa<fir::RecordType>(box.getEleTy())) {
 776     // TODO: skip runtime initialization if this is not required. Currently,
 777     // there is no way to know here if a derived type needs it or not. But the
 778     // information is available at compile time and could be reflected here
 779     // somehow.
 780     mlir::Value irBox = fir::factory::getMutableIRBox(builder, loc, box);
 781     fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
 782   }
 783
 784   heap->setAttr(fir::MustBeHeapAttr::getAttrName(),
 785                 fir::MustBeHeapAttr::get(builder.getContext(), mustBeHeap));
 786 }
 787
 788 mlir::Value fir::factory::genFreemem(fir::FirOpBuilder &builder,
 789                                      mlir::Location loc,
 790                                      const fir::MutableBoxValue &box) {
 791   auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
 792   ::genFreemem(builder, loc, addr);
 793   MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
 794   return addr;
 795 }
 796
 797 fir::factory::MutableBoxReallocation fir::factory::genReallocIfNeeded(
 798     fir::FirOpBuilder &builder, mlir::Location loc,
 799     const fir::MutableBoxValue &box, mlir::ValueRange shape,
 800     mlir::ValueRange lengthParams,
 801     fir::factory::ReallocStorageHandlerFunc storageHandler) {
 802   // Implement 10.2.1.3 point 3 logic when lhs is an array.
 803   auto reader = MutablePropertyReader(builder, loc, box);
 804   auto addr = reader.readBaseAddress();
 805   auto i1Type = builder.getI1Type();
 806   auto addrType = addr.getType();
 807   auto isAllocated = builder.genIsNotNullAddr(loc, addr);
 808   auto getExtValForStorage = [&](mlir::Value newAddr) -> fir::ExtendedValue {
 809     mlir::SmallVector<mlir::Value> extents;
 810     if (box.hasRank()) {
 811       if (shape.empty())
 812         extents = reader.readShape();
 813       else
 814         extents.append(shape.begin(), shape.end());
 815     }
 816     if (box.isCharacter()) {
 817       auto len = box.hasNonDeferredLenParams() ? reader.readCharacterLength()
 818                                                : lengthParams[0];
 819       if (box.hasRank())
 820         return fir::CharArrayBoxValue{newAddr, len, extents};
 821       return fir::CharBoxValue{newAddr, len};
 822     }
 823     if (box.isDerivedWithLenParameters())
 824       TODO(loc, "reallocation of derived type entities with length parameters");
 825     if (box.hasRank())
 826       return fir::ArrayBoxValue{newAddr, extents};
 827     return newAddr;
 828   };
 829   auto ifOp =
 830       builder
 831           .genIfOp(loc, {i1Type, addrType}, isAllocated,
 832                    /*withElseRegion=*/true)
 833           .genThen([&]() {
 834             // The box is allocated. Check if it must be reallocated and
 835             // reallocate.
 836             auto mustReallocate = builder.createBool(loc, false);
 837             auto compareProperty = [&](mlir::Value previous,
 838                                        mlir::Value required) {
 839               auto castPrevious =
 840                   builder.createConvert(loc, required.getType(), previous);
 841               auto cmp = builder.create<mlir::arith::CmpIOp>(
 842                   loc, mlir::arith::CmpIPredicate::ne, castPrevious, required);
 843               mustReallocate = builder.create<mlir::arith::SelectOp>(
 844                   loc, cmp, cmp, mustReallocate);
 845             };
 846             llvm::SmallVector<mlir::Value> previousExtents = reader.readShape();
 847             if (!shape.empty())
 848               for (auto [previousExtent, requested] :
 849                    llvm::zip(previousExtents, shape))
 850                 compareProperty(previousExtent, requested);
 851
 852             if (box.isCharacter() && !box.hasNonDeferredLenParams()) {
 853               // When the allocatable length is not deferred, it must not be
 854               // reallocated in case of length mismatch, instead,
 855               // padding/trimming will occur in later assignment to it.
 856               assert(!lengthParams.empty() &&
 857                      "must provide length parameters for character");
 858               compareProperty(reader.readCharacterLength(), lengthParams[0]);
 859             } else if (box.isDerivedWithLenParameters()) {
 860               TODO(loc, "automatic allocation of derived type allocatable with "
 861                         "length parameters");
 862             }
 863             auto ifOp = builder
 864                             .genIfOp(loc, {addrType}, mustReallocate,
 865                                      /*withElseRegion=*/true)
 866                             .genThen([&]() {
 867                               // If shape or length mismatch, allocate new
 868                               // storage. When rhs is a scalar, keep the
 869                               // previous shape
 870                               auto extents =
 871                                   shape.empty()
 872                                       ? mlir::ValueRange(previousExtents)
 873                                       : shape;
 874                               auto heap = allocateAndInitNewStorage(
 875                                   builder, loc, box, extents, lengthParams,
 876                                   ".auto.alloc");
 877                               if (storageHandler)
 878                                 storageHandler(getExtValForStorage(heap));
 879                               builder.create<fir::ResultOp>(loc, heap);
 880                             })
 881                             .genElse([&]() {
 882                               if (storageHandler)
 883                                 storageHandler(getExtValForStorage(addr));
 884                               builder.create<fir::ResultOp>(loc, addr);
 885                             });
 886             ifOp.end();
 887             auto newAddr = ifOp.getResults()[0];
 888             builder.create<fir::ResultOp>(
 889                 loc, mlir::ValueRange{mustReallocate, newAddr});
 890           })
 891           .genElse([&]() {
 892             auto trueValue = builder.createBool(loc, true);
 893             // The box is not yet allocated, simply allocate it.
 894             if (shape.empty() && box.rank() != 0) {
 895               // See 10.2.1.3 p3.
 896               fir::runtime::genReportFatalUserError(
 897                   builder, loc,
 898                   "array left hand side must be allocated when the right hand "
 899                   "side is a scalar");
 900               builder.create<fir::ResultOp>(loc,
 901                                             mlir::ValueRange{trueValue, addr});
 902             } else {
 903               auto heap = allocateAndInitNewStorage(
 904                   builder, loc, box, shape, lengthParams, ".auto.alloc");
 905               if (storageHandler)
 906                 storageHandler(getExtValForStorage(heap));
 907               builder.create<fir::ResultOp>(loc,
 908                                             mlir::ValueRange{trueValue, heap});
 909             }
 910           });
 911   ifOp.end();
 912   auto wasReallocated = ifOp.getResults()[0];
 913   auto newAddr = ifOp.getResults()[1];
 914   // Create an ExtentedValue for the new storage.
 915   auto newValue = getExtValForStorage(newAddr);
 916   return {newValue, addr, wasReallocated, isAllocated};
 917 }
 918
 919 void fir::factory::finalizeRealloc(fir::FirOpBuilder &builder,
 920                                    mlir::Location loc,
 921                                    const fir::MutableBoxValue &box,
 922                                    mlir::ValueRange lbounds,
 923                                    bool takeLboundsIfRealloc,
 924                                    const MutableBoxReallocation &realloc) {
 925   builder.genIfThen(loc, realloc.wasReallocated)
 926       .genThen([&]() {
 927         auto reader = MutablePropertyReader(builder, loc, box);
 928         llvm::SmallVector<mlir::Value> previousLbounds;
 929         if (!takeLboundsIfRealloc && box.hasRank())
 930           reader.readShape(&previousLbounds);
 931         auto lbs =
 932             takeLboundsIfRealloc ? lbounds : mlir::ValueRange{previousLbounds};
 933         llvm::SmallVector<mlir::Value> lenParams;
 934         if (box.isCharacter())
 935           lenParams.push_back(fir::getLen(realloc.newValue));
 936         if (box.isDerivedWithLenParameters())
 937           TODO(loc,
 938                "reallocation of derived type entities with length parameters");
 939         auto lengths = getNewLengths(builder, loc, box, lenParams);
 940         auto heap = fir::getBase(realloc.newValue);
 941         auto extents = fir::factory::getExtents(loc, builder, realloc.newValue);
 942         builder.genIfThen(loc, realloc.oldAddressWasAllocated)
 943             .genThen([&]() { ::genFreemem(builder, loc, realloc.oldAddress); })
 944             .end();
 945         MutablePropertyWriter{builder, loc, box}.updateMutableBox(
 946             heap, lbs, extents, lengths);
 947       })
 948       .end();
 949 }
 950
 951 //===----------------------------------------------------------------------===//
 952 // MutableBoxValue syncing implementation
 953 //===----------------------------------------------------------------------===//
 954
 955 /// Depending on the implementation, allocatable/pointer descriptor and the
 956 /// MutableBoxValue need to be synced before and after calls passing the
 957 /// descriptor. These calls will generate the syncing if needed or be no-op.
 958 mlir::Value fir::factory::getMutableIRBox(fir::FirOpBuilder &builder,
 959                                           mlir::Location loc,
 960                                           const fir::MutableBoxValue &box) {
 961   MutablePropertyWriter{builder, loc, box}.syncIRBoxFromMutableProperties();
 962   return box.getAddr();
 963 }
 964 void fir::factory::syncMutableBoxFromIRBox(fir::FirOpBuilder &builder,
 965                                            mlir::Location loc,
 966                                            const fir::MutableBoxValue &box) {
 967   MutablePropertyWriter{builder, loc, box}.syncMutablePropertiesFromIRBox();
 968 }
 969
 970 mlir::Value fir::factory::genNullBoxStorage(fir::FirOpBuilder &builder,
 971                                             mlir::Location loc,
 972                                             mlir::Type boxTy) {
 973   mlir::Value boxStorage = builder.createTemporary(loc, boxTy);
 974   mlir::Value nullBox = fir::factory::createUnallocatedBox(
 975       builder, loc, boxTy, /*nonDeferredParams=*/{});
 976   builder.create<fir::StoreOp>(loc, nullBox, boxStorage);
 977   return boxStorage;
 978 }