[flang] Implement legacy %VAL and %REF actual arguments #70343
Merged
Conversation
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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. 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 compiler 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.
llvmbot
added
flang
|
@llvm/pr-subscribers-flang-fir-hlfir @llvm/pr-subscribers-flang-semantics Author: None (jeanPerier) ChangesUpdate evaluate::ActualArgument to propagate the %VAL and %REF markers until lowering. 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. Full diff: https://github.com/llvm/llvm-project/pull/70343.diff 7 Files Affected:
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
|
clementval
reviewed
Oct 26, 2023
klausler
approved these changes
Oct 26, 2023
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
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.