[flang] Adding fir::getSymbolAttrName attribute to the function corresponding to the main program

[Renaud-K]

Summary

It is not possible to arrive to the source name of the main program by deconstructing the name _QQmain
Adding the attribute fir::getSymbolAttrName to capture the name

[vzakhari]

LGTM

[PeteSteinfeld]

All builds and tests correctly and looks good.

[sscalpone]

Isn't this actually the fortran name and not a name arising from a bind c? If that's true, do we have to overload the meaning of bind c do the needful?

[Renaud-K]

It is the attribute we decided to use for now. But the plan is to rename it at some point.

flang/include/flang/Lower/PFTBuilder.h

struct FunctionLikeUnit : public ProgramUnit {
   const semantics::Symbol &getSubprogramSymbol() const {
     const semantics::Symbol *symbol = entryPointList[activeEntry].first;
     if (!symbol)
       llvm::report_fatal_error(
           "not inside a procedure; do not call on main program.");
     return *symbol;
   }
 
+  /// Return a pointer to the main program symbol for named programs
+  /// Return the null pointer for anonymous programs
+  const semantics::Symbol *getMainProgramSymbol() const {
+    if (!isMainProgram()) {
+      llvm::report_fatal_error("call only on main program.");
+    }
+    return entryPointList[activeEntry].first;
+  }
+
   /// Return a pointer to the current entry point Evaluation.
   /// This is null for a primary entry point.
   Evaluation *getEntryEval() const {
     return entryPointList[activeEntry].second;
   }
 
   //===--------------------------------------------------------------------===//
   // Host associations

flang/lib/Lower/CallInterface.cpp

if (funit.isMainProgram())
     return fir::NameUniquer::doProgramEntry().str();
   return ::getMangledName(converter.getCurrentLocation(),
                           funit.getSubprogramSymbol());
 }
 
 const Fortran::semantics::Symbol *
 Fortran::lower::CalleeInterface::getProcedureSymbol() const {
   if (funit.isMainProgram())
-    return nullptr;
+    return funit.getMainProgramSymbol();
   return &funit.getSubprogramSymbol();
 }
 
 mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const {
   // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably
   // should just stash the location in the funit regardless.
   return converter.genLocation(funit.getStartingSourceLoc());
 }
void Fortran::lower::CallInterface<T>::declare() {
   if (!side().isIndirectCall()) {
     std::string name = side().getMangledName();
     mlir::ModuleOp module = converter.getModuleOp();
     func = fir::FirOpBuilder::getNamedFunction(module, name);
     if (!func) {
       mlir::Location loc = side().getCalleeLocation();
       mlir::FunctionType ty = genFunctionType();
       func = fir::FirOpBuilder::createFunction(loc, module, name, ty);
-      if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol())
+      if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol()) {
+        if (side().isMainProgram()) {
+          func->setAttr(fir::getSymbolAttrName(),
+                        mlir::StringAttr::get(&converter.getMLIRContext(),
+                                              sym->name().ToString()));
+        } else {
           addSymbolAttribute(func, *sym, converter.getMLIRContext());
+        }
+      }
       for (const auto &placeHolder : llvm::enumerate(inputs))
         if (!placeHolder.value().attributes.empty())
           func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes);
       side().setFuncAttrs(func);
     }
   }
 }
 

flang/test/Lower/OpenMP/atomic-read.f90

 ! RUN: bbc -fopenmp -emit-fir %s -o - | FileCheck %s
 
 ! This test checks the lowering of atomic read
 
-!CHECK: func @_QQmain() {
+!CHECK: func @_QQmain() attributes {fir.bindc_name = "ompatomic"} {
 !CHECK: %[[VAR_A:.*]] = fir.alloca !fir.char<1> {bindc_name = "a", uniq_name = "_QFEa"}
 !CHECK: %[[VAR_B:.*]] = fir.alloca !fir.char<1> {bindc_name = "b", uniq_name = "_QFEb"}
 !CHECK: %[[VAR_C:.*]] = fir.alloca !fir.logical<4> {bindc_name = "c", uniq_name = "_QFEc"}
 !CHECK: %[[VAR_D:.*]] = fir.alloca !fir.logical<4> {bindc_name = "d", uniq_name = "_QFEd"}
 !CHECK: %[[VAR_E:.*]] = fir.alloca !fir.char<1,8> {bindc_name = "e", uniq_name = "_QFEe"}
 !CHECK: %[[VAR_F:.*]] = fir.alloca !fir.char<1,8> {bindc_name = "f", uniq_name = "_QFEf"}
 !CHECK: %[[VAR_G:.*]] = fir.alloca f32 {bindc_name = "g", uniq_name = "_QFEg"}
 !CHECK: %[[VAR_H:.*]] = fir.alloca f32 {bindc_name = "h", uniq_name = "_QFEh"}

flang/test/Lower/OpenMP/atomic-update.f90

 ! This test checks lowering of atomic and atomic update constructs
 ! RUN: bbc -fopenmp -emit-fir %s -o - | FileCheck %s
 ! RUN: %flang_fc1 -emit-fir -fopenmp %s -o - | FileCheck %s
 
 program OmpAtomicUpdate
     use omp_lib
     integer :: x, y, z
     integer, pointer :: a, b
     integer, target :: c, d
     a=>c
     b=>d
 
-!CHECK: func.func @_QQmain() {
+!CHECK: func.func @_QQmain() attributes {fir.bindc_name = "ompatomicupdate"} {
 !CHECK: %[[A:.*]] = fir.alloca !fir.box<!fir.ptr<i32>> {bindc_name = "a", uniq_name = "_QFEa"}
 !CHECK: %[[A_ADDR:.*]] = fir.alloca !fir.ptr<i32> {uniq_name = "_QFEa.addr"}
 !CHECK: %{{.*}} = fir.zero_bits !fir.ptr<i32>
 !CHECK: fir.store %{{.*}} to %[[A_ADDR]] : !fir.ref<!fir.ptr<i32>>
 !CHECK: %[[B:.*]] = fir.alloca !fir.box<!fir.ptr<i32>> {bindc_name = "b", uniq_name = "_QFEb"}
 !CHECK: %[[B_ADDR:.*]] = fir.alloca !fir.ptr<i32> {uniq_name = "_QFEb.addr"}
 !CHECK: %{{.*}} = fir.zero_bits !fir.ptr<i32>
 !CHECK: fir.store %{{.*}} to %[[B_ADDR]] : !fir.ref<!fir.ptr<i32>>

flang/test/Lower/OpenMP/atomic-write.f90

 ! RUN: bbc -fopenmp -emit-fir %s -o - | FileCheck %s
 
 ! This test checks the lowering of atomic write
 
-!CHECK: func @_QQmain() {
+!CHECK: func @_QQmain() attributes {fir.bindc_name = "ompatomicwrite"} {
 !CHECK: %[[VAR_X:.*]] = fir.alloca i32 {bindc_name = "x", uniq_name = "_QFEx"}
 !CHECK: %[[VAR_Y:.*]] = fir.alloca i32 {bindc_name = "y", uniq_name = "_QFEy"}
 !CHECK: %[[VAR_Z:.*]] = fir.alloca i32 {bindc_name = "z", uniq_name = "_QFEz"}
 !CHECK: %[[CONST_44:.*]] = arith.constant 44 : i32
 !CHECK: omp.atomic.write %[[VAR_X]] = %[[CONST_44]] hint(uncontended) memory_order(seq_cst) : !fir.ref<i32>, i32
 !CHECK: %[[CONST_7:.*]] = arith.constant 7 : i32
 !CHECK: {{.*}} = fir.load %[[VAR_Y]] : !fir.ref<i32>
 !CHECK: %[[VAR_7y:.*]] = arith.muli %[[CONST_7]], {{.*}} : i32

flang/test/Lower/OpenMP/default-clause.f90

 ! This test checks lowering of OpenMP parallel directive
 ! with `DEFAULT` clause present.
 
 ! RUN: %flang_fc1 -emit-fir -fopenmp %s -o - | FileCheck %s
 ! RUN: bbc -fopenmp -emit-fir %s -o - | FileCheck %s
 
 
-!CHECK: func @_QQmain() {
+!CHECK: func @_QQmain() attributes {fir.bindc_name = "default_clause_lowering"} {
 !CHECK: %[[W:.*]] = fir.alloca i32 {bindc_name = "w", uniq_name = "_QFEw"}
 !CHECK: %[[X:.*]] = fir.alloca i32 {bindc_name = "x", uniq_name = "_QFEx"}
 !CHECK: %[[Y:.*]] = fir.alloca i32 {bindc_name = "y", uniq_name = "_QFEy"}
 !CHECK: %[[Z:.*]] = fir.alloca i32 {bindc_name = "z", uniq_name = "_QFEz"}
 !CHECK: omp.parallel {
 !CHECK: %[[PRIVATE_X:.*]] = fir.alloca i32 {bindc_name = "x", pinned, uniq_name = "_QFEx"}
 !CHECK: %[[const:.*]] = fir.load %[[X]] : !fir.ref<i32>
 !CHECK: fir.store %[[const]] to %[[PRIVATE_X]] : !fir.ref<i32>

flang/test/Lower/OpenMP/omp-wsloop-chunks.f90

 ! This test checks that chunk size is passed correctly when lowering of
 ! OpenMP DO Directive(Worksharing) with chunk size
 
 ! RUN: bbc -fopenmp -emit-fir %s -o - | FileCheck %s
 
 program wsloop
         integer :: i
         integer :: chunk
 
-! CHECK-LABEL: func.func @_QQmain() {
+! CHECK-LABEL: func.func @_QQmain() attributes {fir.bindc_name = "wsloop"} {
 ! CHECK:         %[[VAL_0:.*]] = fir.alloca i32 {bindc_name = "chunk", uniq_name = "_QFEchunk"}
 
 !$OMP DO SCHEDULE(static, 4)
 
 do i=1, 9
   print*, i
 
 ! CHECK:         %[[VAL_2:.*]] = arith.constant 1 : i32

flang/test/Lower/OpenMP/sections.f90

 ! This test checks the lowering of OpenMP sections construct with several clauses present
 
 ! RUN: %flang_fc1 -emit-fir -fopenmp %s -o - | FileCheck %s
 
-!CHECK: func @_QQmain() {
+!CHECK: func @_QQmain() attributes {fir.bindc_name = "sample"} {
 !CHECK:   %[[COUNT:.*]] = fir.address_of(@_QFEcount) : !fir.ref<i32>
 !CHECK:   %[[ETA:.*]] = fir.alloca f32 {bindc_name = "eta", uniq_name = "_QFEeta"}
 !CHECK:   %[[CONST_1:.*]] = arith.constant 1 : i32
 !CHECK:   omp.sections allocate(%[[CONST_1]] : i32 -> %0 : !fir.ref<i32>)  {
 !CHECK:     omp.section {
 !CHECK:       %[[PRIVATE_ETA:.*]] = fir.alloca f32 {bindc_name = "eta", pinned, uniq_name = "_QFEeta"}
 !CHECK:       %[[PRIVATE_DOUBLE_COUNT:.*]] = fir.alloca i32 {bindc_name = "double_count", pinned, uniq_name = "_QFEdouble_count"} 
 !CHECK:       %[[const:.*]] = arith.constant 5 : i32

flang/test/Lower/array-character.f90

subroutine issue(c1, c2)
 
   character(4) :: c1(3)
   character(*) :: c2(3)
   c1 = c2
   ! CHECK:         return
   ! CHECK:       }
 end subroutine
 
-! CHECK-LABEL: func @_QQmain() {
+! CHECK-LABEL: func @_QQmain() attributes {fir.bindc_name = "p"} {
 program p
   ! CHECK-DAG: %[[VAL_0:.*]] = arith.constant 4 : index
   ! CHECK-DAG: %[[VAL_1:.*]] = arith.constant 3 : index
   ! CHECK-DAG: %[[VAL_2:.*]] = arith.constant -1 : i32
   ! CHECK: %[[VAL_5:.*]] = fir.alloca !fir.array<3x!fir.char<1,4>> {bindc_name = "c1", uniq_name = "_QFEc1"}
   ! CHECK: %[[VAL_6:.*]] = fir.address_of(@_QFEc2) : !fir.ref<!fir.array<3x!fir.char<1,4>>>
   ! CHECK: %[[VAL_7:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,
   ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>

flang/test/Lower/array-expression-slice-1.f90

 ! RUN: bbc -o - --outline-intrinsics %s | FileCheck %s
 
-! CHECK-LABEL: func @_QQmain() {
+! CHECK-LABEL: func @_QQmain() attributes {fir.bindc_name = "p"} {
 ! CHECK-DAG:         %[[VAL_0:.*]] = arith.constant 10 : index
 ! CHECK-DAG:         %[[VAL_4:.*]] = arith.constant 2 : index
 ! CHECK-DAG:         %[[VAL_5:.*]] = arith.constant 1 : index
 ! CHECK-DAG:         %[[VAL_6:.*]] = arith.constant 0 : index
 ! CHECK-DAG:         %[[VAL_8:.*]] = arith.constant 8 : i64
 ! CHECK-DAG:         %[[VAL_11:.*]] = arith.constant 3 : index
 ! CHECK-DAG:         %[[VAL_13:.*]] = arith.constant 2 : i64
 ! CHECK-DAG:         %[[VAL_14:.*]] = arith.constant 7 : i64

flang/test/Lower/basic-program.f90

 ! RUN: bbc %s --pft-test | FileCheck %s
 ! RUN: bbc %s -o "-" -emit-fir | FileCheck %s --check-prefix=FIR
 
 program basic
 end program
 
 ! CHECK: 1 Program basic
 ! CHECK:   1 EndProgramStmt: end program
 ! CHECK: End Program basic
 
-! FIR-LABEL: func @_QQmain() {
+! FIR-LABEL: func @_QQmain() attributes {fir.bindc_name = "basic"} {
 ! FIR:         return
 ! FIR:       }

flang/test/Lower/big-integer-parameter.f90

 ! Test correct lowering of 128 bit integer parameters.
 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
 
 program i128
   integer(16), parameter :: maxi64 = 9223372036854775807_16
   integer(16), parameter :: mini64 = -9223372036854775808_16
   integer(16), parameter :: maxi128 = 170141183460469231731687303715884105727_16
   integer(16), parameter :: mini128 = -170141183460469231731687303715884105728_16
   integer(16), parameter :: x = 9223372036854775808_16
   integer(16), parameter :: y = -9223372036854775809_16
   integer(16), parameter :: z = 0_16
   print*,x
   print*,y
 end
 
-! CHECK-LABEL: func.func @_QQmain() {
+! CHECK-LABEL: func.func @_QQmain() attributes {fir.bindc_name = "i128"} {
 ! CHECK-COUNT-2:  %{{.*}} = fir.call @_FortranAioOutputInteger128(%{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<i8>, i128) -> i1
 
 
 ! CHECK-LABEL: fir.global internal @_QFECmaxi128 constant : i128 {
 ! CHECK-NEXT: %{{.*}} = arith.constant 170141183460469231731687303715884105727 : i128
 
 ! CHECK-LABEL: fir.global internal @_QFECmaxi64 constant : i128 {
 ! CHECK-NEXT:   %{{.*}} = arith.constant 9223372036854775807 : i128

flang/test/Lower/derived-type-finalization.f90

 
 program p
   use derived_type_finalization
   type(t1) :: t
   if (t%a == 10) return
   print *, 'end of program'
 end program
 
-! CHECK-LABEL: func.func @_QQmain() {
+! CHECK-LABEL: func.func @_QQmain() attributes {fir.bindc_name = "p"} {
 ! CHECK: %[[T:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "t", uniq_name = "_QFEt"}
 ! CHECK: cf.cond_br %{{.*}}, ^bb1, ^bb2
 ! CHECK: ^bb1:
 ! CHECK:  %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
 ! CHECK:  %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
 ! CHECK:  %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
 ! CHECK:  return
 ! CHECK: ^bb2:
 ! CHECK:  %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
 ! CHECK:  %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
 ! CHECK:  %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
 ! CHECK:  return

flang/test/Lower/nested-where.f90

 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
 
-! CHECK-LABEL: func @_QQmain() {
+! CHECK-LABEL: func @_QQmain() attributes {fir.bindc_name = "nested_where"} {
 program nested_where
 
   ! CHECK:  %[[VAL_0:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
   ! CHECK:  %[[VAL_1:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
   ! CHECK:  %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
   ! CHECK:  %[[VAL_3:.*]] = fir.alloca tuple<i64, !fir.heap<!fir.array<?xi8>>, !fir.heap<!fir.array<?xi64>>>
   ! CHECK:  %[[VAL_4:.*]] = fir.alloca tuple<i64, !fir.heap<!fir.array<?xi8>>, !fir.heap<!fir.array<?xi64>>>
   ! CHECK:  %[[VAL_5:.*]] = fir.address_of(@_QFEa) : !fir.ref<!fir.array<3xi32>>

flang/test/Lower/polymorphic.f90

program test
   type(outer), allocatable :: o
   integer :: i(5)
   logical :: l(5)
   allocate(o)
 
   l = i < o%inner
 end program
 
-! CHECK-LABEL: func.func @_QQmain() {
+! CHECK-LABEL: func.func @_QQmain() attributes {fir.bindc_name = "test"} {
 ! CHECK: %[[ADDR_O:.*]] = fir.address_of(@_QFEo) : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>>
 ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ADDR_O]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
 ! CHECK: %[[O:.*]] = fir.load %[[ADDR_O]] : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>>
 ! CHECK: %[[FIELD_INNER:.*]] = fir.field_index inner, !fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>
 ! CHECK: %[[COORD_INNER:.*]] = fir.coordinate_of %[[O]], %[[FIELD_INNER]] : (!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>, !fir.field) -> !fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
 ! CHECK: %{{.*}} = fir.do_loop %{{.*}} = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%arg1 = %9) -> (!fir.array<5x!fir.logical<4>>) {
 ! CHECK:   %[[EMBOXED:.*]] = fir.embox %[[COORD_INNER]] : (!fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
 ! CHECK:   %{{.*}} = fir.call @_QMpolymorphic_testPlt(%17, %[[EMBOXED]]) {{.*}} : (!fir.ref<i32>, !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.logical<4>
 ! CHECK:  }

flang/test/Lower/program-units-fir-mangling.f90

 !  end procedure
 !end submodule
 
 ! CHECK-LABEL: func @_QPshould_not_collide() {
 subroutine should_not_collide()
 ! CHECK: }
 end subroutine
 
-! CHECK-LABEL: func @_QQmain() {
+! CHECK-LABEL: func @_QQmain() attributes {fir.bindc_name = "test"} {
 program test
 ! CHECK: }
 contains
 ! CHECK-LABEL: func @_QFPshould_not_collide() {
 subroutine should_not_collide()
 ! CHECK: }
 end subroutine
 end program

flang/test/Lower/return-statement.f90

 ! RUN: bbc %s -o "-" -emit-fir | FileCheck %s
 
 program basic
   return
 end program
 
-! CHECK-LABEL: func @_QQmain() {
+! CHECK-LABEL: func @_QQmain() attributes {fir.bindc_name = "basic"} {
 ! CHECK:         return
 ! CHECK:       }
 
 subroutine sub1()
   return
 end
 
 ! CHECK-LABEL: func @_QPsub1() {