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

source code of flang/lib/Lower/ConvertConstant.cpp