[flang] Add atomic_fetch_or to the list of intrinsics

[ktras]

Summary

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.

[ktras]

In this patch, in flang/lib/Evaluate/intrinsics.cpp, I would like to be able to bring in and use the value atomic_int_kind from the iso_fortran_env module. I have drafted my solution in this patch where I declare a variable with the value of atomic_int_kind but with the bind(c) attribute in a new Fortran module and then use an extern int in a .h file to theoretically grab that value. However, I have not done much Fortran/C interoperability and am not sure how to do the right CMake changes to make my idea work. At the moment, I commented out the extern int and am just using a magic number. Would anyone be able to help me figure out how to make the right CMake changes so I can use that extern int? Or is there a totally different and better way to get a value equivalent to atomic_int_kind that is not a magic number?

[jeanPerier]

Maybe @klausler has an idea to manage computing atomic_int_kind in https://github.com/llvm/llvm-project/blob/main/flang/include/flang/Runtime/magic-numbers.h and use that in both the module file and the compiler (I don't) ?

As an alternative however, instead of the cmake gymnastic, I would suggest moving the definition of atomic_int_kind parameter as __builting_atomic_int_kind in https://github.com/llvm/llvm-project/blob/main/flang/module/__fortran_builtins.f90, rename it as atomic_int_kind in https://github.com/llvm/llvm-project/blob/main/flang/module/iso_fortran_env.f90, and extract the builtin parameter symbol and its value in a similar way as it is done for builtin types in GetBuiltinDerivedType defined here: https://github.com/llvm/llvm-project/blob/2944f8ef049fa83ee96159c390fa893f251558da/flang/lib/Evaluate/intrinsics.cpp#L1202.

flang/lib/Evaluate/intrinsics.cpp

1670

I am not well versed in coarrays, and the standard phrasing "shall be a scalar coarray or coindexed object" is a bit ambiguous to me. Are you sure the "scalar" part does not also apply to coindexed objects ? It is not entirely clear to me why it would apply on Corarray and not coarray references.

[ktras]

@jeanPerier Thank you for the feedback! I think the idea to use flang/module/__fortran_builtins.f90 seems like a great idea and I will pursue that option. Thank you for pointing out how that could be useful in this case.

flang/lib/Evaluate/intrinsics.cpp

1670

@jeanPerier, As you saw, the interpretation I took is that in that sentence in the standard, scalar only modifies coarray and not coindexed-object, but I am not sure that this interpretation is correct. I can see your point that this interpretation doesn't make as much sense. @rouson, can you give feedback on this coarray question? Do you know whether "shall be a scalar coarray or coindexed object" in 16.9.25 in the 2018 standard means that a coindexed-object shall also be scalar? Or just if it is a coarray?

[rouson]

flang/lib/Evaluate/intrinsics.cpp

1670

I debated whether "scalar" modifies just "coarray" or also "coindexed object" and concluded that the most reasonable answer is that "scalar" modifies both. Otherwise, the standard would be treating coindexed data entities differently from non-coindexed ones, which would create the odd circumstance that we could do something with coindexed entities even in single-image execution that we could not do with non-coindexed entities.

[ktras]

I will updated my patch based on reviewer feedback on the implementation of one of the new errors and the implementation of the atomic_int_kind check.

flang/lib/Evaluate/intrinsics.cpp

1670

That is a good point about the single-image execution. Thank you @jeanPerier and @rouson for this discussion. I will change the way I implement my error check for that sentence in the standard to work based on the interpretation that scalar modifies both coarray and coindexed-object.

[ktras]

Update patch based on reviewer feedback:

• Update the implementation of checks surrounding atomic_int_kind
• Update implementation of checks on the rank of the atom argument
• Update atomic_fetch_or test with new error messages and an additional non-standard conforming call.

[jeanPerier]

A nit and a question, otherwise looks good to me.

flang/lib/Evaluate/intrinsics.cpp

1665

nit: argOk = rank == 0 && (IsCoarray(*arg) || ExtractCoarrayRef(*arg)); would be readable and shorter.

flang/module/iso_fortran_env.f90

20

Is there a reason to define new parameters instead of doing renaming here (e.g., `atomic_int_kind
=> __builtin_atomic_int_kind`) ?

If renames are possible, I think they should be favored because they avoid "spilling" the builtin symbols. With the current patch, a user using iso_fortran_env could directly use __builtin_atomic_int_kind and __builtin_atomic_logical_kind, and I do not think we should allow that to make it impossible for users to start relying on the builtin names for any weird reason as if it was an extension.

[ktras]

• Add a check for a coindexed-object for the optional dummy argument 'stat', which "shall be a noncoindexed integer scalar".
• Updates based on reviewer feedback

[ktras]

flang/module/iso_fortran_env.f90

20

No, there is no reason to define new parameters, but I didn't even think about taking out the original definition fully. Thanks for the great feedback!

[jeanPerier]

LGTM

flang/lib/Evaluate/intrinsics.cpp

ENUM_CLASS(KindCode, none, defaultIntegerKind,
     effectiveKind, // for function results: "kindArg" value, possibly defaulted
     dimArg, // this argument is DIM=
     likeMultiply, // for DOT_PRODUCT and MATMUL
     subscript, // address-sized integer
     size, // default KIND= for SIZE(), UBOUND, &c.
     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 {
   CategorySet categorySet;
   KindCode kindCode{KindCode::none};
   int exactKindValue{0}; // for KindCode::exactBind
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 };

 
 // Result types with known category and KIND=
 static constexpr TypePattern KINDInt{IntType, KindCode::effectiveKind};
 static constexpr TypePattern KINDReal{RealType, KindCode::effectiveKind};
 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,
     elemental, // scalar, or array that conforms with other array arguments
     elementalOrBOZ, // elemental, or typeless BOZ literal scalar
     scalar, vector,
     shape, // INTEGER vector of known length and no negative element
     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
     reduceOperation, // a pure function with constraints for REDUCE
     dimReduced, // scalar if no DIM= argument, else rank(array)-1
     dimRemovedOrScalar, // rank(array)-1 (less DIM) or scalar
     scalarIfDim, // scalar if DIM= argument is present, else rank one array
     locReduced, // vector(1:rank) if no DIM= argument, else rank(array)-1
static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"tanh", {{"x", DefaultReal}}, DefaultReal}},
     {{"zabs", {{"a", TypePattern{ComplexType, KindCode::exactKind, 8}}},
          TypePattern{RealType, KindCode::exactKind, 8}},
         "abs"},
 };
 
 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},
             {"source_image", AnyInt, Rank::scalar, Optionality::required,
                 common::Intent::In},
             {"stat", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out},
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
common::die(
         which);
   }
   const semantics::Symbol &symbol{*iter->second};
   const semantics::Scope &scope{DEREF(symbol.scope())};
   const semantics::DerivedTypeSpec &derived{DEREF(scope.derivedTypeSpec())};
   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,
     std::set<parser::CharBlock> &set, const char *intrinsicName,
     parser::ContextualMessages &messages) {
   if (keyword) {
     std::size_t j{1};
     for (; j < keyword->size(); ++j) {
case KindCode::effectiveKind:
       break;
     case KindCode::addressable:
     case KindCode::nullPointerType:
       argOk = true;
       break;
     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;
     }
     if (!argOk) {
       messages.Say(arg->sourceLocation(),
           "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
           d.keyword, type->AsFortran());
       return std::nullopt;
if (const ActualArgument * arg{actualForDummy[j]}) {
         argOk = IsCoarray(*arg);
         if (!argOk) {
           messages.Say(arg->sourceLocation(),
               "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US,
               name);
           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;
         }
         argOk = rank == knownArg->Rank();
         break;
       case Rank::anyOrAssumedRank:
         if (!hasDimArg && rank > 0 && !isAssumedRank &&
             (std::strcmp(name, "shape") == 0 ||
                 std::strcmp(name, "size") == 0 ||
case Rank::shaped:
     break;
   case Rank::scalarIfDim:
     resultRank = hasDimArg ? 0 : 1;
     break;
   case Rank::elementalOrBOZ:
   case Rank::shape:
   case Rank::array:
   case Rank::coarray:
+  case Rank::atom:
   case Rank::known:
   case Rank::anyOrAssumedRank:
   case Rank::reduceOperation:
   case Rank::dimRemovedOrScalar:
     common::die("INTERNAL: bad Rank code on intrinsic '%s' result", name);
     break;
   }
   CHECK(resultRank >= 0);
if (name == "allocated") {
     }
     if (!ok) {
       context.messages().Say(
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
   } 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")};
     bool statOk{
         CheckForCoindexedObject(context, call.arguments[2], name, "stat")};
     bool errmsgOk{
         CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")};
     ok = aOk && statOk && errmsgOk;

flang/module/__fortran_builtins.f90

module __Fortran_builtins
   type :: __builtin_lock_type
     integer(kind=int64) :: __count
   end type
 
   type :: __builtin_team_type
     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, &
     __builtin_ieee_is_normal
   intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
     __builtin_ieee_next_up
   intrinsic :: scale ! for ieee_scalb
   intrinsic :: __builtin_ieee_selected_real_kind

flang/module/iso_fortran_env.f90

 
 include '../include/flang/Runtime/magic-numbers.h' ! for IOSTAT= error/end code values
 
 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.
 
   integer, parameter, private :: &
     selectedASCII = selected_char_kind('ASCII'), &
     selectedUCS_2 = selected_char_kind('UCS-2'), &
     selectedUnicode = selected_char_kind('ISO_10646')
   integer, parameter :: character_kinds(*) = [ &

flang/test/Semantics/atomic07.f90

 ! 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.
 
 program test_atomic_fetch_or
   use iso_fortran_env, only: atomic_int_kind
   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
 
   !___ standard-conforming calls ___
   call atomic_fetch_or(scalar_coarray, val, old_val)
   call atomic_fetch_or(scalar_coarray[1], val, old_val)
   call atomic_fetch_or(scalar_coarray, val, old_val, status)
   call atomic_fetch_or(scalar_coarray[1], val, old_val, status)
   call atomic_fetch_or(atom=scalar_coarray, value=val, old=old_val, stat=status)
   call atomic_fetch_or(stat=status, old=old_val, value=val, atom=scalar_coarray)
 
   !___ 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)
 
   !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(1)'
   call atomic_fetch_or(kind1_coarray, val, old_val)
 
   !ERROR: Actual argument for 'atom=' has bad type 'REAL(4)'
   call atomic_fetch_or(non_integer_coarray, val, old_val)
program test_atomic_fetch_or
   call atomic_fetch_or(scalar_coarray, val, array)
 
   !ERROR: Actual argument for 'stat=' has bad type 'LOGICAL(4)'
   call atomic_fetch_or(scalar_coarray, val, old_val, non_integer)
 
   !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)
 
   !ERROR: missing mandatory 'atom=' argument
   call atomic_fetch_or()
 
   !ERROR: missing mandatory 'atom=' argument
   call atomic_fetch_or(value=val, old=old_val, stat=status)
program test_atomic_fetch_or
 
   !ERROR: unknown keyword argument to intrinsic 'atomic_fetch_or'
   call atomic_fetch_or(atom=scalar_coarray, value=val, old=old_val, status=status)
 
   !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, 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)
 
 end program test_atomic_fetch_or