[flang] Lower of elemental calls in array expression

[clementval]

Summary

This patch adds tests and missing lowering
code to lower elemental function/subroutine calls
in array expression

This patch is part of the upstreaming effort from fir-dev branch.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Optimizer/Builder/Factory.h

originateIndices(mlir::Location loc, B &builder, mlir::Type memTy,
                  mlir::Value shapeVal, mlir::ValueRange indices) {
   llvm::SmallVector<mlir::Value> result;
   auto origins = getOrigins(shapeVal);
   if (origins.empty()) {
     assert(!shapeVal || mlir::isa<fir::ShapeOp>(shapeVal.getDefiningOp()));
     auto ty = fir::dyn_cast_ptrOrBoxEleTy(memTy);
     assert(ty && ty.isa<fir::SequenceType>());
     auto seqTy = ty.cast<fir::SequenceType>();
+    auto one = builder.template create<mlir::arith::ConstantIndexOp>(loc, 1);
     const auto dimension = seqTy.getDimension();
-    assert(shapeVal &&
-           dimension == mlir::cast<fir::ShapeOp>(shapeVal.getDefiningOp())
+    if (shapeVal) {
+      assert(dimension == mlir::cast<fir::ShapeOp>(shapeVal.getDefiningOp())
                               .getType()
                               .getRank());
-    auto one = builder.template create<mlir::arith::ConstantIndexOp>(loc, 1);
+    }
     for (auto i : llvm::enumerate(indices)) {
       if (i.index() < dimension) {
         assert(fir::isa_integer(i.value().getType()));
         result.push_back(
             builder.template create<mlir::arith::AddIOp>(loc, i.value(), one));
       } else {
         result.push_back(i.value());
       }

flang/lib/Lower/ConvertExpr.cpp

if (auto addr = mlir::dyn_cast_or_null<fir::AddrOfOp>(arg.getDefiningOp())) {
     auto &builder = converter.getFirOpBuilder();
     if (auto funcOp = builder.getNamedFunction(addr.getSymbol()))
       if (fir::anyFuncArgsHaveAttr(funcOp, fir::getHostAssocAttrName()))
         return converter.hostAssocTupleValue();
   }
   return {};
 }
 
+/// \p argTy must be a tuple (pair) of boxproc and integral types. Convert the
+/// \p funcAddr argument to a boxproc value, with the host-association as
+/// required. Call the factory function to finish creating the tuple value.
+static mlir::Value
+createBoxProcCharTuple(Fortran::lower::AbstractConverter &converter,
+                       mlir::Type argTy, mlir::Value funcAddr,
+                       mlir::Value charLen) {
+  auto boxTy =
+      argTy.cast<mlir::TupleType>().getType(0).cast<fir::BoxProcType>();
+  mlir::Location loc = converter.getCurrentLocation();
+  auto &builder = converter.getFirOpBuilder();
+  auto boxProc = [&]() -> mlir::Value {
+    if (auto host = argumentHostAssocs(converter, funcAddr))
+      return builder.create<fir::EmboxProcOp>(
+          loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
+    return builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
+  }();
+  return fir::factory::createCharacterProcedureTuple(builder, loc, argTy,
+                                                     boxProc, charLen);
+}
+
 namespace {
 
 /// Lowering of Fortran::evaluate::Expr<T> expressions
 class ScalarExprLowering {
 public:
   using ExtValue = fir::ExtendedValue;
 
   explicit ScalarExprLowering(mlir::Location loc,
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   ExtValue genval(const Fortran::evaluate::ComplexConstructor<KIND> &op) {
     mlir::Value realPartValue = genunbox(op.left());
     return fir::factory::Complex{builder, getLoc()}.createComplex(
         KIND, realPartValue, genunbox(op.right()));
   }
 
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Concat<KIND> &op) {
-    TODO(getLoc(), "genval Concat<KIND>");
+    ExtValue lhs = genval(op.left());
+    ExtValue rhs = genval(op.right());
+    const fir::CharBoxValue *lhsChar = lhs.getCharBox();
+    const fir::CharBoxValue *rhsChar = rhs.getCharBox();
+    if (lhsChar && rhsChar)
+      return fir::factory::CharacterExprHelper{builder, getLoc()}
+          .createConcatenate(*lhsChar, *rhsChar);
+    TODO(getLoc(), "character array concatenate");
   }
 
   /// MIN and MAX operations
   template <Fortran::common::TypeCategory TC, int KIND>
   ExtValue
   genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>
              &op) {
     TODO(getLoc(), "genval Extremum<TC, KIND>");
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,
                            llvm::Optional<mlir::Type> resultType) {
     ExtValue res = genRawProcedureRef(procRef, resultType);
+    // In most contexts, pointers and allocatable do not appear as allocatable
+    // or pointer variable on the caller side (see 8.5.3 note 1 for
+    // allocatables). The few context where this can happen must call
+    // genRawProcedureRef directly.
+    if (const auto *box = res.getBoxOf<fir::MutableBoxValue>())
+      return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
     return res;
   }
 
   /// Given a call site for which the arguments were already lowered, generate
   /// the call and return the result. This function deals with explicit result
   /// allocation and lowering if needed. It also deals with passing the host
   /// link to internal procedures.
   ExtValue genCallOpAndResult(Fortran::lower::CallerInterface &caller,
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());
     };
   }
 
+  /// Lower a procedure reference to a user-defined elemental procedure.
+  CC genElementalUserDefinedProcRef(
+      const Fortran::evaluate::ProcedureRef &procRef,
+      llvm::Optional<mlir::Type> retTy) {
+    using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
+
+    // 10.1.4 p5. Impure elemental procedures must be called in element order.
+    if (const Fortran::semantics::Symbol *procSym = procRef.proc().GetSymbol())
+      if (!Fortran::semantics::IsPureProcedure(*procSym))
+        setUnordered(false);
+
+    Fortran::lower::CallerInterface caller(procRef, converter);
+    llvm::SmallVector<CC> operands;
+    operands.reserve(caller.getPassedArguments().size());
+    mlir::Location loc = getLoc();
+    mlir::FunctionType callSiteType = caller.genFunctionType();
+    for (const Fortran::lower::CallInterface<
+             Fortran::lower::CallerInterface>::PassedEntity &arg :
+         caller.getPassedArguments()) {
+      // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout)
+      // arguments must be called in element order.
+      if (arg.mayBeModifiedByCall())
+        setUnordered(false);
+      const auto *actual = arg.entity;
+      mlir::Type argTy = callSiteType.getInput(arg.firArgument);
+      if (!actual) {
+        // Optional dummy argument for which there is no actual argument.
+        auto absent = builder.create<fir::AbsentOp>(loc, argTy);
+        operands.emplace_back([=](IterSpace) { return absent; });
+        continue;
+      }
+      const auto *expr = actual->UnwrapExpr();
+      if (!expr)
+        TODO(loc, "assumed type actual argument lowering");
+
+      LLVM_DEBUG(expr->AsFortran(llvm::dbgs()
+                                 << "argument: " << arg.firArgument << " = [")
+                 << "]\n");
+      if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
+                                  *expr, converter.getFoldingContext()))
+        TODO(loc,
+             "passing dynamically optional argument to elemental procedures");
+      switch (arg.passBy) {
+      case PassBy::Value: {
+        // True pass-by-value semantics.
+        PushSemantics(ConstituentSemantics::RefTransparent);
+        operands.emplace_back(genElementalArgument(*expr));
+      } break;
+      case PassBy::BaseAddressValueAttribute: {
+        // VALUE attribute or pass-by-reference to a copy semantics. (byval*)
+        if (isArray(*expr)) {
+          PushSemantics(ConstituentSemantics::ByValueArg);
+          operands.emplace_back(genElementalArgument(*expr));
+        } else {
+          // Store scalar value in a temp to fulfill VALUE attribute.
+          mlir::Value val = fir::getBase(asScalar(*expr));
+          mlir::Value temp = builder.createTemporary(
+              loc, val.getType(),
+              llvm::ArrayRef<mlir::NamedAttribute>{
+                  Fortran::lower::getAdaptToByRefAttr(builder)});
+          builder.create<fir::StoreOp>(loc, val, temp);
+          operands.emplace_back(
+              [=](IterSpace iters) -> ExtValue { return temp; });
+        }
+      } break;
+      case PassBy::BaseAddress: {
+        if (isArray(*expr)) {
+          PushSemantics(ConstituentSemantics::RefOpaque);
+          operands.emplace_back(genElementalArgument(*expr));
+        } else {
+          ExtValue exv = asScalarRef(*expr);
+          operands.emplace_back([=](IterSpace iters) { return exv; });
+        }
+      } break;
+      case PassBy::CharBoxValueAttribute: {
+        if (isArray(*expr)) {
+          PushSemantics(ConstituentSemantics::DataValue);
+          auto lambda = genElementalArgument(*expr);
+          operands.emplace_back([=](IterSpace iters) {
+            return fir::factory::CharacterExprHelper{builder, loc}
+                .createTempFrom(lambda(iters));
+          });
+        } else {
+          fir::factory::CharacterExprHelper helper(builder, loc);
+          fir::CharBoxValue argVal = helper.createTempFrom(asScalarRef(*expr));
+          operands.emplace_back(
+              [=](IterSpace iters) -> ExtValue { return argVal; });
+        }
+      } break;
+      case PassBy::BoxChar: {
+        PushSemantics(ConstituentSemantics::RefOpaque);
+        operands.emplace_back(genElementalArgument(*expr));
+      } break;
+      case PassBy::AddressAndLength:
+        // PassBy::AddressAndLength is only used for character results. Results
+        // are not handled here.
+        fir::emitFatalError(
+            loc, "unexpected PassBy::AddressAndLength in elemental call");
+        break;
+      case PassBy::CharProcTuple: {
+        ExtValue argRef = asScalarRef(*expr);
+        mlir::Value tuple = createBoxProcCharTuple(
+            converter, argTy, fir::getBase(argRef), fir::getLen(argRef));
+        operands.emplace_back(
+            [=](IterSpace iters) -> ExtValue { return tuple; });
+      } break;
+      case PassBy::Box:
+      case PassBy::MutableBox:
+        // See C15100 and C15101
+        fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE");
+      }
+    }
+
+    if (caller.getIfIndirectCallSymbol())
+      fir::emitFatalError(loc, "cannot be indirect call");
+
+    // The lambda is mutable so that `caller` copy can be modified inside it.
+    return
+        [=, caller = std::move(caller)](IterSpace iters) mutable -> ExtValue {
+          for (const auto &[cc, argIface] :
+               llvm::zip(operands, caller.getPassedArguments())) {
+            auto exv = cc(iters);
+            auto arg = exv.match(
+                [&](const fir::CharBoxValue &cb) -> mlir::Value {
+                  return fir::factory::CharacterExprHelper{builder, loc}
+                      .createEmbox(cb);
+                },
+                [&](const auto &) { return fir::getBase(exv); });
+            caller.placeInput(argIface, arg);
+          }
+          return ScalarExprLowering{loc, converter, symMap, getElementCtx()}
+              .genCallOpAndResult(caller, callSiteType, retTy);
+        };
+  }
+
   /// Generate a procedure reference. This code is shared for both functions and
   /// subroutines, the difference 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");
+      // Elemental call.
+      // The procedure is called once per element of the array argument(s).
+      return genElementalUserDefinedProcRef(procRef, retTy);
     }
 
     // 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.

flang/lib/Lower/ConvertVariable.cpp

if (isDummy) {
     mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
     if (lowerToBoxValue(sym, dummyArg)) {
       llvm::SmallVector<mlir::Value> lbounds;
       llvm::SmallVector<mlir::Value> extents;
       llvm::SmallVector<mlir::Value> explicitParams;
       // Lower lower bounds, explicit type parameters and explicit
       // extents if any.
       if (ba.isChar())
-        TODO(loc, "lowerToBoxValue character");
+        if (mlir::Value len =
+                lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
+          explicitParams.push_back(len);
       // TODO: derived type length parameters.
       lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
       lowerExplicitExtents(converter, loc, ba, lbounds, extents, symMap,
                            stmtCtx);
       symMap.addBoxSymbol(sym, dummyArg, lbounds, explicitParams, extents,
                           replace);
       return;
     }

flang/lib/Lower/IntrinsicCall.cpp

struct IntrinsicLibrary {
 
   /// Lowering for the ABS intrinsic. The ABS intrinsic expects one argument in
   /// the llvm::ArrayRef. The ABS intrinsic is lowered into MLIR/FIR operation
   /// if the argument is an integer, into llvm intrinsics if the argument is
   /// real and to the `hypot` math routine if the argument is of complex type.
   mlir::Value genAbs(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genAssociated(mlir::Type,
                                    llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genChar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   template <Extremum, ExtremumBehavior>
   mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
   /// 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 genLbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genSize(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);

 /// argument must not be lowered by value. In which case, the lowering rules
 /// should be provided for all the intrinsic arguments for completeness.
 static constexpr IntrinsicHandler handlers[]{
     {"abs", &I::genAbs},
     {"associated",
      &I::genAssociated,
      {{{"pointer", asInquired}, {"target", asInquired}}},
      /*isElemental=*/false},
+    {"char", &I::genChar},
     {"iand", &I::genIand},
     {"sum",
      &I::genSum,
      {{{"array", asBox},
        {"dim", asValue},
        {"mask", asBox, handleDynamicOptional}}},
      /*isElemental=*/false},
     {"ubound",
targetBox = builder.create<mlir::arith::SelectOp>(loc, isPresent, targetBox,
                                                       absentBox);
   }
   mlir::Value pointerBoxRef =
       fir::factory::getMutableIRBox(builder, loc, *pointer);
   auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef);
   return Fortran::lower::genAssociated(builder, loc, pointerBox, targetBox);
 }
 
+// CHAR
+fir::ExtendedValue
+IntrinsicLibrary::genChar(mlir::Type type,
+                          llvm::ArrayRef<fir::ExtendedValue> args) {
+  // Optional KIND argument.
+  assert(args.size() >= 1);
+  const mlir::Value *arg = args[0].getUnboxed();
+  // expect argument to be a scalar integer
+  if (!arg)
+    mlir::emitError(loc, "CHAR intrinsic argument not unboxed");
+  fir::factory::CharacterExprHelper helper{builder, loc};
+  fir::CharacterType::KindTy kind = helper.getCharacterType(type).getFKind();
+  mlir::Value cast = helper.createSingletonFromCode(*arg, kind);
+  mlir::Value len =
+      builder.createIntegerConstant(loc, builder.getCharacterLengthType(), 1);
+  return fir::CharBoxValue{cast, len};
+}
+
 // IAND
 mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType,
                                       llvm::ArrayRef<mlir::Value> args) {
   assert(args.size() == 2);
   return builder.create<mlir::arith::AndIOp>(loc, args[0], args[1]);
 }
 
 // Compare two FIR values and return boolean result as i1.

flang/lib/Lower/array-elemental-calls-2.f90

+! RUN: bbc -o - -emit-fir %s | FileCheck %s
+
+! Test lowering of operations sub-expression inside elemental call arguments.
+! This tests array contexts where an address is needed for each element (for
+! the argument), but part of the array sub-expression must be lowered by value
+! (for the operation)
+
+module test_ops
+    interface
+      integer elemental function elem_func(i)
+        integer, intent(in) :: i
+      end function
+      integer elemental function elem_func_logical(l)
+        logical(8), intent(in) :: l
+      end function
+      integer elemental function elem_func_logical4(l)
+        logical, intent(in) :: l
+      end function
+      integer elemental function elem_func_real(x)
+        real(8), value :: x
+      end function
+    end interface
+    integer :: i(10), j(10), iscalar
+    logical(8) :: a(10), b(10)
+    real(8) :: x(10), y(10)
+    complex(8) :: z1(10), z2
+  
+  contains
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_binary_ops() {
+  subroutine check_binary_ops()
+    print *,  elem_func(i+j)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
+  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
+  ! CHECK:  %[[VAL_27:.*]] = arith.addi %[[VAL_25]], %[[VAL_26]] : i32
+  ! CHECK:  fir.store %[[VAL_27]] to %[[VAL_0]] : !fir.ref<i32>
+  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_binary_ops_2() {
+  subroutine check_binary_ops_2()
+    print *,  elem_func(i*iscalar)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
+  ! CHECK:  %[[VAL_13:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
+  ! CHECK:  %[[VAL_27:.*]] = arith.muli %[[VAL_25]], %[[VAL_13]] : i32
+  ! CHECK:  fir.store %[[VAL_27]] to %[[VAL_0]] : !fir.ref<i32>
+  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_negate() {
+  subroutine check_negate()
+    print *,  elem_func(-i)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
+  ! CHECK:  %[[VAL_22:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_21]] : i32
+  ! CHECK:  fir.store %[[VAL_23]] to %[[VAL_0]] : !fir.ref<i32>
+  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_convert() {
+  subroutine check_convert()
+    print *,  elem_func(int(x))
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
+  ! CHECK:  %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (f64) -> i32
+  ! CHECK:  fir.store %[[VAL_22]] to %[[VAL_0]] : !fir.ref<i32>
+  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_exteremum() {
+  subroutine check_exteremum()
+    print *,  elem_func(min(i, j))
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
+  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xi32>, index) -> i32
+  ! CHECK:  %[[VAL_27:.*]] = arith.cmpi slt, %[[VAL_25]], %[[VAL_26]] : i32
+  ! CHECK:  %[[VAL_28:.*]] = select %[[VAL_27]], %[[VAL_25]], %[[VAL_26]] : i32
+  ! CHECK:  fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref<i32>
+  ! CHECK:  fir.call @_QPelem_func(%[[VAL_0]]) : (!fir.ref<i32>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_logical_unary_ops() {
+  subroutine check_logical_unary_ops()
+    print *,  elem_func_logical(.not.b)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<8>
+  ! CHECK:  %[[VAL_12:.*]] = arith.constant true
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_22:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
+  ! CHECK:  %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (!fir.logical<8>) -> i1
+  ! CHECK:  %[[VAL_24:.*]] = arith.xori %[[VAL_23]], %[[VAL_12]] : i1
+  ! CHECK:  %[[VAL_25:.*]] = fir.convert %[[VAL_24]] : (i1) -> !fir.logical<8>
+  ! CHECK:  fir.store %[[VAL_25]] to %[[VAL_0]] : !fir.ref<!fir.logical<8>>
+  ! CHECK:  fir.call @_QPelem_func_logical(%[[VAL_0]]) : (!fir.ref<!fir.logical<8>>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_logical_binary_ops() {
+  subroutine check_logical_binary_ops()
+    print *,  elem_func_logical(a.eqv.b)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<8>
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
+  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
+  ! CHECK:  %[[VAL_27:.*]] = fir.convert %[[VAL_25]] : (!fir.logical<8>) -> i1
+  ! CHECK:  %[[VAL_28:.*]] = fir.convert %[[VAL_26]] : (!fir.logical<8>) -> i1
+  ! CHECK:  %[[VAL_29:.*]] = arith.cmpi eq, %[[VAL_27]], %[[VAL_28]] : i1
+  ! CHECK:  %[[VAL_30:.*]] = fir.convert %[[VAL_29]] : (i1) -> !fir.logical<8>
+  ! CHECK:  fir.store %[[VAL_30]] to %[[VAL_0]] : !fir.ref<!fir.logical<8>>
+  ! CHECK:  fir.call @_QPelem_func_logical(%[[VAL_0]]) : (!fir.ref<!fir.logical<8>>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_compare() {
+  subroutine check_compare()
+    print *,  elem_func_logical4(x.lt.y)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<4>
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
+  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
+  ! CHECK:  %[[VAL_27:.*]] = arith.cmpf olt, %[[VAL_25]], %[[VAL_26]] : f64
+  ! CHECK:  %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (i1) -> !fir.logical<4>
+  ! CHECK:  fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref<!fir.logical<4>>
+  ! CHECK:  fir.call @_QPelem_func_logical4(%[[VAL_0]]) : (!fir.ref<!fir.logical<4>>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_pow() {
+  subroutine check_pow()
+    print *,  elem_func_real(x**y)
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca f64
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_25:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
+  ! CHECK:  %[[VAL_26:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
+  ! CHECK:  %[[VAL_27:.*]] = fir.call @__fd_pow_1(%[[VAL_25]], %[[VAL_26]]) : (f64, f64) -> f64
+  ! CHECK:  fir.store %[[VAL_27]] to %[[VAL_0]] : !fir.ref<f64>
+  ! CHECK:  %[[VAL_28:.*]] = fir.call @_QPelem_func_real(%[[VAL_0]]) : (!fir.ref<f64>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_cmplx_part() {
+  subroutine check_cmplx_part()
+    print *,  elem_func_real(AIMAG(z1 + z2))
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca f64
+  ! CHECK:  %[[VAL_13:.*]] = fir.load %{{.*}} : !fir.ref<!fir.complex<8>>
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_23:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.complex<8>>, index) -> !fir.complex<8>
+  ! CHECK:  %[[VAL_24:.*]] = fir.addc %[[VAL_23]], %[[VAL_13]] : !fir.complex<8>
+  ! CHECK:  %[[VAL_25:.*]] = fir.extract_value %[[VAL_24]], [1 : index] : (!fir.complex<8>) -> f64
+  ! CHECK:  fir.store %[[VAL_25]] to %[[VAL_0]] : !fir.ref<f64>
+  ! CHECK:  fir.call @_QPelem_func_real(%[[VAL_0]]) : (!fir.ref<f64>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_parentheses() {
+  subroutine check_parentheses()
+    print *,  elem_func_real((x))
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca f64
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10xf64>, index) -> f64
+  ! CHECK:  %[[VAL_22:.*]] = fir.no_reassoc %[[VAL_21]] : f64
+  ! CHECK:  fir.store %[[VAL_22]] to %[[VAL_0]] : !fir.ref<f64>
+  ! CHECK:  fir.call @_QPelem_func_real(%[[VAL_0]]) : (!fir.ref<f64>) -> i32
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMtest_opsPcheck_parentheses_logical() {
+  subroutine check_parentheses_logical()
+    print *,  elem_func_logical((a))
+  ! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.logical<8>
+  ! CHECK:  fir.do_loop
+  ! CHECK:  %[[VAL_21:.*]] = fir.array_fetch %{{.*}}, %{{.*}} : (!fir.array<10x!fir.logical<8>>, index) -> !fir.logical<8>
+  ! CHECK:  %[[VAL_22:.*]] = fir.no_reassoc %[[VAL_21]] : !fir.logical<8>
+  ! CHECK:  fir.store %[[VAL_22]] to %[[VAL_0]] : !fir.ref<!fir.logical<8>>
+  ! CHECK:  fir.call @_QPelem_func_logical(%[[VAL_0]]) : (!fir.ref<!fir.logical<8>>) -> i32
+  end subroutine
+  
+  subroutine check_parentheses_derived(a)
+    type t
+      integer :: i
+    end type  
+    interface
+      integer elemental function elem_func_derived(x)
+        import :: t
+        type(t), intent(in) :: x
+      end function
+    end interface
+    type(t), pointer :: a(:)
+    print *,  elem_func_derived((a))
+  ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>
+  ! CHECK: fir.do_loop
+  ! CHECK: %[[VAL_21:.*]] = fir.array_access %{{.}}, %{{.*}}
+  ! CHECK: %[[VAL_22:.*]] = fir.no_reassoc %[[VAL_21]] : !fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>
+  ! CHECK: %[[FIELD:.*]] = fir.field_index i, !fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>
+  ! CHECK: %[[FROM:.*]] = fir.coordinate_of %[[VAL_22]], %[[FIELD]] : (!fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
+  ! CHECK: %[[TO:.*]] = fir.coordinate_of %[[VAL_0]], %[[FIELD]] : (!fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
+  ! CHECK: %[[VAL:.*]] = fir.load %[[FROM]] : !fir.ref<i32>
+  ! CHECK: fir.store %[[VAL]] to %[[TO]] : !fir.ref<i32>
+  ! CHECK: %25 = fir.call @_QPelem_func_derived(%[[VAL_0]]) : (!fir.ref<!fir.type<_QMtest_opsFcheck_parentheses_derivedTt{i:i32}>>) -> i32
+  end subroutine
+  end module
+  
 No newline at end of file

flang/test/Lower/array-elemental-calls.f90

+! Test lowering of elemental calls in array expressions.
+! RUN: bbc -o - -emit-fir %s | FileCheck %s
+
+module scalar_in_elem
+
+    contains
+    elemental integer function elem_by_ref(a,b) result(r)
+      integer, intent(in) :: a
+      real, intent(in) :: b
+      r = a + b
+    end function
+    elemental integer function elem_by_valueref(a,b) result(r)
+      integer, value :: a
+      real, value :: b
+      r = a + b
+    end function
+    
+    ! CHECK-LABEL: func @_QMscalar_in_elemPtest_elem_by_ref(
+    ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.array<100xi32>>{{.*}}, %[[arg1:.*]]: !fir.ref<!fir.array<100xi32>>{{.*}}) {
+    subroutine test_elem_by_ref(i, j)
+      integer :: i(100), j(100)
+      ! CHECK: %[[tmp:.*]] = fir.alloca f32
+      ! CHECK: %[[cst:.*]] = arith.constant 4.200000e+01 : f32
+      ! CHECK: fir.store %[[cst]] to %[[tmp]] : !fir.ref<f32>
+    
+      ! CHECK: fir.do_loop
+        ! CHECK: %[[j:.*]] = fir.array_coor %[[arg1]](%{{.*}}) %{{.*}} : (!fir.ref<!fir.array<100xi32>>, !fir.shape<1>, index) -> !fir.ref<i32>
+        ! CHECK: fir.call @_QMscalar_in_elemPelem_by_ref(%[[j]], %[[tmp]]) : (!fir.ref<i32>, !fir.ref<f32>) -> i32
+        ! CHECK: fir.result
+      i = elem_by_ref(j, 42.)
+    end
+    
+    ! CHECK-LABEL: func @_QMscalar_in_elemPtest_elem_by_valueref(
+    ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.array<100xi32>>{{.*}}, %[[arg1:.*]]: !fir.ref<!fir.array<100xi32>>{{.*}}) {
+    subroutine test_elem_by_valueref(i, j)
+      integer :: i(100), j(100)
+      ! CHECK-DAG: %[[tmpA:.*]] = fir.alloca i32 {adapt.valuebyref}
+      ! CHECK-DAG: %[[tmpB:.*]] = fir.alloca f32 {adapt.valuebyref}
+      ! CHECK: %[[jload:.*]] = fir.array_load %[[arg1]]
+      ! CHECK: %[[cst:.*]] = arith.constant 4.200000e+01 : f32
+      ! CHECK: fir.store %[[cst]] to %[[tmpB]] : !fir.ref<f32>
+    
+      ! CHECK: fir.do_loop
+        ! CHECK: %[[j:.*]] = fir.array_fetch %[[jload]], %{{.*}} : (!fir.array<100xi32>, index) -> i32
+        ! CHECK: fir.store %[[j]] to %[[tmpA]] : !fir.ref<i32>
+        ! CHECK: fir.call @_QMscalar_in_elemPelem_by_valueref(%[[tmpA]], %[[tmpB]]) : (!fir.ref<i32>, !fir.ref<f32>) -> i32
+        ! CHECK: fir.result
+      i = elem_by_valueref(j, 42.)
+    end
+    end module
+    
+    
+    ! Test that impure elemental functions cause ordered loops to be emitted
+    subroutine test_loop_order(i, j)
+      integer :: i(:), j(:)
+      interface
+        elemental integer function pure_func(j)
+          integer, intent(in) :: j
+        end function
+        elemental impure integer function impure_func(j)
+          integer, intent(in) :: j
+        end function
+      end interface
+      
+      i = 42 + pure_func(j)
+      i = 42 + impure_func(j)
+    end subroutine
+    
+    ! CHECK-LABEL: func @_QPtest_loop_order(
+    ! CHECK-SAME:    %[[VAL_0:.*]]: !fir.box<!fir.array<?xi32>>{{.*}}, %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>>{{.*}}) {
+    ! CHECK:         %[[VAL_2:.*]] = arith.constant 0 : index
+    ! CHECK:         %[[VAL_3:.*]]:3 = fir.box_dims %[[VAL_0]], %[[VAL_2]] : (!fir.box<!fir.array<?xi32>>, index) -> (index, index, index)
+    ! CHECK:         %[[VAL_4:.*]] = fir.array_load %[[VAL_0]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
+    ! CHECK:         %[[VAL_5:.*]] = arith.constant 42 : i32
+    ! CHECK:         %[[VAL_6:.*]] = arith.constant 1 : index
+    ! CHECK:         %[[VAL_7:.*]] = arith.constant 0 : index
+    ! CHECK:         %[[VAL_8:.*]] = arith.subi %[[VAL_3]]#1, %[[VAL_6]] : index
+    ! CHECK:         %[[VAL_9:.*]] = fir.do_loop %[[VAL_10:.*]] = %[[VAL_7]] to %[[VAL_8]] step %[[VAL_6]] unordered iter_args(%[[VAL_11:.*]] = %[[VAL_4]]) -> (!fir.array<?xi32>) {
+    ! CHECK:           %[[VAL_12:.*]] = arith.constant 1 : index
+    ! CHECK:           %[[VAL_13:.*]] = arith.addi %[[VAL_10]], %[[VAL_12]] : index
+    ! CHECK:           %[[VAL_14:.*]] = fir.array_coor %[[VAL_1]] %[[VAL_13]] : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
+    ! CHECK:           %[[VAL_15:.*]] = fir.call @_QPpure_func(%[[VAL_14]]) : (!fir.ref<i32>) -> i32
+    ! CHECK:           %[[VAL_16:.*]] = arith.addi %[[VAL_5]], %[[VAL_15]] : i32
+    ! CHECK:           %[[VAL_17:.*]] = fir.array_update %[[VAL_11]], %[[VAL_16]], %[[VAL_10]] : (!fir.array<?xi32>, i32, index) -> !fir.array<?xi32>
+    ! CHECK:           fir.result %[[VAL_17]] : !fir.array<?xi32>
+    ! CHECK:         }
+    ! CHECK:         fir.array_merge_store %[[VAL_4]], %[[VAL_18:.*]] to %[[VAL_0]] : !fir.array<?xi32>, !fir.array<?xi32>, !fir.box<!fir.array<?xi32>>
+    ! CHECK:         %[[VAL_19:.*]] = arith.constant 0 : index
+    ! CHECK:         %[[VAL_20:.*]]:3 = fir.box_dims %[[VAL_0]], %[[VAL_19]] : (!fir.box<!fir.array<?xi32>>, index) -> (index, index, index)
+    ! CHECK:         %[[VAL_21:.*]] = fir.array_load %[[VAL_0]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
+    ! CHECK:         %[[VAL_22:.*]] = arith.constant 42 : i32
+    ! CHECK:         %[[VAL_23:.*]] = arith.constant 1 : index
+    ! CHECK:         %[[VAL_24:.*]] = arith.constant 0 : index
+    ! CHECK:         %[[VAL_25:.*]] = arith.subi %[[VAL_20]]#1, %[[VAL_23]] : index
+    ! CHECK:         %[[VAL_26:.*]] = fir.do_loop %[[VAL_27:.*]] = %[[VAL_24]] to %[[VAL_25]] step %[[VAL_23]] iter_args(%[[VAL_28:.*]] = %[[VAL_21]]) -> (!fir.array<?xi32>) {
+    ! CHECK:           %[[VAL_29:.*]] = arith.constant 1 : index
+    ! CHECK:           %[[VAL_30:.*]] = arith.addi %[[VAL_27]], %[[VAL_29]] : index
+    ! CHECK:           %[[VAL_31:.*]] = fir.array_coor %[[VAL_1]] %[[VAL_30]] : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
+    ! CHECK:           %[[VAL_32:.*]] = fir.call @_QPimpure_func(%[[VAL_31]]) : (!fir.ref<i32>) -> i32
+    ! CHECK:           %[[VAL_33:.*]] = arith.addi %[[VAL_22]], %[[VAL_32]] : i32
+    ! CHECK:           %[[VAL_34:.*]] = fir.array_update %[[VAL_28]], %[[VAL_33]], %[[VAL_27]] : (!fir.array<?xi32>, i32, index) -> !fir.array<?xi32>
+    ! CHECK:           fir.result %[[VAL_34]] : !fir.array<?xi32>
+    ! CHECK:         }
+    ! CHECK:         fir.array_merge_store %[[VAL_21]], %[[VAL_35:.*]] to %[[VAL_0]] : !fir.array<?xi32>, !fir.array<?xi32>, !fir.box<!fir.array<?xi32>>
+    ! CHECK:         return
+    ! CHECK:       }