[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