[flang-commits] [flang] b3eb0e1 - [flang] Lower sum intrinsic
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Tue Mar 8 09:51:08 PST 2022
Author: Valentin Clement
Date: 2022-03-08T18:50:34+01:00
New Revision: b3eb0e113e5f12f4fc88bda8bf5a653b00425f2b
URL: https://github.com/llvm/llvm-project/commit/b3eb0e113e5f12f4fc88bda8bf5a653b00425f2b
DIFF: https://github.com/llvm/llvm-project/commit/b3eb0e113e5f12f4fc88bda8bf5a653b00425f2b.diff
LOG: [flang] Lower sum intrinsic
This patch enables the lowering of the `sum` intrinsic. It adds
also infrastructure to deal with optional arguments in intrinsics and
implied loops.
This patch is part of the upstreaming effort from fir-dev branch.
Reviewed By: PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D121221
Co-authored-by: Eric Schweitz <eschweitz at nvidia.com>
Co-authored-by: Jean Perier <jperier at nvidia.com>
Co-authored-by: mleair <leairmark at gmail.com>
Added:
flang/include/flang/Lower/CustomIntrinsicCall.h
flang/lib/Lower/CustomIntrinsicCall.cpp
flang/test/Lower/Intrinsics/sum.f90
Modified:
flang/include/flang/Lower/AbstractConverter.h
flang/include/flang/Lower/ConvertExpr.h
flang/include/flang/Lower/IntrinsicCall.h
flang/include/flang/Optimizer/Builder/FIRBuilder.h
flang/include/flang/Optimizer/Dialect/FIRType.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/CMakeLists.txt
flang/lib/Lower/ConvertExpr.cpp
flang/lib/Lower/IntrinsicCall.cpp
flang/lib/Optimizer/Builder/FIRBuilder.cpp
flang/lib/Optimizer/Dialect/FIRType.cpp
flang/unittests/Runtime/Time.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h
index a62ce31e43fef..893deb47a8ef6 100644
--- a/flang/include/flang/Lower/AbstractConverter.h
+++ b/flang/include/flang/Lower/AbstractConverter.h
@@ -76,6 +76,9 @@ class AbstractConverter {
/// Get the mlir instance of a symbol.
virtual mlir::Value getSymbolAddress(SymbolRef sym) = 0;
+ /// Get the binding of an implied do variable by name.
+ virtual mlir::Value impliedDoBinding(llvm::StringRef name) = 0;
+
/// Get the label set associated with a symbol.
virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0;
diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h
index f4bdeaa54ef69..7787a97a7b726 100644
--- a/flang/include/flang/Lower/ConvertExpr.h
+++ b/flang/include/flang/Lower/ConvertExpr.h
@@ -140,6 +140,13 @@ void createAllocatableArrayAssignment(AbstractConverter &converter,
SymMap &symMap,
StatementContext &stmtCtx);
+/// Lower an array expression with "parallel" semantics. Such a rhs expression
+/// is fully evaluated prior to being assigned back to a temporary array.
+fir::ExtendedValue createSomeArrayTempValue(AbstractConverter &converter,
+ const SomeExpr &expr,
+ SymMap &symMap,
+ StatementContext &stmtCtx);
+
// Attribute for an alloca that is a trivial adaptor for converting a value to
// pass-by-ref semantics for a VALUE parameter. The optimizer may be able to
// eliminate these.
diff --git a/flang/include/flang/Lower/CustomIntrinsicCall.h b/flang/include/flang/Lower/CustomIntrinsicCall.h
new file mode 100644
index 0000000000000..673c26b168387
--- /dev/null
+++ b/flang/include/flang/Lower/CustomIntrinsicCall.h
@@ -0,0 +1,99 @@
+//===-- Lower/CustomIntrinsicCall.h -----------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+///
+/// Custom intrinsic lowering for the few intrinsic that have optional
+/// arguments that prevents them to be handled in a more generic way in
+/// IntrinsicCall.cpp.
+/// The core principle is that this interface provides the intrinsic arguments
+/// via callbacks to generate fir::ExtendedValue (instead of a list of
+/// precomputed fir::ExtendedValue as done in the default intrinsic call
+/// lowering). This gives more flexibility to only generate references to
+/// dynamically optional arguments (pointers, allocatables, OPTIONAL dummies) in
+/// a safe way.
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_CUSTOMINTRINSICCALL_H
+#define FORTRAN_LOWER_CUSTOMINTRINSICCALL_H
+
+#include "flang/Lower/AbstractConverter.h"
+#include "llvm/ADT/Optional.h"
+#include <functional>
+
+namespace Fortran {
+
+namespace evaluate {
+class ProcedureRef;
+struct SpecificIntrinsic;
+} // namespace evaluate
+
+namespace lower {
+
+/// Does the call \p procRef to \p intrinsic need to be handle via this custom
+/// framework due to optional arguments. Otherwise, the tools from
+/// IntrinsicCall.cpp should be used directly.
+bool intrinsicRequiresCustomOptionalHandling(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ AbstractConverter &converter);
+
+/// Type of callback to be provided to prepare the arguments fetching from an
+/// actual argument expression.
+using OperandPrepare = std::function<void(const Fortran::lower::SomeExpr &)>;
+
+/// Type of the callback to inquire about an argument presence, once the call
+/// preparation was done. An absent optional means the argument is statically
+/// present. An mlir::Value means the presence must be checked at runtime, and
+/// that the value contains the "is present" boolean value.
+using OperandPresent = std::function<llvm::Optional<mlir::Value>(std::size_t)>;
+
+/// Type of the callback to generate an argument reference after the call
+/// preparation was done. For optional arguments, the utility guarantees
+/// these callbacks will only be called in regions where the presence was
+/// verified. This means the getter callback can dereference the argument
+/// without any special care.
+/// For elemental intrinsics, the getter must provide the current iteration
+/// element value.
+using OperandGetter = std::function<fir::ExtendedValue(std::size_t)>;
+
+/// Given a callback \p prepareOptionalArgument to prepare optional
+/// arguments and a callback \p prepareOtherArgument to prepare non-optional
+/// arguments prepare the intrinsic arguments calls.
+/// It is up to the caller to decide what argument preparation means,
+/// the only contract is that it should later allow the caller to provide
+/// callbacks to generate argument reference given an argument index without
+/// any further knowledge of the argument. The function simply visits
+/// the actual arguments, deciding which ones are dynamically optional,
+/// and calling the callbacks accordingly in argument order.
+void prepareCustomIntrinsicArgument(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ llvm::Optional<mlir::Type> retTy,
+ const OperandPrepare &prepareOptionalArgument,
+ const OperandPrepare &prepareOtherArgument, AbstractConverter &converter);
+
+/// Given a callback \p getOperand to generate a reference to the i-th argument,
+/// and a callback \p isPresentCheck to test if an argument is present, this
+/// function lowers the intrinsic calls to \p name whose argument were
+/// previously prepared with prepareCustomIntrinsicArgument. The elemental
+/// aspects must be taken into account by the caller (i.e, the function should
+/// be called during the loop nest generation for elemental intrinsics. It will
+/// not generate any implicit loop nest on its own).
+fir::ExtendedValue
+lowerCustomIntrinsic(fir::FirOpBuilder &builder, mlir::Location loc,
+ llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
+ const OperandPresent &isPresentCheck,
+ const OperandGetter &getOperand, std::size_t numOperands,
+ Fortran::lower::StatementContext &stmtCtx);
+} // namespace lower
+} // namespace Fortran
+
+#endif // FORTRAN_LOWER_CUSTOMINTRINSICCALL_H
diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h
index 78f0fe4a486d6..5778013c98637 100644
--- a/flang/include/flang/Lower/IntrinsicCall.h
+++ b/flang/include/flang/Lower/IntrinsicCall.h
@@ -18,6 +18,8 @@ class ExtendedValue;
namespace Fortran::lower {
+class StatementContext;
+
// TODO: Error handling interface ?
// TODO: Implementation is incomplete. Many intrinsics to tbd.
@@ -27,7 +29,8 @@ namespace Fortran::lower {
fir::ExtendedValue genIntrinsicCall(fir::FirOpBuilder &, mlir::Location,
llvm::StringRef name,
llvm::Optional<mlir::Type> resultType,
- llvm::ArrayRef<fir::ExtendedValue> args);
+ llvm::ArrayRef<fir::ExtendedValue> args,
+ StatementContext &);
/// Enum specifying how intrinsic argument evaluate::Expr should be
/// lowered to fir::ExtendedValue to be passed to genIntrinsicCall.
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index 20d657d9135d2..65b3460a8333c 100644
--- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h
+++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
@@ -420,6 +420,18 @@ llvm::SmallVector<mlir::Value> getExtents(fir::FirOpBuilder &builder,
fir::ExtendedValue readBoxValue(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::BoxValue &box);
+/// Get non default (not all ones) lower bounds of \p exv. Returns empty
+/// vector if the lower bounds are all ones.
+llvm::SmallVector<mlir::Value>
+getNonDefaultLowerBounds(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &exv);
+
+/// Return length parameters associated to \p exv that are not deferred (that
+/// are available without having to read any fir.box values).
+/// Empty if \p exv has no length parameters or if they are all deferred.
+llvm::SmallVector<mlir::Value>
+getNonDeferredLengthParams(const fir::ExtendedValue &exv);
+
//===----------------------------------------------------------------------===//
// String literal helper helpers
//===----------------------------------------------------------------------===//
diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index a0db083415b29..9758ba1686b9c 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -127,6 +127,13 @@ inline bool isa_complex(mlir::Type t) {
/// Is `t` a CHARACTER type? Does not check the length.
inline bool isa_char(mlir::Type t) { return t.isa<fir::CharacterType>(); }
+/// Is `t` a trivial intrinsic type? CHARACTER is <em>excluded</em> because it
+/// is a dependent type.
+inline bool isa_trivial(mlir::Type t) {
+ return isa_integer(t) || isa_real(t) || isa_complex(t) ||
+ t.isa<fir::LogicalType>();
+}
+
/// Is `t` a CHARACTER type with a LEN other than 1?
inline bool isa_char_string(mlir::Type t) {
if (auto ct = t.dyn_cast_or_null<fir::CharacterType>())
@@ -184,6 +191,12 @@ inline bool singleIndirectionLevel(mlir::Type ty) {
}
#endif
+/// Return true iff `ty` is the type of an ALLOCATABLE entity or value.
+bool isAllocatableType(mlir::Type ty);
+
+/// Return true iff `ty` is a RecordType with members that are allocatable.
+bool isRecordWithAllocatableMember(mlir::Type ty);
+
/// Return true iff `ty` is a RecordType with type parameters.
inline bool isRecordWithTypeParameters(mlir::Type ty) {
if (auto recTy = ty.dyn_cast_or_null<fir::RecordType>())
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 9b1215eed168c..8715b7f858d19 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -177,6 +177,13 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return lookupSymbol(sym).getAddr();
}
+ mlir::Value impliedDoBinding(llvm::StringRef name) override final {
+ mlir::Value val = localSymbols.lookupImpliedDo(name);
+ if (!val)
+ fir::emitFatalError(toLocation(), "ac-do-variable has no binding");
+ return val;
+ }
+
bool lookupLabelSet(Fortran::lower::SymbolRef sym,
Fortran::lower::pft::LabelSet &labelSet) override final {
Fortran::lower::pft::FunctionLikeUnit &owningProc =
@@ -818,6 +825,13 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return cond;
}
+ static bool
+ isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
+ return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
+ !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
+ !Fortran::evaluate::HasVectorSubscript(expr);
+ }
+
[[maybe_unused]] static bool
isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
const Fortran::semantics::Symbol *sym =
@@ -1086,6 +1100,15 @@ class FirConverter : public Fortran::lower::AbstractConverter {
TODO(toLocation(), "SelectCaseStmt lowering");
}
+ fir::ExtendedValue
+ genAssociateSelector(const Fortran::lower::SomeExpr &selector,
+ Fortran::lower::StatementContext &stmtCtx) {
+ return isArraySectionWithoutVectorSubscript(selector)
+ ? Fortran::lower::createSomeArrayBox(*this, selector,
+ localSymbols, stmtCtx)
+ : genExprAddr(selector, stmtCtx);
+ }
+
void genFIR(const Fortran::parser::AssociateConstruct &) {
TODO(toLocation(), "AssociateConstruct lowering");
}
@@ -1457,10 +1480,6 @@ class FirConverter : public Fortran::lower::AbstractConverter {
TODO(toLocation(), "EndDoStmt lowering");
}
- void genFIR(const Fortran::parser::EndIfStmt &) {
- TODO(toLocation(), "EndIfStmt lowering");
- }
-
void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {
TODO(toLocation(), "EndMpSubprogramStmt lowering");
}
@@ -1472,6 +1491,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
// Nop statements - No code, or code is generated at the construct level.
void genFIR(const Fortran::parser::ContinueStmt &) {} // nop
void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop
+ void genFIR(const Fortran::parser::EndIfStmt &) {} // nop
void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
void genFIR(const Fortran::parser::EntryStmt &) {
diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt
index 6503c8ac5e03c..638787e800539 100644
--- a/flang/lib/Lower/CMakeLists.txt
+++ b/flang/lib/Lower/CMakeLists.txt
@@ -9,6 +9,7 @@ add_flang_library(FortranLower
ConvertType.cpp
ConvertVariable.cpp
ComponentPath.cpp
+ CustomIntrinsicCall.cpp
DumpEvaluateExpr.cpp
HostAssociations.cpp
IntrinsicCall.cpp
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 4962da97efba3..ffd3b97cecef7 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -18,6 +18,7 @@
#include "flang/Lower/ComponentPath.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
+#include "flang/Lower/CustomIntrinsicCall.h"
#include "flang/Lower/DumpEvaluateExpr.h"
#include "flang/Lower/IntrinsicCall.h"
#include "flang/Lower/StatementContext.h"
@@ -28,12 +29,14 @@
#include "flang/Optimizer/Builder/Factory.h"
#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
#include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "flang/Semantics/type.h"
#include "mlir/Dialect/Func/IR/FuncOps.h"
+#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
#define DEBUG_TYPE "flang-lower-expr"
@@ -49,6 +52,16 @@
// to the correct FIR representation in SSA form.
//===----------------------------------------------------------------------===//
+// The default attempts to balance a modest allocation size with expected user
+// input to minimize bounds checks and reallocations during dynamic array
+// construction. Some user codes may have very large array constructors for
+// which the default can be increased.
+static llvm::cl::opt<unsigned> clInitialBufferSize(
+ "array-constructor-initial-buffer-size",
+ llvm::cl::desc(
+ "set the incremental array construction buffer size (default=32)"),
+ llvm::cl::init(32u));
+
/// The various semantics of a program constituent (or a part thereof) as it may
/// appear in an expression.
///
@@ -159,6 +172,19 @@ translateFloatRelational(Fortran::common::RelationalOperator rop) {
llvm_unreachable("unhandled REAL relational operator");
}
+static mlir::Value genActualIsPresentTest(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ fir::ExtendedValue actual) {
+ if (const auto *ptrOrAlloc = actual.getBoxOf<fir::MutableBoxValue>())
+ return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
+ *ptrOrAlloc);
+ // Optional case (not that optional allocatable/pointer cannot be absent
+ // when passed to CMPLX as per 15.5.2.12 point 3 (7) and (8)). It is
+ // therefore possible to catch them in the `then` case above.
+ return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
+ fir::getBase(actual));
+}
+
/// Place \p exv in memory if it is not already a memory reference. If
/// \p forceValueType is provided, the value is first casted to the provided
/// type before being stored (this is mainly intended for logicals whose value
@@ -186,6 +212,21 @@ placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc,
return fir::substBase(exv, temp);
}
+// Copy a copy of scalar \p exv in a new temporary.
+static fir::ExtendedValue
+createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &exv) {
+ assert(exv.rank() == 0 && "input to scalar memory copy must be a scalar");
+ if (exv.getCharBox() != nullptr)
+ return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(exv);
+ if (fir::isDerivedWithLengthParameters(exv))
+ TODO(loc, "copy derived type with length parameters");
+ mlir::Type type = fir::unwrapPassByRefType(fir::getBase(exv).getType());
+ fir::ExtendedValue temp = builder.createTemporary(loc, type);
+ fir::factory::genScalarAssignment(builder, loc, temp, exv);
+ return temp;
+}
+
/// Is this a variable wrapped in parentheses?
template <typename A>
static bool isParenthesizedVariable(const A &) {
@@ -231,6 +272,76 @@ static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
});
}
+/// Create an optional dummy argument value from entity \p exv that may be
+/// absent. This can only be called with numerical or logical scalar \p exv.
+/// If \p exv is considered absent according to 15.5.2.12 point 1., the returned
+/// value is zero (or false), otherwise it is the value of \p exv.
+static fir::ExtendedValue genOptionalValue(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::ExtendedValue &exv,
+ mlir::Value isPresent) {
+ mlir::Type eleType = fir::getBaseTypeOf(exv);
+ assert(exv.rank() == 0 && fir::isa_trivial(eleType) &&
+ "must be a numerical or logical scalar");
+ return builder
+ .genIfOp(loc, {eleType}, isPresent,
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ mlir::Value val = fir::getBase(genLoad(builder, loc, exv));
+ builder.create<fir::ResultOp>(loc, val);
+ })
+ .genElse([&]() {
+ mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
+ builder.create<fir::ResultOp>(loc, zero);
+ })
+ .getResults()[0];
+}
+
+/// Create an optional dummy argument address from entity \p exv that may be
+/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
+/// returned value is a null pointer, otherwise it is the address of \p exv.
+static fir::ExtendedValue genOptionalAddr(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::ExtendedValue &exv,
+ mlir::Value isPresent) {
+ // If it is an exv pointer/allocatable, then it cannot be absent
+ // because it is passed to a non-pointer/non-allocatable.
+ if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
+ return fir::factory::genMutableBoxRead(builder, loc, *box);
+ // If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL
+ // address and can be passed directly.
+ return exv;
+}
+
+/// Create an optional dummy argument address from entity \p exv that may be
+/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
+/// returned value is an absent fir.box, otherwise it is a fir.box describing \p
+/// exv.
+static fir::ExtendedValue genOptionalBox(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::ExtendedValue &exv,
+ mlir::Value isPresent) {
+ // Non allocatable/pointer optional box -> simply forward
+ if (exv.getBoxOf<fir::BoxValue>())
+ return exv;
+
+ fir::ExtendedValue newExv = exv;
+ // Optional allocatable/pointer -> Cannot be absent, but need to translate
+ // unallocated/diassociated into absent fir.box.
+ if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
+ newExv = fir::factory::genMutableBoxRead(builder, loc, *box);
+
+ // createBox will not do create any invalid memory dereferences if exv is
+ // absent. The created fir.box will not be usable, but the SelectOp below
+ // ensures it won't be.
+ mlir::Value box = builder.createBox(loc, newExv);
+ mlir::Type boxType = box.getType();
+ auto absent = builder.create<fir::AbsentOp>(loc, boxType);
+ auto boxOrAbsent = builder.create<mlir::arith::SelectOp>(
+ loc, boxType, isPresent, box, absent);
+ return fir::BoxValue(boxOrAbsent);
+}
+
/// Is this a call to an elemental procedure with at least one array argument?
static bool
isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
@@ -290,8 +401,8 @@ class ScalarExprLowering {
Fortran::lower::StatementContext &stmtCtx,
InitializerData *initializer = nullptr)
: location{loc}, converter{converter},
- builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} {
- }
+ builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap},
+ inInitializer{initializer} {}
ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) {
return gen(expr);
@@ -474,11 +585,36 @@ class ScalarExprLowering {
/// Lowering of an <i>ac-do-variable</i>, which is not a Symbol.
ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) {
- TODO(getLoc(), "genval ImpliedDoIndex");
+ return converter.impliedDoBinding(toStringRef(var.name));
}
ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
- TODO(getLoc(), "genval DescriptorInquiry");
+ ExtValue exv = desc.base().IsSymbol() ? gen(desc.base().GetLastSymbol())
+ : gen(desc.base().GetComponent());
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Location loc = getLoc();
+ auto castResult = [&](mlir::Value v) {
+ using ResTy = Fortran::evaluate::DescriptorInquiry::Result;
+ return builder.createConvert(
+ loc, converter.genType(ResTy::category, ResTy::kind), v);
+ };
+ switch (desc.field()) {
+ case Fortran::evaluate::DescriptorInquiry::Field::Len:
+ return castResult(fir::factory::readCharLen(builder, loc, exv));
+ case Fortran::evaluate::DescriptorInquiry::Field::LowerBound:
+ return castResult(fir::factory::readLowerBound(
+ builder, loc, exv, desc.dimension(),
+ builder.createIntegerConstant(loc, idxTy, 1)));
+ case Fortran::evaluate::DescriptorInquiry::Field::Extent:
+ return castResult(
+ fir::factory::readExtent(builder, loc, exv, desc.dimension()));
+ case Fortran::evaluate::DescriptorInquiry::Field::Rank:
+ TODO(loc, "rank inquiry on assumed rank");
+ case Fortran::evaluate::DescriptorInquiry::Field::Stride:
+ // So far the front end does not generate this inquiry.
+ TODO(loc, "Stride inquiry");
+ }
+ llvm_unreachable("unknown descriptor inquiry");
}
ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) {
@@ -1031,7 +1167,13 @@ class ScalarExprLowering {
/// value. This is required for lowering expressions such as `f1(f2(v))`.
template <typename A>
ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
- TODO(getLoc(), "gen FunctionRef<A>");
+ ExtValue retVal = genFunctionRef(funcRef);
+ mlir::Value retValBase = fir::getBase(retVal);
+ if (fir::conformsWithPassByRef(retValBase.getType()))
+ return retVal;
+ auto mem = builder.create<fir::AllocaOp>(getLoc(), retValBase.getType());
+ builder.create<fir::StoreOp>(getLoc(), retValBase, mem);
+ return fir::substBase(retVal, mem.getResult());
}
/// helper to detect statement functions
@@ -1088,6 +1230,43 @@ class ScalarExprLowering {
llvm_unreachable("anyFuncArgsHaveAttr failed");
}
+ /// Create a contiguous temporary array with the same shape,
+ /// length parameters and type as mold. It is up to the caller to deallocate
+ /// the temporary.
+ ExtValue genArrayTempFromMold(const ExtValue &mold,
+ llvm::StringRef tempName) {
+ mlir::Type type = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(mold).getType());
+ assert(type && "expected descriptor or memory type");
+ mlir::Location loc = getLoc();
+ llvm::SmallVector<mlir::Value> extents =
+ fir::factory::getExtents(builder, loc, mold);
+ llvm::SmallVector<mlir::Value> allocMemTypeParams =
+ fir::getTypeParams(mold);
+ mlir::Value charLen;
+ mlir::Type elementType = fir::unwrapSequenceType(type);
+ if (auto charType = elementType.dyn_cast<fir::CharacterType>()) {
+ charLen = allocMemTypeParams.empty()
+ ? fir::factory::readCharLen(builder, loc, mold)
+ : allocMemTypeParams[0];
+ if (charType.hasDynamicLen() && allocMemTypeParams.empty())
+ allocMemTypeParams.push_back(charLen);
+ } else if (fir::hasDynamicSize(elementType)) {
+ TODO(loc, "Creating temporary for derived type with length parameters");
+ }
+
+ mlir::Value temp = builder.create<fir::AllocMemOp>(
+ loc, type, tempName, allocMemTypeParams, extents);
+ if (fir::unwrapSequenceType(type).isa<fir::CharacterType>())
+ return fir::CharArrayBoxValue{temp, charLen, extents};
+ return fir::ArrayBoxValue{temp, extents};
+ }
+
+ /// Copy \p source array into \p dest array. Both arrays must be
+ /// conforming, but neither array must be contiguous.
+ void genArrayCopy(ExtValue dest, ExtValue source) {
+ return createSomeArrayAssignment(converter, dest, source, symMap, stmtCtx);
+ }
+
/// Lower a non-elemental procedure reference and read allocatable and pointer
/// results into normal values.
ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
@@ -1420,6 +1599,48 @@ class ScalarExprLowering {
return exv;
}
+ /// Generate a contiguous temp to pass \p actualArg as argument \p arg. The
+ /// creation of the temp and copy-in can be made conditional at runtime by
+ /// providing a runtime boolean flag \p restrictCopyAtRuntime (in which case
+ /// the temp and copy will only be made if the value is true at runtime).
+ ExtValue genCopyIn(const ExtValue &actualArg,
+ const Fortran::lower::CallerInterface::PassedEntity &arg,
+ CopyOutPairs ©OutPairs,
+ llvm::Optional<mlir::Value> restrictCopyAtRuntime) {
+ if (!restrictCopyAtRuntime) {
+ ExtValue temp = genArrayTempFromMold(actualArg, ".copyinout");
+ if (arg.mayBeReadByCall())
+ genArrayCopy(temp, actualArg);
+ copyOutPairs.emplace_back(CopyOutPair{
+ actualArg, temp, arg.mayBeModifiedByCall(), restrictCopyAtRuntime});
+ return temp;
+ }
+ // Otherwise, need to be careful to only copy-in if allowed at runtime.
+ mlir::Location loc = getLoc();
+ auto addrType = fir::HeapType::get(
+ fir::unwrapPassByRefType(fir::getBase(actualArg).getType()));
+ mlir::Value addr =
+ builder
+ .genIfOp(loc, {addrType}, *restrictCopyAtRuntime,
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ auto temp = genArrayTempFromMold(actualArg, ".copyinout");
+ if (arg.mayBeReadByCall())
+ genArrayCopy(temp, actualArg);
+ builder.create<fir::ResultOp>(loc, fir::getBase(temp));
+ })
+ .genElse([&]() {
+ auto nullPtr = builder.createNullConstant(loc, addrType);
+ builder.create<fir::ResultOp>(loc, nullPtr);
+ })
+ .getResults()[0];
+ // Associate the temp address with actualArg lengths and extents.
+ fir::ExtendedValue temp = fir::substBase(readIfBoxValue(actualArg), addr);
+ copyOutPairs.emplace_back(CopyOutPair{
+ actualArg, temp, arg.mayBeModifiedByCall(), restrictCopyAtRuntime});
+ return temp;
+ }
+
/// Lower a non-elemental procedure reference.
ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
llvm::Optional<mlir::Type> resultType) {
@@ -1498,6 +1719,9 @@ class ScalarExprLowering {
}
const bool actualArgIsVariable = Fortran::evaluate::IsVariable(*expr);
if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) {
+ const bool actualIsSimplyContiguous =
+ !actualArgIsVariable || Fortran::evaluate::IsSimplyContiguous(
+ *expr, converter.getFoldingContext());
auto argAddr = [&]() -> ExtValue {
ExtValue baseAddr;
if (actualArgIsVariable && arg.isOptional()) {
@@ -1515,7 +1739,13 @@ class ScalarExprLowering {
// copied-in/copied-out without any care if needed.
}
if (actualArgIsVariable && expr->Rank() > 0) {
- TODO(loc, "procedureref arrays");
+ ExtValue box = genBoxArg(*expr);
+ if (!actualIsSimplyContiguous)
+ return genCopyIn(box, arg, copyOutPairs,
+ /*restrictCopyAtRuntime=*/llvm::None);
+ // Contiguous: just use the box we created above!
+ // This gets "unboxed" below, if needed.
+ return box;
}
// Actual argument is a non optional/non pointer/non allocatable
// scalar.
@@ -1615,6 +1845,27 @@ class ScalarExprLowering {
return genProcedureRef(procRef, resTy);
}
+ /// Helper to lower intrinsic arguments for inquiry intrinsic.
+ ExtValue
+ lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
+ if (Fortran::evaluate::IsAllocatableOrPointerObject(
+ expr, converter.getFoldingContext()))
+ return genMutableBoxValue(expr);
+ return gen(expr);
+ }
+
+ /// Helper to lower intrinsic arguments to a fir::BoxValue.
+ /// It preserves all the non default lower bounds/non deferred length
+ /// parameter information.
+ ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
+ mlir::Location loc = getLoc();
+ ExtValue exv = genBoxArg(expr);
+ mlir::Value box = builder.createBox(loc, exv);
+ return fir::BoxValue(
+ box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
+ fir::factory::getNonDeferredLengthParams(exv));
+ }
+
/// Generate a call to an intrinsic function.
ExtValue
genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef,
@@ -1645,32 +1896,57 @@ class ScalarExprLowering {
Fortran::lower::ArgLoweringRule argRules =
Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering,
dummy.name);
+ if (argRules.handleDynamicOptional &&
+ Fortran::evaluate::MayBePassedAsAbsentOptional(
+ *expr, converter.getFoldingContext())) {
+ ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
+ mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
+ switch (argRules.lowerAs) {
+ case Fortran::lower::LowerIntrinsicArgAs::Value:
+ operands.emplace_back(
+ genOptionalValue(builder, loc, optional, isPresent));
+ continue;
+ case Fortran::lower::LowerIntrinsicArgAs::Addr:
+ operands.emplace_back(
+ genOptionalAddr(builder, loc, optional, isPresent));
+ continue;
+ case Fortran::lower::LowerIntrinsicArgAs::Box:
+ operands.emplace_back(
+ genOptionalBox(builder, loc, optional, isPresent));
+ continue;
+ case Fortran::lower::LowerIntrinsicArgAs::Inquired:
+ operands.emplace_back(optional);
+ continue;
+ }
+ llvm_unreachable("bad switch");
+ }
switch (argRules.lowerAs) {
case Fortran::lower::LowerIntrinsicArgAs::Value:
operands.emplace_back(genval(*expr));
continue;
case Fortran::lower::LowerIntrinsicArgAs::Addr:
- TODO(getLoc(), "argument lowering for Addr");
+ operands.emplace_back(gen(*expr));
continue;
case Fortran::lower::LowerIntrinsicArgAs::Box:
- TODO(getLoc(), "argument lowering for Box");
+ operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr));
continue;
case Fortran::lower::LowerIntrinsicArgAs::Inquired:
- TODO(getLoc(), "argument lowering for Inquired");
+ operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr));
continue;
}
llvm_unreachable("bad switch");
}
// Let the intrinsic library lower the intrinsic procedure call
return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType,
- operands);
+ operands, stmtCtx);
}
template <typename A>
ExtValue genval(const Fortran::evaluate::Expr<A> &x) {
- if (isScalar(x))
+ if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) ||
+ inInitializer)
return std::visit([&](const auto &e) { return genval(e); }, x.u);
- TODO(getLoc(), "genval Expr<A> arrays");
+ return asArray(x);
}
/// Helper to detect Transformational function reference.
@@ -1705,6 +1981,12 @@ class ScalarExprLowering {
return x.Rank() == 0;
}
+ template <typename A>
+ ExtValue asArray(const A &x) {
+ return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x),
+ symMap, stmtCtx);
+ }
+
template <int KIND>
ExtValue genval(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Logical, KIND>> &exp) {
@@ -1746,6 +2028,7 @@ class ScalarExprLowering {
fir::FirOpBuilder &builder;
Fortran::lower::StatementContext &stmtCtx;
Fortran::lower::SymMap &symMap;
+ InitializerData *inInitializer = nullptr;
bool useBoxArg = false; // expression lowered as argument
};
} // namespace
@@ -2251,12 +2534,33 @@ class ArrayExprLowering {
return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.gen(x);
}
+ /// Lower an expression without dereferencing any indirection that may be
+ /// a nullptr (because this is an absent optional or unallocated/disassociated
+ /// descriptor). The returned expression cannot be addressed directly, it is
+ /// meant to inquire about its status before addressing the related entity.
+ template <typename A>
+ ExtValue asInquired(const A &x) {
+ return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}
+ .lowerIntrinsicArgumentAsInquired(x);
+ }
+
// An expression with non-zero rank is an array expression.
template <typename A>
bool isArray(const A &x) const {
return x.Rank() != 0;
}
+ /// Some temporaries are allocated on an element-by-element basis during the
+ /// array expression evaluation. Collect the cleanups here so the resources
+ /// can be freed before the next loop iteration, avoiding memory leaks. etc.
+ Fortran::lower::StatementContext &getElementCtx() {
+ if (!elementCtx) {
+ stmtCtx.pushScope();
+ elementCtx = true;
+ }
+ return stmtCtx;
+ }
+
/// If there were temporaries created for this element evaluation, finalize
/// and deallocate the resources now. This should be done just prior the the
/// fir::ResultOp at the end of the innermost loop.
@@ -2267,6 +2571,207 @@ class ArrayExprLowering {
}
}
+ /// Lower an elemental function array argument. This ensures array
+ /// sub-expressions that are not variables and must be passed by address
+ /// are lowered by value and placed in memory.
+ template <typename A>
+ CC genElementalArgument(const A &x) {
+ // Ensure the returned element is in memory if this is what was requested.
+ if ((semant == ConstituentSemantics::RefOpaque ||
+ semant == ConstituentSemantics::DataAddr ||
+ semant == ConstituentSemantics::ByValueArg)) {
+ if (!Fortran::evaluate::IsVariable(x)) {
+ PushSemantics(ConstituentSemantics::DataValue);
+ CC cc = genarr(x);
+ mlir::Location loc = getLoc();
+ if (isParenthesizedVariable(x)) {
+ // Parenthesised variables are lowered to a reference to the variable
+ // storage. When passing it as an argument, a copy must be passed.
+ return [=](IterSpace iters) -> ExtValue {
+ return createInMemoryScalarCopy(builder, loc, cc(iters));
+ };
+ }
+ mlir::Type storageType =
+ fir::unwrapSequenceType(converter.genType(toEvExpr(x)));
+ return [=](IterSpace iters) -> ExtValue {
+ return placeScalarValueInMemory(builder, loc, cc(iters), storageType);
+ };
+ }
+ }
+ return genarr(x);
+ }
+
+ // A procedure reference to a Fortran elemental intrinsic procedure.
+ CC genElementalIntrinsicProcRef(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ llvm::Optional<mlir::Type> retTy,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic) {
+ llvm::SmallVector<CC> operands;
+ llvm::StringRef name = intrinsic.name;
+ const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering =
+ Fortran::lower::getIntrinsicArgumentLowering(name);
+ mlir::Location loc = getLoc();
+ if (Fortran::lower::intrinsicRequiresCustomOptionalHandling(
+ procRef, intrinsic, converter)) {
+ using CcPairT = std::pair<CC, llvm::Optional<mlir::Value>>;
+ llvm::SmallVector<CcPairT> operands;
+ auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
+ if (expr.Rank() == 0) {
+ ExtValue optionalArg = this->asInquired(expr);
+ mlir::Value isPresent =
+ genActualIsPresentTest(builder, loc, optionalArg);
+ operands.emplace_back(
+ [=](IterSpace iters) -> ExtValue {
+ return genLoad(builder, loc, optionalArg);
+ },
+ isPresent);
+ } else {
+ auto [cc, isPresent, _] = this->genOptionalArrayFetch(expr);
+ operands.emplace_back(cc, isPresent);
+ }
+ };
+ auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) {
+ PushSemantics(ConstituentSemantics::RefTransparent);
+ operands.emplace_back(genElementalArgument(expr), llvm::None);
+ };
+ Fortran::lower::prepareCustomIntrinsicArgument(
+ procRef, intrinsic, retTy, prepareOptionalArg, prepareOtherArg,
+ converter);
+
+ fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
+ llvm::StringRef name = intrinsic.name;
+ return [=](IterSpace iters) -> ExtValue {
+ auto getArgument = [&](std::size_t i) -> ExtValue {
+ return operands[i].first(iters);
+ };
+ auto isPresent = [&](std::size_t i) -> llvm::Optional<mlir::Value> {
+ return operands[i].second;
+ };
+ return Fortran::lower::lowerCustomIntrinsic(
+ *bldr, loc, name, retTy, isPresent, getArgument, operands.size(),
+ getElementCtx());
+ };
+ }
+ /// Otherwise, pre-lower arguments and use intrinsic lowering utility.
+ for (const auto &[arg, dummy] :
+ llvm::zip(procRef.arguments(),
+ intrinsic.characteristics.value().dummyArguments)) {
+ const auto *expr =
+ Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
+ if (!expr) {
+ // Absent optional.
+ operands.emplace_back([=](IterSpace) { return mlir::Value{}; });
+ } else if (!argLowering) {
+ // No argument lowering instruction, lower by value.
+ PushSemantics(ConstituentSemantics::RefTransparent);
+ operands.emplace_back(genElementalArgument(*expr));
+ } else {
+ // Ad-hoc argument lowering handling.
+ Fortran::lower::ArgLoweringRule argRules =
+ Fortran::lower::lowerIntrinsicArgumentAs(getLoc(), *argLowering,
+ dummy.name);
+ if (argRules.handleDynamicOptional &&
+ Fortran::evaluate::MayBePassedAsAbsentOptional(
+ *expr, converter.getFoldingContext())) {
+ // Currently, there is not elemental intrinsic that requires lowering
+ // a potentially absent argument to something else than a value (apart
+ // from character MAX/MIN that are handled elsewhere.)
+ if (argRules.lowerAs != Fortran::lower::LowerIntrinsicArgAs::Value)
+ TODO(loc, "lowering non trivial optional elemental intrinsic array "
+ "argument");
+ PushSemantics(ConstituentSemantics::RefTransparent);
+ operands.emplace_back(genarrForwardOptionalArgumentToCall(*expr));
+ continue;
+ }
+ switch (argRules.lowerAs) {
+ case Fortran::lower::LowerIntrinsicArgAs::Value: {
+ PushSemantics(ConstituentSemantics::RefTransparent);
+ operands.emplace_back(genElementalArgument(*expr));
+ } break;
+ case Fortran::lower::LowerIntrinsicArgAs::Addr: {
+ // Note: assume does not have Fortran VALUE attribute semantics.
+ PushSemantics(ConstituentSemantics::RefOpaque);
+ operands.emplace_back(genElementalArgument(*expr));
+ } break;
+ case Fortran::lower::LowerIntrinsicArgAs::Box: {
+ PushSemantics(ConstituentSemantics::RefOpaque);
+ auto lambda = genElementalArgument(*expr);
+ operands.emplace_back([=](IterSpace iters) {
+ return builder.createBox(loc, lambda(iters));
+ });
+ } break;
+ case Fortran::lower::LowerIntrinsicArgAs::Inquired:
+ TODO(loc, "intrinsic function with inquired argument");
+ break;
+ }
+ }
+ }
+
+ // Let the intrinsic library lower the intrinsic procedure call
+ return [=](IterSpace iters) {
+ llvm::SmallVector<ExtValue> args;
+ for (const auto &cc : operands)
+ args.push_back(cc(iters));
+ return Fortran::lower::genIntrinsicCall(builder, loc, name, retTy, args,
+ getElementCtx());
+ };
+ }
+
+ /// Generate a procedure reference. This code is shared for both functions and
+ /// subroutines, the
diff erence being reflected by `retTy`.
+ CC genProcRef(const Fortran::evaluate::ProcedureRef &procRef,
+ llvm::Optional<mlir::Type> retTy) {
+ mlir::Location loc = getLoc();
+ if (procRef.IsElemental()) {
+ if (const Fortran::evaluate::SpecificIntrinsic *intrin =
+ procRef.proc().GetSpecificIntrinsic()) {
+ // All elemental intrinsic functions are pure and cannot modify their
+ // arguments. The only elemental subroutine, MVBITS has an Intent(inout)
+ // argument. So for this last one, loops must be in element order
+ // according to 15.8.3 p1.
+ if (!retTy)
+ setUnordered(false);
+
+ // Elemental intrinsic call.
+ // The intrinsic procedure is called once per element of the array.
+ return genElementalIntrinsicProcRef(procRef, retTy, *intrin);
+ }
+ if (ScalarExprLowering::isStatementFunctionCall(procRef))
+ fir::emitFatalError(loc, "statement function cannot be elemental");
+
+ TODO(loc, "elemental user defined proc ref");
+ }
+
+ // Transformational call.
+ // The procedure is called once and produces a value of rank > 0.
+ if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
+ procRef.proc().GetSpecificIntrinsic()) {
+ if (explicitSpaceIsActive() && procRef.Rank() == 0) {
+ // Elide any implicit loop iters.
+ return [=, &procRef](IterSpace) {
+ return ScalarExprLowering{loc, converter, symMap, stmtCtx}
+ .genIntrinsicRef(procRef, *intrinsic, retTy);
+ };
+ }
+ return genarr(
+ ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef(
+ procRef, *intrinsic, retTy));
+ }
+
+ if (explicitSpaceIsActive() && procRef.Rank() == 0) {
+ // Elide any implicit loop iters.
+ return [=, &procRef](IterSpace) {
+ return ScalarExprLowering{loc, converter, symMap, stmtCtx}
+ .genProcedureRef(procRef, retTy);
+ };
+ }
+ // In the default case, the call can be hoisted out of the loop nest. Apply
+ // the iterations to the result, which may be an array value.
+ return genarr(
+ ScalarExprLowering{loc, converter, symMap, stmtCtx}.genProcedureRef(
+ procRef, retTy));
+ }
+
template <typename A>
CC genScalarAndForwardValue(const A &x) {
ExtValue result = asScalar(x);
@@ -2322,12 +2827,28 @@ class ArrayExprLowering {
TODO(getLoc(), "");
}
+ //===--------------------------------------------------------------------===//
+ // Binary elemental ops
+ //===--------------------------------------------------------------------===//
+
+ template <typename OP, typename A>
+ CC createBinaryOp(const A &evEx) {
+ mlir::Location loc = getLoc();
+ auto lambda = genarr(evEx.left());
+ auto rf = genarr(evEx.right());
+ return [=](IterSpace iters) -> ExtValue {
+ mlir::Value left = fir::getBase(lambda(iters));
+ mlir::Value right = fir::getBase(rf(iters));
+ return builder.create<OP>(loc, left, right);
+ };
+ }
+
#undef GENBIN
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
template <int KIND> \
CC genarr(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
- TODO(getLoc(), "genarr Binary"); \
+ return createBinaryOp<GenBinFirOp>(x); \
}
GENBIN(Add, Integer, mlir::arith::AddIOp)
@@ -2393,9 +2914,410 @@ class ArrayExprLowering {
return genarr(extMemref, dummy);
}
+ //===--------------------------------------------------------------------===//
+ // Array construction
+ //===--------------------------------------------------------------------===//
+
+ /// Target agnostic computation of the size of an element in the array.
+ /// Returns the size in bytes with type `index` or a null Value if the element
+ /// size is not constant.
+ mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy,
+ mlir::Type resTy) {
+ mlir::Location loc = getLoc();
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Value multiplier = builder.createIntegerConstant(loc, idxTy, 1);
+ if (fir::hasDynamicSize(eleTy)) {
+ if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+ // Array of char with dynamic length parameter. Downcast to an array
+ // of singleton char, and scale by the len type parameter from
+ // `exv`.
+ exv.match(
+ [&](const fir::CharBoxValue &cb) { multiplier = cb.getLen(); },
+ [&](const fir::CharArrayBoxValue &cb) { multiplier = cb.getLen(); },
+ [&](const fir::BoxValue &box) {
+ multiplier = fir::factory::CharacterExprHelper(builder, loc)
+ .readLengthFromBox(box.getAddr());
+ },
+ [&](const fir::MutableBoxValue &box) {
+ multiplier = fir::factory::CharacterExprHelper(builder, loc)
+ .readLengthFromBox(box.getAddr());
+ },
+ [&](const auto &) {
+ fir::emitFatalError(loc,
+ "array constructor element has unknown size");
+ });
+ fir::CharacterType newEleTy = fir::CharacterType::getSingleton(
+ eleTy.getContext(), charTy.getFKind());
+ if (auto seqTy = resTy.dyn_cast<fir::SequenceType>()) {
+ assert(eleTy == seqTy.getEleTy());
+ resTy = fir::SequenceType::get(seqTy.getShape(), newEleTy);
+ }
+ eleTy = newEleTy;
+ } else {
+ TODO(loc, "dynamic sized type");
+ }
+ }
+ mlir::Type eleRefTy = builder.getRefType(eleTy);
+ mlir::Type resRefTy = builder.getRefType(resTy);
+ mlir::Value nullPtr = builder.createNullConstant(loc, resRefTy);
+ auto offset = builder.create<fir::CoordinateOp>(
+ loc, eleRefTy, nullPtr, mlir::ValueRange{multiplier});
+ return builder.createConvert(loc, idxTy, offset);
+ }
+
+ /// Get the function signature of the LLVM memcpy intrinsic.
+ mlir::FunctionType memcpyType() {
+ return fir::factory::getLlvmMemcpy(builder).getType();
+ }
+
+ /// Create a call to the LLVM memcpy intrinsic.
+ void createCallMemcpy(llvm::ArrayRef<mlir::Value> args) {
+ mlir::Location loc = getLoc();
+ mlir::FuncOp memcpyFunc = fir::factory::getLlvmMemcpy(builder);
+ mlir::SymbolRefAttr funcSymAttr =
+ builder.getSymbolRefAttr(memcpyFunc.getName());
+ mlir::FunctionType funcTy = memcpyFunc.getType();
+ builder.create<fir::CallOp>(loc, funcTy.getResults(), funcSymAttr, args);
+ }
+
+ // Construct code to check for a buffer overrun and realloc the buffer when
+ // space is depleted. This is done between each item in the ac-value-list.
+ mlir::Value growBuffer(mlir::Value mem, mlir::Value needed,
+ mlir::Value bufferSize, mlir::Value buffSize,
+ mlir::Value eleSz) {
+ mlir::Location loc = getLoc();
+ mlir::FuncOp reallocFunc = fir::factory::getRealloc(builder);
+ auto cond = builder.create<mlir::arith::CmpIOp>(
+ loc, mlir::arith::CmpIPredicate::sle, bufferSize, needed);
+ auto ifOp = builder.create<fir::IfOp>(loc, mem.getType(), cond,
+ /*withElseRegion=*/true);
+ auto insPt = builder.saveInsertionPoint();
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ // Not enough space, resize the buffer.
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Value two = builder.createIntegerConstant(loc, idxTy, 2);
+ auto newSz = builder.create<mlir::arith::MulIOp>(loc, needed, two);
+ builder.create<fir::StoreOp>(loc, newSz, buffSize);
+ mlir::Value byteSz = builder.create<mlir::arith::MulIOp>(loc, newSz, eleSz);
+ mlir::SymbolRefAttr funcSymAttr =
+ builder.getSymbolRefAttr(reallocFunc.getName());
+ mlir::FunctionType funcTy = reallocFunc.getType();
+ auto newMem = builder.create<fir::CallOp>(
+ loc, funcTy.getResults(), funcSymAttr,
+ llvm::ArrayRef<mlir::Value>{
+ builder.createConvert(loc, funcTy.getInputs()[0], mem),
+ builder.createConvert(loc, funcTy.getInputs()[1], byteSz)});
+ mlir::Value castNewMem =
+ builder.createConvert(loc, mem.getType(), newMem.getResult(0));
+ builder.create<fir::ResultOp>(loc, castNewMem);
+ builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
+ // Otherwise, just forward the buffer.
+ builder.create<fir::ResultOp>(loc, mem);
+ builder.restoreInsertionPoint(insPt);
+ return ifOp.getResult(0);
+ }
+
+ /// Copy the next value (or vector of values) into the array being
+ /// constructed.
+ mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos,
+ mlir::Value buffSize, mlir::Value mem,
+ mlir::Value eleSz, mlir::Type eleTy,
+ mlir::Type eleRefTy, mlir::Type resTy) {
+ mlir::Location loc = getLoc();
+ auto off = builder.create<fir::LoadOp>(loc, buffPos);
+ auto limit = builder.create<fir::LoadOp>(loc, buffSize);
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+
+ if (fir::isRecordWithAllocatableMember(eleTy))
+ TODO(loc, "deep copy on allocatable members");
+
+ if (!eleSz) {
+ // Compute the element size at runtime.
+ assert(fir::hasDynamicSize(eleTy));
+ if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+ auto charBytes =
+ builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8;
+ mlir::Value bytes =
+ builder.createIntegerConstant(loc, idxTy, charBytes);
+ mlir::Value length = fir::getLen(exv);
+ if (!length)
+ fir::emitFatalError(loc, "result is not boxed character");
+ eleSz = builder.create<mlir::arith::MulIOp>(loc, bytes, length);
+ } else {
+ TODO(loc, "PDT size");
+ // Will call the PDT's size function with the type parameters.
+ }
+ }
+
+ // Compute the coordinate using `fir.coordinate_of`, or, if the type has
+ // dynamic size, generating the pointer arithmetic.
+ auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) {
+ mlir::Type refTy = eleRefTy;
+ if (fir::hasDynamicSize(eleTy)) {
+ if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+ // Scale a simple pointer using dynamic length and offset values.
+ auto chTy = fir::CharacterType::getSingleton(charTy.getContext(),
+ charTy.getFKind());
+ refTy = builder.getRefType(chTy);
+ mlir::Type toTy = builder.getRefType(builder.getVarLenSeqTy(chTy));
+ buff = builder.createConvert(loc, toTy, buff);
+ off = builder.create<mlir::arith::MulIOp>(loc, off, eleSz);
+ } else {
+ TODO(loc, "PDT offset");
+ }
+ }
+ auto coor = builder.create<fir::CoordinateOp>(loc, refTy, buff,
+ mlir::ValueRange{off});
+ return builder.createConvert(loc, eleRefTy, coor);
+ };
+
+ // Lambda to lower an abstract array box value.
+ auto doAbstractArray = [&](const auto &v) {
+ // Compute the array size.
+ mlir::Value arrSz = one;
+ for (auto ext : v.getExtents())
+ arrSz = builder.create<mlir::arith::MulIOp>(loc, arrSz, ext);
+
+ // Grow the buffer as needed.
+ auto endOff = builder.create<mlir::arith::AddIOp>(loc, off, arrSz);
+ mem = growBuffer(mem, endOff, limit, buffSize, eleSz);
+
+ // Copy the elements to the buffer.
+ mlir::Value byteSz =
+ builder.create<mlir::arith::MulIOp>(loc, arrSz, eleSz);
+ auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem);
+ mlir::Value buffi = computeCoordinate(buff, off);
+ llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+ builder, loc, memcpyType(), buffi, v.getAddr(), byteSz,
+ /*volatile=*/builder.createBool(loc, false));
+ createCallMemcpy(args);
+
+ // Save the incremented buffer position.
+ builder.create<fir::StoreOp>(loc, endOff, buffPos);
+ };
+
+ // Copy a trivial scalar value into the buffer.
+ auto doTrivialScalar = [&](const ExtValue &v, mlir::Value len = {}) {
+ // Increment the buffer position.
+ auto plusOne = builder.create<mlir::arith::AddIOp>(loc, off, one);
+
+ // Grow the buffer as needed.
+ mem = growBuffer(mem, plusOne, limit, buffSize, eleSz);
+
+ // Store the element in the buffer.
+ mlir::Value buff =
+ builder.createConvert(loc, fir::HeapType::get(resTy), mem);
+ auto buffi = builder.create<fir::CoordinateOp>(loc, eleRefTy, buff,
+ mlir::ValueRange{off});
+ fir::factory::genScalarAssignment(
+ builder, loc,
+ [&]() -> ExtValue {
+ if (len)
+ return fir::CharBoxValue(buffi, len);
+ return buffi;
+ }(),
+ v);
+ builder.create<fir::StoreOp>(loc, plusOne, buffPos);
+ };
+
+ // Copy the value.
+ exv.match(
+ [&](mlir::Value) { doTrivialScalar(exv); },
+ [&](const fir::CharBoxValue &v) {
+ auto buffer = v.getBuffer();
+ if (fir::isa_char(buffer.getType())) {
+ doTrivialScalar(exv, eleSz);
+ } else {
+ // Increment the buffer position.
+ auto plusOne = builder.create<mlir::arith::AddIOp>(loc, off, one);
+
+ // Grow the buffer as needed.
+ mem = growBuffer(mem, plusOne, limit, buffSize, eleSz);
+
+ // Store the element in the buffer.
+ mlir::Value buff =
+ builder.createConvert(loc, fir::HeapType::get(resTy), mem);
+ mlir::Value buffi = computeCoordinate(buff, off);
+ llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+ builder, loc, memcpyType(), buffi, v.getAddr(), eleSz,
+ /*volatile=*/builder.createBool(loc, false));
+ createCallMemcpy(args);
+
+ builder.create<fir::StoreOp>(loc, plusOne, buffPos);
+ }
+ },
+ [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); },
+ [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); },
+ [&](const auto &) {
+ TODO(loc, "unhandled array constructor expression");
+ });
+ return mem;
+ }
+
+ // Lower the expr cases in an ac-value-list.
+ template <typename A>
+ std::pair<ExtValue, bool>
+ genArrayCtorInitializer(const Fortran::evaluate::Expr<A> &x, mlir::Type,
+ mlir::Value, mlir::Value, mlir::Value,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (isArray(x))
+ return {lowerNewArrayExpression(converter, symMap, stmtCtx, toEvExpr(x)),
+ /*needCopy=*/true};
+ return {asScalar(x), /*needCopy=*/true};
+ }
+
+ // Lower an ac-implied-do in an ac-value-list.
+ template <typename A>
+ std::pair<ExtValue, bool>
+ genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo<A> &x,
+ mlir::Type resTy, mlir::Value mem,
+ mlir::Value buffPos, mlir::Value buffSize,
+ Fortran::lower::StatementContext &) {
+ mlir::Location loc = getLoc();
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Value lo =
+ builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower())));
+ mlir::Value up =
+ builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper())));
+ mlir::Value step =
+ builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride())));
+ auto seqTy = resTy.template cast<fir::SequenceType>();
+ mlir::Type eleTy = fir::unwrapSequenceType(seqTy);
+ auto loop =
+ builder.create<fir::DoLoopOp>(loc, lo, up, step, /*unordered=*/false,
+ /*finalCount=*/false, mem);
+ // create a new binding for x.name(), to ac-do-variable, to the iteration
+ // value.
+ symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar());
+ auto insPt = builder.saveInsertionPoint();
+ builder.setInsertionPointToStart(loop.getBody());
+ // Thread mem inside the loop via loop argument.
+ mem = loop.getRegionIterArgs()[0];
+
+ mlir::Type eleRefTy = builder.getRefType(eleTy);
+
+ // Any temps created in the loop body must be freed inside the loop body.
+ stmtCtx.pushScope();
+ llvm::Optional<mlir::Value> charLen;
+ for (const Fortran::evaluate::ArrayConstructorValue<A> &acv : x.values()) {
+ auto [exv, copyNeeded] = std::visit(
+ [&](const auto &v) {
+ return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize,
+ stmtCtx);
+ },
+ acv.u);
+ mlir::Value eleSz = computeElementSize(exv, eleTy, resTy);
+ mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem,
+ eleSz, eleTy, eleRefTy, resTy)
+ : fir::getBase(exv);
+ if (fir::isa_char(seqTy.getEleTy()) && !charLen.hasValue()) {
+ charLen = builder.createTemporary(loc, builder.getI64Type());
+ mlir::Value castLen =
+ builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv));
+ builder.create<fir::StoreOp>(loc, castLen, charLen.getValue());
+ }
+ }
+ stmtCtx.finalize(/*popScope=*/true);
+
+ builder.create<fir::ResultOp>(loc, mem);
+ builder.restoreInsertionPoint(insPt);
+ mem = loop.getResult(0);
+ symMap.popImpliedDoBinding();
+ llvm::SmallVector<mlir::Value> extents = {
+ builder.create<fir::LoadOp>(loc, buffPos).getResult()};
+
+ // Convert to extended value.
+ if (fir::isa_char(seqTy.getEleTy())) {
+ auto len = builder.create<fir::LoadOp>(loc, charLen.getValue());
+ return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false};
+ }
+ return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false};
+ }
+
+ // To simplify the handling and interaction between the various cases, array
+ // constructors are always lowered to the incremental construction code
+ // pattern, even if the extent of the array value is constant. After the
+ // MemToReg pass and constant folding, the optimizer should be able to
+ // determine that all the buffer overrun tests are false when the
+ // incremental construction wasn't actually required.
template <typename A>
CC genarr(const Fortran::evaluate::ArrayConstructor<A> &x) {
- TODO(getLoc(), "genarr ArrayConstructor<A>");
+ mlir::Location loc = getLoc();
+ auto evExpr = toEvExpr(x);
+ mlir::Type resTy = translateSomeExprToFIRType(converter, evExpr);
+ mlir::IndexType idxTy = builder.getIndexType();
+ auto seqTy = resTy.template cast<fir::SequenceType>();
+ mlir::Type eleTy = fir::unwrapSequenceType(resTy);
+ mlir::Value buffSize = builder.createTemporary(loc, idxTy, ".buff.size");
+ mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
+ mlir::Value buffPos = builder.createTemporary(loc, idxTy, ".buff.pos");
+ builder.create<fir::StoreOp>(loc, zero, buffPos);
+ // Allocate space for the array to be constructed.
+ mlir::Value mem;
+ if (fir::hasDynamicSize(resTy)) {
+ if (fir::hasDynamicSize(eleTy)) {
+ // The size of each element may depend on a general expression. Defer
+ // creating the buffer until after the expression is evaluated.
+ mem = builder.createNullConstant(loc, builder.getRefType(eleTy));
+ builder.create<fir::StoreOp>(loc, zero, buffSize);
+ } else {
+ mlir::Value initBuffSz =
+ builder.createIntegerConstant(loc, idxTy, clInitialBufferSize);
+ mem = builder.create<fir::AllocMemOp>(
+ loc, eleTy, /*typeparams=*/llvm::None, initBuffSz);
+ builder.create<fir::StoreOp>(loc, initBuffSz, buffSize);
+ }
+ } else {
+ mem = builder.create<fir::AllocMemOp>(loc, resTy);
+ int64_t buffSz = 1;
+ for (auto extent : seqTy.getShape())
+ buffSz *= extent;
+ mlir::Value initBuffSz =
+ builder.createIntegerConstant(loc, idxTy, buffSz);
+ builder.create<fir::StoreOp>(loc, initBuffSz, buffSize);
+ }
+ // Compute size of element
+ mlir::Type eleRefTy = builder.getRefType(eleTy);
+
+ // Populate the buffer with the elements, growing as necessary.
+ llvm::Optional<mlir::Value> charLen;
+ for (const auto &expr : x) {
+ auto [exv, copyNeeded] = std::visit(
+ [&](const auto &e) {
+ return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize,
+ stmtCtx);
+ },
+ expr.u);
+ mlir::Value eleSz = computeElementSize(exv, eleTy, resTy);
+ mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem,
+ eleSz, eleTy, eleRefTy, resTy)
+ : fir::getBase(exv);
+ if (fir::isa_char(seqTy.getEleTy()) && !charLen.hasValue()) {
+ charLen = builder.createTemporary(loc, builder.getI64Type());
+ mlir::Value castLen =
+ builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv));
+ builder.create<fir::StoreOp>(loc, castLen, charLen.getValue());
+ }
+ }
+ mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem);
+ llvm::SmallVector<mlir::Value> extents = {
+ builder.create<fir::LoadOp>(loc, buffPos)};
+
+ // Cleanup the temporary.
+ fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
+ stmtCtx.attachCleanup(
+ [bldr, loc, mem]() { bldr->create<fir::FreeMemOp>(loc, mem); });
+
+ // Return the continuation.
+ if (fir::isa_char(seqTy.getEleTy())) {
+ if (charLen.hasValue()) {
+ auto len = builder.create<fir::LoadOp>(loc, charLen.getValue());
+ return genarr(fir::CharArrayBoxValue{mem, len, extents});
+ }
+ return genarr(fir::CharArrayBoxValue{mem, zero, extents});
+ }
+ return genarr(fir::ArrayBoxValue{mem, extents});
}
CC genarr(const Fortran::evaluate::ImpliedDoIndex &) {
@@ -2458,7 +3380,10 @@ class ArrayExprLowering {
template <typename T>
CC genarr(const Fortran::evaluate::FunctionRef<T> &funRef) {
- TODO(getLoc(), "genarr FunctionRef");
+ // Note that it's possible that the function being called returns either an
+ // array or a scalar. In the first case, use the element type of the array.
+ return genProcRef(
+ funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef))));
}
template <typename A>
@@ -2566,6 +3491,127 @@ class ArrayExprLowering {
return components.reversePath.empty();
}
+ /// Given an optional fir.box, returns an fir.box that is the original one if
+ /// it is present and it otherwise an unallocated box.
+ /// Absent fir.box are implemented as a null pointer descriptor. Generated
+ /// code may need to unconditionally read a fir.box that can be absent.
+ /// This helper allows creating a fir.box that can be read in all cases
+ /// outside of a fir.if (isPresent) region. However, the usages of the value
+ /// read from such box should still only be done in a fir.if(isPresent).
+ static fir::ExtendedValue
+ absentBoxToUnalllocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &exv,
+ mlir::Value isPresent) {
+ mlir::Value box = fir::getBase(exv);
+ mlir::Type boxType = box.getType();
+ assert(boxType.isa<fir::BoxType>() && "argument must be a fir.box");
+ mlir::Value emptyBox =
+ fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None);
+ auto safeToReadBox =
+ builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
+ return fir::substBase(exv, safeToReadBox);
+ }
+
+ std::tuple<CC, mlir::Value, mlir::Type>
+ genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) {
+ assert(expr.Rank() > 0 && "expr must be an array");
+ mlir::Location loc = getLoc();
+ ExtValue optionalArg = asInquired(expr);
+ mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
+ // Generate an array load and access to an array that may be an absent
+ // optional or an unallocated optional.
+ mlir::Value base = getBase(optionalArg);
+ const bool hasOptionalAttr =
+ fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
+ mlir::Type baseType = fir::unwrapRefType(base.getType());
+ const bool isBox = baseType.isa<fir::BoxType>();
+ const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject(
+ expr, converter.getFoldingContext());
+ mlir::Type arrType = fir::unwrapPassByRefType(baseType);
+ mlir::Type eleType = fir::unwrapSequenceType(arrType);
+ ExtValue exv = optionalArg;
+ if (hasOptionalAttr && isBox && !isAllocOrPtr) {
+ // Elemental argument cannot be allocatable or pointers (C15100).
+ // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and
+ // Pointer optional arrays cannot be absent. The only kind of entities
+ // that can get here are optional assumed shape and polymorphic entities.
+ exv = absentBoxToUnalllocatedBox(builder, loc, exv, isPresent);
+ }
+ // All the properties can be read from any fir.box but the read values may
+ // be undefined and should only be used inside a fir.if (canBeRead) region.
+ if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
+ exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
+
+ mlir::Value memref = fir::getBase(exv);
+ mlir::Value shape = builder.createShape(loc, exv);
+ mlir::Value noSlice;
+ auto arrLoad = builder.create<fir::ArrayLoadOp>(
+ loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv));
+ mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
+ mlir::Value arrLd = arrLoad.getResult();
+ // Mark the load to tell later passes it is unsafe to use this array_load
+ // shape unconditionally.
+ arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr());
+
+ // Place the array as optional on the arrayOperands stack so that its
+ // shape will only be used as a fallback to induce the implicit loop nest
+ // (that is if there is no non optional array arguments).
+ arrayOperands.push_back(
+ ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true});
+
+ // By value semantics.
+ auto cc = [=](IterSpace iters) -> ExtValue {
+ auto arrFetch = builder.create<fir::ArrayFetchOp>(
+ loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams);
+ return fir::factory::arraySectionElementToExtendedValue(
+ builder, loc, exv, arrFetch, noSlice);
+ };
+ return {cc, isPresent, eleType};
+ }
+
+ /// Generate a continuation to pass \p expr to an OPTIONAL argument of an
+ /// elemental procedure. This is meant to handle the cases where \p expr might
+ /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an
+ /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can
+ /// directly be called instead.
+ CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) {
+ mlir::Location loc = getLoc();
+ // Only by-value numerical and logical so far.
+ if (semant != ConstituentSemantics::RefTransparent)
+ TODO(loc, "optional arguments in user defined elemental procedures");
+
+ // Handle scalar argument case (the if-then-else is generated outside of the
+ // implicit loop nest).
+ if (expr.Rank() == 0) {
+ ExtValue optionalArg = asInquired(expr);
+ mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
+ mlir::Value elementValue =
+ fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent));
+ return [=](IterSpace iters) -> ExtValue { return elementValue; };
+ }
+
+ CC cc;
+ mlir::Value isPresent;
+ mlir::Type eleType;
+ std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr);
+ return [=](IterSpace iters) -> ExtValue {
+ mlir::Value elementValue =
+ builder
+ .genIfOp(loc, {eleType}, isPresent,
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ builder.create<fir::ResultOp>(loc, fir::getBase(cc(iters)));
+ })
+ .genElse([&]() {
+ mlir::Value zero =
+ fir::factory::createZeroValue(builder, loc, eleType);
+ builder.create<fir::ResultOp>(loc, zero);
+ })
+ .getResults()[0];
+ return elementValue;
+ };
+ }
+
CC genarr(const Fortran::evaluate::ComplexPart &x,
ComponentPath &components) {
TODO(getLoc(), "genarr ComplexPart");
@@ -3123,6 +4169,15 @@ void Fortran::lower::createAllocatableArrayAssignment(
converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
}
+fir::ExtendedValue Fortran::lower::createSomeArrayTempValue(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
+ return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx,
+ expr);
+}
+
mlir::Value Fortran::lower::genMaxWithZero(fir::FirOpBuilder &builder,
mlir::Location loc,
mlir::Value value) {
diff --git a/flang/lib/Lower/CustomIntrinsicCall.cpp b/flang/lib/Lower/CustomIntrinsicCall.cpp
new file mode 100644
index 0000000000000..4e3faa2ea79f5
--- /dev/null
+++ b/flang/lib/Lower/CustomIntrinsicCall.cpp
@@ -0,0 +1,255 @@
+//===-- CustomIntrinsicCall.cpp -------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Lower/CustomIntrinsicCall.h"
+#include "flang/Evaluate/expression.h"
+#include "flang/Evaluate/fold.h"
+#include "flang/Evaluate/tools.h"
+#include "flang/Lower/IntrinsicCall.h"
+#include "flang/Lower/Todo.h"
+
+/// Is this a call to MIN or MAX intrinsic with arguments that may be absent at
+/// runtime? This is a special case because MIN and MAX can have any number of
+/// arguments.
+static bool isMinOrMaxWithDynamicallyOptionalArg(
+ llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
+ Fortran::evaluate::FoldingContext &foldingContex) {
+ if (name != "min" && name != "max")
+ return false;
+ const auto &args = procRef.arguments();
+ std::size_t argSize = args.size();
+ if (argSize <= 2)
+ return false;
+ for (std::size_t i = 2; i < argSize; ++i) {
+ if (auto *expr =
+ Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(args[i]))
+ if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex))
+ return true;
+ }
+ return false;
+}
+
+/// Is this a call to ISHFTC intrinsic with a SIZE argument that may be absent
+/// at runtime? This is a special case because the SIZE value to be applied
+/// when absent is not zero.
+static bool isIshftcWithDynamicallyOptionalArg(
+ llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
+ Fortran::evaluate::FoldingContext &foldingContex) {
+ if (name != "ishftc" || procRef.arguments().size() < 3)
+ return false;
+ auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
+ procRef.arguments()[2]);
+ return expr &&
+ Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex);
+}
+
+/// Is this a call to SYSTEM_CLOCK or RANDOM_SEED intrinsic with arguments that
+/// may be absent at runtime? This are special cases because that aspect cannot
+/// be delegated to the runtime via a null fir.box or address given the current
+/// runtime entry point.
+static bool isSystemClockOrRandomSeedWithOptionalArg(
+ llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
+ Fortran::evaluate::FoldingContext &foldingContex) {
+ if (name != "system_clock" && name != "random_seed")
+ return false;
+ for (const auto &arg : procRef.arguments()) {
+ auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
+ if (expr &&
+ Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex))
+ return true;
+ }
+ return false;
+}
+
+bool Fortran::lower::intrinsicRequiresCustomOptionalHandling(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ AbstractConverter &converter) {
+ llvm::StringRef name = intrinsic.name;
+ Fortran::evaluate::FoldingContext &fldCtx = converter.getFoldingContext();
+ return isMinOrMaxWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
+ isIshftcWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
+ isSystemClockOrRandomSeedWithOptionalArg(name, procRef, fldCtx);
+}
+
+static void prepareMinOrMaxArguments(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ llvm::Optional<mlir::Type> retTy,
+ const Fortran::lower::OperandPrepare &prepareOptionalArgument,
+ const Fortran::lower::OperandPrepare &prepareOtherArgument,
+ Fortran::lower::AbstractConverter &converter) {
+ assert(retTy && "MIN and MAX must have a return type");
+ mlir::Type resultType = retTy.getValue();
+ mlir::Location loc = converter.getCurrentLocation();
+ if (fir::isa_char(resultType))
+ TODO(loc,
+ "CHARACTER MIN and MAX lowering with dynamically optional arguments");
+ for (auto arg : llvm::enumerate(procRef.arguments())) {
+ const auto *expr =
+ Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
+ if (!expr)
+ continue;
+ if (arg.index() <= 1 || !Fortran::evaluate::MayBePassedAsAbsentOptional(
+ *expr, converter.getFoldingContext())) {
+ // Non optional arguments.
+ prepareOtherArgument(*expr);
+ } else {
+ // Dynamically optional arguments.
+ // Subtle: even for scalar the if-then-else will be generated in the loop
+ // nest because the then part will require the current extremum value that
+ // may depend on previous array element argument and cannot be outlined.
+ prepareOptionalArgument(*expr);
+ }
+ }
+}
+
+static fir::ExtendedValue
+lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc,
+ llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
+ const Fortran::lower::OperandPresent &isPresentCheck,
+ const Fortran::lower::OperandGetter &getOperand,
+ std::size_t numOperands,
+ Fortran::lower::StatementContext &stmtCtx) {
+ assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) &&
+ "min/max must have at least two non-optional args");
+ assert(retTy && "MIN and MAX must have a return type");
+ mlir::Type resultType = retTy.getValue();
+ llvm::SmallVector<fir::ExtendedValue> args;
+ args.push_back(getOperand(0));
+ args.push_back(getOperand(1));
+ mlir::Value extremum = fir::getBase(Fortran::lower::genIntrinsicCall(
+ builder, loc, name, resultType, args, stmtCtx));
+
+ for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) {
+ if (llvm::Optional<mlir::Value> isPresentRuntimeCheck =
+ isPresentCheck(opIndex)) {
+ // Argument is dynamically optional.
+ extremum =
+ builder
+ .genIfOp(loc, {resultType}, isPresentRuntimeCheck.getValue(),
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ llvm::SmallVector<fir::ExtendedValue> args;
+ args.emplace_back(extremum);
+ args.emplace_back(getOperand(opIndex));
+ fir::ExtendedValue newExtremum =
+ Fortran::lower::genIntrinsicCall(builder, loc, name,
+ resultType, args, stmtCtx);
+ builder.create<fir::ResultOp>(loc, fir::getBase(newExtremum));
+ })
+ .genElse([&]() { builder.create<fir::ResultOp>(loc, extremum); })
+ .getResults()[0];
+ } else {
+ // Argument is know to be present at compile time.
+ llvm::SmallVector<fir::ExtendedValue> args;
+ args.emplace_back(extremum);
+ args.emplace_back(getOperand(opIndex));
+ extremum = fir::getBase(Fortran::lower::genIntrinsicCall(
+ builder, loc, name, resultType, args, stmtCtx));
+ }
+ }
+ return extremum;
+}
+
+static void prepareIshftcArguments(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ llvm::Optional<mlir::Type> retTy,
+ const Fortran::lower::OperandPrepare &prepareOptionalArgument,
+ const Fortran::lower::OperandPrepare &prepareOtherArgument,
+ Fortran::lower::AbstractConverter &converter) {
+ for (auto arg : llvm::enumerate(procRef.arguments())) {
+ const auto *expr =
+ Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
+ assert(expr && "expected all ISHFTC argument to be textually present here");
+ if (arg.index() == 2) {
+ assert(Fortran::evaluate::MayBePassedAsAbsentOptional(
+ *expr, converter.getFoldingContext()) &&
+ "expected ISHFTC SIZE arg to be dynamically optional");
+ prepareOptionalArgument(*expr);
+ } else {
+ // Non optional arguments.
+ prepareOtherArgument(*expr);
+ }
+ }
+}
+
+static fir::ExtendedValue
+lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc,
+ llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
+ const Fortran::lower::OperandPresent &isPresentCheck,
+ const Fortran::lower::OperandGetter &getOperand,
+ std::size_t numOperands,
+ Fortran::lower::StatementContext &stmtCtx) {
+ assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) &&
+ isPresentCheck(2) &&
+ "only ISHFTC SIZE arg is expected to be dynamically optional here");
+ assert(retTy && "ISFHTC must have a return type");
+ mlir::Type resultType = retTy.getValue();
+ llvm::SmallVector<fir::ExtendedValue> args;
+ args.push_back(getOperand(0));
+ args.push_back(getOperand(1));
+ args.push_back(builder
+ .genIfOp(loc, {resultType}, isPresentCheck(2).getValue(),
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ fir::ExtendedValue sizeExv = getOperand(2);
+ mlir::Value size = builder.createConvert(
+ loc, resultType, fir::getBase(sizeExv));
+ builder.create<fir::ResultOp>(loc, size);
+ })
+ .genElse([&]() {
+ mlir::Value bitSize = builder.createIntegerConstant(
+ loc, resultType,
+ resultType.cast<mlir::IntegerType>().getWidth());
+ builder.create<fir::ResultOp>(loc, bitSize);
+ })
+ .getResults()[0]);
+ return Fortran::lower::genIntrinsicCall(builder, loc, name, resultType, args,
+ stmtCtx);
+}
+
+void Fortran::lower::prepareCustomIntrinsicArgument(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ llvm::Optional<mlir::Type> retTy,
+ const OperandPrepare &prepareOptionalArgument,
+ const OperandPrepare &prepareOtherArgument, AbstractConverter &converter) {
+ llvm::StringRef name = intrinsic.name;
+ if (name == "min" || name == "max")
+ return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
+ prepareOptionalArgument,
+ prepareOtherArgument, converter);
+ if (name == "ishftc")
+ return prepareIshftcArguments(procRef, intrinsic, retTy,
+ prepareOptionalArgument, prepareOtherArgument,
+ converter);
+ TODO(converter.getCurrentLocation(),
+ "unhandled dynamically optional arguments in SYSTEM_CLOCK or "
+ "RANDOM_SEED");
+}
+
+fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
+ fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
+ llvm::Optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
+ const OperandGetter &getOperand, std::size_t numOperands,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (name == "min" || name == "max")
+ return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
+ numOperands, stmtCtx);
+ if (name == "ishftc")
+ return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
+ numOperands, stmtCtx);
+ TODO(loc, "unhandled dynamically optional arguments in SYSTEM_CLOCK or "
+ "RANDOM_SEED");
+}
diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp
index 5fe0a1149b6ab..b4ed072a73b80 100644
--- a/flang/lib/Lower/IntrinsicCall.cpp
+++ b/flang/lib/Lower/IntrinsicCall.cpp
@@ -15,14 +15,18 @@
#include "flang/Lower/IntrinsicCall.h"
#include "flang/Common/static-multimap-view.h"
+#include "flang/Lower/Mangler.h"
#include "flang/Lower/StatementContext.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/Complex.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
+#include "flang/Optimizer/Builder/Runtime/Reduction.h"
#include "flang/Optimizer/Support/FatalError.h"
+#include "mlir/Dialect/LLVMIR/LLVMDialect.h"
#include "llvm/Support/CommandLine.h"
#define DEBUG_TYPE "flang-lower-intrinsic"
@@ -90,12 +94,110 @@ fir::ExtendedValue Fortran::lower::getAbsentIntrinsicArgument() {
return fir::UnboxedValue{};
}
+/// Test if an ExtendedValue is absent.
+static bool isAbsent(const fir::ExtendedValue &exv) {
+ return !fir::getBase(exv);
+}
+
+/// Process calls to Maxval, Minval, Product, Sum intrinsic functions that
+/// take a DIM argument.
+template <typename FD>
+static fir::ExtendedValue
+genFuncDim(FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder,
+ mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
+ llvm::StringRef errMsg, mlir::Value array, fir::ExtendedValue dimArg,
+ mlir::Value mask, int rank) {
+
+ // Create mutable fir.box to be passed to the runtime for the result.
+ mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
+ fir::MutableBoxValue resultMutableBox =
+ fir::factory::createTempMutableBox(builder, loc, resultArrayType);
+ mlir::Value resultIrBox =
+ fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
+
+ mlir::Value dim =
+ isAbsent(dimArg)
+ ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
+ : fir::getBase(dimArg);
+ funcDim(builder, loc, resultIrBox, array, dim, mask);
+
+ fir::ExtendedValue res =
+ fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
+ return res.match(
+ [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
+ // Add cleanup code
+ assert(stmtCtx);
+ fir::FirOpBuilder *bldr = &builder;
+ mlir::Value temp = box.getAddr();
+ stmtCtx->attachCleanup(
+ [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
+ return box;
+ },
+ [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
+ // Add cleanup code
+ assert(stmtCtx);
+ fir::FirOpBuilder *bldr = &builder;
+ mlir::Value temp = box.getAddr();
+ stmtCtx->attachCleanup(
+ [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
+ return box;
+ },
+ [&](const auto &) -> fir::ExtendedValue {
+ fir::emitFatalError(loc, errMsg);
+ });
+}
+
+/// Process calls to Product, Sum intrinsic functions
+template <typename FN, typename FD>
+static fir::ExtendedValue
+genProdOrSum(FN func, FD funcDim, mlir::Type resultType,
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ Fortran::lower::StatementContext *stmtCtx, llvm::StringRef errMsg,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+
+ assert(args.size() == 3);
+
+ // Handle required array argument
+ fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
+ mlir::Value array = fir::getBase(arryTmp);
+ int rank = arryTmp.rank();
+ assert(rank >= 1);
+
+ // Handle optional mask argument
+ auto mask = isAbsent(args[2])
+ ? builder.create<fir::AbsentOp>(
+ loc, fir::BoxType::get(builder.getI1Type()))
+ : builder.createBox(loc, args[2]);
+
+ bool absentDim = isAbsent(args[1]);
+
+ // We call the type specific versions because the result is scalar
+ // in the case below.
+ if (absentDim || rank == 1) {
+ mlir::Type ty = array.getType();
+ mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(ty);
+ auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
+ if (fir::isa_complex(eleTy)) {
+ mlir::Value result = builder.createTemporary(loc, eleTy);
+ func(builder, loc, array, mask, result);
+ return builder.create<fir::LoadOp>(loc, result);
+ }
+ auto resultBox = builder.create<fir::AbsentOp>(
+ loc, fir::BoxType::get(builder.getI1Type()));
+ return func(builder, loc, array, mask, resultBox);
+ }
+ // Handle Product/Sum cases that have an array result.
+ return genFuncDim(funcDim, resultType, builder, loc, stmtCtx, errMsg, array,
+ args[1], mask, rank);
+}
+
// TODO error handling -> return a code or directly emit messages ?
struct IntrinsicLibrary {
// Constructors.
- explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc)
- : builder{builder}, loc{loc} {}
+ explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc,
+ Fortran::lower::StatementContext *stmtCtx = nullptr)
+ : builder{builder}, loc{loc}, stmtCtx{stmtCtx} {}
IntrinsicLibrary() = delete;
IntrinsicLibrary(const IntrinsicLibrary &) = delete;
@@ -131,11 +233,23 @@ struct IntrinsicLibrary {
/// Lowering for the IAND intrinsic. The IAND intrinsic expects two arguments
/// in the llvm::ArrayRef.
mlir::Value genIand(mlir::Type, llvm::ArrayRef<mlir::Value>);
+ fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
/// Define the
diff erent FIR generators that can be mapped to intrinsic to
/// generate the related code. The intrinsic is lowered into an MLIR
/// arith::AndIOp.
using ElementalGenerator = decltype(&IntrinsicLibrary::genAbs);
- using Generator = std::variant<ElementalGenerator>;
+ using ExtendedGenerator = decltype(&IntrinsicLibrary::genSum);
+ using Generator = std::variant<ElementalGenerator, ExtendedGenerator>;
+
+ template <typename GeneratorType>
+ fir::ExtendedValue
+ outlineInExtendedWrapper(GeneratorType, llvm::StringRef name,
+ llvm::Optional<mlir::Type> resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args);
+
+ template <typename GeneratorType>
+ mlir::FuncOp getWrapper(GeneratorType, llvm::StringRef name,
+ mlir::FunctionType, bool loadRefArguments = false);
/// Generate calls to ElementalGenerator, handling the elemental aspects
template <typename GeneratorType>
@@ -150,8 +264,13 @@ struct IntrinsicLibrary {
mlir::Value invokeGenerator(RuntimeCallGenerator generator,
mlir::Type resultType,
llvm::ArrayRef<mlir::Value> args);
+ mlir::Value invokeGenerator(ExtendedGenerator generator,
+ mlir::Type resultType,
+ llvm::ArrayRef<mlir::Value> args);
+
fir::FirOpBuilder &builder;
mlir::Location loc;
+ Fortran::lower::StatementContext *stmtCtx;
};
struct IntrinsicDummyArgument {
@@ -171,11 +290,20 @@ struct Fortran::lower::IntrinsicArgumentLoweringRules {
struct IntrinsicHandler {
const char *name;
IntrinsicLibrary::Generator generator;
+ // The following may be omitted in the table below.
Fortran::lower::IntrinsicArgumentLoweringRules argLoweringRules = {};
+ bool isElemental = true;
};
+constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value;
+constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box;
using I = IntrinsicLibrary;
+/// Flag to indicate that an intrinsic argument has to be handled as
+/// being dynamically optional (e.g. special handling when actual
+/// argument is an optional variable in the current scope).
+static constexpr bool handleDynamicOptional = true;
+
/// Table that drives the fir generation depending on the intrinsic.
/// one to one mapping with Fortran arguments. If no mapping is
/// defined here for a generic intrinsic, genRuntimeCall will be called
@@ -186,6 +314,12 @@ using I = IntrinsicLibrary;
static constexpr IntrinsicHandler handlers[]{
{"abs", &I::genAbs},
{"iand", &I::genIand},
+ {"sum",
+ &I::genSum,
+ {{{"array", asBox},
+ {"dim", asValue},
+ {"mask", asBox, handleDynamicOptional}}},
+ /*isElemental=*/false},
};
static const IntrinsicHandler *findIntrinsicHandler(llvm::StringRef name) {
@@ -513,10 +647,71 @@ static mlir::FunctionType getFunctionType(llvm::Optional<mlir::Type> resultType,
return mlir::FunctionType::get(builder.getModule().getContext(), argTypes,
resTypes);
}
+
+/// fir::ExtendedValue to mlir::Value translation layer
+
+fir::ExtendedValue toExtendedValue(mlir::Value val, fir::FirOpBuilder &builder,
+ mlir::Location loc) {
+ assert(val && "optional unhandled here");
+ mlir::Type type = val.getType();
+ mlir::Value base = val;
+ mlir::IndexType indexType = builder.getIndexType();
+ llvm::SmallVector<mlir::Value> extents;
+
+ fir::factory::CharacterExprHelper charHelper{builder, loc};
+ // FIXME: we may want to allow non character scalar here.
+ if (charHelper.isCharacterScalar(type))
+ return charHelper.toExtendedValue(val);
+
+ if (auto refType = type.dyn_cast<fir::ReferenceType>())
+ type = refType.getEleTy();
+
+ if (auto arrayType = type.dyn_cast<fir::SequenceType>()) {
+ type = arrayType.getEleTy();
+ for (fir::SequenceType::Extent extent : arrayType.getShape()) {
+ if (extent == fir::SequenceType::getUnknownExtent())
+ break;
+ extents.emplace_back(
+ builder.createIntegerConstant(loc, indexType, extent));
+ }
+ // Last extent might be missing in case of assumed-size. If more extents
+ // could not be deduced from type, that's an error (a fir.box should
+ // have been used in the interface).
+ if (extents.size() + 1 < arrayType.getShape().size())
+ mlir::emitError(loc, "cannot retrieve array extents from type");
+ } else if (type.isa<fir::BoxType>() || type.isa<fir::RecordType>()) {
+ fir::emitFatalError(loc, "not yet implemented: descriptor or derived type");
+ }
+
+ if (!extents.empty())
+ return fir::ArrayBoxValue{base, extents};
+ return base;
+}
+
+mlir::Value toValue(const fir::ExtendedValue &val, fir::FirOpBuilder &builder,
+ mlir::Location loc) {
+ if (const fir::CharBoxValue *charBox = val.getCharBox()) {
+ mlir::Value buffer = charBox->getBuffer();
+ if (buffer.getType().isa<fir::BoxCharType>())
+ return buffer;
+ return fir::factory::CharacterExprHelper{builder, loc}.createEmboxChar(
+ buffer, charBox->getLen());
+ }
+
+ // FIXME: need to access other ExtendedValue variants and handle them
+ // properly.
+ return fir::getBase(val);
+}
+
//===----------------------------------------------------------------------===//
// IntrinsicLibrary
//===----------------------------------------------------------------------===//
+/// Emit a TODO error message for as yet unimplemented intrinsics.
+static void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) {
+ TODO(loc, "missing intrinsic lowering: " + llvm::Twine(name));
+}
+
template <typename GeneratorType>
fir::ExtendedValue IntrinsicLibrary::genElementalCall(
GeneratorType generator, llvm::StringRef name, mlir::Type resultType,
@@ -530,6 +725,19 @@ fir::ExtendedValue IntrinsicLibrary::genElementalCall(
return invokeGenerator(generator, resultType, scalarArgs);
}
+template <>
+fir::ExtendedValue
+IntrinsicLibrary::genElementalCall<IntrinsicLibrary::ExtendedGenerator>(
+ ExtendedGenerator generator, llvm::StringRef name, mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
+ for (const fir::ExtendedValue &arg : args)
+ if (!arg.getUnboxed() && !arg.getCharBox())
+ fir::emitFatalError(loc, "nonscalar intrinsic argument");
+ if (outline)
+ return outlineInExtendedWrapper(generator, name, resultType, args);
+ return std::invoke(generator, *this, resultType, args);
+}
+
static fir::ExtendedValue
invokeHandler(IntrinsicLibrary::ElementalGenerator generator,
const IntrinsicHandler &handler,
@@ -541,6 +749,22 @@ invokeHandler(IntrinsicLibrary::ElementalGenerator generator,
outline);
}
+static fir::ExtendedValue
+invokeHandler(IntrinsicLibrary::ExtendedGenerator generator,
+ const IntrinsicHandler &handler,
+ llvm::Optional<mlir::Type> resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
+ IntrinsicLibrary &lib) {
+ assert(resultType && "expect intrinsic function");
+ if (handler.isElemental)
+ return lib.genElementalCall(generator, handler.name, *resultType, args,
+ outline);
+ if (outline)
+ return lib.outlineInExtendedWrapper(generator, handler.name, *resultType,
+ args);
+ return std::invoke(generator, lib, *resultType, args);
+}
+
fir::ExtendedValue
IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name,
llvm::Optional<mlir::Type> resultType,
@@ -555,8 +779,32 @@ IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name,
handler->generator);
}
- TODO(loc, "genIntrinsicCall runtime");
- return {};
+ if (!resultType)
+ // Subroutine should have a handler, they are likely missing for now.
+ crashOnMissingIntrinsic(loc, name);
+
+ // Try the runtime if no special handler was defined for the
+ // intrinsic being called. Maths runtime only has numerical elemental.
+ // No optional arguments are expected at this point, the code will
+ // crash if it gets absent optional.
+
+ // FIXME: using toValue to get the type won't work with array arguments.
+ llvm::SmallVector<mlir::Value> mlirArgs;
+ for (const fir::ExtendedValue &extendedVal : args) {
+ mlir::Value val = toValue(extendedVal, builder, loc);
+ if (!val)
+ // If an absent optional gets there, most likely its handler has just
+ // not yet been defined.
+ crashOnMissingIntrinsic(loc, name);
+ mlirArgs.emplace_back(val);
+ }
+ mlir::FunctionType soughtFuncType =
+ getFunctionType(*resultType, mlirArgs, builder);
+
+ IntrinsicLibrary::RuntimeCallGenerator runtimeCallGenerator =
+ getRuntimeCallGenerator(name, soughtFuncType);
+ return genElementalCall(runtimeCallGenerator, name, *resultType, args,
+ /* outline */ true);
}
mlir::Value
@@ -572,15 +820,108 @@ IntrinsicLibrary::invokeGenerator(RuntimeCallGenerator generator,
llvm::ArrayRef<mlir::Value> args) {
return generator(builder, loc, args);
}
+
+mlir::Value
+IntrinsicLibrary::invokeGenerator(ExtendedGenerator generator,
+ mlir::Type resultType,
+ llvm::ArrayRef<mlir::Value> args) {
+ llvm::SmallVector<fir::ExtendedValue> extendedArgs;
+ for (mlir::Value arg : args)
+ extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
+ auto extendedResult = std::invoke(generator, *this, resultType, extendedArgs);
+ return toValue(extendedResult, builder, loc);
+}
+
+template <typename GeneratorType>
+mlir::FuncOp IntrinsicLibrary::getWrapper(GeneratorType generator,
+ llvm::StringRef name,
+ mlir::FunctionType funcType,
+ bool loadRefArguments) {
+ std::string wrapperName = fir::mangleIntrinsicProcedure(name, funcType);
+ mlir::FuncOp function = builder.getNamedFunction(wrapperName);
+ if (!function) {
+ // First time this wrapper is needed, build it.
+ function = builder.createFunction(loc, wrapperName, funcType);
+ function->setAttr("fir.intrinsic", builder.getUnitAttr());
+ auto internalLinkage = mlir::LLVM::linkage::Linkage::Internal;
+ auto linkage =
+ mlir::LLVM::LinkageAttr::get(builder.getContext(), internalLinkage);
+ function->setAttr("llvm.linkage", linkage);
+ function.addEntryBlock();
+
+ // Create local context to emit code into the newly created function
+ // This new function is not linked to a source file location, only
+ // its calls will be.
+ auto localBuilder =
+ std::make_unique<fir::FirOpBuilder>(function, builder.getKindMap());
+ localBuilder->setInsertionPointToStart(&function.front());
+ // Location of code inside wrapper of the wrapper is independent from
+ // the location of the intrinsic call.
+ mlir::Location localLoc = localBuilder->getUnknownLoc();
+ llvm::SmallVector<mlir::Value> localArguments;
+ for (mlir::BlockArgument bArg : function.front().getArguments()) {
+ auto refType = bArg.getType().dyn_cast<fir::ReferenceType>();
+ if (loadRefArguments && refType) {
+ auto loaded = localBuilder->create<fir::LoadOp>(localLoc, bArg);
+ localArguments.push_back(loaded);
+ } else {
+ localArguments.push_back(bArg);
+ }
+ }
+
+ IntrinsicLibrary localLib{*localBuilder, localLoc};
+
+ assert(funcType.getNumResults() == 1 &&
+ "expect one result for intrinsic function wrapper type");
+ mlir::Type resultType = funcType.getResult(0);
+ auto result =
+ localLib.invokeGenerator(generator, resultType, localArguments);
+ localBuilder->create<mlir::func::ReturnOp>(localLoc, result);
+ } else {
+ // Wrapper was already built, ensure it has the sought type
+ assert(function.getType() == funcType &&
+ "conflict between intrinsic wrapper types");
+ }
+ return function;
+}
+
+/// Helpers to detect absent optional (not yet supported in outlining).
+bool static hasAbsentOptional(llvm::ArrayRef<fir::ExtendedValue> args) {
+ for (const fir::ExtendedValue &arg : args)
+ if (!fir::getBase(arg))
+ return true;
+ return false;
+}
+
+template <typename GeneratorType>
+fir::ExtendedValue IntrinsicLibrary::outlineInExtendedWrapper(
+ GeneratorType generator, llvm::StringRef name,
+ llvm::Optional<mlir::Type> resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ if (hasAbsentOptional(args))
+ TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) +
+ " with absent optional argument");
+ llvm::SmallVector<mlir::Value> mlirArgs;
+ for (const auto &extendedVal : args)
+ mlirArgs.emplace_back(toValue(extendedVal, builder, loc));
+ mlir::FunctionType funcType = getFunctionType(resultType, mlirArgs, builder);
+ mlir::FuncOp wrapper = getWrapper(generator, name, funcType);
+ auto call = builder.create<fir::CallOp>(loc, wrapper, mlirArgs);
+ if (resultType)
+ return toExtendedValue(call.getResult(0), builder, loc);
+ // Subroutine calls
+ return mlir::Value{};
+}
+
IntrinsicLibrary::RuntimeCallGenerator
IntrinsicLibrary::getRuntimeCallGenerator(llvm::StringRef name,
mlir::FunctionType soughtFuncType) {
mlir::FuncOp funcOp = getRuntimeFunction(loc, builder, name, soughtFuncType);
if (!funcOp) {
- mlir::emitError(loc,
- "TODO: missing intrinsic lowering: " + llvm::Twine(name));
- llvm::errs() << "requested type was: " << soughtFuncType << "\n";
- exit(1);
+ std::string buffer("not yet implemented: missing intrinsic lowering: ");
+ llvm::raw_string_ostream sstream(buffer);
+ sstream << name << "\nrequested type was: " << soughtFuncType << '\n';
+ fir::emitFatalError(loc, buffer);
}
mlir::FunctionType actualFuncType = funcOp.getType();
@@ -722,6 +1063,14 @@ mlir::Value IntrinsicLibrary::genExtremum(mlir::Type,
return result;
}
+// SUM
+fir::ExtendedValue
+IntrinsicLibrary::genSum(mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ return genProdOrSum(fir::runtime::genSum, fir::runtime::genSumDim, resultType,
+ builder, loc, stmtCtx, "unexpected result for Sum", args);
+}
+
//===----------------------------------------------------------------------===//
// Argument lowering rules interface
//===----------------------------------------------------------------------===//
@@ -756,9 +1105,10 @@ fir::ExtendedValue
Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
llvm::StringRef name,
llvm::Optional<mlir::Type> resultType,
- llvm::ArrayRef<fir::ExtendedValue> args) {
- return IntrinsicLibrary{builder, loc}.genIntrinsicCall(name, resultType,
- args);
+ llvm::ArrayRef<fir::ExtendedValue> args,
+ Fortran::lower::StatementContext &stmtCtx) {
+ return IntrinsicLibrary{builder, loc, &stmtCtx}.genIntrinsicCall(
+ name, resultType, args);
}
mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder,
diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
index 87f9c42f9a304..daf6c55e578d5 100644
--- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp
+++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
@@ -661,6 +661,46 @@ fir::ExtendedValue fir::factory::readBoxValue(fir::FirOpBuilder &builder,
box.getLBounds());
}
+llvm::SmallVector<mlir::Value>
+fir::factory::getNonDefaultLowerBounds(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::ExtendedValue &exv) {
+ return exv.match(
+ [&](const fir::ArrayBoxValue &array) -> llvm::SmallVector<mlir::Value> {
+ return {array.getLBounds().begin(), array.getLBounds().end()};
+ },
+ [&](const fir::CharArrayBoxValue &array)
+ -> llvm::SmallVector<mlir::Value> {
+ return {array.getLBounds().begin(), array.getLBounds().end()};
+ },
+ [&](const fir::BoxValue &box) -> llvm::SmallVector<mlir::Value> {
+ return {box.getLBounds().begin(), box.getLBounds().end()};
+ },
+ [&](const fir::MutableBoxValue &box) -> llvm::SmallVector<mlir::Value> {
+ auto load = fir::factory::genMutableBoxRead(builder, loc, box);
+ return fir::factory::getNonDefaultLowerBounds(builder, loc, load);
+ },
+ [&](const auto &) -> llvm::SmallVector<mlir::Value> { return {}; });
+}
+
+llvm::SmallVector<mlir::Value>
+fir::factory::getNonDeferredLengthParams(const fir::ExtendedValue &exv) {
+ return exv.match(
+ [&](const fir::CharArrayBoxValue &character)
+ -> llvm::SmallVector<mlir::Value> { return {character.getLen()}; },
+ [&](const fir::CharBoxValue &character)
+ -> llvm::SmallVector<mlir::Value> { return {character.getLen()}; },
+ [&](const fir::MutableBoxValue &box) -> llvm::SmallVector<mlir::Value> {
+ return {box.nonDeferredLenParams().begin(),
+ box.nonDeferredLenParams().end()};
+ },
+ [&](const fir::BoxValue &box) -> llvm::SmallVector<mlir::Value> {
+ return {box.getExplicitParameters().begin(),
+ box.getExplicitParameters().end()};
+ },
+ [&](const auto &) -> llvm::SmallVector<mlir::Value> { return {}; });
+}
+
std::string fir::factory::uniqueCGIdent(llvm::StringRef prefix,
llvm::StringRef name) {
// For "long" identifiers use a hash value
diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp
index 60234fcb9a4ba..2e35cdcb167bc 100644
--- a/flang/lib/Optimizer/Dialect/FIRType.cpp
+++ b/flang/lib/Optimizer/Dialect/FIRType.cpp
@@ -246,6 +246,27 @@ bool hasDynamicSize(mlir::Type t) {
return false;
}
+bool isAllocatableType(mlir::Type ty) {
+ if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
+ ty = refTy;
+ if (auto boxTy = ty.dyn_cast<fir::BoxType>())
+ return boxTy.getEleTy().isa<fir::HeapType>();
+ return false;
+}
+
+bool isRecordWithAllocatableMember(mlir::Type ty) {
+ if (auto recTy = ty.dyn_cast<fir::RecordType>())
+ for (auto [field, memTy] : recTy.getTypeList()) {
+ if (fir::isAllocatableType(memTy))
+ return true;
+ // A record type cannot recursively include itself as a direct member.
+ // There must be an intervening `ptr` type, so recursion is safe here.
+ if (memTy.isa<fir::RecordType>() && isRecordWithAllocatableMember(memTy))
+ return true;
+ }
+ return false;
+}
+
} // namespace fir
namespace {
diff --git a/flang/test/Lower/Intrinsics/sum.f90 b/flang/test/Lower/Intrinsics/sum.f90
new file mode 100644
index 0000000000000..401c9f31ccc22
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/sum.f90
@@ -0,0 +1,134 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func @_QPsum_test(
+! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?xi32>>{{.*}}) -> i32 {
+integer function sum_test(a)
+integer :: a(:)
+! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index
+! CHECK-DAG: %[[a1:.*]] = fir.absent !fir.box<i1>
+! CHECK-DAG: %[[a3:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?xi32>>) -> !fir.box<none>
+! CHECK-DAG: %[[a5:.*]] = fir.convert %[[c0]] : (index) -> i32
+! CHECK-DAG: %[[a6:.*]] = fir.convert %[[a1]] : (!fir.box<i1>) -> !fir.box<none>
+sum_test = sum(a)
+! CHECK: %{{.*}} = fir.call @_FortranASumInteger4(%[[a3]], %{{.*}}, %{{.*}}, %[[a5]], %[[a6]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
+end function
+
+! CHECK-LABEL: func @_QPsum_test2(
+! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x?xi32>>{{.*}}, %[[arg1:.*]]: !fir.box<!fir.array<?xi32>>{{.*}}) {
+subroutine sum_test2(a,r)
+integer :: a(:,:)
+integer :: r(:)
+! CHECK-DAG: %[[c2_i32:.*]] = arith.constant 2 : i32
+! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
+! CHECK-DAG: %[[a1:.*]] = fir.absent !fir.box<i1>
+! CHECK-DAG: %[[a6:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK-DAG: %[[a7:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<none>
+! CHECK-DAG: %[[a9:.*]] = fir.convert %[[a1]] : (!fir.box<i1>) -> !fir.box<none>
+r = sum(a,dim=2)
+! CHECK: %{{.*}} = fir.call @_FortranASumDim(%[[a6]], %[[a7]], %[[c2_i32]], %{{.*}}, %{{.*}}, %[[a9]]) : (!fir.ref<!fir.box<none>>, !fir.box<none>, i32, !fir.ref<i8>, i32, !fir.box<none>) -> none
+! CHECK-DAG: %[[a11:.*]] = fir.load %[[a0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! CHECK-DAG: %[[a13:.*]] = fir.box_addr %[[a11]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
+! CHECK-DAG: fir.freemem %[[a13]]
+end subroutine
+
+! CHECK-LABEL: func @_QPsum_test3(
+! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x!fir.complex<4>>>{{.*}}) -> !fir.complex<4> {
+complex function sum_test3(a)
+complex :: a(:)
+! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index
+! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.complex<4>
+! CHECK-DAG: %[[a3:.*]] = fir.absent !fir.box<i1>
+! CHECK-DAG: %[[a5:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.complex<4>>) -> !fir.ref<complex<f32>>
+! CHECK-DAG: %[[a6:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x!fir.complex<4>>>) -> !fir.box<none>
+! CHECK-DAG: %[[a8:.*]] = fir.convert %[[c0]] : (index) -> i32
+! CHECK-DAG: %[[a9:.*]] = fir.convert %[[a3]] : (!fir.box<i1>) -> !fir.box<none>
+sum_test3 = sum(a)
+! CHECK: %{{.*}} = fir.call @_FortranACppSumComplex4(%[[a5]], %[[a6]], %{{.*}}, %{{.*}}, %[[a8]], %[[a9]]) : (!fir.ref<complex<f32>>, !fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> none
+end function
+
+! CHECK-LABEL: func @_QPsum_test4(
+! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x!fir.complex<10>>>{{.*}}) -> !fir.complex<10> {
+complex(10) function sum_test4(x)
+complex(10):: x(:)
+! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index
+! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.complex<10>
+sum_test4 = sum(x)
+! CHECK-DAG: %[[a2:.*]] = fir.absent !fir.box<i1>
+! CHECK-DAG: %[[a4:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.complex<10>>) -> !fir.ref<complex<f80>>
+! CHECK-DAG: %[[a5:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x!fir.complex<10>>>) -> !fir.box<none>
+! CHECK-DAG: %[[a7:.*]] = fir.convert %[[c0]] : (index) -> i32
+! CHECK-DAG: %[[a8:.*]] = fir.convert %[[a2]] : (!fir.box<i1>) -> !fir.box<none>
+! CHECK: fir.call @_FortranACppSumComplex10(%[[a4]], %[[a5]], %{{.*}}, %{{.*}}, %[[a7]], %8) : (!fir.ref<complex<f80>>, !fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> ()
+end
+
+! CHECK-LABEL: func @_QPsum_test_optional(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>
+integer function sum_test_optional(mask, x)
+integer :: x(:)
+logical, optional :: mask(:)
+sum_test_optional = sum(x, mask=mask)
+! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
+! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_9]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
+end function
+
+! CHECK-LABEL: func @_QPsum_test_optional_2(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>>
+integer function sum_test_optional_2(mask, x)
+integer :: x(:)
+logical, pointer :: mask(:)
+sum_test_optional = sum(x, mask=mask)
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>>
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>) -> !fir.ptr<!fir.array<?x!fir.logical<4>>>
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ptr<!fir.array<?x!fir.logical<4>>>) -> i64
+! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64
+! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>>
+! CHECK: %[[VAL_10:.*]] = fir.absent !fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>
+! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_8]], %[[VAL_9]], %[[VAL_10]] : !fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>
+! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.logical<4>>>>) -> !fir.box<none>
+! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_18]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
+end function
+
+! CHECK-LABEL: func @_QPsum_test_optional_3(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.array<10x!fir.logical<4>>>
+integer function sum_test_optional_3(mask, x)
+integer :: x(:)
+logical, optional :: mask(10)
+sum_test_optional = sum(x, mask=mask)
+! CHECK: %[[VAL_2:.*]] = arith.constant 10 : index
+! CHECK: %[[VAL_5:.*]] = fir.is_present %[[VAL_0]] : (!fir.ref<!fir.array<10x!fir.logical<4>>>) -> i1
+! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_0]](%[[VAL_6]]) : (!fir.ref<!fir.array<10x!fir.logical<4>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.logical<4>>>
+! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box<!fir.array<10x!fir.logical<4>>>
+! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_5]], %[[VAL_7]], %[[VAL_8]] : !fir.box<!fir.array<10x!fir.logical<4>>>
+! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_9]] : (!fir.box<!fir.array<10x!fir.logical<4>>>) -> !fir.box<none>
+! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_18]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
+end function
+
+! CHECK-LABEL: func @_QPsum_test_optional_4(
+integer function sum_test_optional_4(x, use_mask)
+! Test that local allocatable tracked in local variables
+! are dealt as optional argument correctly.
+integer :: x(:)
+logical :: use_mask
+logical, allocatable :: mask(:)
+if (use_mask) then
+ allocate(mask(size(x, 1)))
+ call set_mask(mask)
+ ! CHECK: fir.call @_QPset_mask
+end if
+sum_test_optional = sum(x, mask=mask)
+! CHECK: %[[VAL_20:.*]] = fir.load %[[VAL_3:.*]] : !fir.ref<!fir.heap<!fir.array<?x!fir.logical<4>>>>
+! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.heap<!fir.array<?x!fir.logical<4>>>) -> i64
+! CHECK: %[[VAL_22:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_23:.*]] = arith.cmpi ne, %[[VAL_21]], %[[VAL_22]] : i64
+! CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_4:.*]] : !fir.ref<index>
+! CHECK: %[[VAL_25:.*]] = fir.load %[[VAL_5:.*]] : !fir.ref<index>
+! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.heap<!fir.array<?x!fir.logical<4>>>>
+! CHECK: %[[VAL_27:.*]] = fir.shape_shift %[[VAL_24]], %[[VAL_25]] : (index, index) -> !fir.shapeshift<1>
+! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_26]](%[[VAL_27]]) : (!fir.heap<!fir.array<?x!fir.logical<4>>>, !fir.shapeshift<1>) -> !fir.box<!fir.array<?x!fir.logical<4>>>
+! CHECK: %[[VAL_29:.*]] = fir.absent !fir.box<!fir.array<?x!fir.logical<4>>>
+! CHECK: %[[VAL_30:.*]] = arith.select %[[VAL_23]], %[[VAL_28]], %[[VAL_29]] : !fir.box<!fir.array<?x!fir.logical<4>>>
+! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_30]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
+! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_37]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
+end function
diff --git a/flang/unittests/Runtime/Time.cpp b/flang/unittests/Runtime/Time.cpp
index ceccb4a70805c..479f82ffe524c 100644
--- a/flang/unittests/Runtime/Time.cpp
+++ b/flang/unittests/Runtime/Time.cpp
@@ -166,3 +166,4 @@ TEST(TimeIntrinsics, DateAndTime) {
EXPECT_LE(minutes, 59);
}
}
+
More information about the flang-commits
mailing list