Skip to content

Commit ad4e1ab

Browse files
jeanPerierjeanPerier
authored
[flang] Pass VALUE CHARACTER arg by register in BIND(C) calls (#87774)
Fortran mandates "CHARACTER(1), VALUE" be passed as a C "char" in calls to BIND(C) procedures (F'2023 18.3.7 (4)). Lowering passed them by memory instead. Update call interface lowering code to pass them by register. Fix related test and update it to use HLFIR.
1 parent a5ed14b commit ad4e1ab

File tree

4 files changed

+101
-54
lines changed

4 files changed

+101
-54
lines changed

‎flang/lib/Lower/CallInterface.cpp

Lines changed: 16 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1136,14 +1136,22 @@ class Fortran::lower::CallInterfaceImpl {
11361136
addPassedArg(PassEntityBy::Box, entity, characteristics);
11371137
} else if (dynamicType.category() ==
11381138
Fortran::common::TypeCategory::Character) {
1139-
// Pass as fir.box_char
1140-
mlir::Type boxCharTy =
1141-
fir::BoxCharType::get(&mlirContext, dynamicType.kind());
1142-
addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
1143-
attrs);
1144-
addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute
1145-
: PassEntityBy::BoxChar,
1146-
entity, characteristics);
1139+
if (isValueAttr && isBindC) {
1140+
// Pass as fir.char<1>
1141+
mlir::Type charTy =
1142+
fir::CharacterType::getSingleton(&mlirContext, dynamicType.kind());
1143+
addFirOperand(charTy, nextPassedArgPosition(), Property::Value, attrs);
1144+
addPassedArg(PassEntityBy::Value, entity, characteristics);
1145+
} else {
1146+
// Pass as fir.box_char
1147+
mlir::Type boxCharTy =
1148+
fir::BoxCharType::get(&mlirContext, dynamicType.kind());
1149+
addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
1150+
attrs);
1151+
addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute
1152+
: PassEntityBy::BoxChar,
1153+
entity, characteristics);
1154+
}
11471155
} else {
11481156
// Pass as fir.ref unless it's by VALUE and BIND(C). Also pass-by-value
11491157
// for numerical/logical scalar without OPTIONAL so that the behavior is

‎flang/lib/Lower/ConvertCall.cpp

Lines changed: 12 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1494,11 +1494,19 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
14941494
value =
14951495
hlfir::Entity{genRecordCPtrValueArg(builder, loc, value, eleTy)};
14961496
}
1497-
} else if (fir::isa_derived(value.getFortranElementType())) {
1498-
// BIND(C), VALUE derived type. The derived type value must really
1497+
} else if (fir::isa_derived(value.getFortranElementType()) ||
1498+
value.isCharacter()) {
1499+
// BIND(C), VALUE derived type or character. The value must really
14991500
// be loaded here.
1500-
auto [derived, cleanup] = hlfir::convertToValue(loc, builder, value);
1501-
mlir::Value loadedValue = fir::getBase(derived);
1501+
auto [exv, cleanup] = hlfir::convertToValue(loc, builder, value);
1502+
mlir::Value loadedValue = fir::getBase(exv);
1503+
// Character actual arguments may have unknown length or a length longer
1504+
// than one. Cast the memory ref to the dummy type so that the load is
1505+
// valid and only loads what is needed.
1506+
if (mlir::Type baseTy = fir::dyn_cast_ptrEleTy(loadedValue.getType()))
1507+
if (fir::isa_char(baseTy))
1508+
loadedValue = builder.createConvert(
1509+
loc, fir::ReferenceType::get(argTy), loadedValue);
15021510
if (fir::isa_ref_type(loadedValue.getType()))
15031511
loadedValue = builder.create<fir::LoadOp>(loc, loadedValue);
15041512
caller.placeInput(arg, loadedValue);

‎flang/lib/Lower/ConvertVariable.cpp

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2100,10 +2100,15 @@ void Fortran::lower::mapSymbolAttributes(
21002100
if (ba.isChar()) {
21012101
if (arg) {
21022102
assert(!preAlloc && "dummy cannot be pre-allocated");
2103-
if (arg.getType().isa<fir::BoxCharType>())
2103+
if (mlir::isa<fir::BoxCharType>(arg.getType())) {
21042104
std::tie(addr, len) = charHelp.createUnboxChar(arg);
2105-
else if (!addr)
2105+
} else if (mlir::isa<fir::CharacterType>(arg.getType())) {
2106+
// fir.char<1> passed by value (BIND(C) with VALUE attribute).
2107+
addr = builder.create<fir::AllocaOp>(loc, arg.getType());
2108+
builder.create<fir::StoreOp>(loc, arg, addr);
2109+
} else if (!addr) {
21062110
addr = arg;
2111+
}
21072112
// Ensure proper type is given to array/scalar that was transmitted as a
21082113
// fir.boxchar arg or is a statement function actual argument with
21092114
// a different length than the dummy.

‎flang/test/Lower/call-by-value.f90

Lines changed: 66 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,10 @@
11
! Test for PassBy::Value
2-
! RUN: bbc -emit-fir -hlfir=false %s -o - | FileCheck %s
2+
! RUN: bbc -emit-fir %s -o - | FileCheck %s
33

44
!CHECK-LABEL: func @_QQmain()
5-
!CHECK: %[[LOGICAL:.*]] = fir.alloca !fir.logical<1>
65
!CHECK: %false = arith.constant false
6+
!CHECK: %[[LOGICAL_ALLOC:.*]] = fir.alloca !fir.logical<1>
7+
!CHECK: %[[LOGICAL:.*]] = fir.declare %[[LOGICAL_ALLOC]]
78
!CHECK: %[[VALUE:.*]] = fir.convert %false : (i1) -> !fir.logical<1>
89
!CHECK: fir.store %[[VALUE]] to %[[LOGICAL]]
910
!CHECK: %[[LOAD:.*]] = fir.load %[[LOGICAL]]
@@ -23,52 +24,56 @@ end subroutine omp_set_nested
2324
call omp_set_nested(do_nested)
2425
end program call_by_value
2526

26-
! CHECK-LABEL: func.func @test_integer_value(
27-
! CHECK-SAME: %[[VAL_0:.*]]: i32 {fir.bindc_name = "x"}) attributes {fir.bindc_name = "test_integer_value"} {
28-
! CHECK: %[[VAL_1:.*]] = fir.alloca i32
29-
! CHECK: fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<i32>
30-
! CHECK: fir.call @_QPinternal_call(%[[VAL_1]]) {{.*}}: (!fir.ref<i32>) -> ()
31-
! CHECK: return
32-
! CHECK: }
27+
! CHECK-LABEL: func.func @test_integer_value(
28+
! CHECK-SAME: %[[VAL_0:.*]]: i32
29+
! CHECK: %[[VAL_1:.*]] = fir.alloca i32
30+
! CHECK: fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<i32>
31+
! CHECK: %[[VAL_2:.*]] = fir.declare %[[VAL_1]]
32+
! CHECK: fir.call @_QPinternal_call(%[[VAL_2]]) {{.*}}: (!fir.ref<i32>) -> ()
33+
! CHECK: return
34+
! CHECK: }
3335

3436
subroutine test_integer_value(x) bind(c)
3537
integer, value :: x
3638
call internal_call(x)
3739
end
40+
! CHECK-LABEL: func.func @test_real_value(
41+
! CHECK-SAME: %[[VAL_0:.*]]: f32
42+
! CHECK: %[[VAL_1:.*]] = fir.alloca f32
43+
! CHECK: fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<f32>
44+
! CHECK: %[[VAL_2:.*]] = fir.declare %[[VAL_1]]
45+
! CHECK: fir.call @_QPinternal_call2(%[[VAL_2]]) {{.*}}: (!fir.ref<f32>) -> ()
46+
! CHECK: return
47+
! CHECK: }
3848

39-
! CHECK-LABEL: func.func @test_real_value(
40-
! CHECK-SAME: %[[VAL_0:.*]]: f32 {fir.bindc_name = "x"}) attributes {fir.bindc_name = "test_real_value"} {
41-
! CHECK: %[[VAL_1:.*]] = fir.alloca f32
42-
! CHECK: fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<f32>
43-
! CHECK: fir.call @_QPinternal_call2(%[[VAL_1]]) {{.*}}: (!fir.ref<f32>) -> ()
44-
! CHECK: return
45-
! CHECK: }
4649

4750
subroutine test_real_value(x) bind(c)
4851
real, value :: x
4952
call internal_call2(x)
5053
end
54+
! CHECK-LABEL: func.func @test_complex_value(
55+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.complex<4>
56+
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.complex<4>
57+
! CHECK: fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<!fir.complex<4>>
58+
! CHECK: %[[VAL_2:.*]] = fir.declare %[[VAL_1]]
59+
! CHECK: fir.call @_QPinternal_call3(%[[VAL_2]]) {{.*}}: (!fir.ref<!fir.complex<4>>) -> ()
60+
! CHECK: return
61+
! CHECK: }
5162

52-
! CHECK-LABEL: func.func @test_complex_value(
53-
! CHECK-SAME: %[[VAL_0:.*]]: !fir.complex<4> {fir.bindc_name = "x"}) attributes {fir.bindc_name = "test_complex_value"} {
54-
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.complex<4>
55-
! CHECK: fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<!fir.complex<4>>
56-
! CHECK: fir.call @_QPinternal_call3(%[[VAL_1]]) {{.*}}: (!fir.ref<!fir.complex<4>>) -> ()
57-
! CHECK: return
58-
! CHECK: }
5963

6064
subroutine test_complex_value(x) bind(c)
6165
complex, value :: x
6266
call internal_call3(x)
6367
end
6468

6569
! CHECK-LABEL: func.func @test_char_value(
66-
! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxchar<1> {fir.bindc_name = "x"}) attributes {fir.bindc_name = "test_char_value"} {
67-
! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
68-
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1>>
69-
! CHECK: %[[VAL_2:.*]] = arith.constant 1 : index
70-
! CHECK: %[[VAL_5:.*]] = fir.emboxchar %[[VAL_3]], %[[VAL_2]] : (!fir.ref<!fir.char<1>>, index) -> !fir.boxchar<1>
71-
! CHECK: fir.call @_QPinternal_call4(%[[VAL_5]]) fastmath<contract> : (!fir.boxchar<1>) -> ()
70+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.char<1>
71+
! CHECK: %[[VAL_1:.*]] = arith.constant 1 : index
72+
! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.char<1>
73+
! CHECK: fir.store %[[VAL_0]] to %[[VAL_2]] : !fir.ref<!fir.char<1>>
74+
! CHECK: %[[VAL_3:.*]] = fir.declare %[[VAL_2]] typeparams %[[VAL_1]]
75+
! CHECK: %[[VAL_4:.*]] = fir.emboxchar %[[VAL_3]], %[[VAL_1]] : (!fir.ref<!fir.char<1>>, index) -> !fir.boxchar<1>
76+
! CHECK: fir.call @_QPinternal_call4(%[[VAL_4]]) {{.*}}: (!fir.boxchar<1>) -> ()
7277
! CHECK: return
7378
! CHECK: }
7479

@@ -77,19 +82,40 @@ subroutine test_char_value(x) bind(c)
7782
call internal_call4(x)
7883
end
7984

80-
! CHECK-LABEL: func.func @_QPtest_cptr_value(
81-
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i64> {fir.bindc_name = "x"}) {
82-
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
83-
! CHECK: %[[VAL_2:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
84-
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
85-
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<i64>) -> i64
86-
! CHECK: fir.store %[[VAL_4]] to %[[VAL_3]] : !fir.ref<i64>
87-
! CHECK: fir.call @_QPinternal_call5(%[[VAL_1]]) {{.*}}: (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>) -> ()
88-
! CHECK: return
89-
! CHECK: }
85+
! CHECK-LABEL: func.func @_QPtest_call_char_value(
86+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxchar<1>
87+
! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
88+
! CHECK: %[[VAL_2:.*]] = fir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1
89+
! CHECK: %[[VAL_3:.*]] = fir.emboxchar %[[VAL_2]], %[[VAL_1]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
90+
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1>>
91+
! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref<!fir.char<1>>
92+
! CHECK: fir.call @test_char_value(%[[VAL_5]]) {{.*}}: (!fir.char<1>) -> ()
93+
! CHECK: return
94+
! CHECK: }
95+
subroutine test_call_char_value(x)
96+
character(*) :: x
97+
interface
98+
subroutine test_char_value(x) bind(c)
99+
character(1), value :: x
100+
end
101+
end interface
102+
call test_char_value(x)
103+
end subroutine
104+
105+
! CHECK-LABEL: func.func @_QPtest_cptr_value(
106+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i64>
107+
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
108+
! CHECK: %[[VAL_2:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
109+
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
110+
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<i64>) -> i64
111+
! CHECK: fir.store %[[VAL_4]] to %[[VAL_3]] : !fir.ref<i64>
112+
! CHECK: %[[VAL_5:.*]] = fir.declare %[[VAL_1]]
113+
! CHECK: fir.call @_QPinternal_call5(%[[VAL_5]]) fastmath<contract> : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>) -> ()
114+
! CHECK: return
115+
! CHECK: }
90116

91117
subroutine test_cptr_value(x)
92-
use iso_c_binding
118+
use iso_c_binding, only: c_ptr
93119
type(c_ptr), value :: x
94120
call internal_call5(x)
95121
end

0 commit comments

Comments
 (0)