From 09b4649ea5cefc4f93d9c936d38863df5c6568ed Mon Sep 17 00:00:00 2001 From: jeanPerier Date: Thu, 1 Feb 2024 17:43:43 +0100 Subject: [PATCH] [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. --- flang/lib/Lower/ConvertCall.cpp | 68 ++++++++++++-------- flang/test/Lower/HLFIR/procedure-pointer.f90 | 20 ++++++ 2 files changed, 61 insertions(+), 27 deletions(-) diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index 1d5ebeb1b362..bb8fd2e945f4 100644 --- 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(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(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 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(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(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(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,7 +1291,6 @@ 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); @@ -1292,6 +1298,14 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals, 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 index ba423db15084..28965b22de97 100644 --- a/flang/test/Lower/HLFIR/procedure-pointer.f90 +++ b/flang/test/Lower/HLFIR/procedure-pointer.f90 @@ -340,6 +340,26 @@ use m ! CHECK: fir.call @_QPfoo2(%[[VAL_17]]) fastmath : (!fir.ref ()>>) -> () 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 ()>> +! CHECK: fir.call @_QPtakes_opt_proc_ptr(%[[VAL_0]]) fastmath : (!fir.ref ()>>) -> () +! CHECK: %[[VAL_3:.*]] = fir.absent !fir.ref ()>> +! CHECK: fir.call @_QPtakes_opt_proc_ptr(%[[VAL_3]]) fastmath : (!fir.ref ()>>) -> () + + + ! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref) -> f32> { ! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref) -> f32 ! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref) -> f32) -> !fir.boxproc<(!fir.ref) -> f32>