[flang] Fix lowering of optional char proc args

[luporl]

Summary

Optional character function arguments were not being lowered
properly. As they are passed as a tuple, containing the (boxed)
function address and the character length, it is not possible for
fir.absent to handle it directly. Instead, a tuple needs to be
created and filled with an absent function address and a dummy
character length.

Fixes #60225

[jeanPerier]

Thanks a lot for the fix!

flang/lib/Lower/ConvertExpr.cpp

2463–2474

Can I ask you to move this code into a new FirOpBuilder helper builder.genAbsentOp(loc, argTy) that would detect that the argTy is a tuple via fir::isCharacterProcedureTuple(argTy), and use fir::factory::createCharacterProcedureTuple instead of createBoxProcCharTuple to create the tuple?

That way, it can be reused in other places that also suffer from this bug, like the equivalent HLFIR code pieces here:

• https://github.com/llvm/llvm-project/blob/91cbc3f2d83dfcf064238e807b47c58279509ff7/flang/lib/Lower/ConvertCall.cpp#L1047
• https://github.com/llvm/llvm-project/blob/91cbc3f2d83dfcf064238e807b47c58279509ff7/flang/lib/Lower/ConvertCall.cpp#L764

2470

I would use fir.undefined or zero rather than 1 for the length of an absent character procedure.

[luporl]

Thanks for the review!

flang/lib/Lower/ConvertExpr.cpp

2463–2474

Right, I'll make this change and fix these HLFIR code pieces.

[luporl]

• Use fir.undefined as character length
• Move lowering fix to builder.genAbsentOp
• Fix HLFIR and test it

[jeanPerier]

Thanks a lot, I think the IR can be slightly further simplify by merging the fir.absent and fir.emboxproc into a single fir.absent. Looks great otherwise.

flang/lib/Optimizer/Builder/FIRBuilder.cpp

619

Nit: single line if/for... should not have braces in LLVM/MLIR coding style (it's a bit of brain gymnastic...)

https://llvm.org/docs/CodingStandards.html#don-t-use-braces-on-simple-single-statement-bodies-of-if-else-loop-statements

623–627

Thinking this through a bit more, doesn't auto boxProc = create<fir::AbsentOp>(loc, argTy.cast<mlir::TupleType>().getType(0)); works an save the EmboxProc at that level?
I think AbsentOp should work properly on BoxProcType (otherwise, there would also be a bug for optional non character dummy procedures).

It will probably also make the extension of this code to optional character pointer procedure easier when they arrive (nothing to do other than updating the isCharacterProcedureTuple to detect them).

[luporl]

flang/lib/Optimizer/Builder/FIRBuilder.cpp

623–627

I've tried this and it works (assembly seems correct and test program runs without errors).

I'm just a bit worried about the generated FIR, that has an unconditional fir.box_addr on the absent BoxProc, in the if (present(arg)) part. Is fir.box_addr guaranteed to work with fir.absent BoxProcs?

[jeanPerier]

flang/lib/Optimizer/Builder/FIRBuilder.cpp

623–627

Is fir.box_addr guaranteed to work with fir.absent BoxProcs?

Yes, it's fine. I agree it is not supper nice to do this box_addr + embox_proc. It is a bit useless an noisy, but is not related to your patch.

The box_addr is probably generated here: https://github.com/llvm/llvm-project/blob/cedfd2721e3492e5ab0ea86d24d8027846687c27/flang/lib/Lower/ConvertProcedureDesignator.cpp#L63, but it would need to be tested that the box_addr part can be skipped (that the code in lowering is OK with getting a fir.boxproc), so I would not try to change this in this patch.

[luporl]

flang/lib/Optimizer/Builder/FIRBuilder.cpp

623–627

Ok, thanks for the detailed explanation. Then I'll go ahead with this change.

[luporl]

• Simplify IR

[jeanPerier]

Thanks for having dealt with all the comments, LGTM

flang/include/flang/Optimizer/Builder/FIRBuilder.h

public:
   mlir::Value genIsNullAddr(mlir::Location loc, mlir::Value addr);
 
   /// Compute the extent of (lb:ub:step) as max((ub-lb+step)/step, 0). See
   /// Fortran 2018 9.5.3.3.2 section for more details.
   mlir::Value genExtentFromTriplet(mlir::Location loc, mlir::Value lb,
                                    mlir::Value ub, mlir::Value step,
                                    mlir::Type type);
 
+  /// Create an AbsentOp of \p argTy type and handle special cases, such as
+  /// Character Procedure Tuple arguments.
+  mlir::Value genAbsentOp(mlir::Location loc, mlir::Type argTy);
+
   /// Set default FastMathFlags value for all operations
   /// supporting mlir::arith::FastMathAttr that will be created
   /// by this builder.
   void setFastMathFlags(mlir::arith::FastMathFlags flags) {
     fastMathFlags = flags;
   }
 
   /// Set default FastMathFlags value from the passed MathOptionsBase

flang/lib/Lower/ConvertCall.cpp

struct ConditionallyPreparedDummy {
   void genElseResult(mlir::Location loc, fir::FirOpBuilder &builder) const {
     llvm::SmallVector<mlir::Value> elseResultValues;
     mlir::Type i1Type = builder.getI1Type();
     for (mlir::Value res : thenResultValues) {
       mlir::Type type = res.getType();
       if (type == i1Type)
         elseResultValues.push_back(builder.createBool(loc, false));
       else
-        elseResultValues.push_back(builder.create<fir::AbsentOp>(loc, type));
+        elseResultValues.push_back(builder.genAbsentOp(loc, type));
     }
     builder.create<fir::ResultOp>(loc, elseResultValues);
   }
 
   /// Once the fir.if has been created, get the resulting %conditionallyPrepared
   /// dummy argument.
   PreparedDummyArgument
   getPreparedDummy(fir::IfOp ifOp,
genUserCall(PreparedActualArguments &loweredActuals,
   mlir::Location loc = callContext.loc;
   fir::FirOpBuilder &builder = callContext.getBuilder();
   llvm::SmallVector<CallCleanUp> callCleanUps;
   for (auto [preparedActual, arg] :
        llvm::zip(loweredActuals, caller.getPassedArguments())) {
     mlir::Type argTy = callSiteType.getInput(arg.firArgument);
     if (!preparedActual) {
       // Optional dummy argument for which there is no actual argument.
-      caller.placeInput(arg, builder.create<fir::AbsentOp>(loc, argTy));
+      caller.placeInput(arg, builder.genAbsentOp(loc, argTy));
       continue;
     }
     const auto *expr = arg.entity->UnwrapExpr();
     if (!expr)
       TODO(loc, "assumed type actual argument");
 
     switch (arg.passBy) {
     case PassBy::Value: {

flang/lib/Lower/ConvertExpr.cpp

ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
     // arguments.
     for (const Fortran::lower::CallInterface<
              Fortran::lower::CallerInterface>::PassedEntity &arg :
          caller.getPassedArguments()) {
       const auto *actual = arg.entity;
       mlir::Type argTy = callSiteType.getInput(arg.firArgument);
       if (!actual) {
         // Optional dummy argument for which there is no actual argument.
-        caller.placeInput(arg, builder.create<fir::AbsentOp>(loc, argTy));
+        caller.placeInput(arg, builder.genAbsentOp(loc, argTy));
         continue;
       }
       const auto *expr = actual->UnwrapExpr();
       if (!expr)
         TODO(loc, "assumed type actual argument");
 
       if (arg.passBy == PassBy::Value) {
         ExtValue argVal = genval(*expr);
         if (!fir::isUnboxedValue(argVal))
           fir::emitFatalError(
               loc, "internal error: passing non trivial value by value");
         caller.placeInput(arg, fir::getBase(argVal));
         continue;
       }
 
       if (arg.passBy == PassBy::MutableBox) {
         if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
                 *expr)) {
           // If expr is NULL(), the mutableBox created must be a deallocated
           // pointer with the dummy argument characteristics (see table 16.5
           // in Fortran 2018 standard).
           // No length parameters are set for the created box because any non
           // deferred type parameters of the dummy will be evaluated on the
           // callee side, and it is illegal to use NULL without a MOLD if any

flang/lib/Optimizer/Builder/FIRBuilder.cpp

mlir::Value fir::FirOpBuilder::genExtentFromTriplet(mlir::Location loc,
   auto diff = create<mlir::arith::SubIOp>(loc, ub, lb);
   auto add = create<mlir::arith::AddIOp>(loc, diff, step);
   auto div = create<mlir::arith::DivSIOp>(loc, add, step);
   auto cmp = create<mlir::arith::CmpIOp>(loc, mlir::arith::CmpIPredicate::sgt,
                                          div, zero);
   return create<mlir::arith::SelectOp>(loc, cmp, div, zero);
 }
 
+mlir::Value fir::FirOpBuilder::genAbsentOp(mlir::Location loc,
+                                           mlir::Type argTy) {
+  if (!fir::isCharacterProcedureTuple(argTy))
+    return create<fir::AbsentOp>(loc, argTy);
+
+  auto boxProc =
+      create<fir::AbsentOp>(loc, argTy.cast<mlir::TupleType>().getType(0));
+  mlir::Value charLen = create<fir::UndefOp>(loc, getCharacterLengthType());
+  return fir::factory::createCharacterProcedureTuple(*this, loc, argTy, boxProc,
+                                                     charLen);
+}
+
 void fir::FirOpBuilder::setCommonAttributes(mlir::Operation *op) const {
   auto fmi = mlir::dyn_cast<mlir::arith::ArithFastMathInterface>(*op);
   if (!fmi)
     return;
   // TODO: use fmi.setFastMathFlagsAttr() after D137114 is merged.
   //       For now set the attribute by the name.
   llvm::StringRef arithFMFAttrName = fmi.getFastMathAttrName();
   if (fastMathFlags != mlir::arith::FastMathFlags::none)

flang/test/Lower/HLFIR/dummy-argument-optional.f90

+! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s
+
+! Test OPTIONAL lowering on caller/callee
+module opt
+  implicit none
+contains
+
+! Test optional character function
+! CHECK-LABEL: func @_QMoptPchar_proc(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.char<1,3>>,
+character(len=3) function char_proc(i)
+  integer :: i
+  char_proc = "XYZ"
+end function
+! CHECK-LABEL: func @_QMoptPuse_char_proc(
+! CHECK-SAME: %[[arg0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc},
+subroutine use_char_proc(f, c)
+  optional :: f
+  interface
+    character(len=3) function f(i)
+      integer :: i
+    end function
+  end interface
+  character(len=3) :: c
+! CHECK: %[[boxProc:.*]] = fir.extract_value %[[arg0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK: %[[boxAddr:.*]] = fir.box_addr %[[boxProc]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[boxProc2:.*]] = fir.emboxproc %[[boxAddr]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK: %[[tuple:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple]], %[[boxProc2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple3:.*]] = fir.insert_value %[[tuple2]], %{{.*}}, [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[boxProc3:.*]] = fir.extract_value %[[tuple3]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK: %{{.*}} = fir.is_present %[[boxProc3]] : (!fir.boxproc<() -> ()>) -> i1
+  if (present(f)) then
+    c = f(0)
+  else
+    c = "ABC"
+  end if
+end subroutine
+! CHECK-LABEL: func @_QMoptPcall_use_char_proc(
+subroutine call_use_char_proc()
+  character(len=3) :: c
+! CHECK: %[[boxProc:.*]] = fir.absent !fir.boxproc<() -> ()>
+! CHECK: %[[undef:.*]] = fir.undefined index
+! CHECK: %[[charLen:.*]] = fir.convert %[[undef]] : (index) -> i64
+! CHECK: %[[tuple:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple]], %[[boxProc]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple3:.*]] = fir.insert_value %[[tuple2]], %[[charLen]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: fir.call @_QMoptPuse_char_proc(%[[tuple3]], %{{.*}}){{.*}} : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxchar<1>) -> ()
+  call use_char_proc(c=c)
+! CHECK: %[[funcAddr:.*]] = fir.address_of(@_QMoptPchar_proc) : (!fir.ref<!fir.char<1,3>>, index, {{.*}}) -> !fir.boxchar<1>
+! CHECK: %[[c3:.*]] = arith.constant 3 : i64
+! CHECK: %[[boxProc2:.*]] = fir.emboxproc %[[funcAddr]] : ((!fir.ref<!fir.char<1,3>>, index, {{.*}}) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+! CHECK: %[[tuple4:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple5:.*]] = fir.insert_value %[[tuple4]], %[[boxProc2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple6:.*]] = fir.insert_value %[[tuple5]], %[[c3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: fir.call @_QMoptPuse_char_proc(%[[tuple6]], {{.*}}){{.*}} : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxchar<1>) -> ()
+  call use_char_proc(char_proc, c)
+end subroutine
+
+end module

flang/test/Lower/dummy-argument-optional.f90

 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: flang-new -fc1 -fdefault-integer-8 -emit-fir %s -o - | FileCheck %s
 
 ! Test OPTIONAL lowering on caller/callee and PRESENT intrinsic.
 module opt
   implicit none
   type t
     real, allocatable :: p(:)
   end type
 contains
subroutine call_character_scalar()
   ! CHECK: %[[x:.*]] = fir.emboxchar %[[addrCast]], {{.*}}
   ! CHECK: fir.call @_QMoptPcharacter_scalar(%[[x]]) {{.*}}: (!fir.boxchar<1>) -> ()
   call character_scalar(x)
   ! CHECK: %[[absent:.*]] = fir.absent !fir.boxchar<1>
   ! CHECK: fir.call @_QMoptPcharacter_scalar(%[[absent]]) {{.*}}: (!fir.boxchar<1>) -> ()
   call character_scalar()
 end subroutine
 
+! Test optional character function
+! CHECK-LABEL: func @_QMoptPchar_proc(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.char<1,3>>,
+character(len=3) function char_proc(i)
+  integer :: i
+  char_proc = "XYZ"
+end function
+! CHECK-LABEL: func @_QMoptPuse_char_proc(
+! CHECK-SAME: %[[arg0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc},
+subroutine use_char_proc(f, c)
+  optional :: f
+  interface
+    character(len=3) function f(i)
+      integer :: i
+    end function
+  end interface
+  character(len=3) :: c
+! CHECK: %[[boxProc:.*]] = fir.extract_value %[[arg0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK: %[[procAddr:.*]] = fir.box_addr %[[boxProc]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %{{.*}} = fir.is_present %[[procAddr]] : (() -> ()) -> i1
+  if (present(f)) then
+    c = f(0)
+  else
+    c = "ABC"
+  end if
+end subroutine
+! CHECK-LABEL: func @_QMoptPcall_use_char_proc(
+subroutine call_use_char_proc()
+  character(len=3) :: c
+! CHECK: %[[boxProc:.*]] = fir.absent !fir.boxproc<() -> ()>
+! CHECK: %[[undef:.*]] = fir.undefined index
+! CHECK: %[[charLen:.*]] = fir.convert %[[undef]] : (index) -> i64
+! CHECK: %[[tuple:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple]], %[[boxProc]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple3:.*]] = fir.insert_value %[[tuple2]], %[[charLen]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: fir.call @_QMoptPuse_char_proc(%[[tuple3]], %{{.*}}){{.*}} : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxchar<1>) -> ()
+  call use_char_proc(c=c)
+! CHECK: %[[funcAddr:.*]] = fir.address_of(@_QMoptPchar_proc) : (!fir.ref<!fir.char<1,3>>, index, {{.*}}) -> !fir.boxchar<1>
+! CHECK: %[[c3:.*]] = arith.constant 3 : i64
+! CHECK: %[[boxProc2:.*]] = fir.emboxproc %[[funcAddr]] : ((!fir.ref<!fir.char<1,3>>, index, {{.*}}) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+! CHECK: %[[tuple4:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple5:.*]] = fir.insert_value %[[tuple4]], %[[boxProc2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[tuple6:.*]] = fir.insert_value %[[tuple5]], %[[c3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: fir.call @_QMoptPuse_char_proc(%[[tuple6]], {{.*}}){{.*}} : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxchar<1>) -> ()
+  call use_char_proc(char_proc, c)
+end subroutine
+
 ! Test optional assumed shape
 ! CHECK-LABEL: func @_QMoptPassumed_shape(
 ! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "x", fir.optional}) {
 subroutine assumed_shape(x)
   real, optional :: x(:)
   ! CHECK: fir.is_present %[[arg0]] : (!fir.box<!fir.array<?xf32>>) -> i1
   print *, present(x)
 end subroutine