[flang] Add test for allocatable on the callee side

[clementval]

Summary

This patch adds couple of tests for allocatable
on the callee side. Lowering for some missing underlying features
is added as well.

This patch is part of the upstreaming effort from fir-dev branch.

Depends on D120744

[PeteSteinfeld]

All builds, tests, and is formatted correctly.

[clementval]

Rebase

flang/lib/Lower/CallInterface.cpp

translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {
     Fortran::common::TypeCategory cat = dynamicType.category();
     // DERIVED
     if (cat == Fortran::common::TypeCategory::Derived) {
       TODO(interface.converter.getCurrentLocation(),
            "[translateDynamicType] Derived");
     }
     // CHARACTER with compile time constant length.
     if (cat == Fortran::common::TypeCategory::Character)
-      TODO(interface.converter.getCurrentLocation(),
-           "[translateDynamicType] Character");
+      if (std::optional<std::int64_t> constantLen =
+              toInt64(dynamicType.GetCharLength()))
+        return getConverter().genType(cat, dynamicType.kind(), {*constantLen});
     // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length.
     return getConverter().genType(cat, dynamicType.kind());
   }
 
   void handleExplicitDummy(
       const DummyCharacteristics *characteristics,
       const Fortran::evaluate::characteristics::DummyDataObject &obj,
       const FortranEntity &entity, bool isBindC) {

flang/lib/Lower/ConvertExpr.cpp

mlir::Value createFltCmpOp(const A &ex, mlir::arith::CmpFPredicate pred) {
     ExtValue left = genval(ex.left());
     return createFltCmpOp<OpTy>(pred, left, genval(ex.right()));
   }
 
   /// Returns a reference to a symbol or its box/boxChar descriptor if it has
   /// one.
   ExtValue gen(Fortran::semantics::SymbolRef sym) {
     if (Fortran::lower::SymbolBox val = symMap.lookupSymbol(sym))
-      return val.match([&val](auto &) { return val.toExtendedValue(); });
+      return val.match(
+          [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &boxAddr) {
+            return fir::factory::genMutableBoxRead(builder, getLoc(), boxAddr);
+          },
+          [&val](auto &) { return val.toExtendedValue(); });
     LLVM_DEBUG(llvm::dbgs()
                << "unknown symbol: " << sym << "\nmap: " << symMap << '\n');
     fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value");
   }
 
   ExtValue genLoad(const ExtValue &exv) {
     return ::genLoad(builder, getLoc(), exv);
   }
for (const Fortran::lower::CallInterface<
         // is passed, not one of the dynamic type), and the expr is known to
         // be simply contiguous, so it is safe to unbox it and pass the
         // address without making a copy.
         argAddr = readIfBoxValue(argAddr);
 
         if (arg.passBy == PassBy::BaseAddress) {
           caller.placeInput(arg, fir::getBase(argAddr));
         } else {
-          TODO(loc, "procedureref PassBy::BoxChar");
+          assert(arg.passBy == PassBy::BoxChar);
+          auto helper = fir::factory::CharacterExprHelper{builder, loc};
+          auto boxChar = argAddr.match(
+              [&](const fir::CharBoxValue &x) { return helper.createEmbox(x); },
+              [&](const fir::CharArrayBoxValue &x) {
+                return helper.createEmbox(x);
+              },
+              [&](const auto &x) -> mlir::Value {
+                // Fortran allows an actual argument of a completely different
+                // type to be passed to a procedure expecting a CHARACTER in the
+                // dummy argument position. When this happens, the data pointer
+                // argument is simply assumed to point to CHARACTER data and the
+                // LEN argument used is garbage. Simulate this behavior by
+                // free-casting the base address to be a !fir.char reference and
+                // setting the LEN argument to undefined. What could go wrong?
+                auto dataPtr = fir::getBase(x);
+                assert(!dataPtr.getType().template isa<fir::BoxType>());
+                return builder.convertWithSemantics(
+                    loc, argTy, dataPtr,
+                    /*allowCharacterConversion=*/true);
+              });
+          caller.placeInput(arg, boxChar);
         }
       } else if (arg.passBy == PassBy::Box) {
         // Before lowering to an address, handle the allocatable/pointer actual
         // argument to optional fir.box dummy. It is legal to pass
         // unallocated/disassociated entity to an optional. In this case, an
         // absent fir.box must be created instead of a fir.box with a null value
         // (Fortran 2018 15.5.2.12 point 1).
         if (arg.isOptional() && Fortran::evaluate::IsAllocatableOrPointerObject(

flang/lib/Lower/ConvertVariable.cpp

for (const auto &spec : llvm::enumerate(box.dynamicBound())) {
     } else if (spec.value()->ubound().isStar()) {
       // Assumed extent is undefined. Must be provided by user's code.
       result.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
     }
   }
   assert(result.empty() || result.size() == box.dynamicBound().size());
 }
 
+/// Lower explicit character length if any. Return empty mlir::Value if no
+/// explicit length.
+static mlir::Value
+lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter,
+                     mlir::Location loc, const Fortran::lower::BoxAnalyzer &box,
+                     Fortran::lower::SymMap &symMap,
+                     Fortran::lower::StatementContext &stmtCtx) {
+  if (!box.isChar())
+    return mlir::Value{};
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::Type lenTy = builder.getCharacterLengthType();
+  if (llvm::Optional<int64_t> len = box.getCharLenConst())
+    return builder.createIntegerConstant(loc, lenTy, *len);
+  if (llvm::Optional<Fortran::lower::SomeExpr> lenExpr = box.getCharLenExpr())
+    return genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx);
+  return mlir::Value{};
+}
+
 /// Treat negative values as undefined. Assumed size arrays will return -1 from
 /// the front end for example. Using negative values can produce hard to find
 /// bugs much further along in the compilation.
 static mlir::Value genExtentValue(fir::FirOpBuilder &builder,
                                   mlir::Location loc, mlir::Type idxTy,
                                   long frontEndExtent) {
   if (frontEndExtent >= 0)
     return builder.createIntegerConstant(loc, idxTy, frontEndExtent);
if (!boxAlloc)
       if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym))
         boxAlloc = symbox.getAddr();
     // local
     if (!boxAlloc)
       boxAlloc = createNewLocal(converter, loc, var, preAlloc);
     // Lower non deferred parameters.
     llvm::SmallVector<mlir::Value> nonDeferredLenParams;
     if (ba.isChar()) {
-      TODO(loc, "mapSymbolAttributes allocatble or pointer char");
+      if (mlir::Value len =
+              lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
+        nonDeferredLenParams.push_back(len);
+      else if (Fortran::semantics::IsAssumedLengthCharacter(sym))
+        TODO(loc, "assumed length character allocatable");
     } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) {
       if (const Fortran::semantics::DerivedTypeSpec *derived =
               declTy->AsDerived())
         if (Fortran::semantics::CountLenParameters(*derived) != 0)
           TODO(loc,
                "derived type allocatable or pointer with length parameters");
     }
     fir::MutableBoxValue box = Fortran::lower::createMutableBox(

flang/lib/Optimizer/Builder/MutableBox.cpp

MutablePropertyReader(fir::FirOpBuilder &builder, mlir::Location loc,
                         bool forceIRBoxRead = false)
       : builder{builder}, loc{loc}, box{box} {
     if (forceIRBoxRead || !box.isDescribedByVariables())
       irBox = builder.create<fir::LoadOp>(loc, box.getAddr());
   }
   /// Get base address of allocated/associated entity.
   mlir::Value readBaseAddress() {
     if (irBox) {
-      auto heapOrPtrTy = box.getBoxTy().getEleTy();
-      return builder.create<fir::BoxAddrOp>(loc, heapOrPtrTy, irBox);
+      auto memrefTy = box.getBoxTy().getEleTy();
+      if (!fir::isa_ref_type(memrefTy))
+        memrefTy = builder.getRefType(memrefTy);
+      return builder.create<fir::BoxAddrOp>(loc, memrefTy, irBox);
     }
     auto addrVar = box.getMutableProperties().addr;
     return builder.create<fir::LoadOp>(loc, addrVar);
   }
   /// Return {lbound, extent} values read from the MutableBoxValue given
   /// the dimension.
   std::pair<mlir::Value, mlir::Value> readShape(unsigned dim) {
     auto idxTy = builder.getIndexType();
if (deferred.empty())
       fir::emitFatalError(loc, "allocatable entity has no length property");
     return builder.create<fir::LoadOp>(loc, deferred[0]);
   }
 
   /// Read and return all extents. If \p lbounds vector is provided, lbounds are
   /// also read into it.
   llvm::SmallVector<mlir::Value>
   readShape(llvm::SmallVectorImpl<mlir::Value> *lbounds = nullptr) {
-    llvm::SmallVector<mlir::Value> extents(box.rank());
+    llvm::SmallVector<mlir::Value> extents;
     auto rank = box.rank();
     for (decltype(rank) dim = 0; dim < rank; ++dim) {
       auto [lb, extent] = readShape(dim);
       if (lbounds)
         lbounds->push_back(lb);
       extents.push_back(extent);
     }
     return extents;

flang/test/Lower/allocatable-callee.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test allocatable dummy argument on callee side
+
+! CHECK-LABEL: func @_QPtest_scalar(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<f32>>>{{.*}})
+subroutine test_scalar(x)
+  real, allocatable :: x
+
+  print *, x
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<f32>>>
+  ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
+  ! CHECK: %[[val:.*]] = fir.load %[[addr]] : !fir.heap<f32>
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_array(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>{{.*}})
+subroutine test_array(x)
+  integer, allocatable :: x(:,:)
+
+  print *, x(1,2)
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+  ! CHECK-DAG: fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.heap<!fir.array<?x?xi32>>
+  ! CHECK-DAG: fir.box_dims %[[box]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>, index) -> (index, index, index)
+  ! CHECK-DAG: fir.box_dims %[[box]], %c1{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>, index) -> (index, index, index)
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_scalar_deferred(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}})
+subroutine test_char_scalar_deferred(c)
+  character(:), allocatable :: c
+  external foo1
+  call foo1(c)
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
+  ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> index
+  ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_scalar_explicit_cst(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>{{.*}})
+subroutine test_char_scalar_explicit_cst(c)
+  character(10), allocatable :: c
+  external foo1
+  call foo1(c)
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.char<1,10>>>) -> !fir.heap<!fir.char<1,10>>
+  ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %c10{{.*}} : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_scalar_explicit_dynamic(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}}, %[[arg1:.*]]: !fir.ref<i32>{{.*}})
+subroutine test_char_scalar_explicit_dynamic(c, n)
+  integer :: n
+  character(n), allocatable :: c
+  external foo1
+  ! Check that the length expr was evaluated before the execution parts.
+  ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref<i32>
+  n = n + 1
+  ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref<i32>
+  call foo1(c)
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
+  ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK-DAG: %[[len_cast:.*]] = fir.convert %[[len]] : (i32) -> index
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len_cast]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_array_deferred(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>{{.*}})
+subroutine test_char_array_deferred(c)
+  character(:), allocatable :: c(:)
+  external foo1
+  call foo1(c(10))
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> !fir.heap<!fir.array<?x!fir.char<1,?>>>
+  ! CHECK-DAG: fir.box_dims %[[box]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>, index) -> (index, index, index)
+  ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> index
+  ! [...] address computation
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %{{.*}}, %[[len]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_array_explicit_cst(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>{{.*}})
+subroutine test_char_array_explicit_cst(c)
+  character(10), allocatable :: c(:)
+  external foo1
+  call foo1(c(3))
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>) -> !fir.heap<!fir.array<?x!fir.char<1,10>>>
+  ! [...] address computation
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %{{.*}}, %c10{{.*}} : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_array_explicit_dynamic(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>{{.*}}, %[[arg1:.*]]: !fir.ref<i32>{{.*}})
+subroutine test_char_array_explicit_dynamic(c, n)
+  integer :: n
+  character(n), allocatable :: c(:)
+  external foo1
+  ! Check that the length expr was evaluated before the execution parts.
+  ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref<i32>
+  n = n + 1
+  ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref<i32>
+  call foo1(c(1))
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> !fir.heap<!fir.array<?x!fir.char<1,?>>>
+  ! [...] address computation
+  ! CHECK: fir.coordinate_of
+  ! CHECK-DAG: %[[len_cast:.*]] = fir.convert %[[len]] : (i32) -> index
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %{{.*}}, %[[len_cast]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> ()
+end subroutine
+
+! Check that when reading allocatable length from descriptor, the width is taking
+! into account when the kind is not 1.
+
+! CHECK-LABEL: func @_QPtest_char_scalar_deferred_k2(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<2,?>>>>{{.*}})
+subroutine test_char_scalar_deferred_k2(c)
+  character(kind=2, len=:), allocatable :: c
+  external foo2
+  call foo2(c)
+  ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<2,?>>>>
+  ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.char<2,?>>>) -> !fir.heap<!fir.char<2,?>>
+  ! CHECK-DAG: %[[size:.*]] = fir.box_elesize %[[box]] : (!fir.box<!fir.heap<!fir.char<2,?>>>) -> index
+  ! CHECK-DAG: %[[len:.*]] = arith.divsi %[[size]], %c2{{.*}} : index
+  ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap<!fir.char<2,?>>) -> !fir.ref<!fir.char<2,?>>
+  ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len]] : (!fir.ref<!fir.char<2,?>>, index) -> !fir.boxchar<2>
+  ! CHECK: fir.call @_QPfoo2(%[[boxchar]]) : (!fir.boxchar<2>) -> ()
+end subroutine