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

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