[flang] Fix lowering of unused dummy procedure pointers #155649

luporl · 2025-08-27T16:22:17Z

Fixes #126453

Fixes llvm#126453

llvmbot · 2025-08-27T16:22:47Z

@llvm/pr-subscribers-flang-fir-hlfir

Author: Leandro Lupori (luporl)

Changes

Fixes #126453

Full diff: https://github.com/llvm/llvm-project/pull/155649.diff

4 Files Affected:

(modified) flang/include/flang/Lower/CallInterface.h (+6)
(modified) flang/lib/Lower/CallInterface.cpp (+11)
(modified) flang/lib/Lower/ConvertVariable.cpp (+13-9)
(added) flang/test/Lower/HLFIR/dummy-proc-ptr-in-entry.f90 (+59)

diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
index 72bc9dd890a94..926a42756c6ef 100644
--- a/flang/include/flang/Lower/CallInterface.h
+++ b/flang/include/flang/Lower/CallInterface.h
@@ -478,6 +478,12 @@ getOrDeclareFunction(const Fortran::evaluate::ProcedureDesignator &,
 mlir::Type getDummyProcedureType(const Fortran::semantics::Symbol &dummyProc,
                                  Fortran::lower::AbstractConverter &);
 
+/// Return the type of an argument that is a dummy procedure pointer. This
+/// will be a reference to a boxed procedure.
+mlir::Type
+getDummyProcedurePointerType(const Fortran::semantics::Symbol &dummyProcPtr,
+                             Fortran::lower::AbstractConverter &);
+
 /// Return !fir.boxproc<() -> ()> type.
 mlir::Type getUntypedBoxProcType(mlir::MLIRContext *context);
 
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 72431a9cfacc4..c3284cd936f8f 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1766,6 +1766,17 @@ mlir::Type Fortran::lower::getDummyProcedureType(
   return procType;
 }
 
+mlir::Type Fortran::lower::getDummyProcedurePointerType(
+    const Fortran::semantics::Symbol &dummyProcPtr,
+    Fortran::lower::AbstractConverter &converter) {
+  std::optional<Fortran::evaluate::characteristics::Procedure> iface =
+      Fortran::evaluate::characteristics::Procedure::Characterize(
+          dummyProcPtr, converter.getFoldingContext());
+  mlir::Type procPtrType = getProcedureDesignatorType(
+      iface.has_value() ? &*iface : nullptr, converter);
+  return fir::ReferenceType::get(procPtrType);
+}
+
 bool Fortran::lower::isCPtrArgByValueType(mlir::Type ty) {
   return mlir::isa<fir::ReferenceType>(ty) &&
          fir::isa_integer(fir::unwrapRefType(ty));
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index fd66592bc285b..d43ed8f347b85 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -2149,15 +2149,19 @@ void Fortran::lower::mapSymbolAttributes(
   if (Fortran::semantics::IsProcedure(sym)) {
     if (isUnusedEntryDummy) {
       // Additional discussion below.
-      mlir::Type dummyProcType =
-          Fortran::lower::getDummyProcedureType(sym, converter);
-      mlir::Value undefOp = fir::UndefOp::create(builder, loc, dummyProcType);
-
-      Fortran::lower::genDeclareSymbol(converter, symMap, sym, undefOp);
-    }
-
-    // Procedure pointer.
-    if (Fortran::semantics::IsPointer(sym)) {
+      if (Fortran::semantics::IsPointer(sym)) {
+        mlir::Type procPtrType =
+            Fortran::lower::getDummyProcedurePointerType(sym, converter);
+        mlir::Value undefOp = fir::UndefOp::create(builder, loc, procPtrType);
+        genProcPointer(converter, symMap, sym, undefOp, replace);
+      } else {
+        mlir::Type dummyProcType =
+            Fortran::lower::getDummyProcedureType(sym, converter);
+        mlir::Value undefOp = fir::UndefOp::create(builder, loc, dummyProcType);
+        Fortran::lower::genDeclareSymbol(converter, symMap, sym, undefOp);
+      }
+    } else if (Fortran::semantics::IsPointer(sym)) {
+      // Used procedure pointer.
       // global
       mlir::Value boxAlloc = preAlloc;
       // dummy or passed result
diff --git a/flang/test/Lower/HLFIR/dummy-proc-ptr-in-entry.f90 b/flang/test/Lower/HLFIR/dummy-proc-ptr-in-entry.f90
new file mode 100644
index 0000000000000..280268112d5a0
--- /dev/null
+++ b/flang/test/Lower/HLFIR/dummy-proc-ptr-in-entry.f90
@@ -0,0 +1,59 @@
+! Test dummy procedure pointers that are not an argument in every entry.
+! This requires creating a mock value in the entries where it is not an
+! argument.
+!
+!RUN: %flang_fc1 -emit-hlfir %s -o - 2>&1 | FileCheck %s
+
+!CHECK-LABEL: func @_QPdummy_char_proc_ptr() -> !fir.boxproc<(!fir.ref<!fir.char<1>>, index) -> !fir.boxchar<1>> {
+!CHECK:         %[[UNDEF:.*]] = fir.undefined !fir.ref<!fir.boxproc<() -> ()>>
+!CHECK:         %{{.*}}:2 = hlfir.declare %[[UNDEF]]
+!CHECK-SAME:      {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFdummy_char_proc_ptrEdummy"}
+!CHECK-SAME:      : (!fir.ref<!fir.boxproc<() -> ()>>)
+!CHECK-SAME:      -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+
+!CHECK-LABEL: func @_QPdummy_char_proc_ptr_entry(
+!CHECK-SAME:        %[[ARG:.*]]: !fir.ref<!fir.boxproc<() -> ()>>)
+!CHECK-SAME:        -> !fir.boxproc<(!fir.ref<!fir.char<1>>, index) -> !fir.boxchar<1>> {
+!CHECK:         %{{.*}}:2 = hlfir.declare %[[ARG]] dummy_scope %{{[^ ]*}}
+!CHECK-SAME:      {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFdummy_char_proc_ptrEdummy"}
+!CHECK-SAME:      : (!fir.ref<!fir.boxproc<() -> ()>>, !fir.dscope)
+!CHECK-SAME:      -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+function dummy_char_proc_ptr() result(fun)
+  interface
+    character function char_fun()
+    end function
+  end interface
+
+  procedure (char_fun), pointer :: fun, dummy_char_proc_ptr_entry, dummy
+  fun => null()
+  return
+
+  entry dummy_char_proc_ptr_entry(dummy)
+end function
+
+!CHECK-LABEL: func @_QPdummy_int_proc_ptr()
+!CHECK:         %[[UNDEF:.*]] = fir.undefined !fir.ref<!fir.boxproc<() -> ()>>
+!CHECK:         %{{.*}}:2 = hlfir.declare %[[UNDEF]]
+!CHECK-SAME:      {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFdummy_int_proc_ptrEdummy"}
+!CHECK-SAME:      : (!fir.ref<!fir.boxproc<() -> ()>>)
+!CHECK-SAME:      -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+
+!CHECK-LABEL: func @_QPdummy_int_proc_ptr_entry(
+!CHECK-SAME:        %[[ARG:.*]]: !fir.ref<!fir.boxproc<() -> ()>>)
+!CHECK-SAME:        -> !fir.boxproc<() -> i32> {
+!CHECK:         %{{.*}}:2 = hlfir.declare %[[ARG]] dummy_scope %{{[^ ]*}}
+!CHECK-SAME:      {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFdummy_int_proc_ptrEdummy"}
+!CHECK-SAME:      : (!fir.ref<!fir.boxproc<() -> ()>>, !fir.dscope)
+!CHECK-SAME:      -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+function dummy_int_proc_ptr() result(fun)
+  interface
+    integer function int_fun()
+    end function
+  end interface
+
+  procedure (int_fun), pointer :: fun, dummy_int_proc_ptr_entry, dummy
+  fun => null()
+  return
+
+  entry dummy_int_proc_ptr_entry(dummy)
+end function

DanielCChen

This patch caused some regressions (segfault at the compile time) in our test buckets. I will provide a reducer soon.

DanielCChen · 2025-08-27T18:40:35Z

  MODULE M0

    TYPE :: Base
      CHARACTER(3) :: C
    END TYPE

  END MODULE

  MODULE M
  USE M0

    TYPE, EXTENDS(Base)  :: DT
      PROCEDURE(IFun), NOPASS, POINTER :: ProcPtr
    CONTAINS
      PROCEDURE, NOPASS :: Proc=>ModFun
    END TYPE

    CONTAINS

    FUNCTION ModFun(Arg)
    TYPE(DT), INTENT(IN) :: Arg
    TYPE(DT)             ::  ModFun
      ModFun = Arg
    END FUNCTION

    FUNCTION IFun(Arg)
    TYPE(DT), INTENT(IN) :: Arg
    TYPE(DT)             :: IFun
      IFun = Arg
    END FUNCTION

  END MODULE

  FUNCTION ExtFun(Arg)
  USE M
  TYPE(DT), INTENT(IN) :: Arg
  TYPE(DT)             ::  ExtFun
    ExtFun = Arg
  END FUNCTION

  PROGRAM Arg5
  USE M
  IMPLICIT NONE
  PROCEDURE(IFun) :: ExtFun
  PROCEDURE(IFun), POINTER :: ProcPtr

  INTERFACE
    FUNCTION IFun1(Arg)
      IMPORT DT
      TYPE(DT), INTENT(IN) :: Arg
      TYPE(DT)             :: IFun1
    END FUNCTION
  END INTERFACE

  ProcPtr => ExtFun
  CALL IntSub( ProcPtr, ProcPtr)

  CONTAINS
  
    SUBROUTINE IntSub(ProcPtr0, ProcPtr1)
  IMPLICIT TYPE(DT)(P)

  PROCEDURE(IFun1),      POINTER :: ProcPtr0
  PROCEDURE(TYPE(DT)),   POINTER :: ProcPtr1
  TYPE(DT)                       :: V

  V = ProcPtr0(DT("321", ProcPtr0))
  IF (V%C .NE. "321") STOP 21
  IF ( .NOT. ASSOCIATED(V%ProcPtr, ProcPtr) ) STOP 22

  V = ProcPtr1(DT("121", ExtFun))
  IF (V%C .NE. "121") STOP 31
  IF ( .NOT. ASSOCIATED(V%ProcPtr, ExtFun) ) STOP 32

  END SUBROUTINE

  END

DanielCChen · 2025-08-27T18:57:45Z

  MODULE M0

    TYPE :: Base
      CHARACTER(3) :: C
    END TYPE

  END MODULE

  MODULE M
  USE M0

    TYPE, EXTENDS(Base)  :: DT
      PROCEDURE(IFun), NOPASS, POINTER :: ProcPtr
    CONTAINS
      PROCEDURE, NOPASS :: Proc=>ModFun
    END TYPE

    CONTAINS

    FUNCTION ModFun(Arg)
    TYPE(DT), INTENT(IN) :: Arg
    TYPE(DT)             ::  ModFun
      ModFun = Arg
    END FUNCTION

    FUNCTION IFun(Arg)
    TYPE(DT), INTENT(IN) :: Arg
    TYPE(DT)             :: IFun
      IFun = Arg
    END FUNCTION

  END MODULE

  FUNCTION ExtFun(Arg)
  USE M
  TYPE(DT), INTENT(IN) :: Arg
  TYPE(DT)             ::  ExtFun
    ExtFun = Arg
  END FUNCTION

  PROGRAM Arg5
  USE M
  IMPLICIT NONE
  PROCEDURE(IFun) :: ExtFun
  PROCEDURE(IFun), POINTER :: ProcPtr

  INTERFACE
    FUNCTION IFun1(Arg)
      IMPORT DT
      TYPE(DT), INTENT(IN) :: Arg
      TYPE(DT)             :: IFun1
    END FUNCTION
  END INTERFACE

  ProcPtr => ExtFun
  CALL IntSub( ProcPtr, ProcPtr)

  CONTAINS
  
    SUBROUTINE IntSub(ProcPtr0, ProcPtr1)
  IMPLICIT TYPE(DT)(P)

  PROCEDURE(IFun1),      POINTER :: ProcPtr0
  PROCEDURE(TYPE(DT)),   POINTER :: ProcPtr1
  TYPE(DT)                       :: V

  V = ProcPtr0(DT("321", ProcPtr0))
  IF (V%C .NE. "321") STOP 21
  IF ( .NOT. ASSOCIATED(V%ProcPtr, ProcPtr) ) STOP 22

  V = ProcPtr1(DT("121", ExtFun))
  IF (V%C .NE. "121") STOP 31
  IF ( .NOT. ASSOCIATED(V%ProcPtr, ExtFun) ) STOP 32

  END SUBROUTINE

  END

luporl · 2025-08-28T00:58:43Z

@DanielCChen, thanks for testing this patch.

I couldn't reproduce the segfault with the reproducer you have provided.
I tried on both macOS and Linux (both AArch64). The program compiles and runs without issues:

$ flang regr.f90 && ./a.out
$

Can you share more details about your test environment and the error?

DanielCChen · 2025-08-28T11:06:39Z

I ran the test on AIX, but it seems there is a gap between my build and the latest source. After I pull in the latest then applied the path, all the regressions are gone.
Sorry about the false alarm.

[flang] Fix lowering of unused dummy procedure pointers

f42dd0f

Fixes llvm#126453

llvmbot added flang Flang issues not falling into any other category flang:fir-hlfir labels Aug 27, 2025

luporl requested review from jeanPerier, DanielCChen and clementval August 27, 2025 16:26

DanielCChen requested changes Aug 27, 2025

View reviewed changes

DanielCChen self-requested a review August 28, 2025 10:58

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

Uh oh!

[flang] Fix lowering of unused dummy procedure pointers #155649

[flang] Fix lowering of unused dummy procedure pointers #155649

luporl commented Aug 27, 2025

Uh oh!

llvmbot commented Aug 27, 2025

Uh oh!

DanielCChen left a comment

Uh oh!

DanielCChen commented Aug 27, 2025

Uh oh!

DanielCChen commented Aug 27, 2025

Uh oh!

luporl commented Aug 28, 2025

Uh oh!

DanielCChen commented Aug 28, 2025

Uh oh!

Uh oh!

[flang] Fix lowering of unused dummy procedure pointers #155649

Are you sure you want to change the base?

[flang] Fix lowering of unused dummy procedure pointers #155649

Conversation

luporl commented Aug 27, 2025

Uh oh!

llvmbot commented Aug 27, 2025

Uh oh!

DanielCChen left a comment

Choose a reason for hiding this comment

Uh oh!

DanielCChen commented Aug 27, 2025

Uh oh!

DanielCChen commented Aug 27, 2025

Uh oh!

luporl commented Aug 28, 2025

Uh oh!

DanielCChen commented Aug 28, 2025

Uh oh!

Uh oh!