[flang-commits] [flang] [flang] Implement legacy %VAL and %REF actual arguments (PR #70343)

via flang-commits flang-commits at lists.llvm.org
Thu Oct 26 08:15:01 PDT 2023


llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

Author: None (jeanPerier)

<details>
<summary>Changes</summary>

Update evaluate::ActualArgument to propagate the %VAL and %REF markers until lowering.
Semantic checks are added to %VAL to ensure the argument is a numerical or logical scalar.

I did not push these markers into the characteristics because other compilers do not complain about inconsistent usages (e.g. using %VAL in a call on a procedure with an interface without VALUE dummies is not flagged by any compilers I tested, and it is not an issue for lowering, so I decided to stay simple here and minimize the footprint of these legacy features).

Lowering retrieve these markers and does the right thing: pass %VAL in registers and pass %REF by address without adding any extra arguments for characters.

Note that %LOC was already handled (rewritten as LOC intrinsic), but this patch tests that %VAL(%LOC()) allows skipping copy-in/copy-out as described [in gfortran documentation](https://gcc.gnu.org/onlinedocs/gcc-3.4.6/g77/_0025LOC_0028_0029.html#g_t_0025LOC_0028_0029).

---
Full diff: https://github.com/llvm/llvm-project/pull/70343.diff


7 Files Affected:

- (modified) flang/include/flang/Evaluate/call.h (+22-4) 
- (modified) flang/lib/Evaluate/call.cpp (+1-2) 
- (modified) flang/lib/Evaluate/formatting.cpp (+8) 
- (modified) flang/lib/Lower/CallInterface.cpp (+30-5) 
- (modified) flang/lib/Semantics/expression.cpp (+46-24) 
- (added) flang/test/Lower/HLFIR/calls-percent-val-ref.f90 (+69) 
- (added) flang/test/Semantics/call40.f90 (+46) 


``````````diff
diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h
index d8241c08e3b25e3..3d766bc08e58d46 100644
--- a/flang/include/flang/Evaluate/call.h
+++ b/flang/include/flang/Evaluate/call.h
@@ -52,6 +52,9 @@ using SymbolRef = common::Reference<const Symbol>;
 
 class ActualArgument {
 public:
+  ENUM_CLASS(Attr, PassedObject, PercentVal, PercentRef);
+  using Attrs = common::EnumSet<Attr, Attr_enumSize>;
+
   // Dummy arguments that are TYPE(*) can be forwarded as actual arguments.
   // Since that's the only thing one may do with them in Fortran, they're
   // represented in expressions as a special case of an actual argument.
@@ -118,9 +121,13 @@ class ActualArgument {
   bool isAlternateReturn() const {
     return std::holds_alternative<common::Label>(u_);
   }
-  bool isPassedObject() const { return isPassedObject_; }
+  bool isPassedObject() const { return attrs_.test(Attr::PassedObject); }
   ActualArgument &set_isPassedObject(bool yes = true) {
-    isPassedObject_ = yes;
+    if (yes) {
+      attrs_ = attrs_ + Attr::PassedObject;
+    } else {
+      attrs_ = attrs_ - Attr::PassedObject;
+    }
     return *this;
   }
 
@@ -141,7 +148,18 @@ class ActualArgument {
   // Wrap this argument in parentheses
   void Parenthesize();
 
-  // TODO: Mark legacy %VAL and %REF arguments
+  // Legacy %VAL.
+  bool isPercentVal() const { return attrs_.test(Attr::PercentVal); };
+  ActualArgument &set_isPercentVal() {
+    attrs_ = attrs_ + Attr::PercentVal;
+    return *this;
+  }
+  // Legacy %REF.
+  bool isPercentRef() const { return attrs_.test(Attr::PercentRef); };
+  ActualArgument &set_isPercentRef() {
+    attrs_ = attrs_ + Attr::PercentRef;
+    return *this;
+  }
 
 private:
   // Subtlety: There is a distinction that must be maintained here between an
@@ -153,7 +171,7 @@ class ActualArgument {
       common::Label>
       u_;
   std::optional<parser::CharBlock> keyword_;
-  bool isPassedObject_{false};
+  Attrs attrs_;
   common::Intent dummyIntent_{common::Intent::Default};
   std::optional<parser::CharBlock> sourceLocation_;
 };
diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp
index 55631ee2a476c98..c5b50e806d2497d 100644
--- a/flang/lib/Evaluate/call.cpp
+++ b/flang/lib/Evaluate/call.cpp
@@ -57,8 +57,7 @@ int ActualArgument::Rank() const {
 }
 
 bool ActualArgument::operator==(const ActualArgument &that) const {
-  return keyword_ == that.keyword_ && isPassedObject_ == that.isPassedObject_ &&
-      u_ == that.u_;
+  return keyword_ == that.keyword_ && attrs_ == that.attrs_ && u_ == that.u_;
 }
 
 void ActualArgument::Parenthesize() {
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index 52964fff76d6fa3..5684c07657e61f1 100644
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -132,6 +132,11 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
   if (keyword_) {
     o << keyword_->ToString() << '=';
   }
+  if (isPercentVal()) {
+    o << "%VAL(";
+  } else if (isPercentRef()) {
+    o << "%REF(";
+  }
   common::visit(
       common::visitors{
           [&](const common::CopyableIndirection<Expr<SomeType>> &expr) {
@@ -141,6 +146,9 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
           [&](const common::Label &label) { o << '*' << label; },
       },
       u_);
+  if (isPercentVal() || isPercentRef()) {
+    o << ')';
+  }
   return o;
 }
 
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index ea38b737a303a6d..43bbbb933658a8a 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -844,11 +844,40 @@ class Fortran::lower::CallInterfaceImpl {
     return {};
   }
 
+  mlir::Type
+  getRefType(Fortran::evaluate::DynamicType dynamicType,
+             const Fortran::evaluate::characteristics::DummyDataObject &obj) {
+    mlir::Type type = translateDynamicType(dynamicType);
+    fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
+    if (!bounds.empty())
+      type = fir::SequenceType::get(bounds, type);
+    return fir::ReferenceType::get(type);
+  }
+
   void handleImplicitDummy(
       const DummyCharacteristics *characteristics,
       const Fortran::evaluate::characteristics::DummyDataObject &obj,
       const FortranEntity &entity) {
     Fortran::evaluate::DynamicType dynamicType = obj.type.type();
+    if constexpr (std::is_same_v<FortranEntity,
+                                 const Fortran::evaluate::ActualArgument *>) {
+      if (entity) {
+        if (entity->isPercentVal()) {
+          mlir::Type type = translateDynamicType(dynamicType);
+          addFirOperand(type, nextPassedArgPosition(), Property::Value,
+                        dummyNameAttr(entity));
+          addPassedArg(PassEntityBy::Value, entity, characteristics);
+          return;
+        }
+        if (entity->isPercentRef()) {
+          mlir::Type refType = getRefType(dynamicType, obj);
+          addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
+                        dummyNameAttr(entity));
+          addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
+          return;
+        }
+      }
+    }
     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
       mlir::Type boxCharTy =
           fir::BoxCharType::get(&mlirContext, dynamicType.kind());
@@ -857,11 +886,7 @@ class Fortran::lower::CallInterfaceImpl {
       addPassedArg(PassEntityBy::BoxChar, entity, characteristics);
     } else {
       // non-PDT derived type allowed in implicit interface.
-      mlir::Type type = translateDynamicType(dynamicType);
-      fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
-      if (!bounds.empty())
-        type = fir::SequenceType::get(bounds, type);
-      mlir::Type refType = fir::ReferenceType::get(type);
+      mlir::Type refType = getRefType(dynamicType, obj);
       addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
                     dummyNameAttr(entity));
       addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 4ccb2c3ef5d0121..4952594dfc87237 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -175,6 +175,7 @@ class ArgumentAnalyzer {
   MaybeExpr TryDefinedOp(std::vector<const char *>, parser::MessageFixedText);
   MaybeExpr TryBoundOp(const Symbol &, int passIndex);
   std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
+  std::optional<ActualArgument> AnalyzeVariable(const parser::Variable &);
   MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
   bool AreConformable() const;
   const Symbol *FindBoundOp(parser::CharBlock, int passIndex,
@@ -3869,13 +3870,14 @@ MaybeExpr ExpressionAnalyzer::AnalyzeComplex(
       std::move(im), GetDefaultKind(TypeCategory::Real)));
 }
 
-void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
+std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeVariable(
+    const parser::Variable &x) {
   source_.ExtendToCover(x.GetSource());
   if (MaybeExpr expr{context_.Analyze(x)}) {
     if (!IsConstantExpr(*expr)) {
-      actuals_.emplace_back(std::move(*expr));
-      SetArgSourceLocation(actuals_.back(), x.GetSource());
-      return;
+      ActualArgument actual{std::move(*expr)};
+      SetArgSourceLocation(actual, x.GetSource());
+      return actual;
     }
     const Symbol *symbol{GetLastSymbol(*expr)};
     if (!symbol) {
@@ -3898,32 +3900,52 @@ void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
     }
   }
   fatalErrors_ = true;
+  return std::nullopt;
+}
+
+void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
+  if (auto actual = AnalyzeVariable(x)) {
+    actuals_.emplace_back(std::move(actual));
+  }
 }
 
 void ArgumentAnalyzer::Analyze(
     const parser::ActualArgSpec &arg, bool isSubroutine) {
   // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
   std::optional<ActualArgument> actual;
-  common::visit(common::visitors{
-                    [&](const common::Indirection<parser::Expr> &x) {
-                      actual = AnalyzeExpr(x.value());
-                      SetArgSourceLocation(actual, x.value().source);
-                    },
-                    [&](const parser::AltReturnSpec &label) {
-                      if (!isSubroutine) {
-                        context_.Say(
-                            "alternate return specification may not appear on"
-                            " function reference"_err_en_US);
-                      }
-                      actual = ActualArgument(label.v);
-                    },
-                    [&](const parser::ActualArg::PercentRef &) {
-                      context_.Say("%REF() intrinsic for arguments"_todo_en_US);
-                    },
-                    [&](const parser::ActualArg::PercentVal &) {
-                      context_.Say("%VAL() intrinsic for arguments"_todo_en_US);
-                    },
-                },
+  common::visit(
+      common::visitors{
+          [&](const common::Indirection<parser::Expr> &x) {
+            actual = AnalyzeExpr(x.value());
+          },
+          [&](const parser::AltReturnSpec &label) {
+            if (!isSubroutine) {
+              context_.Say("alternate return specification may not appear on"
+                           " function reference"_err_en_US);
+            }
+            actual = ActualArgument(label.v);
+          },
+          [&](const parser::ActualArg::PercentRef &percentRef) {
+            actual = AnalyzeVariable(percentRef.v);
+            if (actual.has_value()) {
+              actual->set_isPercentRef();
+            }
+          },
+          [&](const parser::ActualArg::PercentVal &percentVal) {
+            actual = AnalyzeExpr(percentVal.v);
+            if (actual.has_value()) {
+              actual->set_isPercentVal();
+              std::optional<DynamicType> type{actual->GetType()};
+              if (!type ||
+                  !(common::IsNumericTypeCategory(type->category()) ||
+                      type->category() == common::TypeCategory::Logical) ||
+                  actual->Rank() != 0) {
+                context_.SayAt(percentVal.v,
+                    "%VAL argument must be a scalar numerical or logical expression"_err_en_US);
+              }
+            }
+          },
+      },
       std::get<parser::ActualArg>(arg.t).u);
   if (actual) {
     if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
diff --git a/flang/test/Lower/HLFIR/calls-percent-val-ref.f90 b/flang/test/Lower/HLFIR/calls-percent-val-ref.f90
new file mode 100644
index 000000000000000..c6acc42455f1b0e
--- /dev/null
+++ b/flang/test/Lower/HLFIR/calls-percent-val-ref.f90
@@ -0,0 +1,69 @@
+! Test lowering of legacy %VAL and %REF actual arguments.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+subroutine test_val_1(x)
+  integer :: x
+  call val1(%val(x))
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_val_1(
+! CHECK-SAME:                             %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_val_1Ex"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<i32>
+! CHECK:           fir.call @_QPval1(%[[VAL_2]]) fastmath<contract> : (i32) -> ()
+
+subroutine test_val_2(x)
+  complex, allocatable :: x
+  call val2(%val(x))
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_val_2(
+! CHECK-SAME:                             %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFtest_val_2Ex"} : (!fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>>, !fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>>
+! CHECK:           %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<!fir.complex<4>>>) -> !fir.heap<!fir.complex<4>>
+! CHECK:           %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.heap<!fir.complex<4>>
+! CHECK:           fir.call @_QPval2(%[[VAL_4]]) fastmath<contract> : (!fir.complex<4>) -> ()
+
+subroutine test_ref_char(x)
+  ! There must be not extra length argument. Only the address is
+  ! passed.
+  character(*) :: x
+  call ref_char(%ref(x))
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ref_char(
+! CHECK-SAME:                                %[[VAL_0:.*]]: !fir.boxchar<1> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:           %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 {uniq_name = "_QFtest_ref_charEx"} : (!fir.ref<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+! CHECK:           %[[VAL_3:.*]]:2 = fir.unboxchar %[[VAL_2]]#0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:           fir.call @_QPref_char(%[[VAL_3]]#0) fastmath<contract> : (!fir.ref<!fir.char<1,?>>) -> ()
+
+subroutine test_ref_1(x)
+  integer :: x
+  call ref1(%ref(x))
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ref_1(
+! CHECK-SAME:                             %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_ref_1Ex"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:           fir.call @_QPref1(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<i32>) -> ()
+
+subroutine test_ref_2(x)
+  complex, pointer :: x
+  call ref2(%ref(x))
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ref_2(
+! CHECK-SAME:                             %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_ref_2Ex"} : (!fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>>
+! CHECK:           %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.complex<4>>>) -> !fir.ptr<!fir.complex<4>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ptr<!fir.complex<4>>) -> !fir.ref<!fir.complex<4>>
+! CHECK:           fir.call @_QPref2(%[[VAL_4]]) fastmath<contract> : (!fir.ref<!fir.complex<4>>) -> ()
+
+subroutine test_skip_copy_in_out(x)
+  real :: x(:)
+  call val3(%val(%loc(x)))
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_skip_copy_in_out(
+! CHECK-SAME:                                        %[[VAL_0:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_skip_copy_in_outEx"} : (!fir.box<!fir.array<?xf32>>) -> (!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>)
+! CHECK:           %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]]#1 : (!fir.box<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>>
+! CHECK:           %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.array<?xf32>>) -> i64
+! CHECK:           fir.call @_QPval3(%[[VAL_3]]) fastmath<contract> : (i64) -> ()
diff --git a/flang/test/Semantics/call40.f90 b/flang/test/Semantics/call40.f90
new file mode 100644
index 000000000000000..492fcdd1256af52
--- /dev/null
+++ b/flang/test/Semantics/call40.f90
@@ -0,0 +1,46 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! %VAL en %REF legacy extension semantic tests.
+
+subroutine val_errors(array, string, polymorphic, derived)
+  type t
+    integer :: t
+  end type
+  integer :: array(10)
+  character(*) :: string
+  type(t) :: derived
+  type(*) :: polymorphic
+  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  call foo1(%val(array))
+  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  call foo2(%val(string))
+  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  call foo3(%val(derived))
+  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  !ERROR: Assumed type argument requires an explicit interface
+  call foo4(%val(polymorphic))
+end subroutine
+
+subroutine val_ok()
+  integer :: array(10)
+  real :: x
+  logical :: l
+  complex :: c
+  call ok1(%val(array(1)))
+  call ok2(%val(x))
+  call ok3(%val(l))
+  call ok4(%val(c))
+  call ok5(%val(42))
+  call ok6(%val(x+x))
+end subroutine
+
+subroutine ref_ok(array, string, derived)
+  type t
+    integer :: t
+  end type
+  integer :: array(10)
+  character(*) :: string
+  type(t) :: derived
+  call rok1(%ref(array))
+  call rok2(%ref(string))
+  call rok3(%ref(derived))
+end subroutine

``````````

</details>


https://github.com/llvm/llvm-project/pull/70343


More information about the flang-commits mailing list