[flang] Lower allocate and deallocate statements

[clementval]

Summary

This patch add the lowering for the allocate
and the deallocate statements.

This patch is part of the upstreaming effort from fir-dev branch.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Lower/Allocatable.h

 class ValueRange;
 class Location;
 } // namespace mlir
 
 namespace fir {
 class MutableBoxValue;
 } // namespace fir
 
+namespace Fortran::parser {
+struct AllocateStmt;
+struct DeallocateStmt;
+} // namespace Fortran::parser
+
 namespace Fortran::lower {
 class AbstractConverter;
 
 namespace pft {
 struct Variable;
 }
 
+/// Lower an allocate statement to fir.
+void genAllocateStmt(Fortran::lower::AbstractConverter &,
+                     const Fortran::parser::AllocateStmt &, mlir::Location);
+
+/// Lower a deallocate statement to fir.
+void genDeallocateStmt(Fortran::lower::AbstractConverter &,
+                       const Fortran::parser::DeallocateStmt &, mlir::Location);
+
 /// Create a MutableBoxValue for an allocatable or pointer entity.
 /// If the variables is a local variable that is not a dummy, it will be
 /// initialized to unallocated/disassociated status.
 fir::MutableBoxValue createMutableBox(Fortran::lower::AbstractConverter &,
                                       mlir::Location,
                                       const Fortran::lower::pft::Variable &var,
                                       mlir::Value boxAddr,
                                       mlir::ValueRange nonDeferredParams);
 
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_ALLOCATABLE_H

flang/lib/Lower/Allocatable.cpp

 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Parser/parse-tree.h"
+#include "flang/Runtime/allocatable.h"
+#include "flang/Runtime/pointer.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
 #include "llvm/Support/CommandLine.h"
 
 /// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.
 /// This switch allow forcing the use of runtime and descriptors for everything.
 /// This is mainly intended as a debug switch.
 static llvm::cl::opt<bool> useAllocateRuntime(
     "use-alloc-runtime",
     llvm::cl::desc("Lower allocations to fortran runtime calls"),
     llvm::cl::init(false));
 /// Switch to force lowering of allocatable and pointers to descriptors in all
 /// cases for debug purposes.
 static llvm::cl::opt<bool> useDescForMutableBox(
     "use-desc-for-alloc",
     llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
     llvm::cl::init(false));
 
 //===----------------------------------------------------------------------===//
+// Error management
+//===----------------------------------------------------------------------===//
+
+namespace {
+// Manage STAT and ERRMSG specifier information across a sequence of runtime
+// calls for an ALLOCATE/DEALLOCATE stmt.
+struct ErrorManager {
+  void init(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+            const Fortran::lower::SomeExpr *statExpr,
+            const Fortran::lower::SomeExpr *errMsgExpr) {
+    Fortran::lower::StatementContext stmtCtx;
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    hasStat = builder.createBool(loc, statExpr != nullptr);
+    statAddr = statExpr
+                   ? fir::getBase(converter.genExprAddr(statExpr, stmtCtx, loc))
+                   : mlir::Value{};
+    errMsgAddr =
+        statExpr && errMsgExpr
+            ? builder.createBox(loc,
+                                converter.genExprAddr(errMsgExpr, stmtCtx, loc))
+            : builder.create<fir::AbsentOp>(
+                  loc,
+                  fir::BoxType::get(mlir::NoneType::get(builder.getContext())));
+    sourceFile = fir::factory::locationToFilename(builder, loc);
+    sourceLine = fir::factory::locationToLineNo(builder, loc,
+                                                builder.getIntegerType(32));
+  }
+
+  bool hasStatSpec() const { return static_cast<bool>(statAddr); }
+
+  void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) {
+    if (statValue) {
+      mlir::Value zero =
+          builder.createIntegerConstant(loc, statValue.getType(), 0);
+      auto cmp = builder.create<mlir::arith::CmpIOp>(
+          loc, mlir::arith::CmpIPredicate::eq, statValue, zero);
+      auto ifOp = builder.create<fir::IfOp>(loc, cmp,
+                                            /*withElseRegion=*/false);
+      builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+    }
+  }
+
+  void assignStat(fir::FirOpBuilder &builder, mlir::Location loc,
+                  mlir::Value stat) {
+    if (hasStatSpec()) {
+      assert(stat && "missing stat value");
+      mlir::Value castStat = builder.createConvert(
+          loc, fir::dyn_cast_ptrEleTy(statAddr.getType()), stat);
+      builder.create<fir::StoreOp>(loc, castStat, statAddr);
+      statValue = stat;
+    }
+  }
+
+  mlir::Value hasStat;
+  mlir::Value errMsgAddr;
+  mlir::Value sourceFile;
+  mlir::Value sourceLine;
+
+private:
+  mlir::Value statAddr;  // STAT variable address
+  mlir::Value statValue; // current runtime STAT value
+};
+
+//===----------------------------------------------------------------------===//
+// Allocatables runtime call generators
+//===----------------------------------------------------------------------===//
+
+using namespace Fortran::runtime;
+/// Generate a runtime call to set the bounds of an allocatable or pointer
+/// descriptor.
+static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc,
+                                const fir::MutableBoxValue &box,
+                                mlir::Value dimIndex, mlir::Value lowerBound,
+                                mlir::Value upperBound) {
+  mlir::FuncOp callee =
+      box.isPointer()
+          ? fir::runtime::getRuntimeFunc<mkRTKey(PointerSetBounds)>(loc,
+                                                                    builder)
+          : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableSetBounds)>(
+                loc, builder);
+  llvm::SmallVector<mlir::Value> args{box.getAddr(), dimIndex, lowerBound,
+                                      upperBound};
+  llvm::SmallVector<mlir::Value> operands;
+  for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs()))
+    operands.emplace_back(builder.createConvert(loc, snd, fst));
+  builder.create<fir::CallOp>(loc, callee, operands);
+}
+
+/// Generate runtime call to set the lengths of a character allocatable or
+/// pointer descriptor.
+static void genRuntimeInitCharacter(fir::FirOpBuilder &builder,
+                                    mlir::Location loc,
+                                    const fir::MutableBoxValue &box,
+                                    mlir::Value len) {
+  mlir::FuncOp callee =
+      box.isPointer()
+          ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>(
+                loc, builder)
+          : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableInitCharacter)>(
+                loc, builder);
+  llvm::ArrayRef<mlir::Type> inputTypes = callee.getType().getInputs();
+  if (inputTypes.size() != 5)
+    fir::emitFatalError(
+        loc, "AllocatableInitCharacter runtime interface not as expected");
+  llvm::SmallVector<mlir::Value> args;
+  args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
+  args.push_back(builder.createConvert(loc, inputTypes[1], len));
+  int kind = box.getEleTy().cast<fir::CharacterType>().getFKind();
+  args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind));
+  int rank = box.rank();
+  args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank));
+  // TODO: coarrays
+  int corank = 0;
+  args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank));
+  builder.create<fir::CallOp>(loc, callee, args);
+}
+
+/// Generate a sequence of runtime calls to allocate memory.
+static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder,
+                                      mlir::Location loc,
+                                      const fir::MutableBoxValue &box,
+                                      ErrorManager &errorManager) {
+  mlir::FuncOp callee =
+      box.isPointer()
+          ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocate)>(loc, builder)
+          : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocate)>(loc,
+                                                                       builder);
+  llvm::SmallVector<mlir::Value> args{
+      box.getAddr(), errorManager.hasStat, errorManager.errMsgAddr,
+      errorManager.sourceFile, errorManager.sourceLine};
+  llvm::SmallVector<mlir::Value> operands;
+  for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs()))
+    operands.emplace_back(builder.createConvert(loc, snd, fst));
+  return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
+}
+
+/// Generate a runtime call to deallocate memory.
+static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder,
+                                        mlir::Location loc,
+                                        const fir::MutableBoxValue &box,
+                                        ErrorManager &errorManager) {
+  // Ensure fir.box is up-to-date before passing it to deallocate runtime.
+  mlir::Value boxAddress = fir::factory::getMutableIRBox(builder, loc, box);
+  mlir::FuncOp callee =
+      box.isPointer()
+          ? fir::runtime::getRuntimeFunc<mkRTKey(PointerDeallocate)>(loc,
+                                                                     builder)
+          : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableDeallocate)>(
+                loc, builder);
+  llvm::SmallVector<mlir::Value> args{
+      boxAddress, errorManager.hasStat, errorManager.errMsgAddr,
+      errorManager.sourceFile, errorManager.sourceLine};
+  llvm::SmallVector<mlir::Value> operands;
+  for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs()))
+    operands.emplace_back(builder.createConvert(loc, snd, fst));
+  return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
+}
+
+//===----------------------------------------------------------------------===//
+// Allocate statement implementation
+//===----------------------------------------------------------------------===//
+
+/// Helper to get symbol from AllocateObject.
+static const Fortran::semantics::Symbol &
+unwrapSymbol(const Fortran::parser::AllocateObject &allocObj) {
+  const Fortran::parser::Name &lastName =
+      Fortran::parser::GetLastName(allocObj);
+  assert(lastName.symbol);
+  return *lastName.symbol;
+}
+
+static fir::MutableBoxValue
+genMutableBoxValue(Fortran::lower::AbstractConverter &converter,
+                   mlir::Location loc,
+                   const Fortran::parser::AllocateObject &allocObj) {
+  const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(allocObj);
+  assert(expr && "semantic analysis failure");
+  return converter.genExprMutableBox(loc, *expr);
+}
+
+/// Implement Allocate statement lowering.
+class AllocateStmtHelper {
+public:
+  AllocateStmtHelper(Fortran::lower::AbstractConverter &converter,
+                     const Fortran::parser::AllocateStmt &stmt,
+                     mlir::Location loc)
+      : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt},
+        loc{loc} {}
+
+  void lower() {
+    visitAllocateOptions();
+    lowerAllocateLengthParameters();
+    errorManager.init(converter, loc, statExpr, errMsgExpr);
+    if (sourceExpr || moldExpr)
+      TODO(loc, "lower MOLD/SOURCE expr in allocate");
+    mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
+    for (const auto &allocation :
+         std::get<std::list<Fortran::parser::Allocation>>(stmt.t))
+      lowerAllocation(unwrapAllocation(allocation));
+    builder.restoreInsertionPoint(insertPt);
+  }
+
+private:
+  struct Allocation {
+    const Fortran::parser::Allocation &alloc;
+    const Fortran::semantics::DeclTypeSpec &type;
+    bool hasCoarraySpec() const {
+      return std::get<std::optional<Fortran::parser::AllocateCoarraySpec>>(
+                 alloc.t)
+          .has_value();
+    }
+    const Fortran::parser::AllocateObject &getAllocObj() const {
+      return std::get<Fortran::parser::AllocateObject>(alloc.t);
+    }
+    const Fortran::semantics::Symbol &getSymbol() const {
+      return unwrapSymbol(getAllocObj());
+    }
+    const std::list<Fortran::parser::AllocateShapeSpec> &getShapeSpecs() const {
+      return std::get<std::list<Fortran::parser::AllocateShapeSpec>>(alloc.t);
+    }
+  };
+
+  Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) {
+    const auto &allocObj = std::get<Fortran::parser::AllocateObject>(alloc.t);
+    const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocObj);
+    assert(symbol.GetType());
+    return Allocation{alloc, *symbol.GetType()};
+  }
+
+  void visitAllocateOptions() {
+    for (const auto &allocOption :
+         std::get<std::list<Fortran::parser::AllocOpt>>(stmt.t))
+      std::visit(
+          Fortran::common::visitors{
+              [&](const Fortran::parser::StatOrErrmsg &statOrErr) {
+                std::visit(
+                    Fortran::common::visitors{
+                        [&](const Fortran::parser::StatVariable &statVar) {
+                          statExpr = Fortran::semantics::GetExpr(statVar);
+                        },
+                        [&](const Fortran::parser::MsgVariable &errMsgVar) {
+                          errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
+                        },
+                    },
+                    statOrErr.u);
+              },
+              [&](const Fortran::parser::AllocOpt::Source &source) {
+                sourceExpr = Fortran::semantics::GetExpr(source.v.value());
+              },
+              [&](const Fortran::parser::AllocOpt::Mold &mold) {
+                moldExpr = Fortran::semantics::GetExpr(mold.v.value());
+              },
+          },
+          allocOption.u);
+  }
+
+  void lowerAllocation(const Allocation &alloc) {
+    fir::MutableBoxValue boxAddr =
+        genMutableBoxValue(converter, loc, alloc.getAllocObj());
+    mlir::Value backupBox;
+
+    if (sourceExpr) {
+      genSourceAllocation(alloc, boxAddr);
+    } else if (moldExpr) {
+      genMoldAllocation(alloc, boxAddr);
+    } else {
+      genSimpleAllocation(alloc, boxAddr);
+    }
+  }
+
+  static bool lowerBoundsAreOnes(const Allocation &alloc) {
+    for (const Fortran::parser::AllocateShapeSpec &shapeSpec :
+         alloc.getShapeSpecs())
+      if (std::get<0>(shapeSpec.t))
+        return false;
+    return true;
+  }
+
+  /// Build name for the fir::allocmem generated for alloc.
+  std::string mangleAlloc(const Allocation &alloc) {
+    return converter.mangleName(alloc.getSymbol()) + ".alloc";
+  }
+
+  /// Generate allocation without runtime calls.
+  /// Only for intrinsic types. No coarrays, no polymorphism. No error recovery.
+  void genInlinedAllocation(const Allocation &alloc,
+                            const fir::MutableBoxValue &box) {
+    llvm::SmallVector<mlir::Value> lbounds;
+    llvm::SmallVector<mlir::Value> extents;
+    Fortran::lower::StatementContext stmtCtx;
+    mlir::Type idxTy = builder.getIndexType();
+    bool lBoundsAreOnes = lowerBoundsAreOnes(alloc);
+    mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+    for (const Fortran::parser::AllocateShapeSpec &shapeSpec :
+         alloc.getShapeSpecs()) {
+      mlir::Value lb;
+      if (!lBoundsAreOnes) {
+        if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =
+                std::get<0>(shapeSpec.t)) {
+          lb = fir::getBase(converter.genExprValue(
+              Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc));
+          lb = builder.createConvert(loc, idxTy, lb);
+        } else {
+          lb = one;
+        }
+        lbounds.emplace_back(lb);
+      }
+      mlir::Value ub = fir::getBase(converter.genExprValue(
+          Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx, loc));
+      ub = builder.createConvert(loc, idxTy, ub);
+      if (lb) {
+        mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, ub, lb);
+        extents.emplace_back(
+            builder.create<mlir::arith::AddIOp>(loc, diff, one));
+      } else {
+        extents.emplace_back(ub);
+      }
+    }
+    fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents,
+                                       lenParams, mangleAlloc(alloc));
+  }
+
+  void genSimpleAllocation(const Allocation &alloc,
+                           const fir::MutableBoxValue &box) {
+    if (!box.isDerived() && !errorManager.hasStatSpec() &&
+        !alloc.type.IsPolymorphic() && !alloc.hasCoarraySpec() &&
+        !useAllocateRuntime) {
+      genInlinedAllocation(alloc, box);
+      return;
+    }
+    // Generate a sequence of runtime calls.
+    errorManager.genStatCheck(builder, loc);
+    if (box.isPointer()) {
+      // For pointers, the descriptor may still be uninitialized (see Fortran
+      // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor
+      // with initialized rank, types and attributes. Initialize the descriptor
+      // here to ensure these constraints are fulfilled.
+      mlir::Value nullPointer = fir::factory::createUnallocatedBox(
+          builder, loc, box.getBoxTy(), box.nonDeferredLenParams());
+      builder.create<fir::StoreOp>(loc, nullPointer, box.getAddr());
+    } else {
+      assert(box.isAllocatable() && "must be an allocatable");
+      // For allocatables, sync the MutableBoxValue and descriptor before the
+      // calls in case it is tracked locally by a set of variables.
+      fir::factory::getMutableIRBox(builder, loc, box);
+    }
+    if (alloc.hasCoarraySpec())
+      TODO(loc, "coarray allocation");
+    if (alloc.type.IsPolymorphic())
+      genSetType(alloc, box);
+    genSetDeferredLengthParameters(alloc, box);
+    // Set bounds for arrays
+    mlir::Type idxTy = builder.getIndexType();
+    mlir::Type i32Ty = builder.getIntegerType(32);
+    Fortran::lower::StatementContext stmtCtx;
+    for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) {
+      mlir::Value lb;
+      const auto &bounds = iter.value().t;
+      if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =
+              std::get<0>(bounds))
+        lb = fir::getBase(converter.genExprValue(
+            Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc));
+      else
+        lb = builder.createIntegerConstant(loc, idxTy, 1);
+      mlir::Value ub = fir::getBase(converter.genExprValue(
+          Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx, loc));
+      mlir::Value dimIndex =
+          builder.createIntegerConstant(loc, i32Ty, iter.index());
+      // Runtime call
+      genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);
+    }
+    mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager);
+    fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
+    errorManager.assignStat(builder, loc, stat);
+  }
+
+  /// Lower the length parameters that may be specified in the optional
+  /// type specification.
+  void lowerAllocateLengthParameters() {
+    const Fortran::semantics::DeclTypeSpec *typeSpec =
+        getIfAllocateStmtTypeSpec();
+    if (!typeSpec)
+      return;
+    if (const Fortran::semantics::DerivedTypeSpec *derived =
+            typeSpec->AsDerived())
+      if (Fortran::semantics::CountLenParameters(*derived) > 0)
+        TODO(loc, "TODO: setting derived type params in allocation");
+    if (typeSpec->category() ==
+        Fortran::semantics::DeclTypeSpec::Category::Character) {
+      Fortran::semantics::ParamValue lenParam =
+          typeSpec->characterTypeSpec().length();
+      if (Fortran::semantics::MaybeIntExpr intExpr = lenParam.GetExplicit()) {
+        Fortran::lower::StatementContext stmtCtx;
+        Fortran::lower::SomeExpr lenExpr{*intExpr};
+        lenParams.push_back(
+            fir::getBase(converter.genExprValue(lenExpr, stmtCtx, &loc)));
+      }
+    }
+  }
+
+  // Set length parameters in the box stored in boxAddr.
+  // This must be called before setting the bounds because it may use
+  // Init runtime calls that may set the bounds to zero.
+  void genSetDeferredLengthParameters(const Allocation &alloc,
+                                      const fir::MutableBoxValue &box) {
+    if (lenParams.empty())
+      return;
+    // TODO: in case a length parameter was not deferred, insert a runtime check
+    // that the length is the same (AllocatableCheckLengthParameter runtime
+    // call).
+    if (box.isCharacter())
+      genRuntimeInitCharacter(builder, loc, box, lenParams[0]);
+
+    if (box.isDerived())
+      TODO(loc, "derived type length parameters in allocate");
+  }
+
+  void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) {
+    TODO(loc, "SOURCE allocation lowering");
+  }
+  void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) {
+    TODO(loc, "MOLD allocation lowering");
+  }
+  void genSetType(const Allocation &, const fir::MutableBoxValue &) {
+    TODO(loc, "Polymorphic entity allocation lowering");
+  }
+
+  /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the
+  /// allocate statement. Returns a null pointer otherwise.
+  const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const {
+    if (const auto &typeSpec =
+            std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t))
+      return typeSpec->declTypeSpec;
+    return nullptr;
+  }
+
+  Fortran::lower::AbstractConverter &converter;
+  fir::FirOpBuilder &builder;
+  const Fortran::parser::AllocateStmt &stmt;
+  const Fortran::lower::SomeExpr *sourceExpr{nullptr};
+  const Fortran::lower::SomeExpr *moldExpr{nullptr};
+  const Fortran::lower::SomeExpr *statExpr{nullptr};
+  const Fortran::lower::SomeExpr *errMsgExpr{nullptr};
+  // If the allocate has a type spec, lenParams contains the
+  // value of the length parameters that were specified inside.
+  llvm::SmallVector<mlir::Value> lenParams;
+  ErrorManager errorManager;
+
+  mlir::Location loc;
+};
+} // namespace
+
+void Fortran::lower::genAllocateStmt(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) {
+  AllocateStmtHelper{converter, stmt, loc}.lower();
+  return;
+}
+
+//===----------------------------------------------------------------------===//
+// Deallocate statement implementation
+//===----------------------------------------------------------------------===//
+
+// Generate deallocation of a pointer/allocatable.
+static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc,
+                          const fir::MutableBoxValue &box,
+                          ErrorManager &errorManager) {
+  // Deallocate intrinsic types inline.
+  if (!box.isDerived() && !errorManager.hasStatSpec() && !useAllocateRuntime) {
+    fir::factory::genInlinedDeallocate(builder, loc, box);
+    return;
+  }
+  // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue
+  // with its descriptor before and after calls if needed.
+  errorManager.genStatCheck(builder, loc);
+  mlir::Value stat = genRuntimeDeallocate(builder, loc, box, errorManager);
+  fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
+  errorManager.assignStat(builder, loc, stat);
+}
+
+void Fortran::lower::genDeallocateStmt(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) {
+  const Fortran::lower::SomeExpr *statExpr{nullptr};
+  const Fortran::lower::SomeExpr *errMsgExpr{nullptr};
+  for (const Fortran::parser::StatOrErrmsg &statOrErr :
+       std::get<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t))
+    std::visit(Fortran::common::visitors{
+                   [&](const Fortran::parser::StatVariable &statVar) {
+                     statExpr = Fortran::semantics::GetExpr(statVar);
+                   },
+                   [&](const Fortran::parser::MsgVariable &errMsgVar) {
+                     errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
+                   },
+               },
+               statOrErr.u);
+  ErrorManager errorManager;
+  errorManager.init(converter, loc, statExpr, errMsgExpr);
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
+  for (const Fortran::parser::AllocateObject &allocateObject :
+       std::get<std::list<Fortran::parser::AllocateObject>>(stmt.t)) {
+    fir::MutableBoxValue box =
+        genMutableBoxValue(converter, loc, allocateObject);
+    genDeallocate(builder, loc, box, errorManager);
+  }
+  builder.restoreInsertionPoint(insertPt);
+}
+
+//===----------------------------------------------------------------------===//
 // MutableBoxValue creation implementation
 //===----------------------------------------------------------------------===//
 
 /// Is this symbol a pointer to a pointer array that does not have the
 /// CONTIGUOUS attribute ?
 static inline bool
 isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
   return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&

flang/lib/Lower/Bridge.cpp

 //===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/Bridge.h"
 #include "flang/Evaluate/tools.h"
+#include "flang/Lower/Allocatable.h"
 #include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/IO.h"
 #include "flang/Lower/IterationSpace.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
     builder->create<fir::SelectOp>(loc, selector, indexList, blockList);
   }
 
   //===--------------------------------------------------------------------===//
   // Memory allocation and deallocation
   //===--------------------------------------------------------------------===//
 
   void genFIR(const Fortran::parser::AllocateStmt &stmt) {
-    TODO(toLocation(), "AllocateStmt lowering");
+    Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
   }
 
   void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
-    TODO(toLocation(), "DeallocateStmt lowering");
+    Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
   }
 
   void genFIR(const Fortran::parser::NullifyStmt &stmt) {
     TODO(toLocation(), "NullifyStmt lowering");
   }
 
   //===--------------------------------------------------------------------===//
 

flang/test/Lower/allocatables.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test lowering of allocatables using runtime for allocate/deallcoate statements.
+! CHECK-LABEL: _QPfooscalar
+subroutine fooscalar()
+  ! Test lowering of local allocatable specification
+  real, allocatable :: x
+  ! CHECK: %[[xAddrVar:.*]] = fir.alloca !fir.heap<f32> {{{.*}}uniq_name = "_QFfooscalarEx.addr"}
+  ! CHECK: %[[nullAddr:.*]] = fir.zero_bits !fir.heap<f32>
+  ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+
+  ! Test allocation of local allocatables
+  allocate(x)
+  ! CHECK: %[[alloc:.*]] = fir.allocmem f32 {{{.*}}uniq_name = "_QFfooscalarEx.alloc"}
+  ! CHECK: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+
+  ! Test reading allocatable bounds and extents
+  print *, x
+  ! CHECK: %[[xAddr1:.*]] = fir.load %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+  ! CHECK: = fir.load %[[xAddr1]] : !fir.heap<f32>
+
+  ! Test deallocation
+  deallocate(x)
+  ! CHECK: %[[xAddr2:.*]] = fir.load %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+  ! CHECK: fir.freemem %[[xAddr2]]
+  ! CHECK: %[[nullAddr1:.*]] = fir.zero_bits !fir.heap<f32>
+  ! fir.store %[[nullAddr1]] to %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+end subroutine
+
+! CHECK-LABEL: _QPfoodim1
+subroutine foodim1()
+  ! Test lowering of local allocatable specification
+  real, allocatable :: x(:)
+  ! CHECK-DAG: %[[xAddrVar:.*]] = fir.alloca !fir.heap<!fir.array<?xf32>> {{{.*}}uniq_name = "_QFfoodim1Ex.addr"}
+  ! CHECK-DAG: %[[xLbVar:.*]] = fir.alloca index {{{.*}}uniq_name = "_QFfoodim1Ex.lb0"}
+  ! CHECK-DAG: %[[xExtVar:.*]] = fir.alloca index {{{.*}}uniq_name = "_QFfoodim1Ex.ext0"}
+  ! CHECK: %[[nullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
+  ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+
+  ! Test allocation of local allocatables
+  allocate(x(42:100))
+  ! CHECK-DAG: %[[c42:.*]] = fir.convert %c42{{.*}} : (i32) -> index
+  ! CHECK-DAG: %[[c100:.*]] = fir.convert %c100_i32 : (i32) -> index
+  ! CHECK-DAG: %[[diff:.*]] = arith.subi %[[c100]], %[[c42]] : index
+  ! CHECK: %[[extent:.*]] = arith.addi %[[diff]], %c1{{.*}} : index
+  ! CHECK: %[[alloc:.*]] = fir.allocmem !fir.array<?xf32>, %[[extent]] {{{.*}}uniq_name = "_QFfoodim1Ex.alloc"}
+  ! CHECK-DAG: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+  ! CHECK-DAG: fir.store %[[extent]] to %[[xExtVar]] : !fir.ref<index>
+  ! CHECK-DAG: fir.store %[[c42]] to %[[xLbVar]] : !fir.ref<index>
+
+  ! Test reading allocatable bounds and extents
+  print *, x(42)
+  ! CHECK-DAG: fir.load %[[xLbVar]] : !fir.ref<index>
+  ! CHECK-DAG: fir.load %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+
+  deallocate(x)
+  ! CHECK: %[[xAddr1:.*]] = fir.load %1 : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+  ! CHECK: fir.freemem %[[xAddr1]]
+  ! CHECK: %[[nullAddr1:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
+  ! CHECK: fir.store %[[nullAddr1]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+end subroutine
+
+! CHECK-LABEL: _QPfoodim2
+subroutine foodim2()
+  ! Test lowering of local allocatable specification
+  real, allocatable :: x(:, :)
+  ! CHECK-DAG: fir.alloca !fir.heap<!fir.array<?x?xf32>> {{{.*}}uniq_name = "_QFfoodim2Ex.addr"}
+  ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.lb0"}
+  ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.ext0"}
+  ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.lb1"}
+  ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.ext1"}
+end subroutine
+
+! test lowering of character allocatables. Focus is placed on the length handling
+! CHECK-LABEL: _QPchar_deferred(
+subroutine char_deferred(n)
+  integer :: n
+  character(:), allocatable :: c
+  ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_deferredEc.addr"}
+  ! CHECK-DAG: %[[cLenVar:.*]] = fir.alloca index {{{.*}}uniq_name = "_QFchar_deferredEc.len"}
+  allocate(character(10):: c)
+  ! CHECK: %[[c10:.]] = fir.convert %c10_i32 : (i32) -> index
+  ! CHECK: fir.allocmem !fir.char<1,?>(%[[c10]] : index) {{{.*}}uniq_name = "_QFchar_deferredEc.alloc"}
+  ! CHECK: fir.store %[[c10]] to %[[cLenVar]] : !fir.ref<index>
+  deallocate(c)
+  ! CHECK: fir.freemem %{{.*}}
+  allocate(character(n):: c)
+  ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
+  ! CHECK: %[[ni:.*]] = fir.convert %[[n]] : (i32) -> index
+  ! CHECK: fir.allocmem !fir.char<1,?>(%[[ni]] : index) {{{.*}}uniq_name = "_QFchar_deferredEc.alloc"}
+  ! CHECK: fir.store %[[ni]] to %[[cLenVar]] : !fir.ref<index>
+
+  call bar(c)
+  ! CHECK-DAG: %[[cLen:.*]] = fir.load %[[cLenVar]] : !fir.ref<index>
+  ! CHECK-DAG: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,?>>>
+  ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+end subroutine
+
+! CHECK-LABEL: _QPchar_explicit_cst(
+subroutine char_explicit_cst(n)
+  integer :: n
+  character(10), allocatable :: c
+  ! CHECK-DAG: %[[cLen:.*]] = arith.constant 10 : index
+  ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,10>> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.addr"}
+  ! CHECK-NOT: "_QFchar_explicit_cstEc.len"
+  allocate(c)
+  ! CHECK: fir.allocmem !fir.char<1,10> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.alloc"}
+  deallocate(c)
+  ! CHECK: fir.freemem %{{.*}}
+  allocate(character(n):: c)
+  ! CHECK: fir.allocmem !fir.char<1,10> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.alloc"}
+  deallocate(c)
+  ! CHECK: fir.freemem %{{.*}}
+  allocate(character(10):: c)
+  ! CHECK: fir.allocmem !fir.char<1,10> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.alloc"}
+  call bar(c)
+  ! CHECK: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,10>>>
+  ! CHECK: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+end subroutine
+
+! CHECK-LABEL: _QPchar_explicit_dyn(
+subroutine char_explicit_dyn(l1, l2)
+  integer :: l1, l2
+  character(l1), allocatable :: c
+  ! CHECK-DAG: %[[cLen:.*]] = fir.load %arg0 : !fir.ref<i32>
+  ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"}
+  ! CHECK-NOT: "_QFchar_explicit_dynEc.len"
+  allocate(c)
+  ! CHECK: %[[cLenCast1:.*]] = fir.convert %[[cLen]] : (i32) -> index
+  ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast1]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
+  deallocate(c)
+  ! CHECK: fir.freemem %{{.*}}
+  allocate(character(l2):: c)
+  ! CHECK: %[[cLenCast2:.*]] = fir.convert %[[cLen]] : (i32) -> index
+  ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast2]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
+  deallocate(c)
+  ! CHECK: fir.freemem %{{.*}}
+  allocate(character(10):: c)
+  ! CHECK: %[[cLenCast3:.*]] = fir.convert %[[cLen]] : (i32) -> index
+  ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast3]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
+  call bar(c)
+  ! CHECK-DAG: %[[cLenCast4:.*]] = fir.convert %[[cLen]] : (i32) -> index
+  ! CHECK-DAG: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,?>>>
+  ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLenCast4]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+end subroutine
+
+! CHECK-LABEL: _QPspecifiers(
+subroutine specifiers
+  allocatable jj1(:), jj2(:,:), jj3(:)
+  ! CHECK: [[STAT:%[0-9]+]] = fir.alloca i32 {{{.*}}uniq_name = "_QFspecifiersEsss"}
+  integer sss
+  character*30 :: mmm = "None"
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+  ! CHECK: fir.store [[RESULT]] to [[STAT]]
+  ! CHECK: fir.if %{{[0-9]+}} {
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+  ! CHECK: fir.store [[RESULT]] to [[STAT]]
+  ! CHECK: fir.if %{{[0-9]+}} {
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+  ! CHECK: fir.store [[RESULT]] to [[STAT]]
+  ! CHECK-NOT: fir.if %{{[0-9]+}} {
+  ! CHECK-COUNT-2: }
+  ! CHECK-NOT: }
+  allocate(jj1(3), jj2(3,3), jj3(3), stat=sss, errmsg=mmm)
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+  ! CHECK: fir.call @_FortranAAllocatableSetBounds
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+  allocate(jj1(3), jj2(3,3), jj3(3), stat=sss, errmsg=mmm)
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+  ! CHECK: fir.store [[RESULT]] to [[STAT]]
+  ! CHECK: fir.if %{{[0-9]+}} {
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+  ! CHECK: fir.store [[RESULT]] to [[STAT]]
+  ! CHECK: fir.if %{{[0-9]+}} {
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+  ! CHECK: fir.store [[RESULT]] to [[STAT]]
+  ! CHECK-NOT: fir.if %{{[0-9]+}} {
+  ! CHECK-COUNT-2: }
+  ! CHECK-NOT: }
+  deallocate(jj1, jj2, jj3, stat=sss, errmsg=mmm)
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+  ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+  deallocate(jj1, jj2, jj3, stat=sss, errmsg=mmm)
+end subroutine specifiers