[flang] Add atomic_fetch_or to the list of intrinsics

Add the atomic subroutine, atomic_fetch_or, to the list of
intrinsic subroutines. Add new enumerators to deal with the rank
of the atom dummy argument, and the kind of atomic_int_kind. Use
check for a coindexed-object for the fourth dummy argument. Move
atomic_int_kind and atomic_logical_kind definitions from
iso_fortran_env module to the __fortran_builtins module to allow
for access to those values when analyzing `atomic_fetch_or`
calls in flang/lib/Evaluate/intrinsics.cpp.

Reviewed By: jeanPerier

Differential Revision: https://reviews.llvm.org/D133174

flang/lib/Evaluate/intrinsics.cpp

@@ -91,6 +91,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
     addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
     nullPointerType, // for ASSOCIATED(NULL())
     exactKind, // a single explicit exactKindValue
+    atomicIntKind, // atomic_int_kind from iso_fortran_env
 )
 
 struct TypePattern {
@@ -176,6 +177,8 @@ static constexpr TypePattern KINDComplex{ComplexType, KindCode::effectiveKind};
 static constexpr TypePattern KINDChar{CharType, KindCode::effectiveKind};
 static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind};
 
+static constexpr TypePattern AtomicInt{IntType, KindCode::atomicIntKind};
+
 // The default rank pattern for dummy arguments and function results is
 // "elemental".
 ENUM_CLASS(Rank,
@@ -186,6 +189,7 @@ ENUM_CLASS(Rank,
     matrix,
     array, // not scalar, rank is known and greater than zero
     coarray, // rank is known and can be scalar; has nonzero corank
+    atom, // is scalar and has nonzero corank or is coindexed
     known, // rank is known and can be scalar
     anyOrAssumedRank, // rank can be unknown; assumed-type TYPE(*) allowed
     conformable, // scalar, or array of same rank & shape as "array" argument
@@ -1087,6 +1091,16 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
 
 static const IntrinsicInterface intrinsicSubroutine[]{
     {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"atomic_fetch_or",
+        {{"atom", AtomicInt, Rank::atom, Optionality::required,
+             common::Intent::InOut},
+            {"value", AnyInt, Rank::scalar, Optionality::required,
+                common::Intent::In},
+            {"old", AtomicInt, Rank::scalar, Optionality::required,
+                common::Intent::Out},
+            {"stat", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
     {"co_broadcast",
         {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
              common::Intent::InOut},
@@ -1252,6 +1266,33 @@ static DynamicType GetBuiltinDerivedType(
   return DynamicType{derived};
 }
 
+static std::int64_t GetBuiltinKind(
+    const semantics::Scope *builtinsScope, const char *which) {
+  if (!builtinsScope) {
+    common::die("INTERNAL: The __fortran_builtins module was not found, and "
+                "the kind '%s' was required",
+        which);
+  }
+  auto iter{
+      builtinsScope->find(semantics::SourceName{which, std::strlen(which)})};
+  if (iter == builtinsScope->cend()) {
+    common::die(
+        "INTERNAL: The __fortran_builtins module does not define the kind '%s'",
+        which);
+  }
+  const semantics::Symbol &symbol{*iter->second};
+  const auto &details{
+      DEREF(symbol.detailsIf<semantics::ObjectEntityDetails>())};
+  if (const auto kind{ToInt64(details.init())}) {
+    return *kind;
+  } else {
+    common::die(
+        "INTERNAL: The __fortran_builtins module does not define the kind '%s'",
+        which);
+    return -1;
+  }
+}
+
 // Ensure that the keywords of arguments to MAX/MIN and their variants
 // are of the form A123 with no duplicates or leading zeroes.
 static bool CheckMaxMinArgument(std::optional<parser::CharBlock> keyword,
@@ -1523,6 +1564,16 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     case KindCode::exactKind:
       argOk = type->kind() == d.typePattern.exactKindValue;
       break;
+    case KindCode::atomicIntKind:
+      argOk = type->kind() ==
+          GetBuiltinKind(builtinsScope, "__builtin_atomic_int_kind");
+      if (!argOk) {
+        messages.Say(arg->sourceLocation(),
+            "Actual argument for '%s=' must have kind=atomic_int_kind, but is '%s'"_err_en_US,
+            d.keyword, type->AsFortran());
+        return std::nullopt;
+      }
+      break;
     default:
       CRASH_NO_CASE;
     }
@@ -1606,6 +1657,15 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
           return std::nullopt;
         }
         break;
+      case Rank::atom:
+        argOk = rank == 0 && (IsCoarray(*arg) || ExtractCoarrayRef(*arg));
+        if (!argOk) {
+          messages.Say(arg->sourceLocation(),
+              "'%s=' argument must be a scalar coarray or coindexed object for intrinsic '%s'"_err_en_US,
+              d.keyword, name);
+          return std::nullopt;
+        }
+        break;
       case Rank::known:
         if (!knownArg) {
           knownArg = arg;
@@ -1858,6 +1918,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
   case Rank::shape:
   case Rank::array:
   case Rank::coarray:
+  case Rank::atom:
   case Rank::known:
   case Rank::anyOrAssumedRank:
   case Rank::reduceOperation:
@@ -2482,6 +2543,8 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
     }
   } else if (name == "associated") {
     return CheckAssociated(call, context);
+  } else if (name == "atomic_fetch_or") {
+    return CheckForCoindexedObject(context, call.arguments[3], name, "stat");
   } else if (name == "co_broadcast" || name == "co_max" || name == "co_min" ||
       name == "co_sum") {
     bool aOk{CheckForCoindexedObject(context, call.arguments[0], name, "a")};

flang/module/__fortran_builtins.f90

@@ -39,6 +39,9 @@
     integer(kind=int64) :: __id
   end type
 
+  integer, parameter :: __builtin_atomic_int_kind = selected_int_kind(18)
+  integer, parameter :: __builtin_atomic_logical_kind = __builtin_atomic_int_kind
+
   procedure(type(__builtin_c_ptr)) :: __builtin_c_loc
 
   intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &

flang/module/iso_fortran_env.f90

@@ -16,13 +16,12 @@ module iso_fortran_env
   use __Fortran_builtins, only: &
     event_type => __builtin_event_type, &
     lock_type => __builtin_lock_type, &
-    team_type => __builtin_team_type
+    team_type => __builtin_team_type, &
+    atomic_int_kind => __builtin_atomic_int_kind, &
+    atomic_logical_kind => __builtin_atomic_logical_kind
 
   implicit none
 
-  integer, parameter :: atomic_int_kind = selected_int_kind(18)
-  integer, parameter :: atomic_logical_kind = atomic_int_kind
-
   ! TODO: Use PACK([x],test) in place of the array constructor idiom
   ! [(x, integer::j=1,COUNT([test]))] below once PACK() can be folded.
 

flang/test/Semantics/atomic07.f90

@@ -1,5 +1,4 @@
 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in atomic_fetch_or subroutine calls based on
 ! the interface defined in section 16.9.26 of the Fortran 2018 standard.
 
@@ -8,8 +7,9 @@ program test_atomic_fetch_or
   implicit none
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, old_val, non_coarray
-  integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10)
-  integer :: status, default_kind_coarray[*], not_same_kind_as_atom, coindexed_status[*], extra_arg, repeated_status, status_array(10)
+  integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10), val_coarray[*], old_val_coarray[*]
+  integer :: status, default_kind_coarray[*], not_same_kind_as_atom, coindexed_status[*]
+  integer :: extra_arg, repeated_status, status_array(10)
   integer(kind=1) :: kind1_coarray[*]
   real :: non_integer_coarray[*], not_same_type_as_atom
   logical :: non_integer
@@ -24,15 +24,18 @@ program test_atomic_fetch_or
 
   !___ non-standard-conforming calls ___
 
-  !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_fetch_or'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or'
   call atomic_fetch_or(non_scalar_coarray, val, old_val)
 
-  !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_fetch_or'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or'
   call atomic_fetch_or(non_coarray, val, old_val)
 
-  !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_fetch_or'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or'
   call atomic_fetch_or(array, val, old_val)
 
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or'
+  call atomic_fetch_or(non_scalar_coarray[1], val, old_val)
+
   !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(4)'
   call atomic_fetch_or(default_kind_coarray, val, old_val)
 
@@ -66,8 +69,12 @@ program test_atomic_fetch_or
   !ERROR: 'stat=' argument has unacceptable rank 1
   call atomic_fetch_or(scalar_coarray, val, old_val, status_array)
 
+  !ERROR: 'stat' argument to 'atomic_fetch_or' may not be a coindexed object
   call atomic_fetch_or(scalar_coarray, val, old_val, coindexed_status[1])
 
+  !ERROR: 'stat' argument to 'atomic_fetch_or' may not be a coindexed object
+  call atomic_fetch_or(scalar_coarray[1], val_coarray[1], old_val_coarray[1], coindexed_status[1])
+
   !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable
   call atomic_fetch_or(scalar_coarray, val, old_val, 1)
 
@@ -120,7 +127,7 @@ program test_atomic_fetch_or
   call atomic_fetch_or(scalar_coarray, val, old_val, atom=repeated_atom)
 
   !ERROR: keyword argument to intrinsic 'atomic_fetch_or' was supplied positionally by an earlier actual argument
-  call atomic_fetch_or(scalar_coarray, val, old_val, val=repeated_val)
+  call atomic_fetch_or(scalar_coarray, val, old_val, value=repeated_val)
 
   !ERROR: keyword argument to intrinsic 'atomic_fetch_or' was supplied positionally by an earlier actual argument
   call atomic_fetch_or(scalar_coarray, val, old_val, status, stat=repeated_status)