Skip to content

Commit 0a10e88

Browse files
jeanPerierjeanPerier
authored
[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.
1 parent ea1909f commit 0a10e88

File tree

9 files changed

+226
-35
lines changed

9 files changed

+226
-35
lines changed

‎flang/include/flang/Evaluate/call.h‎

Lines changed: 22 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,9 @@ using SymbolRef = common::Reference<const Symbol>;
5252

5353
class ActualArgument {
5454
public:
55+
ENUM_CLASS(Attr, PassedObject, PercentVal, PercentRef);
56+
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
57+
5558
// Dummy arguments that are TYPE(*) can be forwarded as actual arguments.
5659
// Since that's the only thing one may do with them in Fortran, they're
5760
// represented in expressions as a special case of an actual argument.
@@ -118,9 +121,13 @@ class ActualArgument {
118121
bool isAlternateReturn() const {
119122
return std::holds_alternative<common::Label>(u_);
120123
}
121-
bool isPassedObject() const { return isPassedObject_; }
124+
bool isPassedObject() const { return attrs_.test(Attr::PassedObject); }
122125
ActualArgument &set_isPassedObject(bool yes = true) {
123-
isPassedObject_ = yes;
126+
if (yes) {
127+
attrs_ = attrs_ + Attr::PassedObject;
128+
} else {
129+
attrs_ = attrs_ - Attr::PassedObject;
130+
}
124131
return *this;
125132
}
126133

@@ -141,7 +148,18 @@ class ActualArgument {
141148
// Wrap this argument in parentheses
142149
void Parenthesize();
143150

144-
// TODO: Mark legacy %VAL and %REF arguments
151+
// Legacy %VAL.
152+
bool isPercentVal() const { return attrs_.test(Attr::PercentVal); };
153+
ActualArgument &set_isPercentVal() {
154+
attrs_ = attrs_ + Attr::PercentVal;
155+
return *this;
156+
}
157+
// Legacy %REF.
158+
bool isPercentRef() const { return attrs_.test(Attr::PercentRef); };
159+
ActualArgument &set_isPercentRef() {
160+
attrs_ = attrs_ + Attr::PercentRef;
161+
return *this;
162+
}
145163

146164
private:
147165
// Subtlety: There is a distinction that must be maintained here between an
@@ -153,7 +171,7 @@ class ActualArgument {
153171
common::Label>
154172
u_;
155173
std::optional<parser::CharBlock> keyword_;
156-
bool isPassedObject_{false};
174+
Attrs attrs_;
157175
common::Intent dummyIntent_{common::Intent::Default};
158176
std::optional<parser::CharBlock> sourceLocation_;
159177
};

‎flang/include/flang/Evaluate/type.h‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -183,6 +183,7 @@ class DynamicType {
183183
constexpr bool IsUnlimitedPolymorphic() const { // TYPE(*) or CLASS(*)
184184
return IsPolymorphic() && !derived_;
185185
}
186+
bool IsLengthlessIntrinsicType() const;
186187
constexpr const semantics::DerivedTypeSpec &GetDerivedTypeSpec() const {
187188
return DEREF(derived_);
188189
}

‎flang/lib/Evaluate/call.cpp‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -57,8 +57,7 @@ int ActualArgument::Rank() const {
5757
}
5858

5959
bool ActualArgument::operator==(const ActualArgument &that) const {
60-
return keyword_ == that.keyword_ && isPassedObject_ == that.isPassedObject_ &&
61-
u_ == that.u_;
60+
return keyword_ == that.keyword_ && attrs_ == that.attrs_ && u_ == that.u_;
6261
}
6362

6463
void ActualArgument::Parenthesize() {

‎flang/lib/Evaluate/formatting.cpp‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -132,6 +132,11 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
132132
if (keyword_) {
133133
o << keyword_->ToString() << '=';
134134
}
135+
if (isPercentVal()) {
136+
o << "%VAL(";
137+
} else if (isPercentRef()) {
138+
o << "%REF(";
139+
}
135140
common::visit(
136141
common::visitors{
137142
[&](const common::CopyableIndirection<Expr<SomeType>> &expr) {
@@ -141,6 +146,9 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
141146
[&](const common::Label &label) { o << '*' << label; },
142147
},
143148
u_);
149+
if (isPercentVal() || isPercentRef()) {
150+
o << ')';
151+
}
144152
return o;
145153
}
146154

‎flang/lib/Evaluate/type.cpp‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -240,6 +240,11 @@ bool DynamicType::IsTypelessIntrinsicArgument() const {
240240
return category_ == TypeCategory::Integer && kind_ == TypelessKind;
241241
}
242242

243+
bool DynamicType::IsLengthlessIntrinsicType() const {
244+
return common::IsNumericTypeCategory(category_) ||
245+
category_ == TypeCategory::Logical;
246+
}
247+
243248
const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
244249
const std::optional<DynamicType> &type) {
245250
return type ? GetDerivedTypeSpec(*type) : nullptr;

‎flang/lib/Lower/CallInterface.cpp‎

Lines changed: 30 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -844,11 +844,40 @@ class Fortran::lower::CallInterfaceImpl {
844844
return {};
845845
}
846846

847+
mlir::Type
848+
getRefType(Fortran::evaluate::DynamicType dynamicType,
849+
const Fortran::evaluate::characteristics::DummyDataObject &obj) {
850+
mlir::Type type = translateDynamicType(dynamicType);
851+
fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
852+
if (!bounds.empty())
853+
type = fir::SequenceType::get(bounds, type);
854+
return fir::ReferenceType::get(type);
855+
}
856+
847857
void handleImplicitDummy(
848858
const DummyCharacteristics *characteristics,
849859
const Fortran::evaluate::characteristics::DummyDataObject &obj,
850860
const FortranEntity &entity) {
851861
Fortran::evaluate::DynamicType dynamicType = obj.type.type();
862+
if constexpr (std::is_same_v<FortranEntity,
863+
const Fortran::evaluate::ActualArgument *>) {
864+
if (entity) {
865+
if (entity->isPercentVal()) {
866+
mlir::Type type = translateDynamicType(dynamicType);
867+
addFirOperand(type, nextPassedArgPosition(), Property::Value,
868+
dummyNameAttr(entity));
869+
addPassedArg(PassEntityBy::Value, entity, characteristics);
870+
return;
871+
}
872+
if (entity->isPercentRef()) {
873+
mlir::Type refType = getRefType(dynamicType, obj);
874+
addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
875+
dummyNameAttr(entity));
876+
addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
877+
return;
878+
}
879+
}
880+
}
852881
if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
853882
mlir::Type boxCharTy =
854883
fir::BoxCharType::get(&mlirContext, dynamicType.kind());
@@ -857,11 +886,7 @@ class Fortran::lower::CallInterfaceImpl {
857886
addPassedArg(PassEntityBy::BoxChar, entity, characteristics);
858887
} else {
859888
// non-PDT derived type allowed in implicit interface.
860-
mlir::Type type = translateDynamicType(dynamicType);
861-
fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
862-
if (!bounds.empty())
863-
type = fir::SequenceType::get(bounds, type);
864-
mlir::Type refType = fir::ReferenceType::get(type);
889+
mlir::Type refType = getRefType(dynamicType, obj);
865890
addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
866891
dummyNameAttr(entity));
867892
addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);

‎flang/lib/Semantics/expression.cpp‎

Lines changed: 44 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -175,6 +175,7 @@ class ArgumentAnalyzer {
175175
MaybeExpr TryDefinedOp(std::vector<const char *>, parser::MessageFixedText);
176176
MaybeExpr TryBoundOp(const Symbol &, int passIndex);
177177
std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
178+
std::optional<ActualArgument> AnalyzeVariable(const parser::Variable &);
178179
MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
179180
bool AreConformable() const;
180181
const Symbol *FindBoundOp(parser::CharBlock, int passIndex,
@@ -3894,13 +3895,14 @@ MaybeExpr ExpressionAnalyzer::AnalyzeComplex(
38943895
std::move(im), GetDefaultKind(TypeCategory::Real)));
38953896
}
38963897

3897-
void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
3898+
std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeVariable(
3899+
const parser::Variable &x) {
38983900
source_.ExtendToCover(x.GetSource());
38993901
if (MaybeExpr expr{context_.Analyze(x)}) {
39003902
if (!IsConstantExpr(*expr)) {
3901-
actuals_.emplace_back(std::move(*expr));
3902-
SetArgSourceLocation(actuals_.back(), x.GetSource());
3903-
return;
3903+
ActualArgument actual{std::move(*expr)};
3904+
SetArgSourceLocation(actual, x.GetSource());
3905+
return actual;
39043906
}
39053907
const Symbol *symbol{GetLastSymbol(*expr)};
39063908
if (!symbol) {
@@ -3923,32 +3925,50 @@ void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
39233925
}
39243926
}
39253927
fatalErrors_ = true;
3928+
return std::nullopt;
3929+
}
3930+
3931+
void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
3932+
if (auto actual = AnalyzeVariable(x)) {
3933+
actuals_.emplace_back(std::move(actual));
3934+
}
39263935
}
39273936

39283937
void ArgumentAnalyzer::Analyze(
39293938
const parser::ActualArgSpec &arg, bool isSubroutine) {
39303939
// TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
39313940
std::optional<ActualArgument> actual;
3932-
common::visit(common::visitors{
3933-
[&](const common::Indirection<parser::Expr> &x) {
3934-
actual = AnalyzeExpr(x.value());
3935-
SetArgSourceLocation(actual, x.value().source);
3936-
},
3937-
[&](const parser::AltReturnSpec &label) {
3938-
if (!isSubroutine) {
3939-
context_.Say(
3940-
"alternate return specification may not appear on"
3941-
" function reference"_err_en_US);
3942-
}
3943-
actual = ActualArgument(label.v);
3944-
},
3945-
[&](const parser::ActualArg::PercentRef &) {
3946-
context_.Say("%REF() intrinsic for arguments"_todo_en_US);
3947-
},
3948-
[&](const parser::ActualArg::PercentVal &) {
3949-
context_.Say("%VAL() intrinsic for arguments"_todo_en_US);
3950-
},
3951-
},
3941+
common::visit(
3942+
common::visitors{
3943+
[&](const common::Indirection<parser::Expr> &x) {
3944+
actual = AnalyzeExpr(x.value());
3945+
},
3946+
[&](const parser::AltReturnSpec &label) {
3947+
if (!isSubroutine) {
3948+
context_.Say("alternate return specification may not appear on"
3949+
" function reference"_err_en_US);
3950+
}
3951+
actual = ActualArgument(label.v);
3952+
},
3953+
[&](const parser::ActualArg::PercentRef &percentRef) {
3954+
actual = AnalyzeVariable(percentRef.v);
3955+
if (actual.has_value()) {
3956+
actual->set_isPercentRef();
3957+
}
3958+
},
3959+
[&](const parser::ActualArg::PercentVal &percentVal) {
3960+
actual = AnalyzeExpr(percentVal.v);
3961+
if (actual.has_value()) {
3962+
actual->set_isPercentVal();
3963+
std::optional<DynamicType> type{actual->GetType()};
3964+
if (!type || !type->IsLengthlessIntrinsicType() ||
3965+
actual->Rank() != 0) {
3966+
context_.SayAt(percentVal.v,
3967+
"%VAL argument must be a scalar numerical or logical expression"_err_en_US);
3968+
}
3969+
}
3970+
},
3971+
},
39523972
std::get<parser::ActualArg>(arg.t).u);
39533973
if (actual) {
39543974
if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {

‎flang/test/Lower/HLFIR/calls-percent-val-ref.f90‎

Lines changed: 69 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,69 @@
1+
! Test lowering of legacy %VAL and %REF actual arguments.
2+
! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
3+
4+
subroutine test_val_1(x)
5+
integer :: x
6+
call val1(%val(x))
7+
end subroutine
8+
! CHECK-LABEL: func.func @_QPtest_val_1(
9+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
10+
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_val_1Ex"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
11+
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<i32>
12+
! CHECK: fir.call @_QPval1(%[[VAL_2]]) fastmath<contract> : (i32) -> ()
13+
14+
subroutine test_val_2(x)
15+
complex, allocatable :: x
16+
call val2(%val(x))
17+
end subroutine
18+
! CHECK-LABEL: func.func @_QPtest_val_2(
19+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>> {fir.bindc_name = "x"}) {
20+
! 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>>>>)
21+
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.complex<4>>>>
22+
! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<!fir.complex<4>>>) -> !fir.heap<!fir.complex<4>>
23+
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.heap<!fir.complex<4>>
24+
! CHECK: fir.call @_QPval2(%[[VAL_4]]) fastmath<contract> : (!fir.complex<4>) -> ()
25+
26+
subroutine test_ref_char(x)
27+
! There must be not extra length argument. Only the address is
28+
! passed.
29+
character(*) :: x
30+
call ref_char(%ref(x))
31+
end subroutine
32+
! CHECK-LABEL: func.func @_QPtest_ref_char(
33+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxchar<1> {fir.bindc_name = "x"}) {
34+
! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
35+
! 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,?>>)
36+
! CHECK: %[[VAL_3:.*]]:2 = fir.unboxchar %[[VAL_2]]#0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
37+
! CHECK: fir.call @_QPref_char(%[[VAL_3]]#0) fastmath<contract> : (!fir.ref<!fir.char<1,?>>) -> ()
38+
39+
subroutine test_ref_1(x)
40+
integer :: x
41+
call ref1(%ref(x))
42+
end subroutine
43+
! CHECK-LABEL: func.func @_QPtest_ref_1(
44+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
45+
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_ref_1Ex"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
46+
! CHECK: fir.call @_QPref1(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<i32>) -> ()
47+
48+
subroutine test_ref_2(x)
49+
complex, pointer :: x
50+
call ref2(%ref(x))
51+
end subroutine
52+
! CHECK-LABEL: func.func @_QPtest_ref_2(
53+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>> {fir.bindc_name = "x"}) {
54+
! 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>>>>)
55+
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.complex<4>>>>
56+
! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.complex<4>>>) -> !fir.ptr<!fir.complex<4>>
57+
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ptr<!fir.complex<4>>) -> !fir.ref<!fir.complex<4>>
58+
! CHECK: fir.call @_QPref2(%[[VAL_4]]) fastmath<contract> : (!fir.ref<!fir.complex<4>>) -> ()
59+
60+
subroutine test_skip_copy_in_out(x)
61+
real :: x(:)
62+
call val3(%val(%loc(x)))
63+
end subroutine
64+
! CHECK-LABEL: func.func @_QPtest_skip_copy_in_out(
65+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "x"}) {
66+
! 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>>)
67+
! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]]#1 : (!fir.box<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>>
68+
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.array<?xf32>>) -> i64
69+
! CHECK: fir.call @_QPval3(%[[VAL_3]]) fastmath<contract> : (i64) -> ()

‎flang/test/Semantics/call40.f90‎

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
! RUN: %python %S/test_errors.py %s %flang_fc1
2+
! %VAL en %REF legacy extension semantic tests.
3+
4+
subroutine val_errors(array, string, polymorphic, derived)
5+
type t
6+
integer :: t
7+
end type
8+
integer :: array(10)
9+
character(*) :: string
10+
type(t) :: derived
11+
type(*) :: polymorphic
12+
!ERROR: %VAL argument must be a scalar numerical or logical expression
13+
call foo1(%val(array))
14+
!ERROR: %VAL argument must be a scalar numerical or logical expression
15+
call foo2(%val(string))
16+
!ERROR: %VAL argument must be a scalar numerical or logical expression
17+
call foo3(%val(derived))
18+
!ERROR: %VAL argument must be a scalar numerical or logical expression
19+
!ERROR: Assumed type argument requires an explicit interface
20+
call foo4(%val(polymorphic))
21+
end subroutine
22+
23+
subroutine val_ok()
24+
integer :: array(10)
25+
real :: x
26+
logical :: l
27+
complex :: c
28+
call ok1(%val(array(1)))
29+
call ok2(%val(x))
30+
call ok3(%val(l))
31+
call ok4(%val(c))
32+
call ok5(%val(42))
33+
call ok6(%val(x+x))
34+
end subroutine
35+
36+
subroutine ref_ok(array, string, derived)
37+
type t
38+
integer :: t
39+
end type
40+
integer :: array(10)
41+
character(*) :: string
42+
type(t) :: derived
43+
call rok1(%ref(array))
44+
call rok2(%ref(string))
45+
call rok3(%ref(derived))
46+
end subroutine

0 commit comments

Comments
 (0)