FLANG
DirectivesCommon.h
1//===-- Lower/DirectivesCommon.h --------------------------------*- C++ -*-===//
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//===----------------------------------------------------------------------===//
16//===----------------------------------------------------------------------===//
17
18#ifndef FORTRAN_LOWER_DIRECTIVES_COMMON_H
19#define FORTRAN_LOWER_DIRECTIVES_COMMON_H
20
21#include "flang/Common/idioms.h"
22#include "flang/Evaluate/tools.h"
23#include "flang/Lower/AbstractConverter.h"
24#include "flang/Lower/Bridge.h"
25#include "flang/Lower/ConvertExpr.h"
26#include "flang/Lower/ConvertVariable.h"
27#include "flang/Lower/OpenACC.h"
28#include "flang/Lower/OpenMP.h"
29#include "flang/Lower/PFTBuilder.h"
30#include "flang/Lower/StatementContext.h"
31#include "flang/Lower/Support/Utils.h"
32#include "flang/Optimizer/Builder/BoxValue.h"
33#include "flang/Optimizer/Builder/FIRBuilder.h"
34#include "flang/Optimizer/Builder/HLFIRTools.h"
35#include "flang/Optimizer/Builder/Todo.h"
36#include "flang/Optimizer/Dialect/FIRType.h"
37#include "flang/Optimizer/HLFIR/HLFIROps.h"
38#include "flang/Parser/parse-tree.h"
39#include "flang/Semantics/openmp-directive-sets.h"
40#include "flang/Semantics/tools.h"
41#include "mlir/Dialect/OpenACC/OpenACC.h"
42#include "mlir/Dialect/OpenMP/OpenMPDialect.h"
43#include "mlir/Dialect/SCF/IR/SCF.h"
44#include "mlir/IR/Value.h"
45#include "llvm/Frontend/OpenMP/OMPConstants.h"
46#include <list>
47#include <type_traits>
48
49namespace Fortran {
50namespace lower {
51
54struct AddrAndBoundsInfo {
55 explicit AddrAndBoundsInfo() {}
56 explicit AddrAndBoundsInfo(mlir::Value addr, mlir::Value rawInput)
57 : addr(addr), rawInput(rawInput) {}
58 explicit AddrAndBoundsInfo(mlir::Value addr, mlir::Value rawInput,
59 mlir::Value isPresent)
60 : addr(addr), rawInput(rawInput), isPresent(isPresent) {}
61 explicit AddrAndBoundsInfo(mlir::Value addr, mlir::Value rawInput,
62 mlir::Value isPresent, mlir::Type boxType)
63 : addr(addr), rawInput(rawInput), isPresent(isPresent), boxType(boxType) {
64 }
65 mlir::Value addr = nullptr;
66 mlir::Value rawInput = nullptr;
67 mlir::Value isPresent = nullptr;
68 mlir::Type boxType = nullptr;
69 void dump(llvm::raw_ostream &os) {
70 os << "AddrAndBoundsInfo addr: " << addr << "\n";
71 os << "AddrAndBoundsInfo rawInput: " << rawInput << "\n";
72 os << "AddrAndBoundsInfo isPresent: " << isPresent << "\n";
73 os << "AddrAndBoundsInfo boxType: " << boxType << "\n";
74 }
75};
76
79static inline void genOmpAtomicHintAndMemoryOrderClauses(
80 Fortran::lower::AbstractConverter &converter,
81 const Fortran::parser::OmpAtomicClauseList &clauseList,
82 mlir::IntegerAttr &hint,
83 mlir::omp::ClauseMemoryOrderKindAttr &memoryOrder) {
84 fir::FirOpBuilder &firOpBuilder = converter.getFirOpBuilder();
85 for (const Fortran::parser::OmpAtomicClause &clause : clauseList.v) {
86 if (const auto *ompClause =
87 std::get_if<Fortran::parser::OmpClause>(&clause.u)) {
88 if (const auto *hintClause =
89 std::get_if<Fortran::parser::OmpClause::Hint>(&ompClause->u)) {
90 const auto *expr = Fortran::semantics::GetExpr(hintClause->v);
91 uint64_t hintExprValue = *Fortran::evaluate::ToInt64(*expr);
92 hint = firOpBuilder.getI64IntegerAttr(hintExprValue);
93 }
94 } else if (const auto *ompMemoryOrderClause =
95 std::get_if<Fortran::parser::OmpMemoryOrderClause>(
96 &clause.u)) {
97 if (std::get_if<Fortran::parser::OmpClause::Acquire>(
98 &ompMemoryOrderClause->v.u)) {
99 memoryOrder = mlir::omp::ClauseMemoryOrderKindAttr::get(
100 firOpBuilder.getContext(),
101 mlir::omp::ClauseMemoryOrderKind::Acquire);
102 } else if (std::get_if<Fortran::parser::OmpClause::Relaxed>(
103 &ompMemoryOrderClause->v.u)) {
104 memoryOrder = mlir::omp::ClauseMemoryOrderKindAttr::get(
105 firOpBuilder.getContext(),
106 mlir::omp::ClauseMemoryOrderKind::Relaxed);
107 } else if (std::get_if<Fortran::parser::OmpClause::SeqCst>(
108 &ompMemoryOrderClause->v.u)) {
109 memoryOrder = mlir::omp::ClauseMemoryOrderKindAttr::get(
110 firOpBuilder.getContext(),
111 mlir::omp::ClauseMemoryOrderKind::Seq_cst);
112 } else if (std::get_if<Fortran::parser::OmpClause::Release>(
113 &ompMemoryOrderClause->v.u)) {
114 memoryOrder = mlir::omp::ClauseMemoryOrderKindAttr::get(
115 firOpBuilder.getContext(),
116 mlir::omp::ClauseMemoryOrderKind::Release);
117 }
118 }
119 }
120}
121
122template <typename AtomicListT>
123static void processOmpAtomicTODO(mlir::Type elementType,
124 [[maybe_unused]] mlir::Location loc) {
125 if (!elementType)
126 return;
127 if constexpr (std::is_same<AtomicListT,
128 Fortran::parser::OmpAtomicClauseList>()) {
129 assert(fir::isa_trivial(fir::unwrapRefType(elementType)) &&
130 "is supported type for omp atomic");
131 }
132}
133
136template <typename AtomicListT>
137static inline void genOmpAccAtomicCaptureStatement(
138 Fortran::lower::AbstractConverter &converter, mlir::Value fromAddress,
139 mlir::Value toAddress,
140 [[maybe_unused]] const AtomicListT *leftHandClauseList,
141 [[maybe_unused]] const AtomicListT *rightHandClauseList,
142 mlir::Type elementType, mlir::Location loc) {
143 // Generate `atomic.read` operation for atomic assigment statements
144 fir::FirOpBuilder &firOpBuilder = converter.getFirOpBuilder();
145
146 processOmpAtomicTODO<AtomicListT>(elementType, loc);
147
148 if constexpr (std::is_same<AtomicListT,
149 Fortran::parser::OmpAtomicClauseList>()) {
150 // If no hint clause is specified, the effect is as if
151 // hint(omp_sync_hint_none) had been specified.
152 mlir::IntegerAttr hint = nullptr;
153
154 mlir::omp::ClauseMemoryOrderKindAttr memoryOrder = nullptr;
155 if (leftHandClauseList)
156 genOmpAtomicHintAndMemoryOrderClauses(converter, *leftHandClauseList,
157 hint, memoryOrder);
158 if (rightHandClauseList)
159 genOmpAtomicHintAndMemoryOrderClauses(converter, *rightHandClauseList,
160 hint, memoryOrder);
161 firOpBuilder.create<mlir::omp::AtomicReadOp>(
162 loc, fromAddress, toAddress, mlir::TypeAttr::get(elementType), hint,
163 memoryOrder);
164 } else {
165 firOpBuilder.create<mlir::acc::AtomicReadOp>(
166 loc, fromAddress, toAddress, mlir::TypeAttr::get(elementType));
167 }
168}
169
172template <typename AtomicListT>
173static inline void genOmpAccAtomicWriteStatement(
174 Fortran::lower::AbstractConverter &converter, mlir::Value lhsAddr,
175 mlir::Value rhsExpr, [[maybe_unused]] const AtomicListT *leftHandClauseList,
176 [[maybe_unused]] const AtomicListT *rightHandClauseList, mlir::Location loc,
177 mlir::Value *evaluatedExprValue = nullptr) {
178 // Generate `atomic.write` operation for atomic assignment statements
179 fir::FirOpBuilder &firOpBuilder = converter.getFirOpBuilder();
180
181 mlir::Type varType = fir::unwrapRefType(lhsAddr.getType());
182 // Create a conversion outside the capture block.
183 auto insertionPoint = firOpBuilder.saveInsertionPoint();
184 firOpBuilder.setInsertionPointAfter(rhsExpr.getDefiningOp());
185 rhsExpr = firOpBuilder.createConvert(loc, varType, rhsExpr);
186 firOpBuilder.restoreInsertionPoint(insertionPoint);
187
188 processOmpAtomicTODO<AtomicListT>(varType, loc);
189
190 if constexpr (std::is_same<AtomicListT,
191 Fortran::parser::OmpAtomicClauseList>()) {
192 // If no hint clause is specified, the effect is as if
193 // hint(omp_sync_hint_none) had been specified.
194 mlir::IntegerAttr hint = nullptr;
195 mlir::omp::ClauseMemoryOrderKindAttr memoryOrder = nullptr;
196 if (leftHandClauseList)
197 genOmpAtomicHintAndMemoryOrderClauses(converter, *leftHandClauseList,
198 hint, memoryOrder);
199 if (rightHandClauseList)
200 genOmpAtomicHintAndMemoryOrderClauses(converter, *rightHandClauseList,
201 hint, memoryOrder);
202 firOpBuilder.create<mlir::omp::AtomicWriteOp>(loc, lhsAddr, rhsExpr, hint,
203 memoryOrder);
204 } else {
205 firOpBuilder.create<mlir::acc::AtomicWriteOp>(loc, lhsAddr, rhsExpr);
206 }
207}
208
211template <typename AtomicListT>
212static inline void genOmpAccAtomicUpdateStatement(
213 Fortran::lower::AbstractConverter &converter, mlir::Value lhsAddr,
214 mlir::Type varType, const Fortran::parser::Variable &assignmentStmtVariable,
215 const Fortran::parser::Expr &assignmentStmtExpr,
216 [[maybe_unused]] const AtomicListT *leftHandClauseList,
217 [[maybe_unused]] const AtomicListT *rightHandClauseList, mlir::Location loc,
218 mlir::Operation *atomicCaptureOp = nullptr) {
219 // Generate `atomic.update` operation for atomic assignment statements
220 fir::FirOpBuilder &firOpBuilder = converter.getFirOpBuilder();
221 mlir::Location currentLocation = converter.getCurrentLocation();
222
223 // Create the omp.atomic.update or acc.atomic.update operation
224 //
225 // func.func @_QPsb() {
226 // %0 = fir.alloca i32 {bindc_name = "a", uniq_name = "_QFsbEa"}
227 // %1 = fir.alloca i32 {bindc_name = "b", uniq_name = "_QFsbEb"}
228 // %2 = fir.load %1 : !fir.ref<i32>
229 // omp.atomic.update %0 : !fir.ref<i32> {
230 // ^bb0(%arg0: i32):
231 // %3 = arith.addi %arg0, %2 : i32
232 // omp.yield(%3 : i32)
233 // }
234 // return
235 // }
236
237 auto getArgExpression =
238 [](std::list<parser::ActualArgSpec>::const_iterator it) {
239 const auto &arg{std::get<parser::ActualArg>((*it).t)};
240 const auto *parserExpr{
241 std::get_if<common::Indirection<parser::Expr>>(&arg.u)};
242 return parserExpr;
243 };
244
245 // Lower any non atomic sub-expression before the atomic operation, and
246 // map its lowered value to the semantic representation.
247 Fortran::lower::ExprToValueMap exprValueOverrides;
248 // Max and min intrinsics can have a list of Args. Hence we need a list
249 // of nonAtomicSubExprs to hoist. Currently, only the load is hoisted.
250 llvm::SmallVector<const Fortran::lower::SomeExpr *> nonAtomicSubExprs;
251 Fortran::common::visit(
252 Fortran::common::visitors{
253 [&](const common::Indirection<parser::FunctionReference> &funcRef)
254 -> void {
255 const auto &args{std::get<std::list<parser::ActualArgSpec>>(
256 funcRef.value().v.t)};
257 std::list<parser::ActualArgSpec>::const_iterator beginIt =
258 args.begin();
259 std::list<parser::ActualArgSpec>::const_iterator endIt = args.end();
260 const auto *exprFirst{getArgExpression(beginIt)};
261 if (exprFirst && exprFirst->value().source ==
262 assignmentStmtVariable.GetSource()) {
263 // Add everything except the first
264 beginIt++;
265 } else {
266 // Add everything except the last
267 endIt--;
268 }
269 std::list<parser::ActualArgSpec>::const_iterator it;
270 for (it = beginIt; it != endIt; it++) {
271 const common::Indirection<parser::Expr> *expr =
272 getArgExpression(it);
273 if (expr)
274 nonAtomicSubExprs.push_back(Fortran::semantics::GetExpr(*expr));
275 }
276 },
277 [&](const auto &op) -> void {
278 using T = std::decay_t<decltype(op)>;
279 if constexpr (std::is_base_of<
280 Fortran::parser::Expr::IntrinsicBinary,
281 T>::value) {
282 const auto &exprLeft{std::get<0>(op.t)};
283 const auto &exprRight{std::get<1>(op.t)};
284 if (exprLeft.value().source == assignmentStmtVariable.GetSource())
285 nonAtomicSubExprs.push_back(
286 Fortran::semantics::GetExpr(exprRight));
287 else
288 nonAtomicSubExprs.push_back(
289 Fortran::semantics::GetExpr(exprLeft));
290 }
291 },
292 },
293 assignmentStmtExpr.u);
294 StatementContext nonAtomicStmtCtx;
295 if (!nonAtomicSubExprs.empty()) {
296 // Generate non atomic part before all the atomic operations.
297 auto insertionPoint = firOpBuilder.saveInsertionPoint();
298 if (atomicCaptureOp)
299 firOpBuilder.setInsertionPoint(atomicCaptureOp);
300 mlir::Value nonAtomicVal;
301 for (auto *nonAtomicSubExpr : nonAtomicSubExprs) {
302 nonAtomicVal = fir::getBase(converter.genExprValue(
303 currentLocation, *nonAtomicSubExpr, nonAtomicStmtCtx));
304 exprValueOverrides.try_emplace(nonAtomicSubExpr, nonAtomicVal);
305 }
306 if (atomicCaptureOp)
307 firOpBuilder.restoreInsertionPoint(insertionPoint);
308 }
309
310 mlir::Operation *atomicUpdateOp = nullptr;
311 if constexpr (std::is_same<AtomicListT,
312 Fortran::parser::OmpAtomicClauseList>()) {
313 // If no hint clause is specified, the effect is as if
314 // hint(omp_sync_hint_none) had been specified.
315 mlir::IntegerAttr hint = nullptr;
316 mlir::omp::ClauseMemoryOrderKindAttr memoryOrder = nullptr;
317 if (leftHandClauseList)
318 genOmpAtomicHintAndMemoryOrderClauses(converter, *leftHandClauseList,
319 hint, memoryOrder);
320 if (rightHandClauseList)
321 genOmpAtomicHintAndMemoryOrderClauses(converter, *rightHandClauseList,
322 hint, memoryOrder);
323 atomicUpdateOp = firOpBuilder.create<mlir::omp::AtomicUpdateOp>(
324 currentLocation, lhsAddr, hint, memoryOrder);
325 } else {
326 atomicUpdateOp = firOpBuilder.create<mlir::acc::AtomicUpdateOp>(
327 currentLocation, lhsAddr);
328 }
329
330 processOmpAtomicTODO<AtomicListT>(varType, loc);
331
332 llvm::SmallVector<mlir::Type> varTys = {varType};
333 llvm::SmallVector<mlir::Location> locs = {currentLocation};
334 firOpBuilder.createBlock(&atomicUpdateOp->getRegion(0), {}, varTys, locs);
335 mlir::Value val =
336 fir::getBase(atomicUpdateOp->getRegion(0).front().getArgument(0));
337
338 exprValueOverrides.try_emplace(
339 Fortran::semantics::GetExpr(assignmentStmtVariable), val);
340 {
341 // statement context inside the atomic block.
342 converter.overrideExprValues(&exprValueOverrides);
343 Fortran::lower::StatementContext atomicStmtCtx;
344 mlir::Value rhsExpr = fir::getBase(converter.genExprValue(
345 *Fortran::semantics::GetExpr(assignmentStmtExpr), atomicStmtCtx));
346 mlir::Value convertResult =
347 firOpBuilder.createConvert(currentLocation, varType, rhsExpr);
348 if constexpr (std::is_same<AtomicListT,
349 Fortran::parser::OmpAtomicClauseList>()) {
350 firOpBuilder.create<mlir::omp::YieldOp>(currentLocation, convertResult);
351 } else {
352 firOpBuilder.create<mlir::acc::YieldOp>(currentLocation, convertResult);
353 }
354 converter.resetExprOverrides();
355 }
356 firOpBuilder.setInsertionPointAfter(atomicUpdateOp);
357}
358
360template <typename AtomicT, typename AtomicListT>
361void genOmpAccAtomicWrite(Fortran::lower::AbstractConverter &converter,
362 const AtomicT &atomicWrite, mlir::Location loc) {
363 const AtomicListT *rightHandClauseList = nullptr;
364 const AtomicListT *leftHandClauseList = nullptr;
365 if constexpr (std::is_same<AtomicListT,
366 Fortran::parser::OmpAtomicClauseList>()) {
367 // Get the address of atomic read operands.
368 rightHandClauseList = &std::get<2>(atomicWrite.t);
369 leftHandClauseList = &std::get<0>(atomicWrite.t);
370 }
371
372 const Fortran::parser::AssignmentStmt &stmt =
373 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
374 atomicWrite.t)
375 .statement;
376 const Fortran::evaluate::Assignment &assign = *stmt.typedAssignment->v;
377 Fortran::lower::StatementContext stmtCtx;
378 // Get the value and address of atomic write operands.
379 mlir::Value rhsExpr =
380 fir::getBase(converter.genExprValue(assign.rhs, stmtCtx));
381 mlir::Value lhsAddr =
382 fir::getBase(converter.genExprAddr(assign.lhs, stmtCtx));
383 genOmpAccAtomicWriteStatement(converter, lhsAddr, rhsExpr, leftHandClauseList,
384 rightHandClauseList, loc);
385}
386
388template <typename AtomicT, typename AtomicListT>
389void genOmpAccAtomicRead(Fortran::lower::AbstractConverter &converter,
390 const AtomicT &atomicRead, mlir::Location loc) {
391 const AtomicListT *rightHandClauseList = nullptr;
392 const AtomicListT *leftHandClauseList = nullptr;
393 if constexpr (std::is_same<AtomicListT,
394 Fortran::parser::OmpAtomicClauseList>()) {
395 // Get the address of atomic read operands.
396 rightHandClauseList = &std::get<2>(atomicRead.t);
397 leftHandClauseList = &std::get<0>(atomicRead.t);
398 }
399
400 const auto &assignmentStmtExpr = std::get<Fortran::parser::Expr>(
401 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
402 atomicRead.t)
403 .statement.t);
404 const auto &assignmentStmtVariable = std::get<Fortran::parser::Variable>(
405 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
406 atomicRead.t)
407 .statement.t);
408
409 Fortran::lower::StatementContext stmtCtx;
410 const Fortran::semantics::SomeExpr &fromExpr =
411 *Fortran::semantics::GetExpr(assignmentStmtExpr);
412 mlir::Type elementType = converter.genType(fromExpr);
413 mlir::Value fromAddress =
414 fir::getBase(converter.genExprAddr(fromExpr, stmtCtx));
415 mlir::Value toAddress = fir::getBase(converter.genExprAddr(
416 *Fortran::semantics::GetExpr(assignmentStmtVariable), stmtCtx));
417 genOmpAccAtomicCaptureStatement(converter, fromAddress, toAddress,
418 leftHandClauseList, rightHandClauseList,
419 elementType, loc);
420}
421
423template <typename AtomicT, typename AtomicListT>
424void genOmpAccAtomicUpdate(Fortran::lower::AbstractConverter &converter,
425 const AtomicT &atomicUpdate, mlir::Location loc) {
426 const AtomicListT *rightHandClauseList = nullptr;
427 const AtomicListT *leftHandClauseList = nullptr;
428 if constexpr (std::is_same<AtomicListT,
429 Fortran::parser::OmpAtomicClauseList>()) {
430 // Get the address of atomic read operands.
431 rightHandClauseList = &std::get<2>(atomicUpdate.t);
432 leftHandClauseList = &std::get<0>(atomicUpdate.t);
433 }
434
435 const auto &assignmentStmtExpr = std::get<Fortran::parser::Expr>(
436 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
437 atomicUpdate.t)
438 .statement.t);
439 const auto &assignmentStmtVariable = std::get<Fortran::parser::Variable>(
440 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
441 atomicUpdate.t)
442 .statement.t);
443
444 Fortran::lower::StatementContext stmtCtx;
445 mlir::Value lhsAddr = fir::getBase(converter.genExprAddr(
446 *Fortran::semantics::GetExpr(assignmentStmtVariable), stmtCtx));
447 mlir::Type varType = fir::unwrapRefType(lhsAddr.getType());
448 genOmpAccAtomicUpdateStatement<AtomicListT>(
449 converter, lhsAddr, varType, assignmentStmtVariable, assignmentStmtExpr,
450 leftHandClauseList, rightHandClauseList, loc);
451}
452
454template <typename AtomicT, typename AtomicListT>
455void genOmpAtomic(Fortran::lower::AbstractConverter &converter,
456 const AtomicT &atomicConstruct, mlir::Location loc) {
457 const AtomicListT &atomicClauseList =
458 std::get<AtomicListT>(atomicConstruct.t);
459 const auto &assignmentStmtExpr = std::get<Fortran::parser::Expr>(
460 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
461 atomicConstruct.t)
462 .statement.t);
463 const auto &assignmentStmtVariable = std::get<Fortran::parser::Variable>(
464 std::get<Fortran::parser::Statement<Fortran::parser::AssignmentStmt>>(
465 atomicConstruct.t)
466 .statement.t);
467 Fortran::lower::StatementContext stmtCtx;
468 mlir::Value lhsAddr = fir::getBase(converter.genExprAddr(
469 *Fortran::semantics::GetExpr(assignmentStmtVariable), stmtCtx));
470 mlir::Type varType = fir::unwrapRefType(lhsAddr.getType());
471 // If atomic-clause is not present on the construct, the behaviour is as if
472 // the update clause is specified (for both OpenMP and OpenACC).
473 genOmpAccAtomicUpdateStatement<AtomicListT>(
474 converter, lhsAddr, varType, assignmentStmtVariable, assignmentStmtExpr,
475 &atomicClauseList, nullptr, loc);
476}
477
479template <typename AtomicT, typename AtomicListT>
480void genOmpAccAtomicCapture(Fortran::lower::AbstractConverter &converter,
481 const AtomicT &atomicCapture, mlir::Location loc) {
482 fir::FirOpBuilder &firOpBuilder = converter.getFirOpBuilder();
483
484 const Fortran::parser::AssignmentStmt &stmt1 =
485 std::get<typename AtomicT::Stmt1>(atomicCapture.t).v.statement;
486 const Fortran::evaluate::Assignment &assign1 = *stmt1.typedAssignment->v;
487 const auto &stmt1Var{std::get<Fortran::parser::Variable>(stmt1.t)};
488 const auto &stmt1Expr{std::get<Fortran::parser::Expr>(stmt1.t)};
489 const Fortran::parser::AssignmentStmt &stmt2 =
490 std::get<typename AtomicT::Stmt2>(atomicCapture.t).v.statement;
491 const Fortran::evaluate::Assignment &assign2 = *stmt2.typedAssignment->v;
492 const auto &stmt2Var{std::get<Fortran::parser::Variable>(stmt2.t)};
493 const auto &stmt2Expr{std::get<Fortran::parser::Expr>(stmt2.t)};
494
495 // Pre-evaluate expressions to be used in the various operations inside
496 // `atomic.capture` since it is not desirable to have anything other than
497 // a `atomic.read`, `atomic.write`, or `atomic.update` operation
498 // inside `atomic.capture`
499 Fortran::lower::StatementContext stmtCtx;
500 // LHS evaluations are common to all combinations of `atomic.capture`
501 mlir::Value stmt1LHSArg =
502 fir::getBase(converter.genExprAddr(assign1.lhs, stmtCtx));
503 mlir::Value stmt2LHSArg =
504 fir::getBase(converter.genExprAddr(assign2.lhs, stmtCtx));
505
506 // Type information used in generation of `atomic.update` operation
507 mlir::Type stmt1VarType =
508 fir::getBase(converter.genExprValue(assign1.lhs, stmtCtx)).getType();
509 mlir::Type stmt2VarType =
510 fir::getBase(converter.genExprValue(assign2.lhs, stmtCtx)).getType();
511
512 mlir::Operation *atomicCaptureOp = nullptr;
513 if constexpr (std::is_same<AtomicListT,
514 Fortran::parser::OmpAtomicClauseList>()) {
515 mlir::IntegerAttr hint = nullptr;
516 mlir::omp::ClauseMemoryOrderKindAttr memoryOrder = nullptr;
517 const AtomicListT &rightHandClauseList = std::get<2>(atomicCapture.t);
518 const AtomicListT &leftHandClauseList = std::get<0>(atomicCapture.t);
519 genOmpAtomicHintAndMemoryOrderClauses(converter, leftHandClauseList, hint,
520 memoryOrder);
521 genOmpAtomicHintAndMemoryOrderClauses(converter, rightHandClauseList, hint,
522 memoryOrder);
523 atomicCaptureOp =
524 firOpBuilder.create<mlir::omp::AtomicCaptureOp>(loc, hint, memoryOrder);
525 } else {
526 atomicCaptureOp = firOpBuilder.create<mlir::acc::AtomicCaptureOp>(loc);
527 }
528
529 firOpBuilder.createBlock(&(atomicCaptureOp->getRegion(0)));
530 mlir::Block &block = atomicCaptureOp->getRegion(0).back();
531 firOpBuilder.setInsertionPointToStart(&block);
532 if (Fortran::semantics::checkForSingleVariableOnRHS(stmt1)) {
533 if (Fortran::semantics::checkForSymbolMatch(stmt2)) {
534 // Atomic capture construct is of the form [capture-stmt, update-stmt]
535 const Fortran::semantics::SomeExpr &fromExpr =
536 *Fortran::semantics::GetExpr(stmt1Expr);
537 mlir::Type elementType = converter.genType(fromExpr);
538 genOmpAccAtomicCaptureStatement<AtomicListT>(
539 converter, stmt2LHSArg, stmt1LHSArg,
540 /*leftHandClauseList=*/nullptr,
541 /*rightHandClauseList=*/nullptr, elementType, loc);
542 genOmpAccAtomicUpdateStatement<AtomicListT>(
543 converter, stmt2LHSArg, stmt2VarType, stmt2Var, stmt2Expr,
544 /*leftHandClauseList=*/nullptr,
545 /*rightHandClauseList=*/nullptr, loc, atomicCaptureOp);
546 } else {
547 // Atomic capture construct is of the form [capture-stmt, write-stmt]
548 firOpBuilder.setInsertionPoint(atomicCaptureOp);
549 mlir::Value stmt2RHSArg =
550 fir::getBase(converter.genExprValue(assign2.rhs, stmtCtx));
551 firOpBuilder.setInsertionPointToStart(&block);
552 const Fortran::semantics::SomeExpr &fromExpr =
553 *Fortran::semantics::GetExpr(stmt1Expr);
554 mlir::Type elementType = converter.genType(fromExpr);
555 genOmpAccAtomicCaptureStatement<AtomicListT>(
556 converter, stmt2LHSArg, stmt1LHSArg,
557 /*leftHandClauseList=*/nullptr,
558 /*rightHandClauseList=*/nullptr, elementType, loc);
559 genOmpAccAtomicWriteStatement<AtomicListT>(
560 converter, stmt2LHSArg, stmt2RHSArg,
561 /*leftHandClauseList=*/nullptr,
562 /*rightHandClauseList=*/nullptr, loc);
563 }
564 } else {
565 // Atomic capture construct is of the form [update-stmt, capture-stmt]
566 const Fortran::semantics::SomeExpr &fromExpr =
567 *Fortran::semantics::GetExpr(stmt2Expr);
568 mlir::Type elementType = converter.genType(fromExpr);
569 genOmpAccAtomicUpdateStatement<AtomicListT>(
570 converter, stmt1LHSArg, stmt1VarType, stmt1Var, stmt1Expr,
571 /*leftHandClauseList=*/nullptr,
572 /*rightHandClauseList=*/nullptr, loc, atomicCaptureOp);
573 genOmpAccAtomicCaptureStatement<AtomicListT>(
574 converter, stmt1LHSArg, stmt2LHSArg,
575 /*leftHandClauseList=*/nullptr,
576 /*rightHandClauseList=*/nullptr, elementType, loc);
577 }
578 firOpBuilder.setInsertionPointToEnd(&block);
579 if constexpr (std::is_same<AtomicListT,
580 Fortran::parser::OmpAtomicClauseList>()) {
581 firOpBuilder.create<mlir::omp::TerminatorOp>(loc);
582 } else {
583 firOpBuilder.create<mlir::acc::TerminatorOp>(loc);
584 }
585 firOpBuilder.setInsertionPointToStart(&block);
586}
587
590template <typename... TerminatorOps>
591void createEmptyRegionBlocks(
592 fir::FirOpBuilder &builder,
593 std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
594 mlir::Region *region = &builder.getRegion();
595 for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
596 if (eval.block) {
597 if (eval.block->empty()) {
598 eval.block->erase();
599 eval.block = builder.createBlock(region);
600 } else {
601 [[maybe_unused]] mlir::Operation &terminatorOp = eval.block->back();
602 assert(mlir::isa<TerminatorOps...>(terminatorOp) &&
603 "expected terminator op");
604 }
605 }
606 if (!eval.isDirective() && eval.hasNestedEvaluations())
607 createEmptyRegionBlocks<TerminatorOps...>(builder,
608 eval.getNestedEvaluations());
609 }
610}
611
612inline AddrAndBoundsInfo getDataOperandBaseAddr(fir::FirOpBuilder &builder,
613 mlir::Value symAddr,
614 bool isOptional,
615 mlir::Location loc) {
616 mlir::Value rawInput = symAddr;
617 if (auto declareOp =
618 mlir::dyn_cast_or_null<hlfir::DeclareOp>(symAddr.getDefiningOp())) {
619 symAddr = declareOp.getResults()[0];
620 rawInput = declareOp.getResults()[1];
621 }
622
623 if (!symAddr)
624 llvm::report_fatal_error("could not retrieve symbol address");
625
626 mlir::Value isPresent;
627 if (isOptional)
628 isPresent =
629 builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), rawInput);
630
631 if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(
632 fir::unwrapRefType(symAddr.getType()))) {
633 if (mlir::isa<fir::RecordType>(boxTy.getEleTy()))
634 TODO(loc, "derived type");
635
636 // In case of a box reference, load it here to get the box value.
637 // This is preferrable because then the same box value can then be used for
638 // all address/dimension retrievals. For Fortran optional though, leave
639 // the load generation for later so it can be done in the appropriate
640 // if branches.
641 if (mlir::isa<fir::ReferenceType>(symAddr.getType()) && !isOptional) {
642 mlir::Value addr = builder.create<fir::LoadOp>(loc, symAddr);
643 return AddrAndBoundsInfo(addr, rawInput, isPresent, boxTy);
644 }
645
646 return AddrAndBoundsInfo(symAddr, rawInput, isPresent, boxTy);
647 }
648 return AddrAndBoundsInfo(symAddr, rawInput, isPresent);
649}
650
651inline AddrAndBoundsInfo
652getDataOperandBaseAddr(Fortran::lower::AbstractConverter &converter,
653 fir::FirOpBuilder &builder,
654 Fortran::lower::SymbolRef sym, mlir::Location loc) {
655 return getDataOperandBaseAddr(builder, converter.getSymbolAddress(sym),
656 Fortran::semantics::IsOptional(sym), loc);
657}
658
659template <typename BoundsOp, typename BoundsType>
660llvm::SmallVector<mlir::Value>
661gatherBoundsOrBoundValues(fir::FirOpBuilder &builder, mlir::Location loc,
662 fir::ExtendedValue dataExv, mlir::Value box,
663 bool collectValuesOnly = false) {
664 assert(box && "box must exist");
665 llvm::SmallVector<mlir::Value> values;
666 mlir::Value byteStride;
667 mlir::Type idxTy = builder.getIndexType();
668 mlir::Type boundTy = builder.getType<BoundsType>();
669 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
670 for (unsigned dim = 0; dim < dataExv.rank(); ++dim) {
671 mlir::Value d = builder.createIntegerConstant(loc, idxTy, dim);
672 mlir::Value baseLb =
673 fir::factory::readLowerBound(builder, loc, dataExv, dim, one);
674 auto dimInfo =
675 builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, d);
676 mlir::Value lb = builder.createIntegerConstant(loc, idxTy, 0);
677 mlir::Value ub =
678 builder.create<mlir::arith::SubIOp>(loc, dimInfo.getExtent(), one);
679 if (dim == 0) // First stride is the element size.
680 byteStride = dimInfo.getByteStride();
681 if (collectValuesOnly) {
682 values.push_back(lb);
683 values.push_back(ub);
684 values.push_back(dimInfo.getExtent());
685 values.push_back(byteStride);
686 values.push_back(baseLb);
687 } else {
688 mlir::Value bound = builder.create<BoundsOp>(
689 loc, boundTy, lb, ub, dimInfo.getExtent(), byteStride, true, baseLb);
690 values.push_back(bound);
691 }
692 // Compute the stride for the next dimension.
693 byteStride = builder.create<mlir::arith::MulIOp>(loc, byteStride,
694 dimInfo.getExtent());
695 }
696 return values;
697}
698
700template <typename BoundsOp, typename BoundsType>
701llvm::SmallVector<mlir::Value>
702genBoundsOpsFromBox(fir::FirOpBuilder &builder, mlir::Location loc,
703 fir::ExtendedValue dataExv,
704 Fortran::lower::AddrAndBoundsInfo &info) {
705 llvm::SmallVector<mlir::Value> bounds;
706 mlir::Type idxTy = builder.getIndexType();
707 mlir::Type boundTy = builder.getType<BoundsType>();
708
709 assert(mlir::isa<fir::BaseBoxType>(info.boxType) &&
710 "expect fir.box or fir.class");
711 assert(fir::unwrapRefType(info.addr.getType()) == info.boxType &&
712 "expected box type consistency");
713
714 if (info.isPresent) {
715 llvm::SmallVector<mlir::Type> resTypes;
716 constexpr unsigned nbValuesPerBound = 5;
717 for (unsigned dim = 0; dim < dataExv.rank() * nbValuesPerBound; ++dim)
718 resTypes.push_back(idxTy);
719
720 mlir::Operation::result_range ifRes =
721 builder.genIfOp(loc, resTypes, info.isPresent, /*withElseRegion=*/true)
722 .genThen([&]() {
723 mlir::Value box =
724 !fir::isBoxAddress(info.addr.getType())
725 ? info.addr
726 : builder.create<fir::LoadOp>(loc, info.addr);
727 llvm::SmallVector<mlir::Value> boundValues =
728 gatherBoundsOrBoundValues<BoundsOp, BoundsType>(
729 builder, loc, dataExv, box,
730 /*collectValuesOnly=*/true);
731 builder.create<fir::ResultOp>(loc, boundValues);
732 })
733 .genElse([&] {
734 // Box is not present. Populate bound values with default values.
735 llvm::SmallVector<mlir::Value> boundValues;
736 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
737 mlir::Value mOne = builder.createMinusOneInteger(loc, idxTy);
738 for (unsigned dim = 0; dim < dataExv.rank(); ++dim) {
739 boundValues.push_back(zero); // lb
740 boundValues.push_back(mOne); // ub
741 boundValues.push_back(zero); // extent
742 boundValues.push_back(zero); // byteStride
743 boundValues.push_back(zero); // baseLb
744 }
745 builder.create<fir::ResultOp>(loc, boundValues);
746 })
747 .getResults();
748 // Create the bound operations outside the if-then-else with the if op
749 // results.
750 for (unsigned i = 0; i < ifRes.size(); i += nbValuesPerBound) {
751 mlir::Value bound = builder.create<BoundsOp>(
752 loc, boundTy, ifRes[i], ifRes[i + 1], ifRes[i + 2], ifRes[i + 3],
753 true, ifRes[i + 4]);
754 bounds.push_back(bound);
755 }
756 } else {
757 mlir::Value box = !fir::isBoxAddress(info.addr.getType())
758 ? info.addr
759 : builder.create<fir::LoadOp>(loc, info.addr);
760 bounds = gatherBoundsOrBoundValues<BoundsOp, BoundsType>(builder, loc,
761 dataExv, box);
762 }
763 return bounds;
764}
765
768template <typename BoundsOp, typename BoundsType>
769llvm::SmallVector<mlir::Value>
770genBaseBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc,
771 fir::ExtendedValue dataExv, bool isAssumedSize) {
772 mlir::Type idxTy = builder.getIndexType();
773 mlir::Type boundTy = builder.getType<BoundsType>();
774 llvm::SmallVector<mlir::Value> bounds;
775
776 if (dataExv.rank() == 0)
777 return bounds;
778
779 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
780 const unsigned rank = dataExv.rank();
781 for (unsigned dim = 0; dim < rank; ++dim) {
782 mlir::Value baseLb =
783 fir::factory::readLowerBound(builder, loc, dataExv, dim, one);
784 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
785 mlir::Value ub;
786 mlir::Value lb = zero;
787 mlir::Value ext = fir::factory::readExtent(builder, loc, dataExv, dim);
788 if (isAssumedSize && dim + 1 == rank) {
789 ext = zero;
790 ub = lb;
791 } else {
792 // ub = extent - 1
793 ub = builder.create<mlir::arith::SubIOp>(loc, ext, one);
794 }
795
796 mlir::Value bound =
797 builder.create<BoundsOp>(loc, boundTy, lb, ub, ext, one, false, baseLb);
798 bounds.push_back(bound);
799 }
800 return bounds;
801}
802
803namespace detail {
804template <typename T> //
805static T &&AsRvalueRef(T &&t) {
806 return std::move(t);
807}
808template <typename T> //
809static T AsRvalueRef(T &t) {
810 return t;
811}
812template <typename T> //
813static T AsRvalueRef(const T &t) {
814 return t;
815}
816
817// Helper class for stripping enclosing parentheses and a conversion that
818// preserves type category. This is used for triplet elements, which are
819// always of type integer(kind=8). The lower/upper bounds are converted to
820// an "index" type, which is 64-bit, so the explicit conversion to kind=8
821// (if present) is not needed. When it's present, though, it causes generated
822// names to contain "int(..., kind=8)".
823struct PeelConvert {
824 template <Fortran::common::TypeCategory Category, int Kind>
825 static Fortran::semantics::MaybeExpr visit_with_category(
826 const Fortran::evaluate::Expr<Fortran::evaluate::Type<Category, Kind>>
827 &expr) {
828 return Fortran::common::visit(
829 [](auto &&s) { return visit_with_category<Category, Kind>(s); },
830 expr.u);
831 }
832 template <Fortran::common::TypeCategory Category, int Kind>
833 static Fortran::semantics::MaybeExpr visit_with_category(
834 const Fortran::evaluate::Convert<Fortran::evaluate::Type<Category, Kind>,
835 Category> &expr) {
836 return AsGenericExpr(AsRvalueRef(expr.left()));
837 }
838 template <Fortran::common::TypeCategory Category, int Kind, typename T>
839 static Fortran::semantics::MaybeExpr visit_with_category(const T &) {
840 return std::nullopt; //
841 }
842 template <Fortran::common::TypeCategory Category, typename T>
843 static Fortran::semantics::MaybeExpr visit_with_category(const T &) {
844 return std::nullopt; //
845 }
846
847 template <Fortran::common::TypeCategory Category>
848 static Fortran::semantics::MaybeExpr
849 visit(const Fortran::evaluate::Expr<Fortran::evaluate::SomeKind<Category>>
850 &expr) {
851 return Fortran::common::visit(
852 [](auto &&s) { return visit_with_category<Category>(s); }, expr.u);
853 }
854 static Fortran::semantics::MaybeExpr
855 visit(const Fortran::evaluate::Expr<Fortran::evaluate::SomeType> &expr) {
856 return Fortran::common::visit([](auto &&s) { return visit(s); }, expr.u);
857 }
858 template <typename T> //
859 static Fortran::semantics::MaybeExpr visit(const T &) {
860 return std::nullopt;
861 }
862};
863
864static inline Fortran::semantics::SomeExpr
865peelOuterConvert(Fortran::semantics::SomeExpr &expr) {
866 if (auto peeled = PeelConvert::visit(expr))
867 return *peeled;
868 return expr;
869}
870} // namespace detail
871
874template <typename BoundsOp, typename BoundsType>
875llvm::SmallVector<mlir::Value>
876genBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc,
877 Fortran::lower::AbstractConverter &converter,
878 Fortran::lower::StatementContext &stmtCtx,
879 const std::vector<Fortran::evaluate::Subscript> &subscripts,
880 std::stringstream &asFortran, fir::ExtendedValue &dataExv,
881 bool dataExvIsAssumedSize, AddrAndBoundsInfo &info,
882 bool treatIndexAsSection = false) {
883 int dimension = 0;
884 mlir::Type idxTy = builder.getIndexType();
885 mlir::Type boundTy = builder.getType<BoundsType>();
886 llvm::SmallVector<mlir::Value> bounds;
887
888 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
889 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
890 const int dataExvRank = static_cast<int>(dataExv.rank());
891 for (const auto &subscript : subscripts) {
892 const auto *triplet{std::get_if<Fortran::evaluate::Triplet>(&subscript.u)};
893 if (triplet || treatIndexAsSection) {
894 if (dimension != 0)
895 asFortran << ',';
896 mlir::Value lbound, ubound, extent;
897 std::optional<std::int64_t> lval, uval;
898 mlir::Value baseLb =
899 fir::factory::readLowerBound(builder, loc, dataExv, dimension, one);
900 bool defaultLb = baseLb == one;
901 mlir::Value stride = one;
902 bool strideInBytes = false;
903
904 if (mlir::isa<fir::BaseBoxType>(
905 fir::unwrapRefType(info.addr.getType()))) {
906 if (info.isPresent) {
907 stride =
908 builder
909 .genIfOp(loc, idxTy, info.isPresent, /*withElseRegion=*/true)
910 .genThen([&]() {
911 mlir::Value box =
912 !fir::isBoxAddress(info.addr.getType())
913 ? info.addr
914 : builder.create<fir::LoadOp>(loc, info.addr);
915 mlir::Value d =
916 builder.createIntegerConstant(loc, idxTy, dimension);
917 auto dimInfo = builder.create<fir::BoxDimsOp>(
918 loc, idxTy, idxTy, idxTy, box, d);
919 builder.create<fir::ResultOp>(loc, dimInfo.getByteStride());
920 })
921 .genElse([&] {
922 mlir::Value zero =
923 builder.createIntegerConstant(loc, idxTy, 0);
924 builder.create<fir::ResultOp>(loc, zero);
925 })
926 .getResults()[0];
927 } else {
928 mlir::Value box = !fir::isBoxAddress(info.addr.getType())
929 ? info.addr
930 : builder.create<fir::LoadOp>(loc, info.addr);
931 mlir::Value d = builder.createIntegerConstant(loc, idxTy, dimension);
932 auto dimInfo =
933 builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, d);
934 stride = dimInfo.getByteStride();
935 }
936 strideInBytes = true;
937 }
938
939 Fortran::semantics::MaybeExpr lower;
940 if (triplet) {
941 lower = Fortran::evaluate::AsGenericExpr(triplet->lower());
942 } else {
943 // Case of IndirectSubscriptIntegerExpr
944 using IndirectSubscriptIntegerExpr =
945 Fortran::evaluate::IndirectSubscriptIntegerExpr;
946 using SubscriptInteger = Fortran::evaluate::SubscriptInteger;
947 Fortran::evaluate::Expr<SubscriptInteger> oneInt =
948 std::get<IndirectSubscriptIntegerExpr>(subscript.u).value();
949 lower = Fortran::evaluate::AsGenericExpr(std::move(oneInt));
950 if (lower->Rank() > 0) {
951 mlir::emitError(
952 loc, "vector subscript cannot be used for an array section");
953 break;
954 }
955 }
956 if (lower) {
957 lval = Fortran::evaluate::ToInt64(*lower);
958 if (lval) {
959 if (defaultLb) {
960 lbound = builder.createIntegerConstant(loc, idxTy, *lval - 1);
961 } else {
962 mlir::Value lb = builder.createIntegerConstant(loc, idxTy, *lval);
963 lbound = builder.create<mlir::arith::SubIOp>(loc, lb, baseLb);
964 }
965 asFortran << *lval;
966 } else {
967 mlir::Value lb =
968 fir::getBase(converter.genExprValue(loc, *lower, stmtCtx));
969 lb = builder.createConvert(loc, baseLb.getType(), lb);
970 lbound = builder.create<mlir::arith::SubIOp>(loc, lb, baseLb);
971 asFortran << detail::peelOuterConvert(*lower).AsFortran();
972 }
973 } else {
974 // If the lower bound is not specified, then the section
975 // starts from offset 0 of the dimension.
976 // Note that the lowerbound in the BoundsOp is always 0-based.
977 lbound = zero;
978 }
979
980 if (!triplet) {
981 // If it is a scalar subscript, then the upper bound
982 // is equal to the lower bound, and the extent is one.
983 ubound = lbound;
984 extent = one;
985 } else {
986 asFortran << ':';
987 Fortran::semantics::MaybeExpr upper =
988 Fortran::evaluate::AsGenericExpr(triplet->upper());
989
990 if (upper) {
991 uval = Fortran::evaluate::ToInt64(*upper);
992 if (uval) {
993 if (defaultLb) {
994 ubound = builder.createIntegerConstant(loc, idxTy, *uval - 1);
995 } else {
996 mlir::Value ub = builder.createIntegerConstant(loc, idxTy, *uval);
997 ubound = builder.create<mlir::arith::SubIOp>(loc, ub, baseLb);
998 }
999 asFortran << *uval;
1000 } else {
1001 mlir::Value ub =
1002 fir::getBase(converter.genExprValue(loc, *upper, stmtCtx));
1003 ub = builder.createConvert(loc, baseLb.getType(), ub);
1004 ubound = builder.create<mlir::arith::SubIOp>(loc, ub, baseLb);
1005 asFortran << detail::peelOuterConvert(*upper).AsFortran();
1006 }
1007 }
1008 if (lower && upper) {
1009 if (lval && uval && *uval < *lval) {
1010 mlir::emitError(loc, "zero sized array section");
1011 break;
1012 } else {
1013 // Stride is mandatory in evaluate::Triplet. Make sure it's 1.
1014 auto val = Fortran::evaluate::ToInt64(triplet->GetStride());
1015 if (!val || *val != 1) {
1016 mlir::emitError(loc, "stride cannot be specified on "
1017 "an array section");
1018 break;
1019 }
1020 }
1021 }
1022
1023 if (info.isPresent && mlir::isa<fir::BaseBoxType>(
1024 fir::unwrapRefType(info.addr.getType()))) {
1025 extent =
1026 builder
1027 .genIfOp(loc, idxTy, info.isPresent, /*withElseRegion=*/true)
1028 .genThen([&]() {
1029 mlir::Value ext = fir::factory::readExtent(
1030 builder, loc, dataExv, dimension);
1031 builder.create<fir::ResultOp>(loc, ext);
1032 })
1033 .genElse([&] {
1034 mlir::Value zero =
1035 builder.createIntegerConstant(loc, idxTy, 0);
1036 builder.create<fir::ResultOp>(loc, zero);
1037 })
1038 .getResults()[0];
1039 } else {
1040 extent = fir::factory::readExtent(builder, loc, dataExv, dimension);
1041 }
1042
1043 if (dataExvIsAssumedSize && dimension + 1 == dataExvRank) {
1044 extent = zero;
1045 if (ubound && lbound) {
1046 mlir::Value diff =
1047 builder.create<mlir::arith::SubIOp>(loc, ubound, lbound);
1048 extent = builder.create<mlir::arith::AddIOp>(loc, diff, one);
1049 }
1050 if (!ubound)
1051 ubound = lbound;
1052 }
1053
1054 if (!ubound) {
1055 // ub = extent - 1
1056 ubound = builder.create<mlir::arith::SubIOp>(loc, extent, one);
1057 }
1058 }
1059 mlir::Value bound = builder.create<BoundsOp>(
1060 loc, boundTy, lbound, ubound, extent, stride, strideInBytes, baseLb);
1061 bounds.push_back(bound);
1062 ++dimension;
1063 }
1064 }
1065 return bounds;
1066}
1067
1068namespace detail {
1069template <typename Ref, typename Expr> //
1070std::optional<Ref> getRef(Expr &&expr) {
1071 if constexpr (std::is_same_v<llvm::remove_cvref_t<Expr>,
1072 Fortran::evaluate::DataRef>) {
1073 if (auto *ref = std::get_if<Ref>(&expr.u))
1074 return *ref;
1075 return std::nullopt;
1076 } else {
1077 auto maybeRef = Fortran::evaluate::ExtractDataRef(expr);
1078 if (!maybeRef || !std::holds_alternative<Ref>(maybeRef->u))
1079 return std::nullopt;
1080 return std::get<Ref>(maybeRef->u);
1081 }
1082}
1083} // namespace detail
1084
1085template <typename BoundsOp, typename BoundsType>
1086AddrAndBoundsInfo gatherDataOperandAddrAndBounds(
1087 Fortran::lower::AbstractConverter &converter, fir::FirOpBuilder &builder,
1088 semantics::SemanticsContext &semaCtx,
1089 Fortran::lower::StatementContext &stmtCtx,
1090 Fortran::semantics::SymbolRef symbol,
1091 const Fortran::semantics::MaybeExpr &maybeDesignator,
1092 mlir::Location operandLocation, std::stringstream &asFortran,
1093 llvm::SmallVector<mlir::Value> &bounds, bool treatIndexAsSection = false) {
1094 using namespace Fortran;
1095
1096 AddrAndBoundsInfo info;
1097
1098 if (!maybeDesignator) {
1099 info = getDataOperandBaseAddr(converter, builder, symbol, operandLocation);
1100 asFortran << symbol->name().ToString();
1101 return info;
1102 }
1103
1104 semantics::SomeExpr designator = *maybeDesignator;
1105
1106 if ((designator.Rank() > 0 || treatIndexAsSection) &&
1107 IsArrayElement(designator)) {
1108 auto arrayRef = detail::getRef<evaluate::ArrayRef>(designator);
1109 // This shouldn't fail after IsArrayElement(designator).
1110 assert(arrayRef && "Expecting ArrayRef");
1111
1112 fir::ExtendedValue dataExv;
1113 bool dataExvIsAssumedSize = false;
1114
1115 auto toMaybeExpr = [&](auto &&base) {
1116 using BaseType = llvm::remove_cvref_t<decltype(base)>;
1117 evaluate::ExpressionAnalyzer ea{semaCtx};
1118
1119 if constexpr (std::is_same_v<evaluate::NamedEntity, BaseType>) {
1120 if (auto *ref = base.UnwrapSymbolRef())
1121 return ea.Designate(evaluate::DataRef{*ref});
1122 if (auto *ref = base.UnwrapComponent())
1123 return ea.Designate(evaluate::DataRef{*ref});
1124 llvm_unreachable("Unexpected NamedEntity");
1125 } else {
1126 static_assert(std::is_same_v<semantics::SymbolRef, BaseType>);
1127 return ea.Designate(evaluate::DataRef{base});
1128 }
1129 };
1130
1131 auto arrayBase = toMaybeExpr(arrayRef->base());
1132 assert(arrayBase);
1133
1134 if (detail::getRef<evaluate::Component>(*arrayBase)) {
1135 dataExv = converter.genExprAddr(operandLocation, *arrayBase, stmtCtx);
1136 info.addr = fir::getBase(dataExv);
1137 info.rawInput = info.addr;
1138 asFortran << arrayBase->AsFortran();
1139 } else {
1140 const semantics::Symbol &sym = arrayRef->GetLastSymbol();
1141 dataExvIsAssumedSize =
1142 Fortran::semantics::IsAssumedSizeArray(sym.GetUltimate());
1143 info = getDataOperandBaseAddr(converter, builder, sym, operandLocation);
1144 dataExv = converter.getSymbolExtendedValue(sym);
1145 asFortran << sym.name().ToString();
1146 }
1147
1148 if (!arrayRef->subscript().empty()) {
1149 asFortran << '(';
1150 bounds = genBoundsOps<BoundsOp, BoundsType>(
1151 builder, operandLocation, converter, stmtCtx, arrayRef->subscript(),
1152 asFortran, dataExv, dataExvIsAssumedSize, info, treatIndexAsSection);
1153 }
1154 asFortran << ')';
1155 } else if (auto compRef = detail::getRef<evaluate::Component>(designator)) {
1156 fir::ExtendedValue compExv =
1157 converter.genExprAddr(operandLocation, designator, stmtCtx);
1158 info.addr = fir::getBase(compExv);
1159 info.rawInput = info.addr;
1160 if (mlir::isa<fir::SequenceType>(fir::unwrapRefType(info.addr.getType())))
1161 bounds = genBaseBoundsOps<BoundsOp, BoundsType>(builder, operandLocation,
1162 compExv,
1163 /*isAssumedSize=*/false);
1164 asFortran << designator.AsFortran();
1165
1166 if (semantics::IsOptional(compRef->GetLastSymbol())) {
1167 info.isPresent = builder.create<fir::IsPresentOp>(
1168 operandLocation, builder.getI1Type(), info.rawInput);
1169 }
1170
1171 if (auto loadOp =
1172 mlir::dyn_cast_or_null<fir::LoadOp>(info.addr.getDefiningOp())) {
1173 if (fir::isAllocatableType(loadOp.getType()) ||
1174 fir::isPointerType(loadOp.getType())) {
1175 info.boxType = info.addr.getType();
1176 info.addr = builder.create<fir::BoxAddrOp>(operandLocation, info.addr);
1177 }
1178 info.rawInput = info.addr;
1179 }
1180
1181 // If the component is an allocatable or pointer the result of
1182 // genExprAddr will be the result of a fir.box_addr operation or
1183 // a fir.box_addr has been inserted just before.
1184 // Retrieve the box so we handle it like other descriptor.
1185 if (auto boxAddrOp =
1186 mlir::dyn_cast_or_null<fir::BoxAddrOp>(info.addr.getDefiningOp())) {
1187 info.addr = boxAddrOp.getVal();
1188 info.boxType = info.addr.getType();
1189 info.rawInput = info.addr;
1190 bounds = genBoundsOpsFromBox<BoundsOp, BoundsType>(
1191 builder, operandLocation, compExv, info);
1192 }
1193 } else {
1194 if (detail::getRef<evaluate::ArrayRef>(designator)) {
1195 fir::ExtendedValue compExv =
1196 converter.genExprAddr(operandLocation, designator, stmtCtx);
1197 info.addr = fir::getBase(compExv);
1198 info.rawInput = info.addr;
1199 asFortran << designator.AsFortran();
1200 } else if (auto symRef = detail::getRef<semantics::SymbolRef>(designator)) {
1201 // Scalar or full array.
1202 fir::ExtendedValue dataExv = converter.getSymbolExtendedValue(*symRef);
1203 info =
1204 getDataOperandBaseAddr(converter, builder, *symRef, operandLocation);
1205 if (mlir::isa<fir::BaseBoxType>(
1206 fir::unwrapRefType(info.addr.getType()))) {
1207 info.boxType = fir::unwrapRefType(info.addr.getType());
1208 bounds = genBoundsOpsFromBox<BoundsOp, BoundsType>(
1209 builder, operandLocation, dataExv, info);
1210 }
1211 bool dataExvIsAssumedSize =
1212 Fortran::semantics::IsAssumedSizeArray(symRef->get().GetUltimate());
1213 if (mlir::isa<fir::SequenceType>(fir::unwrapRefType(info.addr.getType())))
1214 bounds = genBaseBoundsOps<BoundsOp, BoundsType>(
1215 builder, operandLocation, dataExv, dataExvIsAssumedSize);
1216 asFortran << symRef->get().name().ToString();
1217 } else { // Unsupported
1218 llvm::report_fatal_error("Unsupported type of OpenACC operand");
1219 }
1220 }
1221
1222 return info;
1223}
1224
1225template <typename BoundsOp, typename BoundsType>
1226llvm::SmallVector<mlir::Value>
1227genImplicitBoundsOps(fir::FirOpBuilder &builder, lower::AddrAndBoundsInfo &info,
1228 fir::ExtendedValue dataExv, bool dataExvIsAssumedSize,
1229 mlir::Location loc) {
1230 llvm::SmallVector<mlir::Value> bounds;
1231
1232 mlir::Value baseOp = info.rawInput;
1233 if (mlir::isa<fir::BaseBoxType>(fir::unwrapRefType(baseOp.getType())))
1234 bounds = lower::genBoundsOpsFromBox<BoundsOp, BoundsType>(builder, loc,
1235 dataExv, info);
1236 if (mlir::isa<fir::SequenceType>(fir::unwrapRefType(baseOp.getType()))) {
1237 bounds = lower::genBaseBoundsOps<BoundsOp, BoundsType>(
1238 builder, loc, dataExv, dataExvIsAssumedSize);
1239 }
1240
1241 return bounds;
1242}
1243} // namespace lower
1244} // namespace Fortran
1245
1246#endif // FORTRAN_LOWER_DIRECTIVES_COMMON_H
Fortran::common::Indirection< A, true >
Definition: indirection.h:72
Fortran::evaluate::Assignment
Definition: expression.h:878
Fortran::evaluate::ExpressionAnalyzer
Definition: expression.h:102
Fortran::evaluate::Type
Definition: type.h:56
Fortran::lower::AbstractConverter
Definition: AbstractConverter.h:82
Fortran::lower::AbstractConverter::getSymbolAddress
virtual mlir::Value getSymbolAddress(SymbolRef sym)=0
Get the mlir instance of a symbol.
Fortran::lower::AbstractConverter::getCurrentLocation
virtual mlir::Location getCurrentLocation()=0
Get the converter's current location.
Fortran::lower::AbstractConverter::genType
virtual mlir::Type genType(const SomeExpr &)=0
Generate the type of an Expr.
Fortran::lower::AbstractConverter::genExprValue
virtual fir::ExtendedValue genExprValue(const SomeExpr &expr, StatementContext &context, mlir::Location *locPtr=nullptr)=0
Generate the computations of the expression to produce a value.
Fortran::lower::AbstractConverter::overrideExprValues
virtual void overrideExprValues(const ExprToValueMap *)=0
Fortran::lower::AbstractConverter::getFirOpBuilder
virtual fir::FirOpBuilder & getFirOpBuilder()=0
Get the OpBuilder.
Fortran::lower::AbstractConverter::genExprAddr
virtual fir::ExtendedValue genExprAddr(const SomeExpr &expr, StatementContext &context, mlir::Location *locPtr=nullptr)=0
Fortran::lower::StatementContext
Definition: StatementContext.h:46
Fortran::semantics::Symbol
Definition: symbol.h:712
fir::ExtendedValue
Definition: BoxValue.h:478
fir::FirOpBuilder
Definition: FIRBuilder.h:55
fir::FirOpBuilder::createConvert
mlir::Value createConvert(mlir::Location loc, mlir::Type toTy, mlir::Value val)
Lazy creation of fir.convert op.
Definition: FIRBuilder.cpp:511
fir::FirOpBuilder::genIfOp
IfBuilder genIfOp(mlir::Location loc, mlir::TypeRange results, mlir::Value cdt, bool withElseRegion)
Definition: FIRBuilder.h:463
fir::FirOpBuilder::createMinusOneInteger
mlir::Value createMinusOneInteger(mlir::Location loc, mlir::Type integerType)
Definition: FIRBuilder.h:187
fir::FirOpBuilder::getRegion
mlir::Region & getRegion()
Get the current Region of the insertion point.
Definition: FIRBuilder.h:103
fir::FirOpBuilder::createIntegerConstant
mlir::Value createIntegerConstant(mlir::Location loc, mlir::Type integerType, std::int64_t i)
Definition: FIRBuilder.cpp:131
llvm::SmallVector
Definition: OpenACC.h:20
Fortran::lower::genBoundsOpsFromBox
llvm::SmallVector< mlir::Value > genBoundsOpsFromBox(fir::FirOpBuilder &builder, mlir::Location loc, fir::ExtendedValue dataExv, Fortran::lower::AddrAndBoundsInfo &info)
Generate the bounds operation from the descriptor information.
Definition: DirectivesCommon.h:702
Fortran::lower::genBoundsOps
llvm::SmallVector< mlir::Value > genBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc, Fortran::lower::AbstractConverter &converter, Fortran::lower::StatementContext &stmtCtx, const std::vector< Fortran::evaluate::Subscript > &subscripts, std::stringstream &asFortran, fir::ExtendedValue &dataExv, bool dataExvIsAssumedSize, AddrAndBoundsInfo &info, bool treatIndexAsSection=false)
Definition: DirectivesCommon.h:876
Fortran::lower::genOmpAccAtomicRead
void genOmpAccAtomicRead(Fortran::lower::AbstractConverter &converter, const AtomicT &atomicRead, mlir::Location loc)
Processes an atomic construct with read clause.
Definition: DirectivesCommon.h:389
Fortran::lower::genOmpAtomic
void genOmpAtomic(Fortran::lower::AbstractConverter &converter, const AtomicT &atomicConstruct, mlir::Location loc)
Processes an atomic construct with no clause - which implies update clause.
Definition: DirectivesCommon.h:455
Fortran::lower::genBaseBoundsOps
llvm::SmallVector< mlir::Value > genBaseBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc, fir::ExtendedValue dataExv, bool isAssumedSize)
Definition: DirectivesCommon.h:770
Fortran::lower::genOmpAccAtomicUpdate
void genOmpAccAtomicUpdate(Fortran::lower::AbstractConverter &converter, const AtomicT &atomicUpdate, mlir::Location loc)
Processes an atomic construct with update clause.
Definition: DirectivesCommon.h:424
Fortran::lower::createEmptyRegionBlocks
void createEmptyRegionBlocks(fir::FirOpBuilder &builder, std::list< Fortran::lower::pft::Evaluation > &evaluationList)
Definition: DirectivesCommon.h:591
Fortran::lower::genOmpAccAtomicWrite
void genOmpAccAtomicWrite(Fortran::lower::AbstractConverter &converter, const AtomicT &atomicWrite, mlir::Location loc)
Processes an atomic construct with write clause.
Definition: DirectivesCommon.h:361
Fortran::lower::genOmpAccAtomicCapture
void genOmpAccAtomicCapture(Fortran::lower::AbstractConverter &converter, const AtomicT &atomicCapture, mlir::Location loc)
Processes an atomic construct with capture clause.
Definition: DirectivesCommon.h:480
Fortran
Definition: bit-population-count.h:20
fir::isBoxAddress
bool isBoxAddress(mlir::Type t)
Is t an address to fir.box or class type?
Definition: FIRType.h:468
fir::getBase
mlir::Value getBase(const ExtendedValue &exv)
Definition: BoxValue.cpp:21
fir::isPointerType
bool isPointerType(mlir::Type ty)
Definition: FIRType.cpp:272
fir::isAllocatableType
bool isAllocatableType(mlir::Type ty)
Return true iff ty is the type of an ALLOCATABLE entity or value.
Definition: FIRType.cpp:280
fir::isa_trivial
bool isa_trivial(mlir::Type t)
Definition: FIRType.h:195
Fortran::common::visitors
Definition: idioms.h:61
Fortran::evaluate::Convert
Definition: expression.h:211
Fortran::evaluate::DataRef
Definition: variable.h:300
Fortran::evaluate::SomeKind
Definition: type.h:402
Fortran::lower::AddrAndBoundsInfo
Definition: DirectivesCommon.h:54
Fortran::lower::detail::PeelConvert
Definition: DirectivesCommon.h:823
Fortran::lower::pft::Evaluation
Definition: PFTBuilder.h:216
Fortran::parser::AssignmentStmt
Definition: parse-tree.h:2016
Fortran::parser::Expr::IntrinsicBinary
Definition: parse-tree.h:1724
Fortran::parser::Expr
Definition: parse-tree.h:1700
Fortran::parser::OmpAtomicClauseList
Definition: parse-tree.h:4568
Fortran::parser::OmpAtomicClause
Definition: parse-tree.h:4561
Fortran::parser::Statement
Definition: parse-tree.h:355
Fortran::parser::Variable
Definition: parse-tree.h:1865
Generated on Sun Apr 27 2025 15:14:11 for FLANG by doxygen 1.9.6