[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@nvidia.com>
Co-authored-by: Jean Perier <jperier@nvidia.com>
Co-authored-by: mleair <leairmark@gmail.com>

flang/include/flang/Lower/AbstractConverter.h

@@ -76,6 +76,9 @@ public:
   /// 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;
 

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.

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

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.

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
 //===----------------------------------------------------------------------===//

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>())

flang/lib/Lower/Bridge.cpp

@@ -177,6 +177,13 @@ public:
     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 @@ private:
     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 @@ private:
     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 @@ private:
     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 @@ private:
   // 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 &) {

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

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");
+}

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)
+  explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc,
-      : builder{builder}, loc{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 different 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");
+  if (!resultType)
-  return {};
+    // 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,
+    std::string buffer("not yet implemented: missing intrinsic lowering: ");
-                    "TODO: missing intrinsic lowering: " + llvm::Twine(name));
+    llvm::raw_string_ostream sstream(buffer);
-    llvm::errs() << "requested type was: " << soughtFuncType << "\n";
+    sstream << name << "\nrequested type was: " << soughtFuncType << '\n';
-    exit(1);
+    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) {
+                                 llvm::ArrayRef<fir::ExtendedValue> args,
-  return IntrinsicLibrary{builder, loc}.genIntrinsicCall(name, resultType,
+                                 Fortran::lower::StatementContext &stmtCtx) {
-                                                         args);
+  return IntrinsicLibrary{builder, loc, &stmtCtx}.genIntrinsicCall(
+      name, resultType, args);
 }
 
 mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder,

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

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 {

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

flang/unittests/Runtime/Time.cpp

@@ -166,3 +166,4 @@ TEST(TimeIntrinsics, DateAndTime) {
     EXPECT_LE(minutes, 59);
   }
 }
+