1//===-- HLFIRTools.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// Tools to manipulate HLFIR variable and expressions
10//
11//===----------------------------------------------------------------------===//
12
13#include "flang/Optimizer/Builder/HLFIRTools.h"
14#include "flang/Optimizer/Builder/Character.h"
15#include "flang/Optimizer/Builder/FIRBuilder.h"
16#include "flang/Optimizer/Builder/MutableBox.h"
17#include "flang/Optimizer/Builder/Runtime/Allocatable.h"
18#include "flang/Optimizer/Builder/Todo.h"
19#include "flang/Optimizer/HLFIR/HLFIROps.h"
20#include "mlir/IR/IRMapping.h"
21#include "mlir/Support/LLVM.h"
22#include "llvm/ADT/TypeSwitch.h"
23#include <optional>
24
25// Return explicit extents. If the base is a fir.box, this won't read it to
26// return the extents and will instead return an empty vector.
27llvm::SmallVector<mlir::Value>
28hlfir::getExplicitExtentsFromShape(mlir::Value shape,
29 fir::FirOpBuilder &builder) {
30 llvm::SmallVector<mlir::Value> result;
31 auto *shapeOp = shape.getDefiningOp();
32 if (auto s = mlir::dyn_cast_or_null<fir::ShapeOp>(shapeOp)) {
33 auto e = s.getExtents();
34 result.append(e.begin(), e.end());
35 } else if (auto s = mlir::dyn_cast_or_null<fir::ShapeShiftOp>(shapeOp)) {
36 auto e = s.getExtents();
37 result.append(e.begin(), e.end());
38 } else if (mlir::dyn_cast_or_null<fir::ShiftOp>(shapeOp)) {
39 return {};
40 } else if (auto s = mlir::dyn_cast_or_null<hlfir::ShapeOfOp>(shapeOp)) {
41 hlfir::ExprType expr = s.getExpr().getType().cast<hlfir::ExprType>();
42 llvm::ArrayRef<int64_t> exprShape = expr.getShape();
43 mlir::Type indexTy = builder.getIndexType();
44 fir::ShapeType shapeTy = shape.getType().cast<fir::ShapeType>();
45 result.reserve(shapeTy.getRank());
46 for (unsigned i = 0; i < shapeTy.getRank(); ++i) {
47 int64_t extent = exprShape[i];
48 mlir::Value extentVal;
49 if (extent == expr.getUnknownExtent()) {
50 auto op = builder.create<hlfir::GetExtentOp>(shape.getLoc(), shape, i);
51 extentVal = op.getResult();
52 } else {
53 extentVal =
54 builder.createIntegerConstant(shape.getLoc(), indexTy, extent);
55 }
56 result.emplace_back(extentVal);
57 }
58 } else {
59 TODO(shape.getLoc(), "read fir.shape to get extents");
60 }
61 return result;
62}
63static llvm::SmallVector<mlir::Value>
64getExplicitExtents(fir::FortranVariableOpInterface var,
65 fir::FirOpBuilder &builder) {
66 if (mlir::Value shape = var.getShape())
67 return hlfir::getExplicitExtentsFromShape(var.getShape(), builder);
68 return {};
69}
70
71// Return explicit lower bounds. For pointers and allocatables, this will not
72// read the lower bounds and instead return an empty vector.
73static llvm::SmallVector<mlir::Value>
74getExplicitLboundsFromShape(mlir::Value shape) {
75 llvm::SmallVector<mlir::Value> result;
76 auto *shapeOp = shape.getDefiningOp();
77 if (auto s = mlir::dyn_cast_or_null<fir::ShapeOp>(shapeOp)) {
78 return {};
79 } else if (auto s = mlir::dyn_cast_or_null<fir::ShapeShiftOp>(shapeOp)) {
80 auto e = s.getOrigins();
81 result.append(e.begin(), e.end());
82 } else if (auto s = mlir::dyn_cast_or_null<fir::ShiftOp>(shapeOp)) {
83 auto e = s.getOrigins();
84 result.append(e.begin(), e.end());
85 } else {
86 TODO(shape.getLoc(), "read fir.shape to get lower bounds");
87 }
88 return result;
89}
90static llvm::SmallVector<mlir::Value>
91getExplicitLbounds(fir::FortranVariableOpInterface var) {
92 if (mlir::Value shape = var.getShape())
93 return getExplicitLboundsFromShape(shape);
94 return {};
95}
96
97static void
98genLboundsAndExtentsFromBox(mlir::Location loc, fir::FirOpBuilder &builder,
99 hlfir::Entity boxEntity,
100 llvm::SmallVectorImpl<mlir::Value> &lbounds,
101 llvm::SmallVectorImpl<mlir::Value> *extents) {
102 assert(boxEntity.getType().isa<fir::BaseBoxType>() && "must be a box");
103 mlir::Type idxTy = builder.getIndexType();
104 const int rank = boxEntity.getRank();
105 for (int i = 0; i < rank; ++i) {
106 mlir::Value dim = builder.createIntegerConstant(loc, idxTy, i);
107 auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
108 boxEntity, dim);
109 lbounds.push_back(Elt: dimInfo.getLowerBound());
110 if (extents)
111 extents->push_back(Elt: dimInfo.getExtent());
112 }
113}
114
115static llvm::SmallVector<mlir::Value>
116getNonDefaultLowerBounds(mlir::Location loc, fir::FirOpBuilder &builder,
117 hlfir::Entity entity) {
118 if (!entity.hasNonDefaultLowerBounds())
119 return {};
120 if (auto varIface = entity.getIfVariableInterface()) {
121 llvm::SmallVector<mlir::Value> lbounds = getExplicitLbounds(varIface);
122 if (!lbounds.empty())
123 return lbounds;
124 }
125 if (entity.isMutableBox())
126 entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
127 llvm::SmallVector<mlir::Value> lowerBounds;
128 genLboundsAndExtentsFromBox(loc, builder, entity, lowerBounds,
129 /*extents=*/nullptr);
130 return lowerBounds;
131}
132
133static llvm::SmallVector<mlir::Value> toSmallVector(mlir::ValueRange range) {
134 llvm::SmallVector<mlir::Value> res;
135 res.append(range.begin(), range.end());
136 return res;
137}
138
139static llvm::SmallVector<mlir::Value> getExplicitTypeParams(hlfir::Entity var) {
140 if (auto varIface = var.getMaybeDereferencedVariableInterface())
141 return toSmallVector(varIface.getExplicitTypeParams());
142 return {};
143}
144
145static mlir::Value tryGettingNonDeferredCharLen(hlfir::Entity var) {
146 if (auto varIface = var.getMaybeDereferencedVariableInterface())
147 if (!varIface.getExplicitTypeParams().empty())
148 return varIface.getExplicitTypeParams()[0];
149 return mlir::Value{};
150}
151
152static mlir::Value genCharacterVariableLength(mlir::Location loc,
153 fir::FirOpBuilder &builder,
154 hlfir::Entity var) {
155 if (mlir::Value len = tryGettingNonDeferredCharLen(var))
156 return len;
157 auto charType = var.getFortranElementType().cast<fir::CharacterType>();
158 if (charType.hasConstantLen())
159 return builder.createIntegerConstant(loc, builder.getIndexType(),
160 charType.getLen());
161 if (var.isMutableBox())
162 var = hlfir::Entity{builder.create<fir::LoadOp>(loc, var)};
163 mlir::Value len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
164 var.getFirBase());
165 assert(len && "failed to retrieve length");
166 return len;
167}
168
169static fir::CharBoxValue genUnboxChar(mlir::Location loc,
170 fir::FirOpBuilder &builder,
171 mlir::Value boxChar) {
172 if (auto emboxChar = boxChar.getDefiningOp<fir::EmboxCharOp>())
173 return {emboxChar.getMemref(), emboxChar.getLen()};
174 mlir::Type refType = fir::ReferenceType::get(
175 boxChar.getType().cast<fir::BoxCharType>().getEleTy());
176 auto unboxed = builder.create<fir::UnboxCharOp>(
177 loc, refType, builder.getIndexType(), boxChar);
178 mlir::Value addr = unboxed.getResult(0);
179 mlir::Value len = unboxed.getResult(1);
180 if (auto varIface = boxChar.getDefiningOp<fir::FortranVariableOpInterface>())
181 if (mlir::Value explicitlen = varIface.getExplicitCharLen())
182 len = explicitlen;
183 return {addr, len};
184}
185
186mlir::Value hlfir::Entity::getFirBase() const {
187 if (fir::FortranVariableOpInterface variable = getIfVariableInterface()) {
188 if (auto declareOp =
189 mlir::dyn_cast<hlfir::DeclareOp>(variable.getOperation()))
190 return declareOp.getOriginalBase();
191 if (auto associateOp =
192 mlir::dyn_cast<hlfir::AssociateOp>(variable.getOperation()))
193 return associateOp.getFirBase();
194 }
195 return getBase();
196}
197
198fir::FortranVariableOpInterface
199hlfir::genDeclare(mlir::Location loc, fir::FirOpBuilder &builder,
200 const fir::ExtendedValue &exv, llvm::StringRef name,
201 fir::FortranVariableFlagsAttr flags,
202 fir::CUDADataAttributeAttr cudaAttr) {
203
204 mlir::Value base = fir::getBase(exv);
205 assert(fir::conformsWithPassByRef(base.getType()) &&
206 "entity being declared must be in memory");
207 mlir::Value shapeOrShift;
208 llvm::SmallVector<mlir::Value> lenParams;
209 exv.match(
210 [&](const fir::CharBoxValue &box) {
211 lenParams.emplace_back(box.getLen());
212 },
213 [&](const fir::ArrayBoxValue &) {
214 shapeOrShift = builder.createShape(loc, exv);
215 },
216 [&](const fir::CharArrayBoxValue &box) {
217 shapeOrShift = builder.createShape(loc, exv);
218 lenParams.emplace_back(box.getLen());
219 },
220 [&](const fir::BoxValue &box) {
221 if (!box.getLBounds().empty())
222 shapeOrShift = builder.createShape(loc, exv);
223 lenParams.append(box.getExplicitParameters().begin(),
224 box.getExplicitParameters().end());
225 },
226 [&](const fir::MutableBoxValue &box) {
227 lenParams.append(box.nonDeferredLenParams().begin(),
228 box.nonDeferredLenParams().end());
229 },
230 [](const auto &) {});
231 auto declareOp = builder.create<hlfir::DeclareOp>(
232 loc, base, name, shapeOrShift, lenParams, flags, cudaAttr);
233 return mlir::cast<fir::FortranVariableOpInterface>(declareOp.getOperation());
234}
235
236hlfir::AssociateOp
237hlfir::genAssociateExpr(mlir::Location loc, fir::FirOpBuilder &builder,
238 hlfir::Entity value, mlir::Type variableType,
239 llvm::StringRef name,
240 std::optional<mlir::NamedAttribute> attr) {
241 assert(value.isValue() && "must not be a variable");
242 mlir::Value shape{};
243 if (value.isArray())
244 shape = genShape(loc, builder, value);
245
246 mlir::Value source = value;
247 // Lowered scalar expression values for numerical and logical may have a
248 // different type than what is required for the type in memory (logical
249 // expressions are typically manipulated as i1, but needs to be stored
250 // according to the fir.logical<kind> so that the storage size is correct).
251 // Character length mismatches are ignored (it is ok for one to be dynamic
252 // and the other static).
253 mlir::Type varEleTy = getFortranElementType(variableType);
254 mlir::Type valueEleTy = getFortranElementType(value.getType());
255 if (varEleTy != valueEleTy && !(valueEleTy.isa<fir::CharacterType>() &&
256 varEleTy.isa<fir::CharacterType>())) {
257 assert(value.isScalar() && fir::isa_trivial(value.getType()));
258 source = builder.createConvert(loc, fir::unwrapPassByRefType(variableType),
259 value);
260 }
261 llvm::SmallVector<mlir::Value> lenParams;
262 genLengthParameters(loc, builder, value, lenParams);
263 if (attr) {
264 assert(name.empty() && "It attribute is provided, no-name is expected");
265 return builder.create<hlfir::AssociateOp>(loc, source, shape, lenParams,
266 fir::FortranVariableFlagsAttr{},
267 llvm::ArrayRef{*attr});
268 }
269 return builder.create<hlfir::AssociateOp>(loc, source, name, shape, lenParams,
270 fir::FortranVariableFlagsAttr{});
271}
272
273mlir::Value hlfir::genVariableRawAddress(mlir::Location loc,
274 fir::FirOpBuilder &builder,
275 hlfir::Entity var) {
276 assert(var.isVariable() && "only address of variables can be taken");
277 mlir::Value baseAddr = var.getFirBase();
278 if (var.isMutableBox())
279 baseAddr = builder.create<fir::LoadOp>(loc, baseAddr);
280 // Get raw address.
281 if (var.getType().isa<fir::BoxCharType>())
282 baseAddr = genUnboxChar(loc, builder, var.getBase()).getAddr();
283 if (baseAddr.getType().isa<fir::BaseBoxType>())
284 baseAddr = builder.create<fir::BoxAddrOp>(loc, baseAddr);
285 return baseAddr;
286}
287
288mlir::Value hlfir::genVariableBoxChar(mlir::Location loc,
289 fir::FirOpBuilder &builder,
290 hlfir::Entity var) {
291 assert(var.isVariable() && "only address of variables can be taken");
292 if (var.getType().isa<fir::BoxCharType>())
293 return var;
294 mlir::Value addr = genVariableRawAddress(loc, builder, var);
295 llvm::SmallVector<mlir::Value> lengths;
296 genLengthParameters(loc, builder, var, lengths);
297 assert(lengths.size() == 1);
298 auto charType = var.getFortranElementType().cast<fir::CharacterType>();
299 auto boxCharType =
300 fir::BoxCharType::get(builder.getContext(), charType.getFKind());
301 auto scalarAddr =
302 builder.createConvert(loc, fir::ReferenceType::get(charType), addr);
303 return builder.create<fir::EmboxCharOp>(loc, boxCharType, scalarAddr,
304 lengths[0]);
305}
306
307hlfir::Entity hlfir::genVariableBox(mlir::Location loc,
308 fir::FirOpBuilder &builder,
309 hlfir::Entity var) {
310 assert(var.isVariable() && "must be a variable");
311 var = hlfir::derefPointersAndAllocatables(loc, builder, var);
312 if (var.getType().isa<fir::BaseBoxType>())
313 return var;
314 // Note: if the var is not a fir.box/fir.class at that point, it has default
315 // lower bounds and is not polymorphic.
316 mlir::Value shape =
317 var.isArray() ? hlfir::genShape(loc, builder, var) : mlir::Value{};
318 llvm::SmallVector<mlir::Value> typeParams;
319 auto maybeCharType =
320 var.getFortranElementType().dyn_cast<fir::CharacterType>();
321 if (!maybeCharType || maybeCharType.hasDynamicLen())
322 hlfir::genLengthParameters(loc, builder, var, typeParams);
323 mlir::Value addr = var.getBase();
324 if (var.getType().isa<fir::BoxCharType>())
325 addr = genVariableRawAddress(loc, builder, var);
326 mlir::Type boxType = fir::BoxType::get(var.getElementOrSequenceType());
327 auto embox =
328 builder.create<fir::EmboxOp>(loc, boxType, addr, shape,
329 /*slice=*/mlir::Value{}, typeParams);
330 return hlfir::Entity{embox.getResult()};
331}
332
333hlfir::Entity hlfir::loadTrivialScalar(mlir::Location loc,
334 fir::FirOpBuilder &builder,
335 Entity entity) {
336 entity = derefPointersAndAllocatables(loc, builder, entity);
337 if (entity.isVariable() && entity.isScalar() &&
338 fir::isa_trivial(entity.getFortranElementType())) {
339 return Entity{builder.create<fir::LoadOp>(loc, entity)};
340 }
341 return entity;
342}
343
344hlfir::Entity hlfir::getElementAt(mlir::Location loc,
345 fir::FirOpBuilder &builder, Entity entity,
346 mlir::ValueRange oneBasedIndices) {
347 if (entity.isScalar())
348 return entity;
349 llvm::SmallVector<mlir::Value> lenParams;
350 genLengthParameters(loc, builder, entity, lenParams);
351 if (entity.getType().isa<hlfir::ExprType>())
352 return hlfir::Entity{builder.create<hlfir::ApplyOp>(
353 loc, entity, oneBasedIndices, lenParams)};
354 // Build hlfir.designate. The lower bounds may need to be added to
355 // the oneBasedIndices since hlfir.designate expect indices
356 // based on the array operand lower bounds.
357 mlir::Type resultType = hlfir::getVariableElementType(entity);
358 hlfir::DesignateOp designate;
359 llvm::SmallVector<mlir::Value> lbounds =
360 getNonDefaultLowerBounds(loc, builder, entity);
361 if (!lbounds.empty()) {
362 llvm::SmallVector<mlir::Value> indices;
363 mlir::Type idxTy = builder.getIndexType();
364 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
365 for (auto [oneBased, lb] : llvm::zip(oneBasedIndices, lbounds)) {
366 auto lbIdx = builder.createConvert(loc, idxTy, lb);
367 auto oneBasedIdx = builder.createConvert(loc, idxTy, oneBased);
368 auto shift = builder.create<mlir::arith::SubIOp>(loc, lbIdx, one);
369 mlir::Value index =
370 builder.create<mlir::arith::AddIOp>(loc, oneBasedIdx, shift);
371 indices.push_back(index);
372 }
373 designate = builder.create<hlfir::DesignateOp>(loc, resultType, entity,
374 indices, lenParams);
375 } else {
376 designate = builder.create<hlfir::DesignateOp>(loc, resultType, entity,
377 oneBasedIndices, lenParams);
378 }
379 return mlir::cast<fir::FortranVariableOpInterface>(designate.getOperation());
380}
381
382static mlir::Value genUBound(mlir::Location loc, fir::FirOpBuilder &builder,
383 mlir::Value lb, mlir::Value extent,
384 mlir::Value one) {
385 if (auto constantLb = fir::getIntIfConstant(lb))
386 if (*constantLb == 1)
387 return extent;
388 extent = builder.createConvert(loc, one.getType(), extent);
389 lb = builder.createConvert(loc, one.getType(), lb);
390 auto add = builder.create<mlir::arith::AddIOp>(loc, lb, extent);
391 return builder.create<mlir::arith::SubIOp>(loc, add, one);
392}
393
394llvm::SmallVector<std::pair<mlir::Value, mlir::Value>>
395hlfir::genBounds(mlir::Location loc, fir::FirOpBuilder &builder,
396 Entity entity) {
397 if (entity.getType().isa<hlfir::ExprType>())
398 TODO(loc, "bounds of expressions in hlfir");
399 auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
400 assert(!cleanup && "translation of entity should not yield cleanup");
401 if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
402 exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
403 mlir::Type idxTy = builder.getIndexType();
404 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
405 llvm::SmallVector<std::pair<mlir::Value, mlir::Value>> result;
406 for (unsigned dim = 0; dim < exv.rank(); ++dim) {
407 mlir::Value extent = fir::factory::readExtent(builder, loc, exv, dim);
408 mlir::Value lb = fir::factory::readLowerBound(builder, loc, exv, dim, one);
409 mlir::Value ub = genUBound(loc, builder, lb, extent, one);
410 result.push_back({lb, ub});
411 }
412 return result;
413}
414
415llvm::SmallVector<std::pair<mlir::Value, mlir::Value>>
416hlfir::genBounds(mlir::Location loc, fir::FirOpBuilder &builder,
417 mlir::Value shape) {
418 assert((shape.getType().isa<fir::ShapeShiftType>() ||
419 shape.getType().isa<fir::ShapeType>()) &&
420 "shape must contain extents");
421 auto extents = hlfir::getExplicitExtentsFromShape(shape, builder);
422 auto lowers = getExplicitLboundsFromShape(shape);
423 assert(lowers.empty() || lowers.size() == extents.size());
424 mlir::Type idxTy = builder.getIndexType();
425 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
426 llvm::SmallVector<std::pair<mlir::Value, mlir::Value>> result;
427 for (auto extent : llvm::enumerate(extents)) {
428 mlir::Value lb = lowers.empty() ? one : lowers[extent.index()];
429 mlir::Value ub = lowers.empty()
430 ? extent.value()
431 : genUBound(loc, builder, lb, extent.value(), one);
432 result.push_back({lb, ub});
433 }
434 return result;
435}
436
437llvm::SmallVector<mlir::Value> hlfir::genLowerbounds(mlir::Location loc,
438 fir::FirOpBuilder &builder,
439 mlir::Value shape,
440 unsigned rank) {
441 llvm::SmallVector<mlir::Value> lbounds;
442 if (shape)
443 lbounds = getExplicitLboundsFromShape(shape);
444 if (!lbounds.empty())
445 return lbounds;
446 mlir::Value one =
447 builder.createIntegerConstant(loc, builder.getIndexType(), 1);
448 return llvm::SmallVector<mlir::Value>(rank, one);
449}
450
451static hlfir::Entity followShapeInducingSource(hlfir::Entity entity) {
452 while (true) {
453 if (auto reassoc = entity.getDefiningOp<hlfir::NoReassocOp>()) {
454 entity = hlfir::Entity{reassoc.getVal()};
455 continue;
456 }
457 if (auto asExpr = entity.getDefiningOp<hlfir::AsExprOp>()) {
458 entity = hlfir::Entity{asExpr.getVar()};
459 continue;
460 }
461 break;
462 }
463 return entity;
464}
465
466static mlir::Value computeVariableExtent(mlir::Location loc,
467 fir::FirOpBuilder &builder,
468 hlfir::Entity variable,
469 fir::SequenceType seqTy,
470 unsigned dim) {
471 mlir::Type idxTy = builder.getIndexType();
472 if (seqTy.getShape().size() > dim) {
473 fir::SequenceType::Extent typeExtent = seqTy.getShape()[dim];
474 if (typeExtent != fir::SequenceType::getUnknownExtent())
475 return builder.createIntegerConstant(loc, idxTy, typeExtent);
476 }
477 assert(variable.getType().isa<fir::BaseBoxType>() &&
478 "array variable with dynamic extent must be boxed");
479 mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
480 auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
481 variable, dimVal);
482 return dimInfo.getExtent();
483}
484llvm::SmallVector<mlir::Value> getVariableExtents(mlir::Location loc,
485 fir::FirOpBuilder &builder,
486 hlfir::Entity variable) {
487 llvm::SmallVector<mlir::Value> extents;
488 if (fir::FortranVariableOpInterface varIface =
489 variable.getIfVariableInterface()) {
490 extents = getExplicitExtents(varIface, builder);
491 if (!extents.empty())
492 return extents;
493 }
494
495 if (variable.isMutableBox())
496 variable = hlfir::derefPointersAndAllocatables(loc, builder, variable);
497 // Use the type shape information, and/or the fir.box/fir.class shape
498 // information if any extents are not static.
499 fir::SequenceType seqTy =
500 hlfir::getFortranElementOrSequenceType(variable.getType())
501 .cast<fir::SequenceType>();
502 unsigned rank = seqTy.getShape().size();
503 for (unsigned dim = 0; dim < rank; ++dim)
504 extents.push_back(
505 computeVariableExtent(loc, builder, variable, seqTy, dim));
506 return extents;
507}
508
509static mlir::Value tryRetrievingShapeOrShift(hlfir::Entity entity) {
510 if (entity.getType().isa<hlfir::ExprType>()) {
511 if (auto elemental = entity.getDefiningOp<hlfir::ElementalOp>())
512 return elemental.getShape();
513 return mlir::Value{};
514 }
515 if (auto varIface = entity.getIfVariableInterface())
516 return varIface.getShape();
517 return {};
518}
519
520mlir::Value hlfir::genShape(mlir::Location loc, fir::FirOpBuilder &builder,
521 hlfir::Entity entity) {
522 assert(entity.isArray() && "entity must be an array");
523 entity = followShapeInducingSource(entity);
524 assert(entity && "what?");
525 if (auto shape = tryRetrievingShapeOrShift(entity)) {
526 if (shape.getType().isa<fir::ShapeType>())
527 return shape;
528 if (shape.getType().isa<fir::ShapeShiftType>())
529 if (auto s = shape.getDefiningOp<fir::ShapeShiftOp>())
530 return builder.create<fir::ShapeOp>(loc, s.getExtents());
531 }
532 if (entity.getType().isa<hlfir::ExprType>())
533 return builder.create<hlfir::ShapeOfOp>(loc, entity.getBase());
534 // There is no shape lying around for this entity. Retrieve the extents and
535 // build a new fir.shape.
536 return builder.create<fir::ShapeOp>(loc,
537 getVariableExtents(loc, builder, entity));
538}
539
540llvm::SmallVector<mlir::Value>
541hlfir::getIndexExtents(mlir::Location loc, fir::FirOpBuilder &builder,
542 mlir::Value shape) {
543 llvm::SmallVector<mlir::Value> extents =
544 hlfir::getExplicitExtentsFromShape(shape, builder);
545 mlir::Type indexType = builder.getIndexType();
546 for (auto &extent : extents)
547 extent = builder.createConvert(loc, indexType, extent);
548 return extents;
549}
550
551mlir::Value hlfir::genExtent(mlir::Location loc, fir::FirOpBuilder &builder,
552 hlfir::Entity entity, unsigned dim) {
553 entity = followShapeInducingSource(entity);
554 if (auto shape = tryRetrievingShapeOrShift(entity)) {
555 auto extents = hlfir::getExplicitExtentsFromShape(shape, builder);
556 if (!extents.empty()) {
557 assert(extents.size() > dim && "bad inquiry");
558 return extents[dim];
559 }
560 }
561 if (entity.isVariable()) {
562 if (entity.isMutableBox())
563 entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
564 // Use the type shape information, and/or the fir.box/fir.class shape
565 // information if any extents are not static.
566 fir::SequenceType seqTy =
567 hlfir::getFortranElementOrSequenceType(entity.getType())
568 .cast<fir::SequenceType>();
569 return computeVariableExtent(loc, builder, entity, seqTy, dim);
570 }
571 TODO(loc, "get extent from HLFIR expr without producer holding the shape");
572}
573
574mlir::Value hlfir::genLBound(mlir::Location loc, fir::FirOpBuilder &builder,
575 hlfir::Entity entity, unsigned dim) {
576 if (!entity.hasNonDefaultLowerBounds())
577 return builder.createIntegerConstant(loc, builder.getIndexType(), 1);
578 if (auto shape = tryRetrievingShapeOrShift(entity)) {
579 auto lbounds = getExplicitLboundsFromShape(shape);
580 if (!lbounds.empty()) {
581 assert(lbounds.size() > dim && "bad inquiry");
582 return lbounds[dim];
583 }
584 }
585 if (entity.isMutableBox())
586 entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
587 assert(entity.getType().isa<fir::BaseBoxType>() && "must be a box");
588 mlir::Type idxTy = builder.getIndexType();
589 mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
590 auto dimInfo =
591 builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, entity, dimVal);
592 return dimInfo.getLowerBound();
593}
594
595void hlfir::genLengthParameters(mlir::Location loc, fir::FirOpBuilder &builder,
596 Entity entity,
597 llvm::SmallVectorImpl<mlir::Value> &result) {
598 if (!entity.hasLengthParameters())
599 return;
600 if (entity.getType().isa<hlfir::ExprType>()) {
601 mlir::Value expr = entity;
602 if (auto reassoc = expr.getDefiningOp<hlfir::NoReassocOp>())
603 expr = reassoc.getVal();
604 // Going through fir::ExtendedValue would create a temp,
605 // which is not desired for an inquiry.
606 // TODO: make this an interface when adding further character producing ops.
607 if (auto concat = expr.getDefiningOp<hlfir::ConcatOp>()) {
608 result.push_back(concat.getLength());
609 return;
610 } else if (auto concat = expr.getDefiningOp<hlfir::SetLengthOp>()) {
611 result.push_back(concat.getLength());
612 return;
613 } else if (auto asExpr = expr.getDefiningOp<hlfir::AsExprOp>()) {
614 hlfir::genLengthParameters(loc, builder, hlfir::Entity{asExpr.getVar()},
615 result);
616 return;
617 } else if (auto elemental = expr.getDefiningOp<hlfir::ElementalOp>()) {
618 result.append(elemental.getTypeparams().begin(),
619 elemental.getTypeparams().end());
620 return;
621 } else if (auto apply = expr.getDefiningOp<hlfir::ApplyOp>()) {
622 result.append(apply.getTypeparams().begin(), apply.getTypeparams().end());
623 return;
624 }
625 if (entity.isCharacter()) {
626 result.push_back(builder.create<hlfir::GetLengthOp>(loc, expr));
627 return;
628 }
629 TODO(loc, "inquire PDTs length parameters of hlfir.expr");
630 }
631
632 if (entity.isCharacter()) {
633 result.push_back(genCharacterVariableLength(loc, builder, entity));
634 return;
635 }
636 TODO(loc, "inquire PDTs length parameters in HLFIR");
637}
638
639mlir::Value hlfir::genCharLength(mlir::Location loc, fir::FirOpBuilder &builder,
640 hlfir::Entity entity) {
641 llvm::SmallVector<mlir::Value, 1> lenParams;
642 genLengthParameters(loc, builder, entity, lenParams);
643 assert(lenParams.size() == 1 && "characters must have one length parameters");
644 return lenParams[0];
645}
646
647// Return a "shape" that can be used in fir.embox/fir.rebox with \p exv base.
648static mlir::Value asEmboxShape(mlir::Location loc, fir::FirOpBuilder &builder,
649 const fir::ExtendedValue &exv,
650 mlir::Value shape) {
651 if (!shape)
652 return shape;
653 // fir.rebox does not need and does not accept extents (fir.shape or
654 // fir.shape_shift) since this information is already in the input fir.box,
655 // it only accepts fir.shift because local lower bounds may not be reflected
656 // in the fir.box.
657 if (fir::getBase(exv).getType().isa<fir::BaseBoxType>() &&
658 !shape.getType().isa<fir::ShiftType>())
659 return builder.createShape(loc, exv);
660 return shape;
661}
662
663std::pair<mlir::Value, mlir::Value> hlfir::genVariableFirBaseShapeAndParams(
664 mlir::Location loc, fir::FirOpBuilder &builder, Entity entity,
665 llvm::SmallVectorImpl<mlir::Value> &typeParams) {
666 auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
667 assert(!cleanup && "variable to Exv should not produce cleanup");
668 if (entity.hasLengthParameters()) {
669 auto params = fir::getTypeParams(exv);
670 typeParams.append(params.begin(), params.end());
671 }
672 if (entity.isScalar())
673 return {fir::getBase(exv), mlir::Value{}};
674 if (auto variableInterface = entity.getIfVariableInterface())
675 return {fir::getBase(exv),
676 asEmboxShape(loc, builder, exv, variableInterface.getShape())};
677 return {fir::getBase(exv), builder.createShape(loc, exv)};
678}
679
680hlfir::Entity hlfir::derefPointersAndAllocatables(mlir::Location loc,
681 fir::FirOpBuilder &builder,
682 Entity entity) {
683 if (entity.isMutableBox()) {
684 hlfir::Entity boxLoad{builder.create<fir::LoadOp>(loc, entity)};
685 if (entity.isScalar()) {
686 if (!entity.isPolymorphic() && !entity.hasLengthParameters())
687 return hlfir::Entity{builder.create<fir::BoxAddrOp>(loc, boxLoad)};
688 mlir::Type elementType = boxLoad.getFortranElementType();
689 if (auto charType = elementType.dyn_cast<fir::CharacterType>()) {
690 mlir::Value base = builder.create<fir::BoxAddrOp>(loc, boxLoad);
691 if (charType.hasConstantLen())
692 return hlfir::Entity{base};
693 mlir::Value len = genCharacterVariableLength(loc, builder, entity);
694 auto boxCharType =
695 fir::BoxCharType::get(builder.getContext(), charType.getFKind());
696 return hlfir::Entity{
697 builder.create<fir::EmboxCharOp>(loc, boxCharType, base, len)
698 .getResult()};
699 }
700 }
701 // Otherwise, the entity is either an array, a polymorphic entity, or a
702 // derived type with length parameters. All these entities require a fir.box
703 // or fir.class to hold bounds, dynamic type or length parameter
704 // information. Keep them boxed.
705 return boxLoad;
706 } else if (entity.isProcedurePointer()) {
707 return hlfir::Entity{builder.create<fir::LoadOp>(loc, entity)};
708 }
709 return entity;
710}
711
712mlir::Type hlfir::getVariableElementType(hlfir::Entity variable) {
713 assert(variable.isVariable() && "entity must be a variable");
714 if (variable.isScalar())
715 return variable.getType();
716 mlir::Type eleTy = variable.getFortranElementType();
717 if (variable.isPolymorphic())
718 return fir::ClassType::get(eleTy);
719 if (auto charType = eleTy.dyn_cast<fir::CharacterType>()) {
720 if (charType.hasDynamicLen())
721 return fir::BoxCharType::get(charType.getContext(), charType.getFKind());
722 } else if (fir::isRecordWithTypeParameters(eleTy)) {
723 return fir::BoxType::get(eleTy);
724 }
725 return fir::ReferenceType::get(eleTy);
726}
727
728mlir::Type hlfir::getEntityElementType(hlfir::Entity entity) {
729 if (entity.isVariable())
730 return getVariableElementType(entity);
731 if (entity.isScalar())
732 return entity.getType();
733 auto exprType = mlir::dyn_cast<hlfir::ExprType>(entity.getType());
734 assert(exprType && "array value must be an hlfir.expr");
735 return exprType.getElementExprType();
736}
737
738static hlfir::ExprType getArrayExprType(mlir::Type elementType,
739 mlir::Value shape, bool isPolymorphic) {
740 unsigned rank = shape.getType().cast<fir::ShapeType>().getRank();
741 hlfir::ExprType::Shape typeShape(rank, hlfir::ExprType::getUnknownExtent());
742 if (auto shapeOp = shape.getDefiningOp<fir::ShapeOp>())
743 for (auto extent : llvm::enumerate(shapeOp.getExtents()))
744 if (auto cstExtent = fir::getIntIfConstant(extent.value()))
745 typeShape[extent.index()] = *cstExtent;
746 return hlfir::ExprType::get(elementType.getContext(), typeShape, elementType,
747 isPolymorphic);
748}
749
750hlfir::ElementalOp hlfir::genElementalOp(
751 mlir::Location loc, fir::FirOpBuilder &builder, mlir::Type elementType,
752 mlir::Value shape, mlir::ValueRange typeParams,
753 const ElementalKernelGenerator &genKernel, bool isUnordered,
754 mlir::Value polymorphicMold, mlir::Type exprType) {
755 if (!exprType)
756 exprType = getArrayExprType(elementType, shape, !!polymorphicMold);
757 auto elementalOp = builder.create<hlfir::ElementalOp>(
758 loc, exprType, shape, polymorphicMold, typeParams, isUnordered);
759 auto insertPt = builder.saveInsertionPoint();
760 builder.setInsertionPointToStart(elementalOp.getBody());
761 mlir::Value elementResult = genKernel(loc, builder, elementalOp.getIndices());
762 // Numerical and logical scalars may be lowered to another type than the
763 // Fortran expression type (e.g i1 instead of fir.logical). Array expression
764 // values are typed according to their Fortran type. Insert a cast if needed
765 // here.
766 if (fir::isa_trivial(elementResult.getType()))
767 elementResult = builder.createConvert(loc, elementType, elementResult);
768 builder.create<hlfir::YieldElementOp>(loc, elementResult);
769 builder.restoreInsertionPoint(insertPt);
770 return elementalOp;
771}
772
773// TODO: we do not actually need to clone the YieldElementOp,
774// because returning its getElementValue() operand should be enough
775// for all callers of this function.
776hlfir::YieldElementOp
777hlfir::inlineElementalOp(mlir::Location loc, fir::FirOpBuilder &builder,
778 hlfir::ElementalOp elemental,
779 mlir::ValueRange oneBasedIndices) {
780 // hlfir.elemental region is a SizedRegion<1>.
781 assert(elemental.getRegion().hasOneBlock() &&
782 "expect elemental region to have one block");
783 mlir::IRMapping mapper;
784 mapper.map(elemental.getIndices(), oneBasedIndices);
785 mlir::Operation *newOp;
786 for (auto &op : elemental.getRegion().back().getOperations())
787 newOp = builder.clone(op, mapper);
788 auto yield = mlir::dyn_cast_or_null<hlfir::YieldElementOp>(newOp);
789 assert(yield && "last ElementalOp operation must be am hlfir.yield_element");
790 return yield;
791}
792
793mlir::Value hlfir::inlineElementalOp(
794 mlir::Location loc, fir::FirOpBuilder &builder,
795 hlfir::ElementalOpInterface elemental, mlir::ValueRange oneBasedIndices,
796 mlir::IRMapping &mapper,
797 const std::function<bool(hlfir::ElementalOp)> &mustRecursivelyInline) {
798 mlir::Region &region = elemental.getElementalRegion();
799 // hlfir.elemental region is a SizedRegion<1>.
800 assert(region.hasOneBlock() && "elemental region must have one block");
801 mapper.map(elemental.getIndices(), oneBasedIndices);
802 for (auto &op : region.front().without_terminator()) {
803 if (auto apply = mlir::dyn_cast<hlfir::ApplyOp>(op))
804 if (auto appliedElemental =
805 apply.getExpr().getDefiningOp<hlfir::ElementalOp>())
806 if (mustRecursivelyInline(appliedElemental)) {
807 llvm::SmallVector<mlir::Value> clonedApplyIndices;
808 for (auto indice : apply.getIndices())
809 clonedApplyIndices.push_back(mapper.lookupOrDefault(indice));
810 hlfir::ElementalOpInterface elementalIface =
811 mlir::cast<hlfir::ElementalOpInterface>(
812 appliedElemental.getOperation());
813 mlir::Value inlined = inlineElementalOp(loc, builder, elementalIface,
814 clonedApplyIndices, mapper,
815 mustRecursivelyInline);
816 mapper.map(apply.getResult(), inlined);
817 continue;
818 }
819 (void)builder.clone(op, mapper);
820 }
821 return mapper.lookupOrDefault(elemental.getElementEntity());
822}
823
824hlfir::LoopNest hlfir::genLoopNest(mlir::Location loc,
825 fir::FirOpBuilder &builder,
826 mlir::ValueRange extents, bool isUnordered) {
827 hlfir::LoopNest loopNest;
828 assert(!extents.empty() && "must have at least one extent");
829 auto insPt = builder.saveInsertionPoint();
830 loopNest.oneBasedIndices.assign(extents.size(), mlir::Value{});
831 // Build loop nest from column to row.
832 auto one = builder.create<mlir::arith::ConstantIndexOp>(loc, 1);
833 mlir::Type indexType = builder.getIndexType();
834 unsigned dim = extents.size() - 1;
835 for (auto extent : llvm::reverse(extents)) {
836 auto ub = builder.createConvert(loc, indexType, extent);
837 loopNest.innerLoop =
838 builder.create<fir::DoLoopOp>(loc, one, ub, one, isUnordered);
839 builder.setInsertionPointToStart(loopNest.innerLoop.getBody());
840 // Reverse the indices so they are in column-major order.
841 loopNest.oneBasedIndices[dim--] = loopNest.innerLoop.getInductionVar();
842 if (!loopNest.outerLoop)
843 loopNest.outerLoop = loopNest.innerLoop;
844 }
845 builder.restoreInsertionPoint(insPt);
846 return loopNest;
847}
848
849static fir::ExtendedValue
850translateVariableToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
851 hlfir::Entity variable,
852 bool forceHlfirBase = false) {
853 assert(variable.isVariable() && "must be a variable");
854 /// When going towards FIR, use the original base value to avoid
855 /// introducing descriptors at runtime when they are not required.
856 mlir::Value base =
857 forceHlfirBase ? variable.getBase() : variable.getFirBase();
858 if (variable.isMutableBox())
859 return fir::MutableBoxValue(base, getExplicitTypeParams(variable),
860 fir::MutableProperties{});
861
862 if (base.getType().isa<fir::BaseBoxType>()) {
863 if (!variable.isSimplyContiguous() || variable.isPolymorphic() ||
864 variable.isDerivedWithLengthParameters() || variable.isOptional()) {
865 llvm::SmallVector<mlir::Value> nonDefaultLbounds =
866 getNonDefaultLowerBounds(loc, builder, variable);
867 return fir::BoxValue(base, nonDefaultLbounds,
868 getExplicitTypeParams(variable));
869 }
870 // Otherwise, the variable can be represented in a fir::ExtendedValue
871 // without the overhead of a fir.box.
872 base = genVariableRawAddress(loc, builder, variable);
873 }
874
875 if (variable.isScalar()) {
876 if (variable.isCharacter()) {
877 if (base.getType().isa<fir::BoxCharType>())
878 return genUnboxChar(loc, builder, base);
879 mlir::Value len = genCharacterVariableLength(loc, builder, variable);
880 return fir::CharBoxValue{base, len};
881 }
882 return base;
883 }
884 llvm::SmallVector<mlir::Value> extents;
885 llvm::SmallVector<mlir::Value> nonDefaultLbounds;
886 if (variable.getType().isa<fir::BaseBoxType>() &&
887 !variable.getIfVariableInterface()) {
888 // This special case avoids generating two sets of identical
889 // fir.box_dim to get both the lower bounds and extents.
890 genLboundsAndExtentsFromBox(loc, builder, variable, nonDefaultLbounds,
891 &extents);
892 } else {
893 extents = getVariableExtents(loc, builder, variable);
894 nonDefaultLbounds = getNonDefaultLowerBounds(loc, builder, variable);
895 }
896 if (variable.isCharacter())
897 return fir::CharArrayBoxValue{
898 base, genCharacterVariableLength(loc, builder, variable), extents,
899 nonDefaultLbounds};
900 return fir::ArrayBoxValue{base, extents, nonDefaultLbounds};
901}
902
903fir::ExtendedValue
904hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
905 fir::FortranVariableOpInterface var,
906 bool forceHlfirBase) {
907 return translateVariableToExtendedValue(loc, builder, var, forceHlfirBase);
908}
909
910std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
911hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
912 hlfir::Entity entity) {
913 if (entity.isVariable())
914 return {translateVariableToExtendedValue(loc, builder, entity),
915 std::nullopt};
916
917 if (entity.isProcedure()) {
918 if (fir::isCharacterProcedureTuple(entity.getType())) {
919 auto [boxProc, len] = fir::factory::extractCharacterProcedureTuple(
920 builder, loc, entity, /*openBoxProc=*/false);
921 return {fir::CharBoxValue{boxProc, len}, std::nullopt};
922 }
923 return {static_cast<mlir::Value>(entity), std::nullopt};
924 }
925
926 if (entity.getType().isa<hlfir::ExprType>()) {
927 mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);
928 hlfir::AssociateOp associate = hlfir::genAssociateExpr(
929 loc, builder, entity, entity.getType(), "", byRefAttr);
930 auto *bldr = &builder;
931 hlfir::CleanupFunction cleanup = [bldr, loc, associate]() -> void {
932 bldr->create<hlfir::EndAssociateOp>(loc, associate);
933 };
934 hlfir::Entity temp{associate.getBase()};
935 return {translateToExtendedValue(loc, builder, temp).first, cleanup};
936 }
937 return {{static_cast<mlir::Value>(entity)}, {}};
938}
939
940std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
941hlfir::convertToValue(mlir::Location loc, fir::FirOpBuilder &builder,
942 hlfir::Entity entity) {
943 // Load scalar references to integer, logical, real, or complex value
944 // to an mlir value, dereference allocatable and pointers, and get rid
945 // of fir.box that are not needed or create a copy into contiguous memory.
946 auto derefedAndLoadedEntity = loadTrivialScalar(loc, builder, entity);
947 return translateToExtendedValue(loc, builder, derefedAndLoadedEntity);
948}
949
950static fir::ExtendedValue placeTrivialInMemory(mlir::Location loc,
951 fir::FirOpBuilder &builder,
952 mlir::Value val,
953 mlir::Type targetType) {
954 auto temp = builder.createTemporary(loc, targetType);
955 if (targetType != val.getType())
956 builder.createStoreWithConvert(loc, val, temp);
957 else
958 builder.create<fir::StoreOp>(loc, val, temp);
959 return temp;
960}
961
962std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
963hlfir::convertToBox(mlir::Location loc, fir::FirOpBuilder &builder,
964 hlfir::Entity entity, mlir::Type targetType) {
965 // fir::factory::createBoxValue is not meant to deal with procedures.
966 // Dereference procedure pointers here.
967 if (entity.isProcedurePointer())
968 entity = hlfir::derefPointersAndAllocatables(loc, builder, entity);
969
970 auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
971 // Procedure entities should not go through createBoxValue that embox
972 // object entities. Return the fir.boxproc directly.
973 if (entity.isProcedure())
974 return {exv, cleanup};
975 mlir::Value base = fir::getBase(exv);
976 if (fir::isa_trivial(base.getType()))
977 exv = placeTrivialInMemory(loc, builder, base, targetType);
978 fir::BoxValue box = fir::factory::createBoxValue(builder, loc, exv);
979 return {box, cleanup};
980}
981
982std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
983hlfir::convertToAddress(mlir::Location loc, fir::FirOpBuilder &builder,
984 hlfir::Entity entity, mlir::Type targetType) {
985 hlfir::Entity derefedEntity =
986 hlfir::derefPointersAndAllocatables(loc, builder, entity);
987 auto [exv, cleanup] =
988 hlfir::translateToExtendedValue(loc, builder, derefedEntity);
989 mlir::Value base = fir::getBase(exv);
990 if (fir::isa_trivial(base.getType()))
991 exv = placeTrivialInMemory(loc, builder, base, targetType);
992 return {exv, cleanup};
993}
994
995/// Clone:
996/// ```
997/// hlfir.elemental_addr %shape : !fir.shape<1> {
998/// ^bb0(%i : index)
999/// .....
1000/// %hlfir.yield %scalarAddress : fir.ref<T>
1001/// }
1002/// ```
1003//
1004/// into
1005///
1006/// ```
1007/// %expr = hlfir.elemental %shape : (!fir.shape<1>) -> hlfir.expr<?xT> {
1008/// ^bb0(%i : index)
1009/// .....
1010/// %value = fir.load %scalarAddress : fir.ref<T>
1011/// %hlfir.yield_element %value : T
1012/// }
1013/// ```
1014hlfir::ElementalOp
1015hlfir::cloneToElementalOp(mlir::Location loc, fir::FirOpBuilder &builder,
1016 hlfir::ElementalAddrOp elementalAddrOp) {
1017 hlfir::Entity scalarAddress =
1018 hlfir::Entity{mlir::cast<hlfir::YieldOp>(
1019 elementalAddrOp.getBody().back().getTerminator())
1020 .getEntity()};
1021 llvm::SmallVector<mlir::Value, 1> typeParams;
1022 hlfir::genLengthParameters(loc, builder, scalarAddress, typeParams);
1023
1024 builder.setInsertionPointAfter(elementalAddrOp);
1025 auto genKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
1026 mlir::ValueRange oneBasedIndices) -> hlfir::Entity {
1027 mlir::IRMapping mapper;
1028 mapper.map(elementalAddrOp.getIndices(), oneBasedIndices);
1029 mlir::Operation *newOp = nullptr;
1030 for (auto &op : elementalAddrOp.getBody().back().getOperations())
1031 newOp = b.clone(op, mapper);
1032 auto newYielOp = mlir::dyn_cast_or_null<hlfir::YieldOp>(newOp);
1033 assert(newYielOp && "hlfir.elemental_addr is ill formed");
1034 hlfir::Entity newAddr{newYielOp.getEntity()};
1035 newYielOp->erase();
1036 return hlfir::loadTrivialScalar(l, b, newAddr);
1037 };
1038 mlir::Type elementType = scalarAddress.getFortranElementType();
1039 return hlfir::genElementalOp(
1040 loc, builder, elementType, elementalAddrOp.getShape(), typeParams,
1041 genKernel, !elementalAddrOp.isOrdered(), elementalAddrOp.getMold());
1042}
1043
1044bool hlfir::elementalOpMustProduceTemp(hlfir::ElementalOp elemental) {
1045 for (mlir::Operation *useOp : elemental->getUsers())
1046 if (auto destroy = mlir::dyn_cast<hlfir::DestroyOp>(useOp))
1047 if (destroy.mustFinalizeExpr())
1048 return true;
1049
1050 return false;
1051}
1052
1053std::pair<hlfir::Entity, mlir::Value>
1054hlfir::createTempFromMold(mlir::Location loc, fir::FirOpBuilder &builder,
1055 hlfir::Entity mold) {
1056 llvm::SmallVector<mlir::Value> lenParams;
1057 hlfir::genLengthParameters(loc, builder, mold, lenParams);
1058 llvm::StringRef tmpName{".tmp"};
1059 mlir::Value alloc;
1060 mlir::Value isHeapAlloc;
1061 mlir::Value shape{};
1062 fir::FortranVariableFlagsAttr declAttrs;
1063
1064 if (mold.isPolymorphic()) {
1065 // Create unallocated polymorphic temporary using the dynamic type
1066 // of the mold. The static type of the temporary matches
1067 // the static type of the mold, but then the dynamic type
1068 // of the mold is applied to the temporary's descriptor.
1069
1070 if (mold.isArray())
1071 hlfir::genShape(loc, builder, mold);
1072
1073 // Create polymorphic allocatable box on the stack.
1074 mlir::Type boxHeapType = fir::HeapType::get(fir::unwrapRefType(
1075 mlir::cast<fir::BaseBoxType>(mold.getType()).getEleTy()));
1076 // The box must be initialized, because AllocatableApplyMold
1077 // may read its contents (e.g. for checking whether it is allocated).
1078 alloc = fir::factory::genNullBoxStorage(builder, loc,
1079 fir::ClassType::get(boxHeapType));
1080 // The temporary is unallocated even after AllocatableApplyMold below.
1081 // If the temporary is used as assignment LHS it will be automatically
1082 // allocated on the heap, as long as we use Assign family
1083 // runtime functions. So set MustFree to true.
1084 isHeapAlloc = builder.createBool(loc, true);
1085 declAttrs = fir::FortranVariableFlagsAttr::get(
1086 builder.getContext(), fir::FortranVariableFlagsEnum::allocatable);
1087 } else if (mold.isArray()) {
1088 mlir::Type sequenceType =
1089 hlfir::getFortranElementOrSequenceType(mold.getType());
1090 shape = hlfir::genShape(loc, builder, mold);
1091 auto extents = hlfir::getIndexExtents(loc, builder, shape);
1092 alloc = builder.createHeapTemporary(loc, sequenceType, tmpName, extents,
1093 lenParams);
1094 isHeapAlloc = builder.createBool(loc, true);
1095 } else {
1096 alloc = builder.createTemporary(loc, mold.getFortranElementType(), tmpName,
1097 /*shape=*/std::nullopt, lenParams);
1098 isHeapAlloc = builder.createBool(loc, false);
1099 }
1100 auto declareOp = builder.create<hlfir::DeclareOp>(loc, alloc, tmpName, shape,
1101 lenParams, declAttrs);
1102 if (mold.isPolymorphic()) {
1103 int rank = mold.getRank();
1104 // TODO: should probably read rank from the mold.
1105 if (rank < 0)
1106 TODO(loc, "create temporary for assumed rank polymorphic");
1107 fir::runtime::genAllocatableApplyMold(builder, loc, alloc,
1108 mold.getFirBase(), rank);
1109 }
1110
1111 return {hlfir::Entity{declareOp.getBase()}, isHeapAlloc};
1112}
1113
1114hlfir::Entity hlfir::createStackTempFromMold(mlir::Location loc,
1115 fir::FirOpBuilder &builder,
1116 hlfir::Entity mold) {
1117 llvm::SmallVector<mlir::Value> lenParams;
1118 hlfir::genLengthParameters(loc, builder, mold, lenParams);
1119 llvm::StringRef tmpName{".tmp"};
1120 mlir::Value alloc;
1121 mlir::Value shape{};
1122 fir::FortranVariableFlagsAttr declAttrs;
1123
1124 if (mold.isPolymorphic()) {
1125 // genAllocatableApplyMold does heap allocation
1126 TODO(loc, "createStackTempFromMold for polymorphic type");
1127 } else if (mold.isArray()) {
1128 mlir::Type sequenceType =
1129 hlfir::getFortranElementOrSequenceType(mold.getType());
1130 shape = hlfir::genShape(loc, builder, mold);
1131 auto extents = hlfir::getIndexExtents(loc, builder, shape);
1132 alloc =
1133 builder.createTemporary(loc, sequenceType, tmpName, extents, lenParams);
1134 } else {
1135 alloc = builder.createTemporary(loc, mold.getFortranElementType(), tmpName,
1136 /*shape=*/std::nullopt, lenParams);
1137 }
1138 auto declareOp = builder.create<hlfir::DeclareOp>(loc, alloc, tmpName, shape,
1139 lenParams, declAttrs);
1140 return hlfir::Entity{declareOp.getBase()};
1141}
1142
1143hlfir::EntityWithAttributes
1144hlfir::convertCharacterKind(mlir::Location loc, fir::FirOpBuilder &builder,
1145 hlfir::Entity scalarChar, int toKind) {
1146 auto src = hlfir::convertToAddress(loc, builder, scalarChar,
1147 scalarChar.getFortranElementType());
1148 assert(src.first.getCharBox() && "must be scalar character");
1149 fir::CharBoxValue res = fir::factory::convertCharacterKind(
1150 builder, loc, *src.first.getCharBox(), toKind);
1151 if (src.second.has_value())
1152 src.second.value()();
1153
1154 return hlfir::EntityWithAttributes{builder.create<hlfir::DeclareOp>(
1155 loc, res.getAddr(), ".temp.kindconvert", /*shape=*/nullptr,
1156 /*typeparams=*/mlir::ValueRange{res.getLen()},
1157 fir::FortranVariableFlagsAttr{})};
1158}
1159
1160std::pair<hlfir::Entity, std::optional<hlfir::CleanupFunction>>
1161hlfir::genTypeAndKindConvert(mlir::Location loc, fir::FirOpBuilder &builder,
1162 hlfir::Entity source, mlir::Type toType,
1163 bool preserveLowerBounds) {
1164 mlir::Type fromType = source.getFortranElementType();
1165 toType = hlfir::getFortranElementType(toType);
1166 if (!toType || fromType == toType ||
1167 !(fir::isa_trivial(toType) || mlir::isa<fir::CharacterType>(toType)))
1168 return {source, std::nullopt};
1169
1170 std::optional<int> toKindCharConvert;
1171 if (auto toCharTy = mlir::dyn_cast<fir::CharacterType>(toType)) {
1172 if (auto fromCharTy = mlir::dyn_cast<fir::CharacterType>(fromType))
1173 if (toCharTy.getFKind() != fromCharTy.getFKind()) {
1174 toKindCharConvert = toCharTy.getFKind();
1175 // Preserve source length (padding/truncation will occur in assignment
1176 // if needed).
1177 toType = fir::CharacterType::get(
1178 fromType.getContext(), toCharTy.getFKind(), fromCharTy.getLen());
1179 }
1180 // Do not convert in case of character length mismatch only, hlfir.assign
1181 // deals with it.
1182 if (!toKindCharConvert)
1183 return {source, std::nullopt};
1184 }
1185
1186 if (source.getRank() == 0) {
1187 mlir::Value cast = toKindCharConvert
1188 ? mlir::Value{hlfir::convertCharacterKind(
1189 loc, builder, source, *toKindCharConvert)}
1190 : builder.convertWithSemantics(loc, toType, source);
1191 return {hlfir::Entity{cast}, std::nullopt};
1192 }
1193
1194 mlir::Value shape = hlfir::genShape(loc, builder, source);
1195 auto genKernel = [source, toType, toKindCharConvert](
1196 mlir::Location loc, fir::FirOpBuilder &builder,
1197 mlir::ValueRange oneBasedIndices) -> hlfir::Entity {
1198 auto elementPtr =
1199 hlfir::getElementAt(loc, builder, source, oneBasedIndices);
1200 auto val = hlfir::loadTrivialScalar(loc, builder, elementPtr);
1201 if (toKindCharConvert)
1202 return hlfir::convertCharacterKind(loc, builder, val, *toKindCharConvert);
1203 return hlfir::EntityWithAttributes{
1204 builder.convertWithSemantics(loc, toType, val)};
1205 };
1206 llvm::SmallVector<mlir::Value, 1> lenParams;
1207 hlfir::genLengthParameters(loc, builder, source, lenParams);
1208 mlir::Value convertedRhs =
1209 hlfir::genElementalOp(loc, builder, toType, shape, lenParams, genKernel,
1210 /*isUnordered=*/true);
1211
1212 if (preserveLowerBounds && source.hasNonDefaultLowerBounds()) {
1213 hlfir::AssociateOp associate =
1214 genAssociateExpr(loc, builder, hlfir::Entity{convertedRhs},
1215 convertedRhs.getType(), ".tmp.keeplbounds");
1216 fir::ShapeOp shapeOp = associate.getShape().getDefiningOp<fir::ShapeOp>();
1217 assert(shapeOp && "associate shape must be a fir.shape");
1218 const unsigned rank = shapeOp.getExtents().size();
1219 llvm::SmallVector<mlir::Value> lbAndExtents;
1220 for (unsigned dim = 0; dim < rank; ++dim) {
1221 lbAndExtents.push_back(hlfir::genLBound(loc, builder, source, dim));
1222 lbAndExtents.push_back(shapeOp.getExtents()[dim]);
1223 }
1224 auto shapeShiftType = fir::ShapeShiftType::get(builder.getContext(), rank);
1225 mlir::Value shapeShift =
1226 builder.create<fir::ShapeShiftOp>(loc, shapeShiftType, lbAndExtents);
1227 auto declareOp = builder.create<hlfir::DeclareOp>(
1228 loc, associate.getFirBase(), *associate.getUniqName(), shapeShift,
1229 associate.getTypeparams(), /*flags=*/fir::FortranVariableFlagsAttr{});
1230 hlfir::Entity castWithLbounds =
1231 mlir::cast<fir::FortranVariableOpInterface>(declareOp.getOperation());
1232 fir::FirOpBuilder *bldr = &builder;
1233 auto cleanup = [loc, bldr, convertedRhs, associate]() {
1234 bldr->create<hlfir::EndAssociateOp>(loc, associate);
1235 bldr->create<hlfir::DestroyOp>(loc, convertedRhs);
1236 };
1237 return {castWithLbounds, cleanup};
1238 }
1239
1240 fir::FirOpBuilder *bldr = &builder;
1241 auto cleanup = [loc, bldr, convertedRhs]() {
1242 bldr->create<hlfir::DestroyOp>(loc, convertedRhs);
1243 };
1244 return {hlfir::Entity{convertedRhs}, cleanup};
1245}
1246

source code of flang/lib/Optimizer/Builder/HLFIRTools.cpp