[flang] Avoid descriptor conversion for descriptor args with ignore_tkr(c) (#176240)

For descriptor arguments marked with `!dir$ ignore_tkr(c)` we want to
leave them unmodified: don't create another descriptor or change the
existing descriptor.

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:

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()); }

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<mlir::FunctionType>
+getTypeWithIgnoreTkrC(mlir::FunctionType funcType,
+                      Fortran::lower::CallerInterface &caller,
+                      mlir::MLIRContext *context) {
+  llvm::SmallVector<mlir::Type> newInputs =
+      llvm::to_vector(funcType.getInputs());
+  bool typeChanged = false;
+  for (const auto &arg : caller.getPassedArguments()) {
+    if (arg.firArgument >= 0 &&
+        arg.firArgument < static_cast<int>(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::LoweredResult, bool>
 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<mlir::Value> 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.

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<!fir.box<!fir.heap<!fir.array<?xf32>>>>
+  subroutine s1(arr)
+    real, allocatable :: arr(:)
+    ! CHECK: %[[BOX_REF:.*]]:2 = hlfir.declare %[[ARR]]
+    ! CHECK: %[[CONV:.*]] = fir.convert %[[BOX_REF]]#0 : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: fir.call @_QPpass_array_ptr(%[[CONV]]) {{.*}} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> ()
+    call pass_array_ptr(arr)
+  end subroutine
+
+  ! CHECK-LABEL: func.func @_QMm_ignore_tkr_cPs2(
+  ! CHECK-SAME: %[[ARR:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
+  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<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> ()
+    call pass_array_val(arr)
+  end subroutine
+
+  ! CHECK-LABEL: func.func @_QMm_ignore_tkr_cPs3(
+  ! CHECK-SAME: %[[ARR:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
+  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<pointer>, uniq_name = "_QMm_ignore_tkr_cFs3Ep"}
+    ! CHECK: %[[ADDR:.*]] = fir.load %[[P_REF]]#0 : !fir.ref<!fir.boxproc<(!fir.box<!fir.array<?xf32>>) -> ()>>
+    ! CHECK: %[[FUNC_ADDR:.*]] = fir.box_addr %[[ADDR]] : (!fir.boxproc<(!fir.box<!fir.array<?xf32>>) -> ()>) -> ((!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> ())
+    ! CHECK: fir.call %[[FUNC_ADDR]](%[[BOX_REF]]#0) {{.*}} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> ()
+    call p(arr)
+  end subroutine
+
+  ! CHECK: func.func private @_QPpass_array_ptr(!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>)
+  ! CHECK: func.func private @_QPpass_array_val(!fir.box<!fir.array<?xf32>>)
+end module