[flang] Fix passing NULL to OPTIONAL procedure pointers (#80267)

Procedure pointer lowering used `prepareUserCallActualArgument` because it was convenient, but this helper was not meant for POINTERs when originally written and it did not handled passing NULL to an OPTIONAL procedure pointer correctly. The resulting argument should be a disassociated pointer, not an absent pointer (Fortran 15.5.2.12 point 1.). Move the logic for procedure pointer argument "cooking" in its own helper to avoid triggering the logic that created an absent argument in this case.
llvm · Feb 1, 2024 · 09b4649 · 09b4649
1 parent 4eb0810
commit 09b4649
Show file tree

Hide file tree

Showing 2 changed files with 61 additions and 27 deletions.
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
@@ -912,37 +912,16 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
   // element if this is an array in an elemental call.
   hlfir::Entity actual = preparedActual.getActual(loc, builder);
 
-  // Handle the procedure pointer actual arguments.
-  if (actual.isProcedurePointer()) {
-    // Procedure pointer actual to procedure pointer dummy.
-    if (fir::isBoxProcAddressType(dummyType))
-      return PreparedDummyArgument{actual, /*cleanups=*/{}};
+  // Handle procedure arguments (procedure pointers should go through
+  // prepareProcedurePointerActualArgument).
+  if (hlfir::isFortranProcedureValue(dummyType)) {
     // Procedure pointer actual to procedure dummy.
-    if (hlfir::isFortranProcedureValue(dummyType)) {
+    if (actual.isProcedurePointer()) {
       actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
       return PreparedDummyArgument{actual, /*cleanups=*/{}};
     }
-  }
-
-  // NULL() actual to procedure pointer dummy
-  if (Fortran::evaluate::IsNullProcedurePointer(expr) &&
-      fir::isBoxProcAddressType(dummyType)) {
-    auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
-    auto tempBoxProc{builder.createTemporary(loc, boxTy)};
-    hlfir::Entity nullBoxProc(
-        fir::factory::createNullBoxProc(builder, loc, boxTy));
-    builder.create<fir::StoreOp>(loc, nullBoxProc, tempBoxProc);
-    return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
-  }
-
-  if (actual.isProcedure()) {
-    // Procedure actual to procedure pointer dummy.
-    if (fir::isBoxProcAddressType(dummyType)) {
-      auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
-      builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
-      return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
-    }
     // Procedure actual to procedure dummy.
+    assert(actual.isProcedure());
     // Do nothing if this is a procedure argument. It is already a
     // fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
     if (actual.getType() != dummyType)
@@ -1219,6 +1198,34 @@ static PreparedDummyArgument prepareUserCallActualArgument(
   return result;
 }
 
+/// Prepare actual argument for a procedure pointer dummy.
+static PreparedDummyArgument prepareProcedurePointerActualArgument(
+    mlir::Location loc, fir::FirOpBuilder &builder,
+    const Fortran::lower::PreparedActualArgument &preparedActual,
+    mlir::Type dummyType,
+    const Fortran::lower::CallerInterface::PassedEntity &arg,
+    const Fortran::lower::SomeExpr &expr, CallContext &callContext) {
+
+  // NULL() actual to procedure pointer dummy
+  if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr) &&
+      fir::isBoxProcAddressType(dummyType)) {
+    auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
+    auto tempBoxProc{builder.createTemporary(loc, boxTy)};
+    hlfir::Entity nullBoxProc(
+        fir::factory::createNullBoxProc(builder, loc, boxTy));
+    builder.create<fir::StoreOp>(loc, nullBoxProc, tempBoxProc);
+    return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
+  }
+  hlfir::Entity actual = preparedActual.getActual(loc, builder);
+  if (actual.isProcedurePointer())
+    return PreparedDummyArgument{actual, /*cleanups=*/{}};
+  assert(actual.isProcedure());
+  // Procedure actual to procedure pointer dummy.
+  auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
+  builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
+  return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
+}
+
 /// Lower calls to user procedures with actual arguments that have been
 /// pre-lowered but not yet prepared according to the interface.
 /// This can be called for elemental procedures, but only with scalar
@@ -1284,14 +1291,21 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
     case PassBy::CharBoxValueAttribute:
     case PassBy::Box:
     case PassBy::BaseAddress:
-    case PassBy::BoxProcRef:
     case PassBy::BoxChar: {
       PreparedDummyArgument preparedDummy = prepareUserCallActualArgument(
           loc, builder, *preparedActual, argTy, arg, *expr, callContext);
       callCleanUps.append(preparedDummy.cleanups.rbegin(),
                           preparedDummy.cleanups.rend());
       caller.placeInput(arg, preparedDummy.dummy);
     } break;
+    case PassBy::BoxProcRef: {
+      PreparedDummyArgument preparedDummy =
+          prepareProcedurePointerActualArgument(loc, builder, *preparedActual,
+                                                argTy, arg, *expr, callContext);
+      callCleanUps.append(preparedDummy.cleanups.rbegin(),
+                          preparedDummy.cleanups.rend());
+      caller.placeInput(arg, preparedDummy.dummy);
+    } break;
     case PassBy::AddressAndLength:
       // PassBy::AddressAndLength is only used for character results. Results
       // are not handled here.

diff --git a/flang/test/Lower/HLFIR/procedure-pointer.f90 b/flang/test/Lower/HLFIR/procedure-pointer.f90
@@ -340,6 +340,26 @@ subroutine sub12()
 ! CHECK: fir.call @_QPfoo2(%[[VAL_17]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
 end 
 
+subroutine test_opt_pointer()
+  interface
+    subroutine takes_opt_proc_ptr(p)
+      procedure(), pointer, optional :: p
+    end subroutine
+  end interface
+  call takes_opt_proc_ptr(NULL())
+  call takes_opt_proc_ptr()
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_opt_pointer() {
+! CHECK:    %[[VAL_0:.*]] = fir.alloca !fir.boxproc<() -> ()>
+! CHECK:    %[[VAL_1:.*]] = fir.zero_bits () -> ()
+! CHECK:    %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:    fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK:    fir.call @_QPtakes_opt_proc_ptr(%[[VAL_0]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
+! CHECK:    %[[VAL_3:.*]] = fir.absent !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK:    fir.call @_QPtakes_opt_proc_ptr(%[[VAL_3]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
+
+
+
 ! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
 ! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
 ! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>