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 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
139private:
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
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, 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`.
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 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.
281template <int KIND>
282static fir::StringLitOp
283createStringLitOp(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.
312template <int KIND>
313static mlir::Value
314genScalarLit(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.
352static fir::ExtendedValue
353genConstantValue(Fortran::lower::AbstractConverter &converter,
354 mlir::Location loc,
355 const Fortran::lower::SomeExpr &constantExpr);
356
357static 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::IsNullPointerOrAllocatable(&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).
462static 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
536static 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.
565template <typename T>
566static mlir::Value
567genInlinedArrayLit(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.
647template <typename T>
648static mlir::Value
649genOutlineArrayLit(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.
692template <typename T>
693static fir::ExtendedValue
694genArrayLit(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
737template <typename T>
738fir::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
766static fir::ExtendedValue
767genConstantValue(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
783template <Fortran::common::TypeCategory TC, int KIND>
784static 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
796static fir::ExtendedValue
797genConstantValue(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
822fir::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
830using namespace Fortran::evaluate;
831FOR_EACH_SPECIFIC_TYPE(template class Fortran::lower::ConstantBuilder, )
832

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