flang/lib/Lower/ConvertConstant.cpp

   1 //===-- ConvertConstant.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 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
  10 //
  11 //===----------------------------------------------------------------------===//
  12
  13 #include "flang/Lower/ConvertConstant.h"
  14 #include "flang/Evaluate/expression.h"
  15 #include "flang/Lower/AbstractConverter.h"
  16 #include "flang/Lower/BuiltinModules.h"
  17 #include "flang/Lower/ConvertExprToHLFIR.h"
  18 #include "flang/Lower/ConvertType.h"
  19 #include "flang/Lower/ConvertVariable.h"
  20 #include "flang/Lower/Mangler.h"
  21 #include "flang/Lower/StatementContext.h"
  22 #include "flang/Lower/SymbolMap.h"
  23 #include "flang/Optimizer/Builder/Complex.h"
  24 #include "flang/Optimizer/Builder/MutableBox.h"
  25 #include "flang/Optimizer/Builder/Todo.h"
  26
  27 #include <algorithm>
  28
  29 /// Convert string, \p s, to an APFloat value. Recognize and handle Inf and
  30 /// NaN strings as well. \p s is assumed to not contain any spaces.
  31 static llvm::APFloat consAPFloat(const llvm::fltSemantics &fsem,
  32                                  llvm::StringRef s) {
  33   assert(!s.contains(' '));
  34   if (s.compare_insensitive("-inf") == 0)
  35     return llvm::APFloat::getInf(fsem, /*negative=*/true);
  36   if (s.compare_insensitive("inf") == 0 || s.compare_insensitive("+inf") == 0)
  37     return llvm::APFloat::getInf(fsem);
  38   // TODO: Add support for quiet and signaling NaNs.
  39   if (s.compare_insensitive("-nan") == 0)
  40     return llvm::APFloat::getNaN(fsem, /*negative=*/true);
  41   if (s.compare_insensitive("nan") == 0 || s.compare_insensitive("+nan") == 0)
  42     return llvm::APFloat::getNaN(fsem);
  43   return {fsem, s};
  44 }
  45
  46 //===----------------------------------------------------------------------===//
  47 // Fortran::lower::tryCreatingDenseGlobal implementation
  48 //===----------------------------------------------------------------------===//
  49
  50 /// Generate an mlir attribute from a literal value
  51 template <Fortran::common::TypeCategory TC, int KIND>
  52 static mlir::Attribute convertToAttribute(
  53     fir::FirOpBuilder &builder,
  54     const Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>> &value,
  55     mlir::Type type) {
  56   if constexpr (TC == Fortran::common::TypeCategory::Integer) {
  57     if constexpr (KIND <= 8)
  58       return builder.getIntegerAttr(type, value.ToInt64());
  59     else {
  60       static_assert(KIND <= 16, "integers with KIND > 16 are not supported");
  61       return builder.getIntegerAttr(
  62           type, llvm::APInt(KIND * 8,
  63                             {value.ToUInt64(), value.SHIFTR(64).ToUInt64()}));
  64     }
  65   } else if constexpr (TC == Fortran::common::TypeCategory::Logical) {
  66     return builder.getIntegerAttr(type, value.IsTrue());
  67   } else {
  68     auto getFloatAttr = [&](const auto &value, mlir::Type type) {
  69       std::string str = value.DumpHexadecimal();
  70       auto floatVal =
  71           consAPFloat(builder.getKindMap().getFloatSemantics(KIND), str);
  72       return builder.getFloatAttr(type, floatVal);
  73     };
  74
  75     if constexpr (TC == Fortran::common::TypeCategory::Real) {
  76       return getFloatAttr(value, type);
  77     } else {
  78       static_assert(TC == Fortran::common::TypeCategory::Complex,
  79                     "type values cannot be converted to attributes");
  80       mlir::Type eleTy = mlir::cast<mlir::ComplexType>(type).getElementType();
  81       llvm::SmallVector<mlir::Attribute, 2> attrs = {
  82           getFloatAttr(value.REAL(), eleTy),
  83           getFloatAttr(value.AIMAG(), eleTy)};
  84       return builder.getArrayAttr(attrs);
  85     }
  86   }
  87   return {};
  88 }
  89
  90 namespace {
  91 /// Helper class to lower an array constant to a global with an MLIR dense
  92 /// attribute.
  93 ///
  94 /// If we have an array of integer, real, complex, or logical, then we can
  95 /// create a global array with the dense attribute.
  96 ///
  97 /// The mlir tensor type can only handle integer, real, complex, or logical.
  98 /// It does not currently support nested structures.
  99 class DenseGlobalBuilder {
 100 public:
 101   static fir::GlobalOp tryCreating(fir::FirOpBuilder &builder,
 102                                    mlir::Location loc, mlir::Type symTy,
 103                                    llvm::StringRef globalName,
 104                                    mlir::StringAttr linkage, bool isConst,
 105                                    const Fortran::lower::SomeExpr &initExpr,
 106                                    cuf::DataAttributeAttr dataAttr) {
 107     DenseGlobalBuilder globalBuilder;
 108     Fortran::common::visit(
 109         Fortran::common::visitors{
 110             [&](const Fortran::evaluate::Expr<Fortran::evaluate::SomeLogical> &
 111                     x) { globalBuilder.tryConvertingToAttributes(builder, x); },
 112             [&](const Fortran::evaluate::Expr<Fortran::evaluate::SomeInteger> &
 113                     x) { globalBuilder.tryConvertingToAttributes(builder, x); },
 114             [&](const Fortran::evaluate::Expr<Fortran::evaluate::SomeReal> &x) {
 115               globalBuilder.tryConvertingToAttributes(builder, x);
 116             },
 117             [&](const Fortran::evaluate::Expr<Fortran::evaluate::SomeComplex> &
 118                     x) { globalBuilder.tryConvertingToAttributes(builder, x); },
 119             [](const auto &) {},
 120         },
 121         initExpr.u);
 122     return globalBuilder.tryCreatingGlobal(builder, loc, symTy, globalName,
 123                                            linkage, isConst, dataAttr);
 124   }
 125
 126   template <Fortran::common::TypeCategory TC, int KIND>
 127   static fir::GlobalOp tryCreating(
 128       fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type symTy,
 129       llvm::StringRef globalName, mlir::StringAttr linkage, bool isConst,
 130       const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
 131           &constant,
 132       cuf::DataAttributeAttr dataAttr) {
 133     DenseGlobalBuilder globalBuilder;
 134     globalBuilder.tryConvertingToAttributes(builder, constant);
 135     return globalBuilder.tryCreatingGlobal(builder, loc, symTy, globalName,
 136                                            linkage, isConst, dataAttr);
 137   }
 138
 139 private:
 140   DenseGlobalBuilder() = default;
 141
 142   /// Try converting an evaluate::Constant to a list of MLIR attributes.
 143   template <Fortran::common::TypeCategory TC, int KIND>
 144   void tryConvertingToAttributes(
 145       fir::FirOpBuilder &builder,
 146       const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
 147           &constant) {
 148     static_assert(TC != Fortran::common::TypeCategory::Character,
 149                   "must be numerical or logical");
 150     auto attrTc = TC == Fortran::common::TypeCategory::Logical
 151                       ? Fortran::common::TypeCategory::Integer
 152                       : TC;
 153     attributeElementType = Fortran::lower::getFIRType(
 154         builder.getContext(), attrTc, KIND, std::nullopt);
 155     for (auto element : constant.values())
 156       attributes.push_back(
 157           convertToAttribute<TC, KIND>(builder, element, attributeElementType));
 158   }
 159
 160   /// Try converting an evaluate::Expr to a list of MLIR attributes.
 161   template <typename SomeCat>
 162   void tryConvertingToAttributes(fir::FirOpBuilder &builder,
 163                                  const Fortran::evaluate::Expr<SomeCat> &expr) {
 164     Fortran::common::visit(
 165         [&](const auto &x) {
 166           using TR = Fortran::evaluate::ResultType<decltype(x)>;
 167           if (const auto *constant =
 168                   std::get_if<Fortran::evaluate::Constant<TR>>(&x.u))
 169             tryConvertingToAttributes<TR::category, TR::kind>(builder,
 170                                                               *constant);
 171         },
 172         expr.u);
 173   }
 174
 175   /// Create a fir::Global if MLIR attributes have been successfully created by
 176   /// tryConvertingToAttributes.
 177   fir::GlobalOp tryCreatingGlobal(fir::FirOpBuilder &builder,
 178                                   mlir::Location loc, mlir::Type symTy,
 179                                   llvm::StringRef globalName,
 180                                   mlir::StringAttr linkage, bool isConst,
 181                                   cuf::DataAttributeAttr dataAttr) const {
 182     // Not a "trivial" intrinsic constant array, or empty array.
 183     if (!attributeElementType || attributes.empty())
 184       return {};
 185
 186     assert(mlir::isa<fir::SequenceType>(symTy) && "expecting an array global");
 187     auto arrTy = mlir::cast<fir::SequenceType>(symTy);
 188     llvm::SmallVector<int64_t> tensorShape(arrTy.getShape());
 189     std::reverse(tensorShape.begin(), tensorShape.end());
 190     auto tensorTy =
 191         mlir::RankedTensorType::get(tensorShape, attributeElementType);
 192     auto init = mlir::DenseElementsAttr::get(tensorTy, attributes);
 193     return builder.createGlobal(loc, symTy, globalName, linkage, init, isConst,
 194                                 /*isTarget=*/false, dataAttr);
 195   }
 196
 197   llvm::SmallVector<mlir::Attribute> attributes;
 198   mlir::Type attributeElementType;
 199 };
 200 } // namespace
 201
 202 fir::GlobalOp Fortran::lower::tryCreatingDenseGlobal(
 203     fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type symTy,
 204     llvm::StringRef globalName, mlir::StringAttr linkage, bool isConst,
 205     const Fortran::lower::SomeExpr &initExpr, cuf::DataAttributeAttr dataAttr) {
 206   return DenseGlobalBuilder::tryCreating(builder, loc, symTy, globalName,
 207                                          linkage, isConst, initExpr, dataAttr);
 208 }
 209
 210 //===----------------------------------------------------------------------===//
 211 // Fortran::lower::convertConstant
 212 // Lower a constant to a fir::ExtendedValue.
 213 //===----------------------------------------------------------------------===//
 214
 215 /// Generate a real constant with a value `value`.
 216 template <int KIND>
 217 static mlir::Value genRealConstant(fir::FirOpBuilder &builder,
 218                                    mlir::Location loc,
 219                                    const llvm::APFloat &value) {
 220   mlir::Type fltTy = Fortran::lower::convertReal(builder.getContext(), KIND);
 221   return builder.createRealConstant(loc, fltTy, value);
 222 }
 223
 224 /// Convert a scalar literal constant to IR.
 225 template <Fortran::common::TypeCategory TC, int KIND>
 226 static mlir::Value genScalarLit(
 227     fir::FirOpBuilder &builder, mlir::Location loc,
 228     const Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>> &value) {
 229   if constexpr (TC == Fortran::common::TypeCategory::Integer ||
 230                 TC == Fortran::common::TypeCategory::Unsigned) {
 231     // MLIR requires constants to be signless
 232     mlir::Type ty = Fortran::lower::getFIRType(
 233         builder.getContext(), Fortran::common::TypeCategory::Integer, KIND,
 234         std::nullopt);
 235     if (KIND == 16) {
 236       auto bigInt = llvm::APInt(ty.getIntOrFloatBitWidth(),
 237                                 TC == Fortran::common::TypeCategory::Unsigned
 238                                     ? value.UnsignedDecimal()
 239                                     : value.SignedDecimal(),
 240                                 10);
 241       return builder.create<mlir::arith::ConstantOp>(
 242           loc, ty, mlir::IntegerAttr::get(ty, bigInt));
 243     }
 244     return builder.createIntegerConstant(loc, ty, value.ToInt64());
 245   } else if constexpr (TC == Fortran::common::TypeCategory::Logical) {
 246     return builder.createBool(loc, value.IsTrue());
 247   } else if constexpr (TC == Fortran::common::TypeCategory::Real) {
 248     std::string str = value.DumpHexadecimal();
 249     if constexpr (KIND == 2) {
 250       auto floatVal = consAPFloat(llvm::APFloatBase::IEEEhalf(), str);
 251       return genRealConstant<KIND>(builder, loc, floatVal);
 252     } else if constexpr (KIND == 3) {
 253       auto floatVal = consAPFloat(llvm::APFloatBase::BFloat(), str);
 254       return genRealConstant<KIND>(builder, loc, floatVal);
 255     } else if constexpr (KIND == 4) {
 256       auto floatVal = consAPFloat(llvm::APFloatBase::IEEEsingle(), str);
 257       return genRealConstant<KIND>(builder, loc, floatVal);
 258     } else if constexpr (KIND == 10) {
 259       auto floatVal = consAPFloat(llvm::APFloatBase::x87DoubleExtended(), str);
 260       return genRealConstant<KIND>(builder, loc, floatVal);
 261     } else if constexpr (KIND == 16) {
 262       auto floatVal = consAPFloat(llvm::APFloatBase::IEEEquad(), str);
 263       return genRealConstant<KIND>(builder, loc, floatVal);
 264     } else {
 265       // convert everything else to double
 266       auto floatVal = consAPFloat(llvm::APFloatBase::IEEEdouble(), str);
 267       return genRealConstant<KIND>(builder, loc, floatVal);
 268     }
 269   } else if constexpr (TC == Fortran::common::TypeCategory::Complex) {
 270     mlir::Value real = genScalarLit<Fortran::common::TypeCategory::Real, KIND>(
 271         builder, loc, value.REAL());
 272     mlir::Value imag = genScalarLit<Fortran::common::TypeCategory::Real, KIND>(
 273         builder, loc, value.AIMAG());
 274     return fir::factory::Complex{builder, loc}.createComplex(real, imag);
 275   } else /*constexpr*/ {
 276     llvm_unreachable("unhandled constant");
 277   }
 278 }
 279
 280 /// Create fir::string_lit from a scalar character constant.
 281 template <int KIND>
 282 static fir::StringLitOp
 283 createStringLitOp(fir::FirOpBuilder &builder, mlir::Location loc,
 284                   const Fortran::evaluate::Scalar<Fortran::evaluate::Type<
 285                       Fortran::common::TypeCategory::Character, KIND>> &value,
 286                   [[maybe_unused]] int64_t len) {
 287   if constexpr (KIND == 1) {
 288     assert(value.size() == static_cast<std::uint64_t>(len));
 289     return builder.createStringLitOp(loc, value);
 290   } else {
 291     using ET = typename std::decay_t<decltype(value)>::value_type;
 292     fir::CharacterType type =
 293         fir::CharacterType::get(builder.getContext(), KIND, len);
 294     mlir::MLIRContext *context = builder.getContext();
 295     std::int64_t size = static_cast<std::int64_t>(value.size());
 296     mlir::ShapedType shape = mlir::RankedTensorType::get(
 297         llvm::ArrayRef<std::int64_t>{size},
 298         mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8));
 299     auto denseAttr = mlir::DenseElementsAttr::get(
 300         shape, llvm::ArrayRef<ET>{value.data(), value.size()});
 301     auto denseTag = mlir::StringAttr::get(context, fir::StringLitOp::xlist());
 302     mlir::NamedAttribute dataAttr(denseTag, denseAttr);
 303     auto sizeTag = mlir::StringAttr::get(context, fir::StringLitOp::size());
 304     mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len));
 305     llvm::SmallVector<mlir::NamedAttribute> attrs = {dataAttr, sizeAttr};
 306     return builder.create<fir::StringLitOp>(
 307         loc, llvm::ArrayRef<mlir::Type>{type}, std::nullopt, attrs);
 308   }
 309 }
 310
 311 /// Convert a scalar literal CHARACTER to IR.
 312 template <int KIND>
 313 static mlir::Value
 314 genScalarLit(fir::FirOpBuilder &builder, mlir::Location loc,
 315              const Fortran::evaluate::Scalar<Fortran::evaluate::Type<
 316                  Fortran::common::TypeCategory::Character, KIND>> &value,
 317              int64_t len, bool outlineInReadOnlyMemory) {
 318   // When in an initializer context, construct the literal op itself and do
 319   // not construct another constant object in rodata.
 320   if (!outlineInReadOnlyMemory)
 321     return createStringLitOp<KIND>(builder, loc, value, len);
 322
 323   // Otherwise, the string is in a plain old expression so "outline" the value
 324   // in read only data by hash consing it to a constant literal object.
 325
 326   // ASCII global constants are created using an mlir string attribute.
 327   if constexpr (KIND == 1) {
 328     return fir::getBase(fir::factory::createStringLiteral(builder, loc, value));
 329   }
 330
 331   auto size = builder.getKindMap().getCharacterBitsize(KIND) / 8 * value.size();
 332   llvm::StringRef strVal(reinterpret_cast<const char *>(value.c_str()), size);
 333   std::string globalName = fir::factory::uniqueCGIdent(
 334       KIND == 1 ? "cl"s : "cl"s + std::to_string(KIND), strVal);
 335   fir::GlobalOp global = builder.getNamedGlobal(globalName);
 336   fir::CharacterType type =
 337       fir::CharacterType::get(builder.getContext(), KIND, len);
 338   if (!global)
 339     global = builder.createGlobalConstant(
 340         loc, type, globalName,
 341         [&](fir::FirOpBuilder &builder) {
 342           fir::StringLitOp str =
 343               createStringLitOp<KIND>(builder, loc, value, len);
 344           builder.create<fir::HasValueOp>(loc, str);
 345         },
 346         builder.createLinkOnceLinkage());
 347   return builder.create<fir::AddrOfOp>(loc, global.resultType(),
 348                                        global.getSymbol());
 349 }
 350
 351 // Helper to generate StructureConstructor component values.
 352 static fir::ExtendedValue
 353 genConstantValue(Fortran::lower::AbstractConverter &converter,
 354                  mlir::Location loc,
 355                  const Fortran::lower::SomeExpr &constantExpr);
 356
 357 static mlir::Value genStructureComponentInit(
 358     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 359     const Fortran::semantics::Symbol &sym, const Fortran::lower::SomeExpr &expr,
 360     mlir::Value res) {
 361   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 362   fir::RecordType recTy = mlir::cast<fir::RecordType>(res.getType());
 363   std::string name = converter.getRecordTypeFieldName(sym);
 364   mlir::Type componentTy = recTy.getType(name);
 365   auto fieldTy = fir::FieldType::get(recTy.getContext());
 366   assert(componentTy && "failed to retrieve component");
 367   // FIXME: type parameters must come from the derived-type-spec
 368   auto field = builder.create<fir::FieldIndexOp>(
 369       loc, fieldTy, name, recTy,
 370       /*typeParams=*/mlir::ValueRange{} /*TODO*/);
 371
 372   if (Fortran::semantics::IsAllocatable(sym)) {
 373     if (!Fortran::evaluate::IsNullPointer(expr)) {
 374       fir::emitFatalError(loc, "constant structure constructor with an "
 375                                "allocatable component value that is not NULL");
 376     } else {
 377       // Handle NULL() initialization
 378       mlir::Value componentValue{fir::factory::createUnallocatedBox(
 379           builder, loc, componentTy, std::nullopt)};
 380       componentValue = builder.createConvert(loc, componentTy, componentValue);
 381
 382       return builder.create<fir::InsertValueOp>(
 383           loc, recTy, res, componentValue,
 384           builder.getArrayAttr(field.getAttributes()));
 385     }
 386   }
 387
 388   if (Fortran::semantics::IsPointer(sym)) {
 389     mlir::Value initialTarget;
 390     if (Fortran::semantics::IsProcedure(sym)) {
 391       if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr))
 392         initialTarget =
 393             fir::factory::createNullBoxProc(builder, loc, componentTy);
 394       else {
 395         Fortran::lower::SymMap globalOpSymMap;
 396         Fortran::lower::StatementContext stmtCtx;
 397         auto box{getBase(Fortran::lower::convertExprToAddress(
 398             loc, converter, expr, globalOpSymMap, stmtCtx))};
 399         initialTarget = builder.createConvert(loc, componentTy, box);
 400       }
 401     } else
 402       initialTarget = Fortran::lower::genInitialDataTarget(converter, loc,
 403                                                            componentTy, expr);
 404     res = builder.create<fir::InsertValueOp>(
 405         loc, recTy, res, initialTarget,
 406         builder.getArrayAttr(field.getAttributes()));
 407     return res;
 408   }
 409
 410   if (Fortran::lower::isDerivedTypeWithLenParameters(sym))
 411     TODO(loc, "component with length parameters in structure constructor");
 412
 413   // Special handling for scalar c_ptr/c_funptr constants. The array constant
 414   // must fall through to genConstantValue() below.
 415   if (Fortran::semantics::IsBuiltinCPtr(sym) && sym.Rank() == 0 &&
 416       (Fortran::evaluate::GetLastSymbol(expr) ||
 417        Fortran::evaluate::IsNullPointer(expr))) {
 418     // Builtin c_ptr and c_funptr have special handling because designators
 419     // and NULL() are handled as initial values for them as an extension
 420     // (otherwise only c_ptr_null/c_funptr_null are allowed and these are
 421     // replaced by structure constructors by semantics, so GetLastSymbol
 422     // returns nothing).
 423
 424     // The Ev::Expr is an initializer that is a pointer target (e.g., 'x' or
 425     // NULL()) that must be inserted into an intermediate cptr record value's
 426     // address field, which ought to be an intptr_t on the target.
 427     mlir::Value addr = fir::getBase(
 428         Fortran::lower::genExtAddrInInitializer(converter, loc, expr));
 429     if (mlir::isa<fir::BoxProcType>(addr.getType()))
 430       addr = builder.create<fir::BoxAddrOp>(loc, addr);
 431     assert((fir::isa_ref_type(addr.getType()) ||
 432             mlir::isa<mlir::FunctionType>(addr.getType())) &&
 433            "expect reference type for address field");
 434     assert(fir::isa_derived(componentTy) &&
 435            "expect C_PTR, C_FUNPTR to be a record");
 436     auto cPtrRecTy = mlir::cast<fir::RecordType>(componentTy);
 437     llvm::StringRef addrFieldName = Fortran::lower::builtin::cptrFieldName;
 438     mlir::Type addrFieldTy = cPtrRecTy.getType(addrFieldName);
 439     auto addrField = builder.create<fir::FieldIndexOp>(
 440         loc, fieldTy, addrFieldName, componentTy,
 441         /*typeParams=*/mlir::ValueRange{});
 442     mlir::Value castAddr = builder.createConvert(loc, addrFieldTy, addr);
 443     auto undef = builder.create<fir::UndefOp>(loc, componentTy);
 444     addr = builder.create<fir::InsertValueOp>(
 445         loc, componentTy, undef, castAddr,
 446         builder.getArrayAttr(addrField.getAttributes()));
 447     res = builder.create<fir::InsertValueOp>(
 448         loc, recTy, res, addr, builder.getArrayAttr(field.getAttributes()));
 449     return res;
 450   }
 451
 452   mlir::Value val = fir::getBase(genConstantValue(converter, loc, expr));
 453   assert(!fir::isa_ref_type(val.getType()) && "expecting a constant value");
 454   mlir::Value castVal = builder.createConvert(loc, componentTy, val);
 455   res = builder.create<fir::InsertValueOp>(
 456       loc, recTy, res, castVal, builder.getArrayAttr(field.getAttributes()));
 457   return res;
 458 }
 459
 460 // Generate a StructureConstructor inlined (returns raw fir.type<T> value,
 461 // not the address of a global constant).
 462 static mlir::Value genInlinedStructureCtorLitImpl(
 463     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 464     const Fortran::evaluate::StructureConstructor &ctor, mlir::Type type) {
 465   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 466   auto recTy = mlir::cast<fir::RecordType>(type);
 467
 468   if (!converter.getLoweringOptions().getLowerToHighLevelFIR()) {
 469     mlir::Value res = builder.create<fir::UndefOp>(loc, recTy);
 470     for (const auto &[sym, expr] : ctor.values()) {
 471       // Parent components need more work because they do not appear in the
 472       // fir.rec type.
 473       if (sym->test(Fortran::semantics::Symbol::Flag::ParentComp))
 474         TODO(loc, "parent component in structure constructor");
 475       res = genStructureComponentInit(converter, loc, sym, expr.value(), res);
 476     }
 477     return res;
 478   }
 479
 480   auto fieldTy = fir::FieldType::get(recTy.getContext());
 481   mlir::Value res{};
 482   // When the first structure component values belong to some parent type PT
 483   // and the next values belong to a type extension ET, a new undef for ET must
 484   // be created and the previous PT value inserted into it. There may
 485   // be empty parent types in between ET and PT, hence the list and while loop.
 486   auto insertParentValueIntoExtension = [&](mlir::Type typeExtension) {
 487     assert(res && "res must be set");
 488     llvm::SmallVector<mlir::Type> parentTypes = {typeExtension};
 489     while (true) {
 490       fir::RecordType last = mlir::cast<fir::RecordType>(parentTypes.back());
 491       mlir::Type next =
 492           last.getType(0); // parent components are first in HLFIR.
 493       if (next != res.getType())
 494         parentTypes.push_back(next);
 495       else
 496         break;
 497     }
 498     for (mlir::Type parentType : llvm::reverse(parentTypes)) {
 499       auto undef = builder.create<fir::UndefOp>(loc, parentType);
 500       fir::RecordType parentRecTy = mlir::cast<fir::RecordType>(parentType);
 501       auto field = builder.create<fir::FieldIndexOp>(
 502           loc, fieldTy, parentRecTy.getTypeList()[0].first, parentType,
 503           /*typeParams=*/mlir::ValueRange{} /*TODO*/);
 504       res = builder.create<fir::InsertValueOp>(
 505           loc, parentRecTy, undef, res,
 506           builder.getArrayAttr(field.getAttributes()));
 507     }
 508   };
 509
 510   const Fortran::semantics::DerivedTypeSpec *curentType = nullptr;
 511   for (const auto &[sym, expr] : ctor.values()) {
 512     const Fortran::semantics::DerivedTypeSpec *componentParentType =
 513         sym->owner().derivedTypeSpec();
 514     assert(componentParentType && "failed to retrieve component parent type");
 515     if (!res) {
 516       mlir::Type parentType = converter.genType(*componentParentType);
 517       curentType = componentParentType;
 518       res = builder.create<fir::UndefOp>(loc, parentType);
 519     } else if (*componentParentType != *curentType) {
 520       mlir::Type parentType = converter.genType(*componentParentType);
 521       insertParentValueIntoExtension(parentType);
 522       curentType = componentParentType;
 523     }
 524     res = genStructureComponentInit(converter, loc, sym, expr.value(), res);
 525   }
 526
 527   if (!res) // structure constructor for empty type.
 528     return builder.create<fir::UndefOp>(loc, recTy);
 529
 530   // The last component may belong to a parent type.
 531   if (res.getType() != recTy)
 532     insertParentValueIntoExtension(recTy);
 533   return res;
 534 }
 535
 536 static mlir::Value genScalarLit(
 537     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 538     const Fortran::evaluate::Scalar<Fortran::evaluate::SomeDerived> &value,
 539     mlir::Type eleTy, bool outlineBigConstantsInReadOnlyMemory) {
 540   if (!outlineBigConstantsInReadOnlyMemory)
 541     return genInlinedStructureCtorLitImpl(converter, loc, value, eleTy);
 542   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 543   auto expr = std::make_unique<Fortran::lower::SomeExpr>(toEvExpr(
 544       Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived>(value)));
 545   llvm::StringRef globalName =
 546       converter.getUniqueLitName(loc, std::move(expr), eleTy);
 547   fir::GlobalOp global = builder.getNamedGlobal(globalName);
 548   if (!global) {
 549     global = builder.createGlobalConstant(
 550         loc, eleTy, globalName,
 551         [&](fir::FirOpBuilder &builder) {
 552           mlir::Value result =
 553               genInlinedStructureCtorLitImpl(converter, loc, value, eleTy);
 554           builder.create<fir::HasValueOp>(loc, result);
 555         },
 556         builder.createInternalLinkage());
 557   }
 558   return builder.create<fir::AddrOfOp>(loc, global.resultType(),
 559                                        global.getSymbol());
 560 }
 561
 562 /// Create an evaluate::Constant<T> array to a fir.array<> value
 563 /// built with a chain of fir.insert or fir.insert_on_range operations.
 564 /// This is intended to be called when building the body of a fir.global.
 565 template <typename T>
 566 static mlir::Value
 567 genInlinedArrayLit(Fortran::lower::AbstractConverter &converter,
 568                    mlir::Location loc, mlir::Type arrayTy,
 569                    const Fortran::evaluate::Constant<T> &con) {
 570   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 571   mlir::IndexType idxTy = builder.getIndexType();
 572   Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds();
 573   auto createIdx = [&]() {
 574     llvm::SmallVector<mlir::Attribute> idx;
 575     for (size_t i = 0; i < subscripts.size(); ++i)
 576       idx.push_back(
 577           builder.getIntegerAttr(idxTy, subscripts[i] - con.lbounds()[i]));
 578     return idx;
 579   };
 580   mlir::Value array = builder.create<fir::UndefOp>(loc, arrayTy);
 581   if (Fortran::evaluate::GetSize(con.shape()) == 0)
 582     return array;
 583   if constexpr (T::category == Fortran::common::TypeCategory::Character) {
 584     do {
 585       mlir::Value elementVal =
 586           genScalarLit<T::kind>(builder, loc, con.At(subscripts), con.LEN(),
 587                                 /*outlineInReadOnlyMemory=*/false);
 588       array = builder.create<fir::InsertValueOp>(
 589           loc, arrayTy, array, elementVal, builder.getArrayAttr(createIdx()));
 590     } while (con.IncrementSubscripts(subscripts));
 591   } else if constexpr (T::category == Fortran::common::TypeCategory::Derived) {
 592     do {
 593       mlir::Type eleTy =
 594           mlir::cast<fir::SequenceType>(arrayTy).getElementType();
 595       mlir::Value elementVal =
 596           genScalarLit(converter, loc, con.At(subscripts), eleTy,
 597                        /*outlineInReadOnlyMemory=*/false);
 598       array = builder.create<fir::InsertValueOp>(
 599           loc, arrayTy, array, elementVal, builder.getArrayAttr(createIdx()));
 600     } while (con.IncrementSubscripts(subscripts));
 601   } else {
 602     llvm::SmallVector<mlir::Attribute> rangeStartIdx;
 603     uint64_t rangeSize = 0;
 604     mlir::Type eleTy = mlir::cast<fir::SequenceType>(arrayTy).getElementType();
 605     do {
 606       auto getElementVal = [&]() {
 607         return builder.createConvert(loc, eleTy,
 608                                      genScalarLit<T::category, T::kind>(
 609                                          builder, loc, con.At(subscripts)));
 610       };
 611       Fortran::evaluate::ConstantSubscripts nextSubscripts = subscripts;
 612       bool nextIsSame = con.IncrementSubscripts(nextSubscripts) &&
 613                         con.At(subscripts) == con.At(nextSubscripts);
 614       if (!rangeSize && !nextIsSame) { // single (non-range) value
 615         array = builder.create<fir::InsertValueOp>(
 616             loc, arrayTy, array, getElementVal(),
 617             builder.getArrayAttr(createIdx()));
 618       } else if (!rangeSize) { // start a range
 619         rangeStartIdx = createIdx();
 620         rangeSize = 1;
 621       } else if (nextIsSame) { // expand a range
 622         ++rangeSize;
 623       } else { // end a range
 624         llvm::SmallVector<int64_t> rangeBounds;
 625         llvm::SmallVector<mlir::Attribute> idx = createIdx();
 626         for (size_t i = 0; i < idx.size(); ++i) {
 627           rangeBounds.push_back(mlir::cast<mlir::IntegerAttr>(rangeStartIdx[i])
 628                                     .getValue()
 629                                     .getSExtValue());
 630           rangeBounds.push_back(
 631               mlir::cast<mlir::IntegerAttr>(idx[i]).getValue().getSExtValue());
 632         }
 633         array = builder.create<fir::InsertOnRangeOp>(
 634             loc, arrayTy, array, getElementVal(),
 635             builder.getIndexVectorAttr(rangeBounds));
 636         rangeSize = 0;
 637       }
 638     } while (con.IncrementSubscripts(subscripts));
 639   }
 640   return array;
 641 }
 642
 643 /// Convert an evaluate::Constant<T> array into a fir.ref<fir.array<>> value
 644 /// that points to the storage of a fir.global in read only memory and is
 645 /// initialized with the value of the constant.
 646 /// This should not be called while generating the body of a fir.global.
 647 template <typename T>
 648 static mlir::Value
 649 genOutlineArrayLit(Fortran::lower::AbstractConverter &converter,
 650                    mlir::Location loc, mlir::Type arrayTy,
 651                    const Fortran::evaluate::Constant<T> &constant) {
 652   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 653   mlir::Type eleTy = mlir::cast<fir::SequenceType>(arrayTy).getElementType();
 654   llvm::StringRef globalName = converter.getUniqueLitName(
 655       loc, std::make_unique<Fortran::lower::SomeExpr>(toEvExpr(constant)),
 656       eleTy);
 657   fir::GlobalOp global = builder.getNamedGlobal(globalName);
 658   if (!global) {
 659     // Using a dense attribute for the initial value instead of creating an
 660     // intialization body speeds up MLIR/LLVM compilation, but this is not
 661     // always possible.
 662     if constexpr (T::category == Fortran::common::TypeCategory::Logical ||
 663                   T::category == Fortran::common::TypeCategory::Integer ||
 664                   T::category == Fortran::common::TypeCategory::Real ||
 665                   T::category == Fortran::common::TypeCategory::Complex) {
 666       global = DenseGlobalBuilder::tryCreating(
 667           builder, loc, arrayTy, globalName, builder.createInternalLinkage(),
 668           true, constant, {});
 669     }
 670     if (!global)
 671       // If the number of elements of the array is huge, the compilation may
 672       // use a lot of memory and take a very long time to complete.
 673       // Empirical evidence shows that an array with 150000 elements of
 674       // complex type takes roughly 30 seconds to compile and uses 4GB of RAM,
 675       // on a modern machine.
 676       // It would be nice to add a driver switch to control the array size
 677       // after which flang should not continue to compile.
 678       global = builder.createGlobalConstant(
 679           loc, arrayTy, globalName,
 680           [&](fir::FirOpBuilder &builder) {
 681             mlir::Value result =
 682                 genInlinedArrayLit(converter, loc, arrayTy, constant);
 683             builder.create<fir::HasValueOp>(loc, result);
 684           },
 685           builder.createInternalLinkage());
 686   }
 687   return builder.create<fir::AddrOfOp>(loc, global.resultType(),
 688                                        global.getSymbol());
 689 }
 690
 691 /// Convert an evaluate::Constant<T> array into an fir::ExtendedValue.
 692 template <typename T>
 693 static fir::ExtendedValue
 694 genArrayLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 695             const Fortran::evaluate::Constant<T> &con,
 696             bool outlineInReadOnlyMemory) {
 697   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 698   Fortran::evaluate::ConstantSubscript size =
 699       Fortran::evaluate::GetSize(con.shape());
 700   if (size > std::numeric_limits<std::uint32_t>::max())
 701     // llvm::SmallVector has limited size
 702     TODO(loc, "Creation of very large array constants");
 703   fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end());
 704   llvm::SmallVector<std::int64_t> typeParams;
 705   if constexpr (T::category == Fortran::common::TypeCategory::Character)
 706     typeParams.push_back(con.LEN());
 707   mlir::Type eleTy;
 708   if constexpr (T::category == Fortran::common::TypeCategory::Derived)
 709     eleTy = Fortran::lower::translateDerivedTypeToFIRType(
 710         converter, con.GetType().GetDerivedTypeSpec());
 711   else
 712     eleTy = Fortran::lower::getFIRType(builder.getContext(), T::category,
 713                                        T::kind, typeParams);
 714   auto arrayTy = fir::SequenceType::get(shape, eleTy);
 715   mlir::Value array = outlineInReadOnlyMemory
 716                           ? genOutlineArrayLit(converter, loc, arrayTy, con)
 717                           : genInlinedArrayLit(converter, loc, arrayTy, con);
 718
 719   mlir::IndexType idxTy = builder.getIndexType();
 720   llvm::SmallVector<mlir::Value> extents;
 721   for (auto extent : shape)
 722     extents.push_back(builder.createIntegerConstant(loc, idxTy, extent));
 723   // Convert  lower bounds if they are not all ones.
 724   llvm::SmallVector<mlir::Value> lbounds;
 725   if (llvm::any_of(con.lbounds(), [](auto lb) { return lb != 1; }))
 726     for (auto lb : con.lbounds())
 727       lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb));
 728
 729   if constexpr (T::category == Fortran::common::TypeCategory::Character) {
 730     mlir::Value len = builder.createIntegerConstant(loc, idxTy, con.LEN());
 731     return fir::CharArrayBoxValue{array, len, extents, lbounds};
 732   } else {
 733     return fir::ArrayBoxValue{array, extents, lbounds};
 734   }
 735 }
 736
 737 template <typename T>
 738 fir::ExtendedValue Fortran::lower::ConstantBuilder<T>::gen(
 739     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 740     const Fortran::evaluate::Constant<T> &constant,
 741     bool outlineBigConstantsInReadOnlyMemory) {
 742   if (constant.Rank() > 0)
 743     return genArrayLit(converter, loc, constant,
 744                        outlineBigConstantsInReadOnlyMemory);
 745   std::optional<Fortran::evaluate::Scalar<T>> opt = constant.GetScalarValue();
 746   assert(opt.has_value() && "constant has no value");
 747   if constexpr (T::category == Fortran::common::TypeCategory::Character) {
 748     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 749     auto value =
 750         genScalarLit<T::kind>(builder, loc, opt.value(), constant.LEN(),
 751                               outlineBigConstantsInReadOnlyMemory);
 752     mlir::Value len = builder.createIntegerConstant(
 753         loc, builder.getCharacterLengthType(), constant.LEN());
 754     return fir::CharBoxValue{value, len};
 755   } else if constexpr (T::category == Fortran::common::TypeCategory::Derived) {
 756     mlir::Type eleTy = Fortran::lower::translateDerivedTypeToFIRType(
 757         converter, opt->GetType().GetDerivedTypeSpec());
 758     return genScalarLit(converter, loc, *opt, eleTy,
 759                         outlineBigConstantsInReadOnlyMemory);
 760   } else {
 761     return genScalarLit<T::category, T::kind>(converter.getFirOpBuilder(), loc,
 762                                               opt.value());
 763   }
 764 }
 765
 766 static fir::ExtendedValue
 767 genConstantValue(Fortran::lower::AbstractConverter &converter,
 768                  mlir::Location loc,
 769                  const Fortran::evaluate::Expr<Fortran::evaluate::SomeDerived>
 770                      &constantExpr) {
 771   if (const auto *constant = std::get_if<
 772           Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived>>(
 773           &constantExpr.u))
 774     return Fortran::lower::convertConstant(converter, loc, *constant,
 775                                            /*outline=*/false);
 776   if (const auto *structCtor =
 777           std::get_if<Fortran::evaluate::StructureConstructor>(&constantExpr.u))
 778     return Fortran::lower::genInlinedStructureCtorLit(converter, loc,
 779                                                       *structCtor);
 780   fir::emitFatalError(loc, "not a constant derived type expression");
 781 }
 782
 783 template <Fortran::common::TypeCategory TC, int KIND>
 784 static fir::ExtendedValue genConstantValue(
 785     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 786     const Fortran::evaluate::Expr<Fortran::evaluate::Type<TC, KIND>>
 787         &constantExpr) {
 788   using T = Fortran::evaluate::Type<TC, KIND>;
 789   if (const auto *constant =
 790           std::get_if<Fortran::evaluate::Constant<T>>(&constantExpr.u))
 791     return Fortran::lower::convertConstant(converter, loc, *constant,
 792                                            /*outline=*/false);
 793   fir::emitFatalError(loc, "not an evaluate::Constant<T>");
 794 }
 795
 796 static fir::ExtendedValue
 797 genConstantValue(Fortran::lower::AbstractConverter &converter,
 798                  mlir::Location loc,
 799                  const Fortran::lower::SomeExpr &constantExpr) {
 800   return Fortran::common::visit(
 801       [&](const auto &x) -> fir::ExtendedValue {
 802         using T = std::decay_t<decltype(x)>;
 803         if constexpr (Fortran::common::HasMember<
 804                           T, Fortran::lower::CategoryExpression>) {
 805           if constexpr (T::Result::category ==
 806                         Fortran::common::TypeCategory::Derived) {
 807             return genConstantValue(converter, loc, x);
 808           } else {
 809             return Fortran::common::visit(
 810                 [&](const auto &preciseKind) {
 811                   return genConstantValue(converter, loc, preciseKind);
 812                 },
 813                 x.u);
 814           }
 815         } else {
 816           fir::emitFatalError(loc, "unexpected typeless constant value");
 817         }
 818       },
 819       constantExpr.u);
 820 }
 821
 822 fir::ExtendedValue Fortran::lower::genInlinedStructureCtorLit(
 823     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
 824     const Fortran::evaluate::StructureConstructor &ctor) {
 825   mlir::Type type = Fortran::lower::translateDerivedTypeToFIRType(
 826       converter, ctor.derivedTypeSpec());
 827   return genInlinedStructureCtorLitImpl(converter, loc, ctor, type);
 828 }
 829
 830 using namespace Fortran::evaluate;
 831 FOR_EACH_SPECIFIC_TYPE(template class Fortran::lower::ConstantBuilder, )