[flang][openmp]Add UserReductionDetails and use in DECLARE REDUCTION

This adds another puzzle piece for the support of OpenMP DECLARE
REDUCTION functionality.

This adds support for operators with derived types, as well as declaring
multiple different types with the same name or operator.

A new detail class for UserReductionDetials is introduced to hold
the list of types supported for a given reduction declaration.

Tests for parsing and symbol generation added.

Declare reduction is still not supported to lowering, it
will generate a "Not yet implemented" fatal error.

Author: Leporacanthicus

flang/include/flang/Semantics/symbol.h

@@ -701,14 +701,33 @@ class GenericDetails {
 };
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const GenericDetails &);
 
+class UserReductionDetails : public WithBindName {
+public:
+  using TypeVector = std::vector<const DeclTypeSpec *>;
+  UserReductionDetails() = default;
+
+  void AddType(const DeclTypeSpec *type) { typeList_.push_back(type); }
+  const TypeVector &GetTypeList() const { return typeList_; }
+
+  bool SupportsType(const DeclTypeSpec *type) const {
+    for (auto t : typeList_)
+      if (t == type)
+        return true;
+    return false;
+  }
+
+private:
+  TypeVector typeList_;
+};
+
 class UnknownDetails {};
 
 using Details = std::variant<UnknownDetails, MainProgramDetails, ModuleDetails,
     SubprogramDetails, SubprogramNameDetails, EntityDetails,
     ObjectEntityDetails, ProcEntityDetails, AssocEntityDetails,
     DerivedTypeDetails, UseDetails, UseErrorDetails, HostAssocDetails,
     GenericDetails, ProcBindingDetails, NamelistDetails, CommonBlockDetails,
-    TypeParamDetails, MiscDetails>;
+    TypeParamDetails, MiscDetails, UserReductionDetails>;
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const Details &);
 std::string DetailsToString(const Details &);
 

flang/lib/Semantics/check-omp-structure.cpp

@@ -8,6 +8,7 @@
 
 #include "check-omp-structure.h"
 #include "definable.h"
+#include "resolve-names-utils.h"
 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Evaluate/type.h"
@@ -3361,8 +3362,8 @@ bool OmpStructureChecker::CheckReductionOperator(
       valid =
           llvm::is_contained({"max", "min", "iand", "ior", "ieor"}, realName);
       if (!valid) {
-        auto *misc{name->symbol->detailsIf<MiscDetails>()};
-        valid = misc && misc->kind() == MiscDetails::Kind::ConstructName;
+        auto *reductionDetails{name->symbol->detailsIf<UserReductionDetails>()};
+        valid = reductionDetails != nullptr;
       }
     }
     if (!valid) {
@@ -3444,7 +3445,8 @@ void OmpStructureChecker::CheckReductionObjects(
 }
 
 static bool IsReductionAllowedForType(
-    const parser::OmpReductionIdentifier &ident, const DeclTypeSpec &type) {
+    const parser::OmpReductionIdentifier &ident, const DeclTypeSpec &type,
+    const Scope &scope) {
   auto isLogical{[](const DeclTypeSpec &type) -> bool {
     return type.category() == DeclTypeSpec::Logical;
   }};
@@ -3464,9 +3466,11 @@ static bool IsReductionAllowedForType(
       case parser::DefinedOperator::IntrinsicOperator::Multiply:
       case parser::DefinedOperator::IntrinsicOperator::Add:
       case parser::DefinedOperator::IntrinsicOperator::Subtract:
-        return type.IsNumeric(TypeCategory::Integer) ||
+        if (type.IsNumeric(TypeCategory::Integer) ||
             type.IsNumeric(TypeCategory::Real) ||
-            type.IsNumeric(TypeCategory::Complex);
+            type.IsNumeric(TypeCategory::Complex))
+          return true;
+        break;
 
       case parser::DefinedOperator::IntrinsicOperator::AND:
       case parser::DefinedOperator::IntrinsicOperator::OR:
@@ -3479,8 +3483,18 @@ static bool IsReductionAllowedForType(
         DIE("This should have been caught in CheckIntrinsicOperator");
         return false;
       }
+      parser::CharBlock name{MakeNameFromOperator(*intrinsicOp)};
+      Symbol *symbol{scope.FindSymbol(name)};
+      if (symbol) {
+        const auto *reductionDetails{symbol->detailsIf<UserReductionDetails>()};
+        assert(reductionDetails && "Expected to find reductiondetails");
+
+        return reductionDetails->SupportsType(&type);
+      }
+      return false;
     }
-    return true;
+    assert(0 && "Intrinsic Operator not found - parsing gone wrong?");
+    return false; // Reject everything else.
   }};
 
   auto checkDesignator{[&](const parser::ProcedureDesignator &procD) {
@@ -3493,18 +3507,42 @@ static bool IsReductionAllowedForType(
         // IAND: arguments must be integers: F2023 16.9.100
         // IEOR: arguments must be integers: F2023 16.9.106
         // IOR: arguments must be integers: F2023 16.9.111
-        return type.IsNumeric(TypeCategory::Integer);
+        if (type.IsNumeric(TypeCategory::Integer)) {
+          return true;
+        }
       } else if (realName == "max" || realName == "min") {
         // MAX: arguments must be integer, real, or character:
         // F2023 16.9.135
         // MIN: arguments must be integer, real, or character:
         // F2023 16.9.141
-        return type.IsNumeric(TypeCategory::Integer) ||
-            type.IsNumeric(TypeCategory::Real) || isCharacter(type);
+        if (type.IsNumeric(TypeCategory::Integer) ||
+            type.IsNumeric(TypeCategory::Real) || isCharacter(type)) {
+          return true;
+        }
       }
+
+      // If we get here, it may be a user declared reduction, so check
+      // if the symbol has UserReductionDetails, and if so, the type is
+      // supported.
+      if (const auto *reductionDetails{
+              name->symbol->detailsIf<UserReductionDetails>()}) {
+        return reductionDetails->SupportsType(&type);
+      }
+
+      // We also need to check for mangled names (max, min, iand, ieor and ior)
+      // and then check if the type is there.
+      parser::CharBlock mangledName = MangleSpecialFunctions(name->source);
+      if (const auto &symbol{scope.FindSymbol(mangledName)}) {
+        if (const auto *reductionDetails{
+                symbol->detailsIf<UserReductionDetails>()}) {
+          return reductionDetails->SupportsType(&type);
+        }
+      }
+      // Everything else is "not matching type".
+      return false;
     }
-    // TODO: user defined reduction operators. Just allow everything for now.
-    return true;
+    assert(0 && "name and name->symbol should be set here...");
+    return false;
   }};
 
   return common::visit(
@@ -3519,7 +3557,8 @@ void OmpStructureChecker::CheckReductionObjectTypes(
 
   for (auto &[symbol, source] : symbols) {
     if (auto *type{symbol->GetType()}) {
-      if (!IsReductionAllowedForType(ident, *type)) {
+      const auto &scope{context_.FindScope(symbol->name())};
+      if (!IsReductionAllowedForType(ident, *type, scope)) {
         context_.Say(source,
             "The type of '%s' is incompatible with the reduction operator."_err_en_US,
             symbol->name());

flang/lib/Semantics/resolve-names-utils.h

@@ -146,5 +146,9 @@ struct SymbolAndTypeMappings;
 void MapSubprogramToNewSymbols(const Symbol &oldSymbol, Symbol &newSymbol,
     Scope &newScope, SymbolAndTypeMappings * = nullptr);
 
+parser::CharBlock MakeNameFromOperator(
+    const parser::DefinedOperator::IntrinsicOperator &op);
+parser::CharBlock MangleSpecialFunctions(const parser::CharBlock name);
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_RESOLVE_NAMES_H_

flang/lib/Semantics/resolve-names.cpp

@@ -1748,15 +1748,75 @@ void OmpVisitor::ProcessMapperSpecifier(const parser::OmpMapperSpecifier &spec,
   PopScope();
 }
 
+parser::CharBlock MakeNameFromOperator(
+    const parser::DefinedOperator::IntrinsicOperator &op) {
+  switch (op) {
+  case parser::DefinedOperator::IntrinsicOperator::Multiply:
+    return parser::CharBlock{"op.*", 4};
+  case parser::DefinedOperator::IntrinsicOperator::Add:
+    return parser::CharBlock{"op.+", 4};
+  case parser::DefinedOperator::IntrinsicOperator::Subtract:
+    return parser::CharBlock{"op.-", 4};
+
+  case parser::DefinedOperator::IntrinsicOperator::AND:
+    return parser::CharBlock{"op.AND", 6};
+  case parser::DefinedOperator::IntrinsicOperator::OR:
+    return parser::CharBlock{"op.OR", 6};
+  case parser::DefinedOperator::IntrinsicOperator::EQV:
+    return parser::CharBlock{"op.EQV", 7};
+  case parser::DefinedOperator::IntrinsicOperator::NEQV:
+    return parser::CharBlock{"op.NEQV", 8};
+
+  default:
+    assert(0 && "Unsupported operator...");
+    return parser::CharBlock{"op.?", 4};
+  }
+}
+
+parser::CharBlock MangleSpecialFunctions(const parser::CharBlock name) {
+  if (name == "max") {
+    return parser::CharBlock{"op.max", 6};
+  }
+  if (name == "min") {
+    return parser::CharBlock{"op.min", 6};
+  }
+  if (name == "iand") {
+    return parser::CharBlock{"op.iand", 7};
+  }
+  if (name == "ior") {
+    return parser::CharBlock{"op.ior", 6};
+  }
+  if (name == "ieor") {
+    return parser::CharBlock{"op.ieor", 7};
+  }
+  // All other names: return as is.
+  return name;
+}
+
 void OmpVisitor::ProcessReductionSpecifier(
     const parser::OmpReductionSpecifier &spec,
     const std::optional<parser::OmpClauseList> &clauses) {
+  const parser::Name *name{nullptr};
+  parser::Name mangledName{};
+  UserReductionDetails reductionDetailsTemp{};
   const auto &id{std::get<parser::OmpReductionIdentifier>(spec.t)};
   if (auto procDes{std::get_if<parser::ProcedureDesignator>(&id.u)}) {
-    if (auto *name{std::get_if<parser::Name>(&procDes->u)}) {
-      name->symbol =
-          &MakeSymbol(*name, MiscDetails{MiscDetails::Kind::ConstructName});
+    name = std::get_if<parser::Name>(&procDes->u);
+    if (name) {
+      mangledName.source = MangleSpecialFunctions(name->source);
     }
+  } else {
+    const auto &defOp{std::get<parser::DefinedOperator>(id.u)};
+    mangledName.source = MakeNameFromOperator(
+        std::get<parser::DefinedOperator::IntrinsicOperator>(defOp.u));
+    name = &mangledName;
+  }
+
+  UserReductionDetails *reductionDetails{&reductionDetailsTemp};
+  Symbol *symbol{name ? name->symbol : nullptr};
+  symbol = FindSymbol(mangledName);
+  if (symbol) {
+    reductionDetails = symbol->detailsIf<UserReductionDetails>();
   }
 
   auto &typeList{std::get<parser::OmpTypeNameList>(spec.t)};
@@ -1788,6 +1848,10 @@ void OmpVisitor::ProcessReductionSpecifier(
     const DeclTypeSpec *typeSpec{GetDeclTypeSpec()};
     assert(typeSpec && "We should have a type here");
 
+    if (reductionDetails) {
+      reductionDetails->AddType(typeSpec);
+    }
+
     for (auto &nm : ompVarNames) {
       ObjectEntityDetails details{};
       details.set_type(*typeSpec);
@@ -1798,6 +1862,13 @@ void OmpVisitor::ProcessReductionSpecifier(
     Walk(clauses);
     PopScope();
   }
+
+  if (name) {
+    if (!symbol) {
+      symbol = &MakeSymbol(mangledName, Attrs{}, std::move(*reductionDetails));
+    }
+    name->symbol = symbol;
+  }
 }
 
 bool OmpVisitor::Pre(const parser::OmpDirectiveSpecification &x) {

flang/lib/Semantics/symbol.cpp

@@ -246,7 +246,7 @@ void GenericDetails::CopyFrom(const GenericDetails &from) {
 // This is primarily for debugging.
 std::string DetailsToString(const Details &details) {
   return common::visit(
-      common::visitors{
+      common::visitors{//
           [](const UnknownDetails &) { return "Unknown"; },
           [](const MainProgramDetails &) { return "MainProgram"; },
           [](const ModuleDetails &) { return "Module"; },
@@ -266,7 +266,7 @@ std::string DetailsToString(const Details &details) {
           [](const TypeParamDetails &) { return "TypeParam"; },
           [](const MiscDetails &) { return "Misc"; },
           [](const AssocEntityDetails &) { return "AssocEntity"; },
-      },
+          [](const UserReductionDetails &) { return "UserReductionDetails"; }},
       details);
 }
 
@@ -300,6 +300,9 @@ bool Symbol::CanReplaceDetails(const Details &details) const {
             [&](const HostAssocDetails &) {
               return this->has<HostAssocDetails>();
             },
+            [&](const UserReductionDetails &) {
+              return this->has<UserReductionDetails>();
+            },
             [](const auto &) { return false; },
         },
         details);
@@ -598,6 +601,11 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Details &details) {
           [&](const MiscDetails &x) {
             os << ' ' << MiscDetails::EnumToString(x.kind());
           },
+          [&](const UserReductionDetails &x) {
+            for (auto &type : x.GetTypeList()) {
+              DumpType(os, type);
+            }
+          },
           [&](const auto &x) { os << x; },
       },
       details);