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

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 retrieves these markers and does the right thing: pass %VAL in registers and pass %REF by address without adding any extra arguments for characters.
llvm · Oct 27, 2023 · 0a10e88 · 0a10e88
1 parent ea1909f
commit 0a10e88
Show file tree

Hide file tree

Showing 9 changed files with 226 additions and 35 deletions.
diff --git 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/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
@@ -183,6 +183,7 @@ class DynamicType {
   constexpr bool IsUnlimitedPolymorphic() const { // TYPE(*) or CLASS(*)
     return IsPolymorphic() && !derived_;
   }
+  bool IsLengthlessIntrinsicType() const;
   constexpr const semantics::DerivedTypeSpec &GetDerivedTypeSpec() const {
     return DEREF(derived_);
   }

diff --git 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
@@ -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/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
@@ -240,6 +240,11 @@ bool DynamicType::IsTypelessIntrinsicArgument() const {
   return category_ == TypeCategory::Integer && kind_ == TypelessKind;
 }
 
+bool DynamicType::IsLengthlessIntrinsicType() const {
+  return common::IsNumericTypeCategory(category_) ||
+      category_ == TypeCategory::Logical;
+}
+
 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
     const std::optional<DynamicType> &type) {
   return type ? GetDerivedTypeSpec(*type) : nullptr;

diff --git 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
@@ -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,
@@ -3894,13 +3895,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) {
@@ -3923,32 +3925,50 @@ 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 || !type->IsLengthlessIntrinsicType() ||
+                  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
@@ -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
@@ -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