[flang][OpenMP]Improve support for DECLARE REDUCTION (llvm#127088)

Part of the DECLARE REDUCTION was already supported by the parser, but
the semantics to add the reduction identifier wasn't implemented.

The semantics would not accept the name given by the reduction, so a few
lines added to support that.

Some tests were in place but not quite working, so fixed those up too.
Adding new tests for unparsing and parse-tree, as well as checking the
symbolic name being generated.

Lowering of DECLARE REDUCTION is not supported in this patch, and a test
that it hits the relevant TODO is in this patch (most of this was
already existing, but not actually testing the TODO message).

Author: Leporacanthicus

flang/include/flang/Parser/parse-tree.h

@@ -4553,8 +4553,8 @@ WRAPPER_CLASS(OmpReductionInitializerClause, Expr);
 struct OpenMPDeclareReductionConstruct {
   TUPLE_CLASS_BOILERPLATE(OpenMPDeclareReductionConstruct);
   CharBlock source;
-  std::tuple<Verbatim, OmpReductionIdentifier, std::list<DeclarationTypeSpec>,
-      OmpReductionCombiner, std::optional<OmpReductionInitializerClause>>
+  std::tuple<Verbatim, common::Indirection<OmpReductionSpecifier>,
+      std::optional<OmpReductionInitializerClause>>
       t;
 };
 

flang/lib/Parser/openmp-parsers.cpp

@@ -170,8 +170,8 @@ TYPE_PARSER(sourced( //
 TYPE_PARSER(construct<OmpLocatorList>(nonemptyList(Parser<OmpLocator>{})))
 
 TYPE_PARSER( //
-    construct<OmpTypeSpecifier>(Parser<TypeSpec>{}) ||
-    construct<OmpTypeSpecifier>(Parser<DeclarationTypeSpec>{}))
+    construct<OmpTypeSpecifier>(Parser<DeclarationTypeSpec>{}) ||
+    construct<OmpTypeSpecifier>(Parser<TypeSpec>{}))
 
 TYPE_PARSER(construct<OmpReductionSpecifier>( //
     Parser<OmpReductionIdentifier>{},
@@ -1148,9 +1148,7 @@ TYPE_PARSER(construct<OmpReductionInitializerClause>(
 // 2.16 Declare Reduction Construct
 TYPE_PARSER(sourced(construct<OpenMPDeclareReductionConstruct>(
     verbatim("DECLARE REDUCTION"_tok),
-    "(" >> Parser<OmpReductionIdentifier>{} / ":",
-    nonemptyList(Parser<DeclarationTypeSpec>{}) / ":",
-    Parser<OmpReductionCombiner>{} / ")",
+    "(" >> indirect(Parser<OmpReductionSpecifier>{}) / ")",
     maybe(Parser<OmpReductionInitializerClause>{}))))
 
 // declare-target with list

flang/lib/Parser/unparse.cpp

@@ -2690,11 +2690,10 @@ class UnparseVisitor {
     BeginOpenMP();
     Word("!$OMP DECLARE REDUCTION ");
     Put("(");
-    Walk(std::get<OmpReductionIdentifier>(x.t)), Put(" : ");
-    Walk(std::get<std::list<DeclarationTypeSpec>>(x.t), ","), Put(" : ");
-    Walk(std::get<OmpReductionCombiner>(x.t));
+    Walk(std::get<common::Indirection<OmpReductionSpecifier>>(x.t));
     Put(")");
     Walk(std::get<std::optional<OmpReductionInitializerClause>>(x.t));
+    Put("\n");
     EndOpenMP();
   }
 

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

@@ -3178,6 +3178,10 @@ bool OmpStructureChecker::CheckReductionOperator(
       const SourceName &realName{name->symbol->GetUltimate().name()};
       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;
+      }
     }
     if (!valid) {
       context_.Say(source,

flang/lib/Semantics/resolve-directives.cpp

@@ -446,6 +446,9 @@ class OmpAttributeVisitor : DirectiveAttributeVisitor<llvm::omp::Directive> {
   bool Pre(const parser::OpenMPDeclareMapperConstruct &);
   void Post(const parser::OpenMPDeclareMapperConstruct &) { PopContext(); }
 
+  bool Pre(const parser::OpenMPDeclareReductionConstruct &);
+  void Post(const parser::OpenMPDeclareReductionConstruct &) { PopContext(); }
+
   bool Pre(const parser::OpenMPThreadprivate &);
   void Post(const parser::OpenMPThreadprivate &) { PopContext(); }
 
@@ -1976,6 +1979,12 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPDeclareMapperConstruct &x) {
   return true;
 }
 
+bool OmpAttributeVisitor::Pre(
+    const parser::OpenMPDeclareReductionConstruct &x) {
+  PushContext(x.source, llvm::omp::Directive::OMPD_declare_reduction);
+  return true;
+}
+
 bool OmpAttributeVisitor::Pre(const parser::OpenMPThreadprivate &x) {
   PushContext(x.source, llvm::omp::Directive::OMPD_threadprivate);
   const auto &list{std::get<parser::OmpObjectList>(x.t)};

flang/lib/Semantics/resolve-names.cpp

@@ -1482,6 +1482,15 @@ class OmpVisitor : public virtual DeclarationVisitor {
     return false;
   }
 
+  bool Pre(const parser::OpenMPDeclareReductionConstruct &x) {
+    AddOmpSourceRange(x.source);
+    parser::OmpClauseList emptyList{std::list<parser::OmpClause>{}};
+    ProcessReductionSpecifier(
+        std::get<Indirection<parser::OmpReductionSpecifier>>(x.t).value(),
+        emptyList);
+    Walk(std::get<std::optional<parser::OmpReductionInitializerClause>>(x.t));
+    return false;
+  }
   bool Pre(const parser::OmpMapClause &);
 
   void Post(const parser::OmpBeginLoopDirective &) {
@@ -1732,11 +1741,19 @@ void OmpVisitor::ProcessMapperSpecifier(const parser::OmpMapperSpecifier &spec,
 void OmpVisitor::ProcessReductionSpecifier(
     const parser::OmpReductionSpecifier &spec,
     const parser::OmpClauseList &clauses) {
+  BeginDeclTypeSpec();
+  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});
+    }
+  }
+  EndDeclTypeSpec();
   // Creating a new scope in case the combiner expression (or clauses) use
   // reerved identifiers, like "omp_in". This is a temporary solution until
   // we deal with these in a more thorough way.
   PushScope(Scope::Kind::OtherConstruct, nullptr);
-  Walk(std::get<parser::OmpReductionIdentifier>(spec.t));
   Walk(std::get<parser::OmpTypeNameList>(spec.t));
   Walk(std::get<std::optional<parser::OmpReductionCombiner>>(spec.t));
   Walk(clauses);

flang/test/Lower/OpenMP/Todo/omp-declare-reduction.f90

@@ -1,10 +1,10 @@
 ! This test checks lowering of OpenMP declare reduction Directive.
 
-// RUN: not flang -fc1 -emit-fir -fopenmp %s 2>&1 | FileCheck %s
+! RUN: not flang -fc1 -emit-fir -fopenmp %s 2>&1 | FileCheck %s
 
 subroutine declare_red()
   integer :: my_var
-  // CHECK: not yet implemented: OpenMPDeclareReductionConstruct
+  !CHECK: not yet implemented: OpenMPDeclareReductionConstruct
   !$omp declare reduction (my_red : integer : omp_out = omp_in) initializer (omp_priv = 0)
   my_var = 0
 end subroutine declare_red

flang/test/Parser/OpenMP/declare-reduction-unparse.f90

@@ -0,0 +1,21 @@
+! RUN: %flang_fc1 -fdebug-unparse -fopenmp %s | FileCheck --ignore-case %s
+! RUN: %flang_fc1 -fdebug-dump-parse-tree -fopenmp %s | FileCheck --check-prefix="PARSE-TREE" %s
+!CHECK-LABEL: program main
+program main
+  integer :: my_var
+  !CHECK: !$OMP DECLARE REDUCTION (my_add_red:INTEGER: omp_out=omp_out+omp_in
+  !CHECK-NEXT: ) INITIALIZER(OMP_PRIV = 0_4)
+  
+  !$omp declare reduction (my_add_red : integer : omp_out = omp_out + omp_in) initializer (omp_priv=0)
+  my_var = 0
+  !$omp parallel reduction (my_add_red : my_var) num_threads(4)
+  my_var = omp_get_thread_num() + 1
+  !$omp end parallel
+  print *, "sum of thread numbers is ", my_var
+end program main
+
+!PARSE-TREE:      OpenMPDeclareReductionConstruct
+!PARSE-TREE:        OmpReductionIdentifier -> ProcedureDesignator -> Name = 'my_add_red'
+!PARSE-TREE:        DeclarationTypeSpec -> IntrinsicTypeSpec -> IntegerTypeSpec
+!PARSE-TREE:        OmpReductionCombiner -> AssignmentStmt = 'omp_out=omp_out+omp_in'
+!PARSE-TREE:        OmpReductionInitializerClause -> Expr = '0_4'

flang/test/Semantics/OpenMP/declarative-directive01.f90

@@ -2,9 +2,6 @@
 
 ! Check OpenMP declarative directives
 
-!TODO: all internal errors
-!      enable declare-reduction example after name resolution
-
 ! 2.4 requires
 
 subroutine requires_1(a)
@@ -88,15 +85,14 @@ end module m2
 
 ! 2.16 declare-reduction
 
-! subroutine declare_red_1()
-!   use omp_lib
-!   integer :: my_var
-!   !$omp declare reduction (my_add_red : integer : omp_out = omp_out + omp_in) initializer (omp_priv=0)
-!   my_var = 0
-!   !$omp parallel reduction (my_add_red : my_var) num_threads(4)
-!   my_var = omp_get_thread_num() + 1
-!   !$omp end parallel
-!   print *, "sum of thread numbers is ", my_var
-! end subroutine declare_red_1
+subroutine declare_red_1()
+  integer :: my_var
+  !$omp declare reduction (my_add_red : integer : omp_out = omp_out + omp_in) initializer (omp_priv=0)
+  my_var = 0
+  !$omp parallel reduction (my_add_red : my_var) num_threads(4)
+  my_var = 1
+  !$omp end parallel
+  print *, "sum of thread numbers is ", my_var
+end subroutine declare_red_1
 
 end

flang/test/Semantics/OpenMP/declare-reduction.f90

@@ -0,0 +1,11 @@
+! RUN: %flang_fc1 -fdebug-dump-symbols -fopenmp -fopenmp-version=50 %s | FileCheck %s
+
+program main
+!CHECK-LABEL: MainProgram scope: main
+
+  !$omp declare reduction (my_add_red : integer : omp_out = omp_out + omp_in) initializer (omp_priv=0)
+
+!CHECK: my_add_red: Misc ConstructName
+  
+end program main
+