[Flang][OpenMP] Add frontend support for declare variant

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

@@ -483,6 +483,11 @@ class ParseTreeDumper {
   NODE(parser, OldParameterStmt)
   NODE(parser, OmpTypeSpecifier)
   NODE(parser, OmpTypeNameList)
+  NODE(parser, OmpAdjustArgsClause)
+  NODE(OmpAdjustArgsClause, OmpAdjustOp)
+  NODE_ENUM(OmpAdjustArgsClause::OmpAdjustOp, Value)
+  NODE(parser, OmpAppendArgsClause)
+  NODE(OmpAppendArgsClause, OmpAppendOp)
   NODE(parser, OmpLocator)
   NODE(parser, OmpLocatorList)
   NODE(parser, OmpReductionSpecifier)
@@ -703,6 +708,7 @@ class ParseTreeDumper {
   NODE(parser, OpenMPCriticalConstruct)
   NODE(parser, OpenMPDeclarativeAllocate)
   NODE(parser, OpenMPDeclarativeConstruct)
+  NODE(parser, OmpDeclareVariantDirective)
   NODE(parser, OpenMPDeclareReductionConstruct)
   NODE(parser, OpenMPDeclareSimdConstruct)
   NODE(parser, OpenMPDeclareTargetConstruct)

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

@@ -4013,6 +4013,15 @@ struct OmpAbsentClause {
   WRAPPER_CLASS_BOILERPLATE(OmpAbsentClause, OmpDirectiveList);
 };
 
+struct OmpAdjustArgsClause {
+  TUPLE_CLASS_BOILERPLATE(OmpAdjustArgsClause);
+  struct OmpAdjustOp {
+    ENUM_CLASS(Value, Nothing, Need_Device_Ptr)
+    WRAPPER_CLASS_BOILERPLATE(OmpAdjustOp, Value);
+  };
+  std::tuple<OmpAdjustOp, OmpObjectList> t;
+};
+
 // Ref: [5.0:135-140], [5.1:161-166], [5.2:264-265]
 //
 // affinity-clause ->
@@ -4056,6 +4065,13 @@ struct OmpAllocateClause {
   std::tuple<MODIFIERS(), OmpObjectList> t;
 };
 
+struct OmpAppendArgsClause {
+  struct OmpAppendOp {
+    WRAPPER_CLASS_BOILERPLATE(OmpAppendOp, std::list<OmpInteropType>);
+  };
+  WRAPPER_CLASS_BOILERPLATE(OmpAppendArgsClause, std::list<OmpAppendOp>);
+};
+
 // Ref: [5.2:216-217 (sort of, as it's only mentioned in passing)
 // AT(compilation|execution)
 struct OmpAtClause {
@@ -4693,6 +4709,12 @@ struct OmpBlockDirective {
   CharBlock source;
 };
 
+struct OmpDeclareVariantDirective {
+  TUPLE_CLASS_BOILERPLATE(OmpDeclareVariantDirective);
+  CharBlock source;
+  std::tuple<Verbatim, std::optional<Name>, Name, OmpClauseList> t;
+};
+
 // 2.10.6 declare-target -> DECLARE TARGET (extended-list) |
 //                          DECLARE TARGET [declare-target-clause[ [,]
 //                                          declare-target-clause]...]
@@ -4771,8 +4793,8 @@ struct OpenMPDeclarativeConstruct {
   std::variant<OpenMPDeclarativeAllocate, OpenMPDeclarativeAssumes,
       OpenMPDeclareMapperConstruct, OpenMPDeclareReductionConstruct,
       OpenMPDeclareSimdConstruct, OpenMPDeclareTargetConstruct,
-      OpenMPThreadprivate, OpenMPRequiresConstruct, OpenMPUtilityConstruct,
-      OmpMetadirectiveDirective>
+      OmpDeclareVariantDirective, OpenMPThreadprivate, OpenMPRequiresConstruct,
+      OpenMPUtilityConstruct, OmpMetadirectiveDirective>
       u;
 };
 

flang/lib/Lower/OpenMP/OpenMP.cpp

@@ -3755,6 +3755,13 @@ static void genOMP(lower::AbstractConverter &converter, lower::SymMap &symTable,
   TODO(converter.getCurrentLocation(), "OpenMP ASSUMES declaration");
 }
 
+static void
+genOMP(lower::AbstractConverter &converter, lower::SymMap &symTable,
+       semantics::SemanticsContext &semaCtx, lower::pft::Evaluation &eval,
+       const parser::OmpDeclareVariantDirective &declareVariantDirective) {
+  TODO(converter.getCurrentLocation(), "OpenMPDeclareVariantDirective");
+}
+
 static void genOMP(
     lower::AbstractConverter &converter, lower::SymMap &symTable,
     semantics::SemanticsContext &semaCtx, lower::pft::Evaluation &eval,

flang/lib/Parser/openmp-parsers.cpp

@@ -611,6 +611,14 @@ TYPE_PARSER(sourced(construct<OmpToClause::Modifier>(
 TYPE_PARSER(sourced(construct<OmpWhenClause::Modifier>( //
     Parser<OmpContextSelector>{})))
 
+TYPE_PARSER(construct<OmpAppendArgsClause::OmpAppendOp>(
+    "INTEROP" >> parenthesized(nonemptyList(Parser<OmpInteropType>{}))))
+
+TYPE_PARSER(construct<OmpAdjustArgsClause::OmpAdjustOp>(
+    "NOTHING" >> pure(OmpAdjustArgsClause::OmpAdjustOp::Value::Nothing) ||
+    "NEED_DEVICE_PTR" >>
+        pure(OmpAdjustArgsClause::OmpAdjustOp::Value::Need_Device_Ptr)))
+
 // --- Parsers for clauses --------------------------------------------
 
 /// `MOBClause` is a clause that has a
@@ -630,6 +638,10 @@ static inline MOBClause makeMobClause(
   }
 }
 
+TYPE_PARSER(construct<OmpAdjustArgsClause>(
+    (Parser<OmpAdjustArgsClause::OmpAdjustOp>{} / ":"),
+    Parser<OmpObjectList>{}))
+
 // [5.0] 2.10.1 affinity([aff-modifier:] locator-list)
 //              aff-modifier: interator-modifier
 TYPE_PARSER(construct<OmpAffinityClause>(
@@ -653,6 +665,9 @@ TYPE_PARSER(construct<OmpAtomicDefaultMemOrderClause>(
 TYPE_PARSER(construct<OmpCancellationConstructTypeClause>(
     OmpDirectiveNameParser{}, maybe(parenthesized(scalarLogicalExpr))))
 
+TYPE_PARSER(construct<OmpAppendArgsClause>(
+    nonemptyList(Parser<OmpAppendArgsClause::OmpAppendOp>{})))
+
 // 2.15.3.1 DEFAULT (PRIVATE | FIRSTPRIVATE | SHARED | NONE)
 TYPE_PARSER(construct<OmpDefaultClause::DataSharingAttribute>(
     "PRIVATE" >> pure(OmpDefaultClause::DataSharingAttribute::Private) ||
@@ -901,6 +916,8 @@ TYPE_PARSER( //
                     parenthesized(Parser<OmpAbsentClause>{}))) ||
     "ACQUIRE" >> construct<OmpClause>(construct<OmpClause::Acquire>()) ||
     "ACQ_REL" >> construct<OmpClause>(construct<OmpClause::AcqRel>()) ||
+    "ADJUST_ARGS" >> construct<OmpClause>(construct<OmpClause::AdjustArgs>(
+                         parenthesized(Parser<OmpAdjustArgsClause>{}))) ||
     "AFFINITY" >> construct<OmpClause>(construct<OmpClause::Affinity>(
                       parenthesized(Parser<OmpAffinityClause>{}))) ||
     "ALIGN" >> construct<OmpClause>(construct<OmpClause::Align>(
@@ -909,6 +926,8 @@ TYPE_PARSER( //
                      parenthesized(Parser<OmpAlignedClause>{}))) ||
     "ALLOCATE" >> construct<OmpClause>(construct<OmpClause::Allocate>(
                       parenthesized(Parser<OmpAllocateClause>{}))) ||
+    "APPEND_ARGS" >> construct<OmpClause>(construct<OmpClause::AppendArgs>(
+                         parenthesized(Parser<OmpAppendArgsClause>{}))) ||
     "ALLOCATOR" >> construct<OmpClause>(construct<OmpClause::Allocator>(
                        parenthesized(scalarIntExpr))) ||
     "AT" >> construct<OmpClause>(construct<OmpClause::At>(
@@ -1342,6 +1361,11 @@ TYPE_PARSER(construct<OmpInitializerClause>(
     construct<OmpInitializerClause>(assignmentStmt) ||
     construct<OmpInitializerClause>(Parser<OmpInitializerProc>{})))
 
+// OpenMP 5.2: 7.5.4 Declare Variant directive
+TYPE_PARSER(sourced(
+    construct<OmpDeclareVariantDirective>(verbatim("DECLARE VARIANT"_tok),
+        "(" >> maybe(name / ":"), name / ")", Parser<OmpClauseList>{})))
+
 // 2.16 Declare Reduction Construct
 TYPE_PARSER(sourced(construct<OpenMPDeclareReductionConstruct>(
     verbatim("DECLARE REDUCTION"_tok),
@@ -1513,6 +1537,8 @@ TYPE_PARSER(
                                 Parser<OpenMPDeclareSimdConstruct>{}) ||
                             construct<OpenMPDeclarativeConstruct>(
                                 Parser<OpenMPDeclareTargetConstruct>{}) ||
+                            construct<OpenMPDeclarativeConstruct>(
+                                Parser<OmpDeclareVariantDirective>{}) ||
                             construct<OpenMPDeclarativeConstruct>(
                                 Parser<OpenMPDeclarativeAllocate>{}) ||
                             construct<OpenMPDeclarativeConstruct>(

flang/lib/Parser/unparse.cpp

@@ -2743,7 +2743,28 @@ class UnparseVisitor {
     Put("\n");
     EndOpenMP();
   }
-
+  void Unparse(const OmpAppendArgsClause::OmpAppendOp &x) {
+    Put("INTEROP(");
+    Walk(x.v, ",");
+    Put(")");
+  }
+  void Unparse(const OmpAppendArgsClause &x) { Walk(x.v, ","); }
+  void Unparse(const OmpAdjustArgsClause &x) {
+    Walk(std::get<OmpAdjustArgsClause::OmpAdjustOp>(x.t).v);
+    Put(":");
+    Walk(std::get<parser::OmpObjectList>(x.t));
+  }
+  void Unparse(const OmpDeclareVariantDirective &x) {
+    BeginOpenMP();
+    Word("!$OMP DECLARE VARIANT ");
+    Put("(");
+    Walk(std::get<std::optional<Name>>(x.t), ":");
+    Walk(std::get<Name>(x.t));
+    Put(")");
+    Walk(std::get<OmpClauseList>(x.t));
+    Put("\n");
+    EndOpenMP();
+  }
   void Unparse(const OpenMPInteropConstruct &x) {
     BeginOpenMP();
     Word("!$OMP INTEROP");
@@ -3042,6 +3063,7 @@ class UnparseVisitor {
   WALK_NESTED_ENUM(InquireSpec::LogVar, Kind)
   WALK_NESTED_ENUM(ProcedureStmt, Kind) // R1506
   WALK_NESTED_ENUM(UseStmt, ModuleNature) // R1410
+  WALK_NESTED_ENUM(OmpAdjustArgsClause::OmpAdjustOp, Value) // OMP adjustop
   WALK_NESTED_ENUM(OmpAtClause, ActionTime) // OMP at
   WALK_NESTED_ENUM(OmpBindClause, Binding) // OMP bind
   WALK_NESTED_ENUM(OmpProcBindClause, AffinityPolicy) // OMP proc_bind

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

@@ -1619,6 +1619,16 @@ void OmpStructureChecker::Leave(const parser::OpenMPDeclareSimdConstruct &) {
   dirContext_.pop_back();
 }
 
+void OmpStructureChecker::Enter(const parser::OmpDeclareVariantDirective &x) {
+  const auto &dir{std::get<parser::Verbatim>(x.t)};
+  PushContextAndClauseSets(
+      dir.source, llvm::omp::Directive::OMPD_declare_variant);
+}
+
+void OmpStructureChecker::Leave(const parser::OmpDeclareVariantDirective &) {
+  dirContext_.pop_back();
+}
+
 void OmpStructureChecker::Enter(const parser::OpenMPDepobjConstruct &x) {
   const auto &dirName{std::get<parser::OmpDirectiveName>(x.v.t)};
   PushContextAndClauseSets(dirName.source, llvm::omp::Directive::OMPD_depobj);

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

@@ -98,6 +98,8 @@ class OmpStructureChecker
   void Enter(const parser::OmpEndSectionsDirective &);
   void Leave(const parser::OmpEndSectionsDirective &);
 
+  void Enter(const parser::OmpDeclareVariantDirective &);
+  void Leave(const parser::OmpDeclareVariantDirective &);
   void Enter(const parser::OpenMPDeclareSimdConstruct &);
   void Leave(const parser::OpenMPDeclareSimdConstruct &);
   void Enter(const parser::OpenMPDeclarativeAllocate &);

flang/lib/Semantics/resolve-names.cpp

@@ -1511,6 +1511,25 @@ class OmpVisitor : public virtual DeclarationVisitor {
     return true;
   }
 
+  bool Pre(const parser::OmpDeclareVariantDirective &x) {
+    AddOmpSourceRange(x.source);
+    auto FindSymbolOrError = [&](const parser::Name &procName) {
+      auto *symbol{FindSymbol(NonDerivedTypeScope(), procName)};
+      if (!symbol) {
+        context().Say(procName.source,
+            "Implicit subroutine declaration '%s' in !$OMP DECLARE VARIANT"_err_en_US,
+            procName.source);
+      }
+    };
+    auto &baseProcName = std::get<std::optional<parser::Name>>(x.t);
+    if (baseProcName) {
+      FindSymbolOrError(*baseProcName);
+    }
+    auto &varProcName = std::get<parser::Name>(x.t);
+    FindSymbolOrError(varProcName);
+    return true;
+  }
+
   bool Pre(const parser::OpenMPDeclareReductionConstruct &x) {
     AddOmpSourceRange(x.source);
     ProcessReductionSpecifier(

flang/test/Lower/OpenMP/Todo/declare-variant.f90

@@ -0,0 +1,17 @@
+! RUN: %not_todo_cmd %flang_fc1 -emit-fir -fopenmp -fopenmp-version=51 -o - %s 2>&1 | FileCheck %s
+
+! CHECK: not yet implemented: OpenMPDeclareVariantDirective
+
+subroutine sb1
+  integer :: x
+  x = 1
+  call sub(x)
+contains
+  subroutine vsub (v1)
+    integer, value :: v1
+  end
+  subroutine sub (v1)
+    !$omp declare variant(vsub), match(construct={dispatch})
+    integer, value :: v1
+  end
+end subroutine

flang/test/Parser/OpenMP/declare-variant.f90

@@ -0,0 +1,104 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema -fopenmp %s | FileCheck --ignore-case %s
+! RUN: %flang_fc1 -fdebug-dump-parse-tree-no-sema -fopenmp %s | FileCheck --check-prefix="PARSE-TREE" %s
+
+subroutine sub0
+!CHECK: !$OMP DECLARE VARIANT (sub:vsub) MATCH(CONSTRUCT={PARALLEL})
+!PARSE-TREE: OpenMPDeclarativeConstruct -> OmpDeclareVariantDirective
+!PARSE-TREE: | Verbatim
+!PARSE-TREE: | Name = 'sub'
+!PARSE-TREE: | Name = 'vsub'
+!PARSE-TREE: | OmpClauseList -> OmpClause -> Match -> OmpMatchClause -> OmpContextSelectorSpecification -> OmpTraitSetSelector
+!PARSE-TREE: | | OmpTraitSetSelectorName -> Value = Construct
+!PARSE-TREE: | | OmpTraitSelector
+!PARSE-TREE: | | | OmpTraitSelectorName -> llvm::omp::Directive = parallel
+  !$omp declare variant (sub:vsub) match (construct={parallel})
+contains
+  subroutine vsub
+  end subroutine
+
+  subroutine sub ()
+  end subroutine
+end subroutine
+
+subroutine sb1
+  integer :: x
+  x = 1
+  !$omp dispatch device(1)
+    call sub(x)
+contains
+  subroutine vsub (v1)
+    integer, value :: v1
+  end
+  subroutine sub (v1)
+!CHECK: !$OMP DECLARE VARIANT (vsub) MATCH(CONSTRUCT={DISPATCH}
+!PARSE-TREE: OpenMPDeclarativeConstruct -> OmpDeclareVariantDirective
+!PARSE-TREE: | Verbatim
+!PARSE-TREE: | Name = 'vsub'
+!PARSE-TREE: | OmpClauseList -> OmpClause -> Match -> OmpMatchClause -> OmpContextSelectorSpecification -> OmpTraitSetSelector
+!PARSE-TREE: | | OmpTraitSetSelectorName -> Value = Construct
+!PARSE-TREE: | | OmpTraitSelector
+!PARSE-TREE: | | | OmpTraitSelectorName -> llvm::omp::Directive = dispatch
+    !$omp declare variant(vsub), match(construct={dispatch})
+    integer, value :: v1
+  end
+end subroutine
+
+subroutine sb2 (x1, x2)
+  use omp_lib, only: omp_interop_kind
+  integer :: x
+  x = 1
+  !$omp dispatch device(1)
+    call sub(x)
+contains
+  subroutine vsub (v1, a1, a2)
+    integer, value :: v1
+    integer(omp_interop_kind) :: a1
+    integer(omp_interop_kind), value :: a2
+  end
+  subroutine sub (v1)
+!CHECK: !$OMP DECLARE VARIANT (vsub) MATCH(CONSTRUCT={DISPATCH}) APPEND_ARGS(INTEROP(T&
+!CHECK: !$OMP&ARGET),INTEROP(TARGET))
+!PARSE-TREE: OpenMPDeclarativeConstruct -> OmpDeclareVariantDirective
+!PARSE-TREE: | Verbatim
+!PARSE-TREE: | Name = 'vsub'
+!PARSE-TREE: | OmpClauseList -> OmpClause -> Match -> OmpMatchClause -> OmpContextSelectorSpecification -> OmpTraitSetSelector
+!PARSE-TREE: | | OmpTraitSetSelectorName -> Value = Construct
+!PARSE-TREE: | | OmpTraitSelector
+!PARSE-TREE: | | | OmpTraitSelectorName -> llvm::omp::Directive = dispatch
+!PARSE-TREE: | OmpClause -> AppendArgs -> OmpAppendArgsClause -> OmpAppendOp -> OmpInteropType -> Value = Target
+!PARSE-TREE: | OmpAppendOp -> OmpInteropType -> Value = Target
+    !$omp declare variant(vsub), match(construct={dispatch}), append_args (interop(target), interop(target))
+    integer, value :: v1
+  end
+end subroutine
+
+subroutine sb3 (x1, x2)
+  use iso_c_binding, only: c_ptr
+  type(c_ptr), value :: x1, x2
+
+  !$omp dispatch device(1)
+  call sub(x1, x2)
+contains
+  subroutine sub (v1, v2)
+    type(c_ptr), value :: v1, v2
+!CHECK: !$OMP DECLARE VARIANT (vsub) MATCH(CONSTRUCT={DISPATCH}) ADJUST_ARGS(NOTHING:v&
+!CHECK: !$OMP&1) ADJUST_ARGS(NEED_DEVICE_PTR:v2)
+!PARSE-TREE: DeclarationConstruct -> SpecificationConstruct -> OpenMPDeclarativeConstruct -> OmpDeclareVariantDirective
+!PARSE-TREE: | Verbatim
+!PARSE-TREE: | Name = 'vsub'
+!PARSE-TREE: | OmpClauseList -> OmpClause -> Match -> OmpMatchClause -> OmpContextSelectorSpecification -> OmpTraitSetSelector
+!PARSE-TREE: | | OmpTraitSetSelectorName -> Value = Construct
+!PARSE-TREE: | | OmpTraitSelector
+!PARSE-TREE: | | | OmpTraitSelectorName -> llvm::omp::Directive = dispatch
+!PARSE-TREE: | OmpClause -> AdjustArgs -> OmpAdjustArgsClause
+!PARSE-TREE: | | OmpAdjustOp -> Value = Nothing
+!PARSE-TREE: | | OmpObjectList -> OmpObject -> Designator -> DataRef -> Name = 'v1'
+!PARSE-TREE: | OmpClause -> AdjustArgs -> OmpAdjustArgsClause
+!PARSE-TREE: | | OmpAdjustOp -> Value = Need_Device_Ptr
+!PARSE-TREE: | | OmpObjectList -> OmpObject -> Designator -> DataRef -> Name = 'v2'
+    !$omp declare variant(vsub) match ( construct = { dispatch } ) adjust_args(nothing : v1 ) adjust_args(need_device_ptr : v2)
+  end
+  subroutine vsub(v1, v2)
+    type(c_ptr), value :: v1, v2
+  end
+end subroutine

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

@@ -0,0 +1,14 @@
+! RUN: %python %S/../test_errors.py %s %flang -fopenmp -fopenmp-version=51
+
+subroutine sub0
+!ERROR: Implicit subroutine declaration 'vsub1' in !$OMP DECLARE VARIANT
+  !$omp declare variant (sub:vsub1) match (construct={parallel})
+!ERROR: Implicit subroutine declaration 'sub1' in !$OMP DECLARE VARIANT
+  !$omp declare variant (sub1:vsub) match (construct={parallel})
+contains
+  subroutine vsub
+  end subroutine
+
+  subroutine sub ()
+  end subroutine
+end subroutine