diff --git a/flang/docs/Directives.md b/flang/docs/Directives.md index 5640e44e16ba..704bb76a1d25 100644 --- a/flang/docs/Directives.md +++ b/flang/docs/Directives.md @@ -19,8 +19,11 @@ A list of non-standard directives supported by Flang incompatible in type (T), kind (K), rank (R), CUDA device (D), or managed (M) status. The letter (A) is a shorthand for (TKRDM), and is the default when no letters appear. The letter (C) checks for contiguity, for example allowing an - element of an assumed-shape array to be passed as a dummy argument. The - letter (P) ignores pointer and allocatable matching, so that one can pass an + element of an assumed-shape array to be passed as a dummy argument. It also + specifies that dummy arguments passed by descriptor should not have their + descriptor copied or reboxed, allowing the original descriptor to be passed + directly even if attributes like ALLOCATABLE or POINTER don't match exactly. + The letter (P) ignores pointer and allocatable matching, so that one can pass an allocatable array to routine with pointer array argument and vice versa. For example, if one wanted to call a "set all bytes to zero" utility that could be applied to arrays of any type or rank: diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h index 9933e3ed6c30..c41313da050a 100644 --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -66,6 +66,7 @@ public: bool isBoxAddressOrValue() const { return hlfir::isBoxAddressOrValueType(getType()); } + bool isBoxAddress() const { return fir::isBoxAddress(getType()); } /// Is this entity a procedure designator? bool isProcedure() const { return isFortranProcedureValue(getType()); } diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index 2cbb6f20d34d..7bdd84903c1d 100644 --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -298,6 +298,50 @@ getResultLengthFromElementalOp(fir::FirOpBuilder &builder, lengths.push_back(len); } +// Go through the args. Any descriptor args that have ignore_tkr(c) cause +// function type modification to avoid changing the descriptor args. +static std::optional +getTypeWithIgnoreTkrC(mlir::FunctionType funcType, + Fortran::lower::CallerInterface &caller, + mlir::MLIRContext *context) { + llvm::SmallVector newInputs = + llvm::to_vector(funcType.getInputs()); + bool typeChanged = false; + for (const auto &arg : caller.getPassedArguments()) { + if (arg.firArgument >= 0 && + arg.firArgument < static_cast(newInputs.size())) { + + // Only need to change the arg type for ignore_tkr(c) + if (!arg.testTKR(Fortran::common::IgnoreTKR::Contiguous)) + continue; + + mlir::Type expectedType = newInputs[arg.firArgument]; + // Cast is only needed for descriptors + if (!fir::isa_box_type(expectedType)) + continue; + + // Handle ignore_tkr(c) for descriptors + mlir::Value actual = caller.getInput(arg); + if (!actual) + continue; + + mlir::Type actualType = actual.getType(); + if (fir::isBoxAddress(actualType)) { + newInputs[arg.firArgument] = actualType; + typeChanged = true; + } + } + } + + if (typeChanged) { + // At least one of the arguments had its type changed, so need to + // create a new function type to be used in a cast. + return mlir::FunctionType::get(context, newInputs, funcType.getResults()); + } + + return std::nullopt; +} + std::pair Fortran::lower::genCallOpAndResult( mlir::Location loc, Fortran::lower::AbstractConverter &converter, @@ -495,6 +539,29 @@ Fortran::lower::genCallOpAndResult( mlir::FunctionType funcType = funcPointer ? callSiteType : caller.getFuncOp().getFunctionType(); + + // If we have any ignore_tkr(c) dummy args, adjust the function type to + // have these args match the caller. + if (auto modifiedFuncType = + getTypeWithIgnoreTkrC(funcType, caller, builder.getContext())) { + // Note: funcPointer would only be non-null here, if we are already + // processing indirect function call. In such case we can re-use the same + // funcPointer and we'll cast it below the the modified funcType. + if (!funcPointer) { + // We want to cast the function to a different type, in order to avoid + // changing/casting some of the args. The cast will generate a new + // function pointer, so that we would make a function call not through + // the original function symbol, but through the new function pointer + // (an indirect function call). + mlir::SymbolRefAttr symbolAttr = + builder.getSymbolRefAttr(caller.getMangledName()); + // Create pointer to original function. This pointer will be cast later. + funcPointer = fir::AddrOfOp::create(builder, loc, funcType, symbolAttr); + funcSymbolAttr = {}; // This marks it as indirect call + } + funcType = *modifiedFuncType; + } + llvm::SmallVector operands; // First operand of indirect call is the function pointer. Cast it to // required function type for the call to handle procedures that have a @@ -1257,6 +1324,12 @@ static PreparedDummyArgument preparePresentUserCallActualArgument( // element if this is an array in an elemental call. hlfir::Entity actual = preparedActual.getActual(loc, builder); + if (arg.testTKR(Fortran::common::IgnoreTKR::Contiguous) && + actual.isBoxAddress()) { + // With ignore_tkr(c), pointer to a descriptor should be passed as is + return PreparedDummyArgument{actual, /*cleanups=*/{}}; + } + // Handle procedure arguments (procedure pointers should go through // prepareProcedurePointerActualArgument). if (hlfir::isFortranProcedureValue(dummyType)) { @@ -1756,6 +1829,12 @@ void prepareUserCallArguments( caller.placeInput(arg, boxStorage); continue; } + if (arg.testTKR(Fortran::common::IgnoreTKR::Contiguous) && + actual.isBoxAddress()) { + // With ignore_tkr(c), pointer to a descriptor should be passed as is + caller.placeInput(arg, actual); + continue; + } if (fir::isPointerType(argTy) && (!Fortran::evaluate::IsObjectPointer(*expr) || thisIsPassArg)) { // Passing a non POINTER actual argument to a POINTER dummy argument. diff --git a/flang/test/Lower/HLFIR/ignore-tkr-c-descriptor.f90 b/flang/test/Lower/HLFIR/ignore-tkr-c-descriptor.f90 new file mode 100644 index 000000000000..8982614c5155 --- /dev/null +++ b/flang/test/Lower/HLFIR/ignore-tkr-c-descriptor.f90 @@ -0,0 +1,55 @@ +! RUN: bbc -emit-hlfir -o - %s | FileCheck %s + +! Test that ignore_tkr(c) avoids descriptor copies (rebox/embox) for dummy arguments. + +module m_ignore_tkr_c + interface + subroutine pass_array_ptr(a) + !dir$ ignore_tkr(cp) a + real, pointer :: a(:) + end subroutine + subroutine pass_array_val(a) + !dir$ ignore_tkr(c) a + real :: a(:) + end subroutine + end interface +contains + ! CHECK-LABEL: func.func @_QMm_ignore_tkr_cPs1( + ! CHECK-SAME: %[[ARR:.*]]: !fir.ref>>> + subroutine s1(arr) + real, allocatable :: arr(:) + ! CHECK: %[[BOX_REF:.*]]:2 = hlfir.declare %[[ARR]] + ! CHECK: %[[CONV:.*]] = fir.convert %[[BOX_REF]]#0 : (!fir.ref>>>) -> !fir.ref>>> + ! CHECK: fir.call @_QPpass_array_ptr(%[[CONV]]) {{.*}} : (!fir.ref>>>) -> () + call pass_array_ptr(arr) + end subroutine + + ! CHECK-LABEL: func.func @_QMm_ignore_tkr_cPs2( + ! CHECK-SAME: %[[ARR:.*]]: !fir.ref>>> + subroutine s2(arr) + real, allocatable :: arr(:) + ! CHECK: %[[BOX_REF:.*]]:2 = hlfir.declare %[[ARR]] + ! CHECK-NOT: fir.load %[[BOX_REF]]#0 + ! CHECK: %[[ADDR:.*]] = fir.address_of(@_QPpass_array_val) + ! CHECK: %[[CAST:.*]] = fir.convert %[[ADDR]] + ! CHECK: fir.call %[[CAST]](%[[BOX_REF]]#0) {{.*}} : (!fir.ref>>>) -> () + call pass_array_val(arr) + end subroutine + + ! CHECK-LABEL: func.func @_QMm_ignore_tkr_cPs3( + ! CHECK-SAME: %[[ARR:.*]]: !fir.ref>>> + subroutine s3(arr) + real, allocatable :: arr(:) + procedure(pass_array_val), pointer :: p + p => pass_array_val + ! CHECK: %[[BOX_REF:.*]]:2 = hlfir.declare %[[ARR]] + ! CHECK: %[[P_REF:.*]]:2 = hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QMm_ignore_tkr_cFs3Ep"} + ! CHECK: %[[ADDR:.*]] = fir.load %[[P_REF]]#0 : !fir.ref>) -> ()>> + ! CHECK: %[[FUNC_ADDR:.*]] = fir.box_addr %[[ADDR]] : (!fir.boxproc<(!fir.box>) -> ()>) -> ((!fir.ref>>>) -> ()) + ! CHECK: fir.call %[[FUNC_ADDR]](%[[BOX_REF]]#0) {{.*}} : (!fir.ref>>>) -> () + call p(arr) + end subroutine + + ! CHECK: func.func private @_QPpass_array_ptr(!fir.ref>>>) + ! CHECK: func.func private @_QPpass_array_val(!fir.box>) +end module