[flang] Make 'this_image()' an intrinsic function

[craig.rasmussen]

Summary

Added 'this_image()' to the list of functions that are evaluated as intrinsic.
Added IsCoarray functions to determine if an expression is a coarray (corank > 1).

flang/docs/Intrinsics.md

 
 ### Semantic Analysis
 F18 semantic expression analysis phase detects intrinsic procedure references,
 validates the argument types and deduces the return types.
 This phase currently supports all the intrinsic procedures listed above but the ones in the table below.
 
 | Intrinsic Category | Intrinsic Procedures Lacking Support |
 | --- | --- |
-| Coarray intrinsic functions | LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE, COSHAPE |
+| Coarray intrinsic functions | LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, STOPPED_IMAGES, TEAM_NUMBER, COSHAPE |
 | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
 | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
 | Non-standard intrinsic functions | AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, LOC, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
 | Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SYSTEM_CLOCK |
 | Atomic intrinsic subroutines | ATOMIC_ADD &al. |
 | Collective intrinsic subroutines | CO_BROADCAST &al. |
 
 

flang/include/flang/Evaluate/tools.h

 }
 template <typename T> bool IsAssumedRank(const Expr<T> &expr) {
   return std::visit([](const auto &x) { return IsAssumedRank(x); }, expr.u);
 }
 template <typename A> bool IsAssumedRank(const std::optional<A> &x) {
   return x && IsAssumedRank(*x);
 }
 
+// Predicate: true when an expression is a coarray (corank > 0)
+bool IsCoarray(const ActualArgument &);
+template <typename A> bool IsCoarray(const A &) { return false; }
+template <typename A> bool IsCoarray(const Designator<A> &designator) {
+  if (const auto *symbol{std::get_if<SymbolRef>(&designator.u)}) {
+    return IsCoarray(symbol->get());
+  } else {
+    return false;
+  }
+}
+template <typename T> bool IsCoarray(const Expr<T> &expr) {
+  return std::visit([](const auto &x) { return IsCoarray(x); }, expr.u);
+}
+template <typename A> bool IsCoarray(const std::optional<A> &x) {
+  return x && IsCoarray(*x);
+}
+
 // Generalizing packagers: these take operations and expressions of more
 // specific types and wrap them in Expr<> containers of more abstract types.
 
 template <typename A> common::IfNoLvalue<Expr<ResultType<A>>, A> AsExpr(A &&x) {
   return Expr<ResultType<A>>{std::move(x)};
 }
 
 template <typename T> Expr<T> AsExpr(Expr<T> &&x) {

flang/lib/Evaluate/intrinsics.cpp

 #include "flang/Common/enum-set.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/common.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/shape.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/type.h"
+#include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
 #include <algorithm>
 #include <map>
 #include <string>
 #include <utility>
 
 using namespace Fortran::parser::literals;
 

 // "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
     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
     locReduced, // vector(1:rank) if no DIM= argument, else rank(array)-1
     rankPlus1, // rank(known)+1
static const IntrinsicInterface genericIntrinsicFunction[]{
     {"sum", {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK},
         SameNumeric, Rank::dimReduced,
         IntrinsicClass::transformationalFunction},
     {"sum", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK},
         SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"tan", {{"x", SameFloating}}, SameFloating},
     {"tand", {{"x", SameFloating}}, SameFloating},
     {"tanh", {{"x", SameFloating}}, SameFloating},
+    // optional team dummy arguments needed to complete the following
+    // this_image versions
+    {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalDIM},
+        DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
+    {"this_image", {}, DefaultInt, Rank::scalar,
+        IntrinsicClass::transformationalFunction},
     {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar,
         IntrinsicClass::inquiryFunction},
     {"trailz", {{"i", AnyInt}}, DefaultInt},
     {"transfer",
         {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::scalar}},
         SameType, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"transfer",
         {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::array}},
// this_image versions
         DefaultLogical},
     {"__builtin_ieee_support_underflow_control",
         {{"x", AnyReal, Rank::elemental, Optionality::optional}},
         DefaultLogical},
 };
 
 // TODO: Coarray intrinsic functions
 //   LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX,
-//   STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE,
-//   COSHAPE
+//   STOPPED_IMAGES, TEAM_NUMBER, COSHAPE
 // TODO: Non-standard intrinsic functions
 //  AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT,
 //  COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,
 //  QCMPLX, QEXT, QFLOAT, QREAL, DNUM,
 //  INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN,
 //  MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR
 //  IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE,
 //  EOF, FP_CLASS, INT_PTR_KIND, MALLOC
if (const ActualArgument * arg{actualForDummy[j]}) {
         argOk = rank > 0;
         if (!arrayArg) {
           arrayArg = arg;
           arrayArgName = d.keyword;
         } else {
           argOk &= rank == arrayArg->Rank();
         }
         break;
+      case Rank::coarray:
+        argOk = IsCoarray(*arg);
+        if (!argOk) {
+          messages.Say(
+              "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US,
+              name);
+          return std::nullopt;
+        }
+        break;
       case Rank::known:
         if (!knownArg) {
           knownArg = arg;
         }
         argOk = rank == knownArg->Rank();
         break;
       case Rank::anyOrAssumedRank:
         argOk = true;
case Rank::rankPlus1:
     break;
   case Rank::shaped:
     CHECK(shapeArgSize);
     resultRank = *shapeArgSize;
     break;
   case Rank::elementalOrBOZ:
   case Rank::shape:
   case Rank::array:
+  case Rank::coarray:
   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);

flang/lib/Evaluate/tools.cpp

if (const auto *expr{arg.UnwrapExpr()}) {
     return IsAssumedRank(*expr);
   } else {
     const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
     CHECK(assumedTypeDummy);
     return IsAssumedRank(*assumedTypeDummy);
   }
 }
 
+bool IsCoarray(const ActualArgument &arg) {
+  if (const auto *expr{arg.UnwrapExpr()}) {
+    return IsCoarray(*expr);
+  } else {
+    return false;
+  }
+}
+
 bool IsProcedure(const Expr<SomeType> &expr) {
   return std::holds_alternative<ProcedureDesignator>(expr.u);
 }
 bool IsFunction(const Expr<SomeType> &expr) {
   const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
   return designator && designator->GetType().has_value();
 }
 

flang/test/Semantics/call10.f90

contains
   end subroutine
   pure subroutine s13
     !ERROR: An image control statement may not appear in a pure subprogram
     sync all ! C1599
   end subroutine
   pure subroutine s14
     integer :: img, nimgs, i[*], tmp
                                    ! implicit sync all
-    !ERROR: Procedure 'this_image' referenced in pure subprogram 's14' must be pure too
     img = this_image()
     nimgs = num_images()
     i = img                       ! i is ready to use
 
     if ( img .eq. 1 ) then
       !ERROR: An image control statement may not appear in a pure subprogram
       sync images( nimgs )          ! explicit sync 1 with last img
       tmp = i[ nimgs ]

flang/test/Semantics/this_image.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Check for semantic errors in this_image() function calls
+
+subroutine test
+  use, intrinsic :: iso_fortran_env, only: team_type
+  type(team_type) :: oregon, coteam[*]
+  integer :: coscalar[*], coarray(3)[*]
+  save :: coteam, coscalar, coarray
+
+  ! correct calls, should produce no errors
+  print *, this_image()
+  print *, this_image(coarray)
+  print *, this_image(coscalar,1)
+  print *, this_image(coarray,1)
+
+  !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'this_image'
+  print *, this_image(array,1)
+
+  ! TODO: More complete testing requires implementation of team_type
+  ! actual arguments in flang/lib/Evaluate/intrinsics.cpp
+
+end subroutine