[flang] Lower assumed length character allocatable and pointer arguments

[jpenix-quic]

Summary

I think the needed functionality was already implemented for host associations,
so turn that code into a function and move it into a (hopefully appropriate)
common location and reuse it.

[jeanPerier]

Thanks for working on this and identifying the opportunity to re-use some code (I had completely forgotten this was here) !

flang/include/flang/Optimizer/Builder/Character.h

229 ↗

(On Diff #466155)

the "Optimizer" part does not depend on semantics (the rational being that it is meant to work from FIR files that will not include any semantics data structures any more).

In this case, I think you can just move the helper to https://github.com/llvm/llvm-project/blob/main/flang/include/flang/Lower/Allocatable.h and its cpp files (where it is OK to depends on semantics).

[jpenix-quic]

Move helper function to Allocatable.h/cpp. Also add lines to pointer tests to check we are reading from the argument to match the allocatable tests.

[jpenix-quic]

flang/include/flang/Optimizer/Builder/Character.h

229 ↗

(On Diff #466155)

Got it, thanks! The helper has been moved.

Thanks for looking over this!

[jeanPerier]

Thanks, looks great to me.

flang/include/flang/Lower/Allocatable.h

 } // namespace fir
 
 namespace Fortran {
 namespace parser {
 struct AllocateStmt;
 struct DeallocateStmt;
 } // namespace parser
 
+namespace semantics {
+class Symbol;
+} // namespace semantics
+
 namespace lower {
 struct SymbolBox;
 
 class StatementContext;
 
 bool isArraySectionWithoutVectorSubscript(const SomeExpr &expr);
 
 /// Lower an allocate statement to fir.
void associateMutableBox(AbstractConverter &converter, mlir::Location loc,
                          StatementContext &stmtCtx);
 
 /// Is \p expr a reference to an entity with the ALLOCATABLE attribute?
 bool isWholeAllocatable(const SomeExpr &expr);
 
 /// Is \p expr a reference to an entity with the POINTER attribute?
 bool isWholePointer(const SomeExpr &expr);
 
+/// Read the length from \p box for an assumed length character allocatable or
+/// pointer dummy argument given by \p sym.
+mlir::Value getAssumedCharAllocatableOrPointerLen(
+    fir::FirOpBuilder &builder, mlir::Location loc,
+    const Fortran::semantics::Symbol &sym, mlir::Value box);
+
 } // namespace lower
 } // namespace Fortran
 
 #endif // FORTRAN_LOWER_ALLOCATABLE_H

flang/lib/Lower/Allocatable.cpp

 }
 
 bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {
   if (const Fortran::semantics::Symbol *sym =
           Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
     return Fortran::semantics::IsPointer(*sym);
   return false;
 }
+
+mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen(
+    fir::FirOpBuilder &builder, mlir::Location loc,
+    const Fortran::semantics::Symbol &sym, mlir::Value box) {
+  // Read length from fir.box (explicit expr cannot safely be re-evaluated
+  // here).
+  auto readLength = [&]() {
+    fir::BoxValue boxLoad =
+        builder.create<fir::LoadOp>(loc, fir::getBase(box)).getResult();
+    return fir::factory::readCharLen(builder, loc, boxLoad);
+  };
+  if (Fortran::semantics::IsOptional(sym)) {
+    mlir::IndexType idxTy = builder.getIndexType();
+    // It is not safe to unconditionally read boxes of optionals in case
+    // they are absents. According to 15.5.2.12 3 (9), it is illegal to
+    // inquire the length of absent optional, even if non deferred, so
+    // it's fine to use undefOp in this case.
+    auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
+                                                      fir::getBase(box));
+    mlir::Value len =
+        builder.genIfOp(loc, {idxTy}, isPresent, true)
+            .genThen(
+                [&]() { builder.create<fir::ResultOp>(loc, readLength()); })
+            .genElse([&]() {
+              auto undef = builder.create<fir::UndefOp>(loc, idxTy);
+              builder.create<fir::ResultOp>(loc, undef.getResult());
+            })
+            .getResults()[0];
+    return len;
+  }
+
+  return readLength();
+}

flang/lib/Lower/ConvertVariable.cpp

if (!boxAlloc)
       boxAlloc = createNewLocal(converter, loc, var, preAlloc);
     // Lower non deferred parameters.
     llvm::SmallVector<mlir::Value> nonDeferredLenParams;
     if (ba.isChar()) {
       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");
+        nonDeferredLenParams.push_back(
+            Fortran::lower::getAssumedCharAllocatableOrPointerLen(
+                builder, loc, sym, boxAlloc));
     } 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/Lower/HostAssociations.cpp

static void getFromTuple(const GetFromTuple &args,
     llvm::SmallVector<mlir::Value> nonDeferredLenParams;
     if (ba.isChar()) {
       mlir::IndexType idxTy = builder.getIndexType();
       if (llvm::Optional<int64_t> len = ba.getCharLenConst()) {
         nonDeferredLenParams.push_back(
             builder.createIntegerConstant(loc, idxTy, *len));
       } else if (Fortran::semantics::IsAssumedLengthCharacter(sym) ||
                  ba.getCharLenExpr()) {
-        // Read length from fir.box (explicit expr cannot safely be re-evaluated
-        // here).
-        auto readLength = [&]() {
-          fir::BoxValue boxLoad =
-              builder.create<fir::LoadOp>(loc, fir::getBase(args.valueInTuple))
-                  .getResult();
-          return fir::factory::readCharLen(builder, loc, boxLoad);
-        };
-        if (Fortran::semantics::IsOptional(sym)) {
-          // It is not safe to unconditionally read boxes of optionals in case
-          // they are absents. According to 15.5.2.12 3 (9), it is illegal to
-          // inquire the length of absent optional, even if non deferred, so
-          // it's fine to use undefOp in this case.
-          auto isPresent = builder.create<fir::IsPresentOp>(
-              loc, builder.getI1Type(), fir::getBase(args.valueInTuple));
-          mlir::Value len =
-              builder.genIfOp(loc, {idxTy}, isPresent, true)
-                  .genThen([&]() {
-                    builder.create<fir::ResultOp>(loc, readLength());
-                  })
-                  .genElse([&]() {
-                    auto undef = builder.create<fir::UndefOp>(loc, idxTy);
-                    builder.create<fir::ResultOp>(loc, undef.getResult());
-                  })
-                  .getResults()[0];
-          nonDeferredLenParams.push_back(len);
-        } else {
-          nonDeferredLenParams.push_back(readLength());
-        }
+        nonDeferredLenParams.push_back(
+            Fortran::lower::getAssumedCharAllocatableOrPointerLen(
+                builder, loc, sym, args.valueInTuple));
       }
     } else if (isDerivedWithLenParameters(sym)) {
       TODO(loc, "host associated derived type allocatable or pointer with "
                 "length parameters");
     }
     args.symMap.addSymbol(
         sym, fir::MutableBoxValue(args.valueInTuple, nonDeferredLenParams, {}));
   }

flang/test/Lower/allocatable-callee.f90

subroutine test_char_scalar_deferred_k2(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
+
+! Check that assumed length character allocatables are reading the length from
+! the descriptor.
+
+! CHECK-LABEL: _QPtest_char_assumed(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}}
+subroutine test_char_assumed(a)
+  integer :: n
+  character(len=*), allocatable :: a
+  ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+  ! CHECK: %[[argLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> index
+
+  n = len(a)
+  ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+  ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+end subroutine
+
+! CHECK-LABEL: _QPtest_char_assumed_optional(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}}
+subroutine test_char_assumed_optional(a)
+  integer :: n
+  character(len=*), allocatable, optional :: a
+  ! CHECK: %[[argPresent:.*]] = fir.is_present %[[arg0]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> i1
+  ! CHECK: %[[argLen:.*]] = fir.if %[[argPresent]] -> (index) {
+  ! CHECK:   %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+  ! CHECK:   %[[argEleSz:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> index
+  ! CHECK:   fir.result %[[argEleSz]] : index
+  ! CHECK: } else {
+  ! CHECK:   %[[undef:.*]] = fir.undefined index
+  ! CHECK:   fir.result %[[undef]] : index
+
+  if (present(a)) then
+    n = len(a)
+    ! CHECK:   %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+    ! CHECK:   fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+  endif
+end subroutine

flang/test/Lower/pointer-args-callee.f90

+! Test calls with POINTER dummy arguments on the callee side.
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func @_QPchar_assumed(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}}
+subroutine char_assumed(a)
+  integer :: n
+  character(len=*), pointer :: a
+  ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+  ! CHECK: %[[argLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.ptr<!fir.char<1,?>>>) -> index
+
+  n = len(a)
+  ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+  ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+end subroutine
+
+! CHECK-LABEL: func @_QPchar_assumed_optional(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}}
+subroutine char_assumed_optional(a)
+  integer :: n
+  character(len=*), pointer, optional :: a
+  ! CHECK: %[[argPresent:.*]] = fir.is_present %[[arg0]] : (!fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>) -> i1
+  ! CHECK: %[[argLen:.*]] = fir.if %[[argPresent]] -> (index) {
+  ! CHECK:   %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+  ! CHECK:   %[[argLoadLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.ptr<!fir.char<1,?>>>) -> index
+  ! CHECK:   fir.result %[[argLoadLen]] : index
+  ! CHECK: } else {
+  ! CHECK:   %[[undef:.*]] = fir.undefined index
+  ! CHECK:   fir.result %[[undef]] : index
+  ! CHECK: }
+
+  if (present(a)) then
+    n = len(a)
+    ! CHECK:   %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+    ! CHECK:   fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+  endif
+end subroutine