llvm · khaki3 · Apr 18, 2024
diff --git a/flang/examples/FeatureList/FeatureList.cpp b/flang/examples/FeatureList/FeatureList.cpp
@@ -410,10 +410,12 @@ struct NodeVisitor {
   READ_FEATURE(LetterSpec)
   READ_FEATURE(LiteralConstant)
   READ_FEATURE(IntLiteralConstant)
+  READ_FEATURE(ReduceOperation)
   READ_FEATURE(LocalitySpec)
   READ_FEATURE(LocalitySpec::DefaultNone)
   READ_FEATURE(LocalitySpec::Local)
   READ_FEATURE(LocalitySpec::LocalInit)
+  READ_FEATURE(LocalitySpec::Reduce)
   READ_FEATURE(LocalitySpec::Shared)
   READ_FEATURE(LockStmt)
   READ_FEATURE(LockStmt::LockStat)

diff --git a/flang/include/flang/Optimizer/Dialect/FIRAttr.td b/flang/include/flang/Optimizer/Dialect/FIRAttr.td
@@ -67,6 +67,36 @@ def fir_BoxFieldAttr : I32EnumAttr<
   let cppNamespace = "fir";
 }
 
+def fir_ReduceOperationEnum : I32BitEnumAttr<"ReduceOperationEnum",
+    "intrinsic operations and functions supported by DO CONCURRENT REDUCE",
+    [
+      I32BitEnumAttrCaseBit<"Add", 0, "add">,
+      I32BitEnumAttrCaseBit<"Multiply", 1, "multiply">,
+      I32BitEnumAttrCaseBit<"AND", 2, "and">,
+      I32BitEnumAttrCaseBit<"OR", 3, "or">,
+      I32BitEnumAttrCaseBit<"EQV", 4, "eqv">,
+      I32BitEnumAttrCaseBit<"NEQV", 5, "neqv">,
+      I32BitEnumAttrCaseBit<"MAX", 6, "max">,
+      I32BitEnumAttrCaseBit<"MIN", 7, "min">,
+      I32BitEnumAttrCaseBit<"IAND", 8, "iand">,
+      I32BitEnumAttrCaseBit<"IOR", 9, "ior">,
+      I32BitEnumAttrCaseBit<"EIOR", 10, "eior">
+    ]> {
+  let separator = ", ";
+  let cppNamespace = "::fir";
+  let printBitEnumPrimaryGroups = 1;
+}
+
+def fir_ReduceAttr : fir_Attr<"Reduce"> {
+  let mnemonic = "reduce_attr";
+
+  let parameters = (ins
+    "ReduceOperationEnum":$reduce_operation
+  );
+
+  let assemblyFormat = "`<` $reduce_operation `>`";
+}
+
 // mlir::SideEffects::Resource for modelling operations which add debugging information
 def DebuggingResource : Resource<"::fir::DebuggingResource">;
 

diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td
@@ -2062,8 +2062,37 @@ class region_Op<string mnemonic, list<Trait> traits = []> :
   let hasVerifier = 1;
 }
 
-def fir_DoLoopOp : region_Op<"do_loop",
-    [DeclareOpInterfaceMethods<LoopLikeOpInterface,
+def fir_ReduceOp : fir_SimpleOp<"reduce", [NoMemoryEffect]> {
+  let summary = "Represent reduction semantics for the reduce clause";
+
+  let description = [{
+    Given the address of a variable, creates reduction information for the
+    reduce clause.
+
+    ```
+      %17 = fir.reduce %8 {name = "sum"} : (!fir.ref<f32>) -> !fir.ref<f32>
+      fir.do_loop ... unordered reduce(#fir.reduce_attr<add> -> %17 : !fir.ref<f32>) ...
+    ```
+
+    This operation is typically used for DO CONCURRENT REDUCE clause. The memref
+    operand may have a unique name while the `name` attribute preserves the
+    original name of a reduction variable.
+  }];
+
+  let arguments = (ins
+     AnyRefOrBoxLike:$memref,
+     Builtin_StringAttr:$name
+  );
+
+  let results = (outs AnyRefOrBox);
+
+  let assemblyFormat = [{
+    operands attr-dict `:` functional-type(operands, results)
+  }];
+}
+
+def fir_DoLoopOp : region_Op<"do_loop", [AttrSizedOperandSegments,
+    DeclareOpInterfaceMethods<LoopLikeOpInterface,
         ["getYieldedValuesMutable"]>]> {
   let summary = "generalized loop operation";
   let description = [{
@@ -2095,7 +2124,9 @@ def fir_DoLoopOp : region_Op<"do_loop",
     Index:$step,
     Variadic<AnyType>:$initArgs,
     OptionalAttr<UnitAttr>:$unordered,
-    OptionalAttr<UnitAttr>:$finalValue
+    OptionalAttr<UnitAttr>:$finalValue,
+    Variadic<AnyType>:$reduceOperands,
+    OptionalAttr<ArrayAttr>:$reduceAttrs
   );
   let results = (outs Variadic<AnyType>:$results);
   let regions = (region SizedRegion<1>:$region);
@@ -2106,6 +2137,8 @@ def fir_DoLoopOp : region_Op<"do_loop",
       "mlir::Value":$step, CArg<"bool", "false">:$unordered,
       CArg<"bool", "false">:$finalCountValue,
       CArg<"mlir::ValueRange", "std::nullopt">:$iterArgs,
+      CArg<"mlir::ValueRange", "std::nullopt">:$reduceOperands,
+      CArg<"llvm::ArrayRef<mlir::Attribute>", "{}">:$reduceAttrs,
       CArg<"llvm::ArrayRef<mlir::NamedAttribute>", "{}">:$attributes)>
   ];
 
@@ -2118,11 +2151,13 @@ def fir_DoLoopOp : region_Op<"do_loop",
       return getBody()->getArguments().drop_front();
     }
     mlir::Operation::operand_range getIterOperands() {
-      return getOperands().drop_front(getNumControlOperands());
+      return getOperands().drop_front(getNumControlOperands())
+          .take_front(getNumIterOperands());
     }
     llvm::MutableArrayRef<mlir::OpOperand> getInitsMutable() {
       return
-          getOperation()->getOpOperands().drop_front(getNumControlOperands());
+          getOperation()->getOpOperands().drop_front(getNumControlOperands())
+          .take_front(getNumIterOperands());
     }
 
     void setLowerBound(mlir::Value bound) { (*this)->setOperand(0, bound); }
@@ -2131,17 +2166,31 @@ def fir_DoLoopOp : region_Op<"do_loop",
 
     /// Number of region arguments for loop-carried values
     unsigned getNumRegionIterArgs() {
-      return getBody()->getNumArguments() - 1;
+      return getBody()->getNumArguments() - (1 + getNumReduceOperands());
     }
     /// Number of operands controlling the loop: lb, ub, step
     unsigned getNumControlOperands() { return 3; }
     /// Does the operation hold operands for loop-carried values
     bool hasIterOperands() {
-      return (*this)->getNumOperands() > getNumControlOperands();
+      return getNumIterOperands() > 0;
+    }
+    /// Does the operation hold operands for reduction variables
+    bool hasReduceOperands() {
+      return getNumReduceOperands() > 0;
+    }
+    /// Get Number of variadic operands
+    unsigned getNumOperands(unsigned idx) {
+      auto segments = (*this)->getAttrOfType<mlir::DenseI32ArrayAttr>(
+        getOperandSegmentSizeAttr());
+      return static_cast<unsigned>(segments[idx]);
     }
     /// Get Number of loop-carried values
     unsigned getNumIterOperands() {
-      return (*this)->getNumOperands() - getNumControlOperands();
+      return getNumOperands(3);
+    }
+    // Get Number of reduction operands
+    unsigned getNumReduceOperands() {
+      return getNumOperands(4);
     }
 
     /// Get the body of the loop

diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h
@@ -436,10 +436,12 @@ class ParseTreeDumper {
   NODE(parser, LetterSpec)
   NODE(parser, LiteralConstant)
   NODE(parser, IntLiteralConstant)
+  NODE(parser, ReduceOperation)
   NODE(parser, LocalitySpec)
   NODE(LocalitySpec, DefaultNone)
   NODE(LocalitySpec, Local)
   NODE(LocalitySpec, LocalInit)
+  NODE(LocalitySpec, Reduce)
   NODE(LocalitySpec, Shared)
   NODE(parser, LockStmt)
   NODE(LockStmt, LockStat)

diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
@@ -1870,6 +1870,13 @@ struct ProcComponentRef {
   WRAPPER_CLASS_BOILERPLATE(ProcComponentRef, Scalar<StructureComponent>);
 };
 
+// R1522 procedure-designator ->
+//         procedure-name | proc-component-ref | data-ref % binding-name
+struct ProcedureDesignator {
+  UNION_CLASS_BOILERPLATE(ProcedureDesignator);
+  std::variant<Name, ProcComponentRef> u;
+};
+
 // R914 coindexed-named-object -> data-ref
 struct CoindexedNamedObject {
   BOILERPLATE(CoindexedNamedObject);
@@ -2236,16 +2243,29 @@ struct ConcurrentHeader {
       t;
 };
 
+// F'2023 R1131 reduce-operation ->
+//                + | * | .AND. | .OR. | .EQV. | .NEQV. |
+//                MAX | MIN | IAND | IOR | IEOR
+struct ReduceOperation {
+  UNION_CLASS_BOILERPLATE(ReduceOperation);
+  std::variant<DefinedOperator, ProcedureDesignator> u;
+};
+
 // R1130 locality-spec ->
 //         LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
+//         REDUCE ( reduce-operation : variable-name-list ) |
 //         SHARED ( variable-name-list ) | DEFAULT ( NONE )
 struct LocalitySpec {
   UNION_CLASS_BOILERPLATE(LocalitySpec);
   WRAPPER_CLASS(Local, std::list<Name>);
   WRAPPER_CLASS(LocalInit, std::list<Name>);
+  struct Reduce {
+    TUPLE_CLASS_BOILERPLATE(Reduce);
+    std::tuple<ReduceOperation, std::list<Name>> t;
+  };
   WRAPPER_CLASS(Shared, std::list<Name>);
   EMPTY_CLASS(DefaultNone);
-  std::variant<Local, LocalInit, Shared, DefaultNone> u;
+  std::variant<Local, LocalInit, Reduce, Shared, DefaultNone> u;
 };
 
 // R1123 loop-control ->
@@ -3180,13 +3200,6 @@ WRAPPER_CLASS(ExternalStmt, std::list<Name>);
 // R1519 intrinsic-stmt -> INTRINSIC [::] intrinsic-procedure-name-list
 WRAPPER_CLASS(IntrinsicStmt, std::list<Name>);
 
-// R1522 procedure-designator ->
-//         procedure-name | proc-component-ref | data-ref % binding-name
-struct ProcedureDesignator {
-  UNION_CLASS_BOILERPLATE(ProcedureDesignator);
-  std::variant<Name, ProcComponentRef> u;
-};
-
 // R1525 alt-return-spec -> * label
 WRAPPER_CLASS(AltReturnSpec, Label);
 

diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
@@ -714,6 +714,7 @@ class Symbol {
       CrayPointer, CrayPointee,
       LocalityLocal, // named in LOCAL locality-spec
       LocalityLocalInit, // named in LOCAL_INIT locality-spec
+      LocalityReduce, // named in REDUCE locality-spec
       LocalityShared, // named in SHARED locality-spec
       InDataStmt, // initialized in a DATA statement, =>object, or /init/
       InNamelist, // in a Namelist group

diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
@@ -101,7 +101,7 @@ struct IncrementLoopInfo {
 
   bool hasLocalitySpecs() const {
     return !localSymList.empty() || !localInitSymList.empty() ||
-           !sharedSymList.empty();
+           !reduceSymList.empty() || !sharedSymList.empty();
   }
 
   // Data members common to both structured and unstructured loops.
@@ -113,6 +113,8 @@ struct IncrementLoopInfo {
   bool isUnordered; // do concurrent, forall
   llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList;
   llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList;
+  llvm::SmallVector<std::pair<fir::ReduceOperationEnum,
+      const Fortran::semantics::Symbol *>> reduceSymList;
   llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList;
   mlir::Value loopVariable = nullptr;
 
@@ -1696,6 +1698,62 @@ class FirConverter : public Fortran::lower::AbstractConverter {
     builder->create<fir::UnreachableOp>(loc);
   }
 
+  fir::ReduceOperationEnum getReduceOperationEnum(
+      const Fortran::parser::ReduceOperation &rOpr) const {
+    fir::ReduceOperationEnum reduce_operation = fir::ReduceOperationEnum::Add;
+    using IntrinsicOperator =
+        Fortran::parser::DefinedOperator::IntrinsicOperator;
+    std::visit(
+        Fortran::common::visitors{
+            [&](const Fortran::parser::DefinedOperator &dOpr) {
+              const auto &intrinsicOp{std::get<IntrinsicOperator>(dOpr.u)};
+              switch (intrinsicOp) {
+              case IntrinsicOperator::Add:
+                reduce_operation = fir::ReduceOperationEnum::Add;
+                return;
+              case IntrinsicOperator::Multiply:
+                reduce_operation = fir::ReduceOperationEnum::Multiply;
+                return;
+              case IntrinsicOperator::AND:
+                reduce_operation = fir::ReduceOperationEnum::AND;
+                return;
+              case IntrinsicOperator::OR:
+                reduce_operation = fir::ReduceOperationEnum::OR;
+                return;
+              case IntrinsicOperator::EQV:
+                reduce_operation = fir::ReduceOperationEnum::EQV;
+                return;
+              case IntrinsicOperator::NEQV:
+                reduce_operation = fir::ReduceOperationEnum::NEQV;
+                return;
+              default:
+                return;
+              }
+            },
+            [&](const Fortran::parser::ProcedureDesignator &procD) {
+              const Fortran::parser::Name *name{
+                std::get_if<Fortran::parser::Name>(&procD.u)
+              };
+              if (name && name->symbol) {
+                const Fortran::parser::CharBlock
+                    &realName{name->symbol->GetUltimate().name()};
+                if (realName == "max")
+                  reduce_operation = fir::ReduceOperationEnum::MAX;
+                else if (realName == "min")
+                  reduce_operation = fir::ReduceOperationEnum::MIN;
+                else if (realName == "iand")
+                  reduce_operation = fir::ReduceOperationEnum::IAND;
+                else if (realName == "ior")
+                  reduce_operation = fir::ReduceOperationEnum::IOR;
+                else if (realName == "ieor")
+                  reduce_operation = fir::ReduceOperationEnum::EIOR;
+              }
+            }
+        },
+        rOpr.u);
+    return fir::ReduceOperationEnum(reduce_operation);
+  }
+
   /// Collect DO CONCURRENT or FORALL loop control information.
   IncrementLoopNestInfo getConcurrentControl(
       const Fortran::parser::ConcurrentHeader &header,
@@ -1718,6 +1776,15 @@ class FirConverter : public Fortran::lower::AbstractConverter {
               std::get_if<Fortran::parser::LocalitySpec::LocalInit>(&x.u))
         for (const Fortran::parser::Name &x : localInitList->v)
           info.localInitSymList.push_back(x.symbol);
+      if (const auto *reduceList =
+              std::get_if<Fortran::parser::LocalitySpec::Reduce>(&x.u)) {
+        fir::ReduceOperationEnum reduce_operation = getReduceOperationEnum(
+            std::get<Fortran::parser::ReduceOperation>(reduceList->t));
+        for (const Fortran::parser::Name &x :
+                 std::get<std::list<Fortran::parser::Name>>(reduceList->t)) {
+          info.reduceSymList.push_back(std::make_pair(reduce_operation, x.symbol));
+        }
+      }
       if (const auto *sharedList =
               std::get_if<Fortran::parser::LocalitySpec::Shared>(&x.u))
         for (const Fortran::parser::Name &x : sharedList->v)
@@ -1910,9 +1977,26 @@ class FirConverter : public Fortran::lower::AbstractConverter {
         mlir::Type loopVarType = info.getLoopVariableType();
         mlir::Value loopValue;
         if (info.isUnordered) {
+          llvm::SmallVector<mlir::Value> reduceOperands;
+          llvm::SmallVector<mlir::Attribute> reduceAttrs;
+          // Create DO CONCURRENT reduce operations and attributes
+          for (const auto reduceSym : info.reduceSymList) {
+            const fir::ReduceOperationEnum reduce_operation = reduceSym.first;
+            const Fortran::semantics::Symbol *sym = reduceSym.second;
+            fir::ExtendedValue exv = getSymbolExtendedValue(*sym, nullptr);
+            auto reduce_op = builder->create<fir::ReduceOp>(
+                loc, fir::ReferenceType::get(genType(*sym)), fir::getBase(exv),
+                builder->getStringAttr(sym->name().ToString()));
+            reduceOperands.push_back(reduce_op);
+            auto reduce_attr = fir::ReduceAttr::get(
+                builder->getContext(), reduce_operation);
+            reduceAttrs.push_back(reduce_attr);
+          }
           // The loop variable value is explicitly updated.
           info.doLoop = builder->create<fir::DoLoopOp>(
-              loc, lowerValue, upperValue, stepValue, /*unordered=*/true);
+              loc, lowerValue, upperValue, stepValue, /*unordered=*/true,
+              /*finalCountValue=*/false, /*iterArgs=*/std::nullopt,
+              llvm::ArrayRef<mlir::Value>(reduceOperands), reduceAttrs);
           builder->setInsertionPointToStart(info.doLoop.getBody());
           loopValue = builder->createConvert(loc, loopVarType,
                                              info.doLoop.getInductionVar());

diff --git a/flang/lib/Optimizer/Dialect/FIRAttr.cpp b/flang/lib/Optimizer/Dialect/FIRAttr.cpp
@@ -297,8 +297,8 @@ void fir::printFirAttribute(FIROpsDialect *dialect, mlir::Attribute attr,
 
 void FIROpsDialect::registerAttributes() {
   addAttributes<ClosedIntervalAttr, ExactTypeAttr, FortranVariableFlagsAttr,
-                LowerBoundAttr, PointIntervalAttr, RealAttr, SubclassAttr,
-                UpperBoundAttr, CUDADataAttributeAttr, CUDAProcAttributeAttr,
-                CUDALaunchBoundsAttr, CUDAClusterDimsAttr,
-                CUDADataTransferKindAttr>();
+                LowerBoundAttr, PointIntervalAttr, RealAttr, ReduceAttr,
+                SubclassAttr, UpperBoundAttr, CUDADataAttributeAttr,
+                CUDAProcAttributeAttr, CUDALaunchBoundsAttr,
+                CUDAClusterDimsAttr, CUDADataTransferKindAttr>();
 }