[flang] Set assumed-size last extent to -1

flang/include/flang/Optimizer/Builder/BoxValue.h

@@ -527,9 +527,6 @@ class ExtendedValue : public details::matcher<ExtendedValue> {
                  [](const auto &box) -> bool { return false; });
   }
 
-  /// Is this an assumed size array ?
-  bool isAssumedSize() const;
-
   /// LLVM style debugging of extended values
   LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this << '\n'; }
 

flang/lib/Lower/ConvertVariable.cpp

@@ -684,6 +684,13 @@ static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter,
   llvm::StringRef symNm = toStringRef(ultimateSymbol.name());
   bool isTarg = var.isTarget();
 
+  // Do not allocate storage for cray pointee. The address inside the cray
+  // pointer will be used instead when using the pointee. Allocating space
+  // would be a waste of space, and incorrect if the pointee is a non dummy
+  // assumed-size (possible with cray pointee).
+  if (ultimateSymbol.test(Fortran::semantics::Symbol::Flag::CrayPointee))
+    return builder.create<fir::ZeroOp>(loc, fir::ReferenceType::get(ty));
+
   // Let the builder do all the heavy lifting.
   if (!Fortran::semantics::IsProcedurePointer(ultimateSymbol))
     return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
@@ -1454,6 +1461,15 @@ static void lowerExplicitLowerBounds(
   assert(result.empty() || result.size() == box.dynamicBound().size());
 }
 
+/// Return -1 for the last dimension extent/upper bound of assumed-size arrays.
+/// This value is required to fulfill the requirements for assumed-rank
+/// associated with assumed-size (see for instance UBOUND in 16.9.196, and
+/// CFI_desc_t requirements in 18.5.3 point 5.).
+static mlir::Value getAssumedSizeExtent(mlir::Location loc,
+                                        fir::FirOpBuilder &builder) {
+  return builder.createIntegerConstant(loc, builder.getIndexType(), -1);
+}
+
 /// Lower explicit extents into \p result if this is an explicit-shape or
 /// assumed-size array. Does nothing if this is not an explicit-shape or
 /// assumed-size array.
@@ -1484,8 +1500,7 @@ lowerExplicitExtents(Fortran::lower::AbstractConverter &converter,
         result.emplace_back(
             computeExtent(builder, loc, lowerBounds[spec.index()], ub));
     } 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));
+      result.emplace_back(getAssumedSizeExtent(loc, builder));
     }
   }
   assert(result.empty() || result.size() == box.dynamicBound().size());
@@ -1513,15 +1528,13 @@ lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter,
   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.
+/// Assumed size arrays last extent is -1 in the front end.
 static mlir::Value genExtentValue(fir::FirOpBuilder &builder,
                                   mlir::Location loc, mlir::Type idxTy,
                                   long frontEndExtent) {
   if (frontEndExtent >= 0)
     return builder.createIntegerConstant(loc, idxTy, frontEndExtent);
-  return builder.create<fir::UndefOp>(loc, idxTy);
+  return getAssumedSizeExtent(loc, builder);
 }
 
 /// If a symbol is an array, it may have been declared with unknown extent
@@ -2000,7 +2013,7 @@ void Fortran::lower::mapSymbolAttributes(
             builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim);
         shapes.emplace_back(dimInfo.getResult(1));
       } else if (spec->ubound().isStar()) {
-        shapes.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
+        shapes.emplace_back(getAssumedSizeExtent(loc, builder));
       } else {
         llvm::report_fatal_error("unknown bound category");
       }
@@ -2047,7 +2060,7 @@ void Fortran::lower::mapSymbolAttributes(
         } else {
           // An assumed size array. The extent is not computed.
           assert(spec->ubound().isStar() && "expected assumed size");
-          extents.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
+          extents.emplace_back(getAssumedSizeExtent(loc, builder));
         }
       }
     }

flang/lib/Lower/DirectivesCommon.h

@@ -761,7 +761,7 @@ template <typename BoundsOp, typename BoundsType>
 llvm::SmallVector<mlir::Value>
 genBaseBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc,
                  Fortran::lower::AbstractConverter &converter,
-                 fir::ExtendedValue dataExv) {
+                 fir::ExtendedValue dataExv, bool isAssumedSize) {
   mlir::Type idxTy = builder.getIndexType();
   mlir::Type boundTy = builder.getType<BoundsType>();
   llvm::SmallVector<mlir::Value> bounds;
@@ -770,14 +770,15 @@ genBaseBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc,
     return bounds;
 
   mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
-  for (std::size_t dim = 0; dim < dataExv.rank(); ++dim) {
+  const unsigned rank = dataExv.rank();
+  for (unsigned dim = 0; dim < rank; ++dim) {
     mlir::Value baseLb =
         fir::factory::readLowerBound(builder, loc, dataExv, dim, one);
     mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
     mlir::Value ub;
     mlir::Value lb = zero;
     mlir::Value ext = fir::factory::readExtent(builder, loc, dataExv, dim);
-    if (mlir::isa<fir::UndefOp>(ext.getDefiningOp())) {
+    if (isAssumedSize && dim + 1 == rank) {
       ext = zero;
       ub = lb;
     } else {
@@ -801,14 +802,16 @@ genBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc,
              Fortran::lower::StatementContext &stmtCtx,
              const std::list<Fortran::parser::SectionSubscript> &subscripts,
              std::stringstream &asFortran, fir::ExtendedValue &dataExv,
-             mlir::Value baseAddr, bool treatIndexAsSection = false) {
+             bool dataExvIsAssumedSize, mlir::Value baseAddr,
+             bool treatIndexAsSection = false) {
   int dimension = 0;
   mlir::Type idxTy = builder.getIndexType();
   mlir::Type boundTy = builder.getType<BoundsType>();
   llvm::SmallVector<mlir::Value> bounds;
 
   mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
   mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+  const int dataExvRank = static_cast<int>(dataExv.rank());
   for (const auto &subscript : subscripts) {
     const auto *triplet{
         std::get_if<Fortran::parser::SubscriptTriplet>(&subscript.u)};
@@ -912,7 +915,7 @@ genBoundsOps(fir::FirOpBuilder &builder, mlir::Location loc,
         }
 
         extent = fir::factory::readExtent(builder, loc, dataExv, dimension);
-        if (mlir::isa<fir::UndefOp>(extent.getDefiningOp())) {
+        if (dataExvIsAssumedSize && dimension + 1 == dataExvRank) {
           extent = zero;
           if (ubound && lbound) {
             mlir::Value diff =
@@ -959,6 +962,7 @@ AddrAndBoundsInfo gatherDataOperandAddrAndBounds(
                 const auto *dataRef =
                     std::get_if<Fortran::parser::DataRef>(&designator.u);
                 fir::ExtendedValue dataExv;
+                bool dataExvIsAssumedSize = false;
                 if (Fortran::parser::Unwrap<
                         Fortran::parser::StructureComponent>(
                         arrayElement->base)) {
@@ -971,6 +975,8 @@ AddrAndBoundsInfo gatherDataOperandAddrAndBounds(
                 } else {
                   const Fortran::parser::Name &name =
                       Fortran::parser::GetLastName(*dataRef);
+                  dataExvIsAssumedSize = Fortran::semantics::IsAssumedSizeArray(
+                      name.symbol->GetUltimate());
                   info = getDataOperandBaseAddr(converter, builder,
                                                 *name.symbol, operandLocation);
                   dataExv = converter.getSymbolExtendedValue(*name.symbol);
@@ -981,8 +987,8 @@ AddrAndBoundsInfo gatherDataOperandAddrAndBounds(
                   asFortran << '(';
                   bounds = genBoundsOps<BoundsOp, BoundsType>(
                       builder, operandLocation, converter, stmtCtx,
-                      arrayElement->subscripts, asFortran, dataExv, info.addr,
-                      treatIndexAsSection);
+                      arrayElement->subscripts, asFortran, dataExv,
+                      dataExvIsAssumedSize, info.addr, treatIndexAsSection);
                 }
                 asFortran << ')';
               } else if (auto structComp = Fortran::parser::Unwrap<
@@ -993,7 +999,8 @@ AddrAndBoundsInfo gatherDataOperandAddrAndBounds(
                 if (fir::unwrapRefType(info.addr.getType())
                         .isa<fir::SequenceType>())
                   bounds = genBaseBoundsOps<BoundsOp, BoundsType>(
-                      builder, operandLocation, converter, compExv);
+                      builder, operandLocation, converter, compExv,
+                      /*isAssumedSize=*/false);
                 asFortran << (*expr).AsFortran();
 
                 bool isOptional = Fortran::semantics::IsOptional(
@@ -1047,10 +1054,14 @@ AddrAndBoundsInfo gatherDataOperandAddrAndBounds(
                     bounds = genBoundsOpsFromBox<BoundsOp, BoundsType>(
                         builder, operandLocation, converter, dataExv, info);
                   }
+                  bool dataExvIsAssumedSize =
+                      Fortran::semantics::IsAssumedSizeArray(
+                          name.symbol->GetUltimate());
                   if (fir::unwrapRefType(info.addr.getType())
                           .isa<fir::SequenceType>())
                     bounds = genBaseBoundsOps<BoundsOp, BoundsType>(
-                        builder, operandLocation, converter, dataExv);
+                        builder, operandLocation, converter, dataExv,
+                        dataExvIsAssumedSize);
                   asFortran << name.ToString();
                 } else { // Unsupported
                   llvm::report_fatal_error(

flang/lib/Lower/OpenMP.cpp

@@ -2915,11 +2915,14 @@ genTargetOp(Fortran::lower::AbstractConverter &converter,
                                                   mlir::omp::DataBoundsType>(
                   converter.getFirOpBuilder(), converter.getCurrentLocation(),
                   converter, dataExv, info);
-        if (fir::unwrapRefType(info.addr.getType()).isa<fir::SequenceType>())
+        if (fir::unwrapRefType(info.addr.getType()).isa<fir::SequenceType>()) {
+          bool dataExvIsAssumedSize =
+              Fortran::semantics::IsAssumedSizeArray(sym.GetUltimate());
           bounds = Fortran::lower::genBaseBoundsOps<mlir::omp::DataBoundsOp,
                                                     mlir::omp::DataBoundsType>(
               converter.getFirOpBuilder(), converter.getCurrentLocation(),
-              converter, dataExv);
+              converter, dataExv, dataExvIsAssumedSize);
+        }
 
         llvm::omp::OpenMPOffloadMappingFlags mapFlag =
             llvm::omp::OpenMPOffloadMappingFlags::OMP_MAP_IMPLICIT;

flang/lib/Optimizer/Builder/BoxValue.cpp

@@ -232,19 +232,3 @@ mlir::Value fir::factory::getExtentAtDimension(mlir::Location loc,
     return extents[dim];
   return {};
 }
-
-static inline bool isUndefOp(mlir::Value v) {
-  return mlir::isa_and_nonnull<fir::UndefOp>(v.getDefiningOp());
-}
-
-bool fir::ExtendedValue::isAssumedSize() const {
-  return match(
-      [](const fir::ArrayBoxValue &box) -> bool {
-        return !box.getExtents().empty() && isUndefOp(box.getExtents().back());
-        ;
-      },
-      [](const fir::CharArrayBoxValue &box) -> bool {
-        return !box.getExtents().empty() && isUndefOp(box.getExtents().back());
-      },
-      [](const auto &box) -> bool { return false; });
-}

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -5691,10 +5691,10 @@ static mlir::Value computeLBOUND(fir::FirOpBuilder &builder, mlir::Location loc,
   if (hasDefaultLowerBound(array))
     return one;
   mlir::Value lb = fir::factory::readLowerBound(builder, loc, array, dim, one);
-  if (dim + 1 == array.rank() && array.isAssumedSize())
-    return lb;
   mlir::Value extent = fir::factory::readExtent(builder, loc, array, dim);
   zero = builder.createConvert(loc, extent.getType(), zero);
+  // Note: for assumed size, the extent is -1, and the lower bound should
+  // be returned. It is important to test extent == 0 and not extent > 0.
   auto dimIsEmpty = builder.create<mlir::arith::CmpIOp>(
       loc, mlir::arith::CmpIPredicate::eq, extent, zero);
   one = builder.createConvert(loc, lb.getType(), one);
@@ -5703,52 +5703,29 @@ static mlir::Value computeLBOUND(fir::FirOpBuilder &builder, mlir::Location loc,
 
 /// Create a fir.box to be passed to the LBOUND/UBOUND runtime.
 /// This ensure that local lower bounds of assumed shape are propagated and that
-/// a fir.box with equivalent LBOUNDs but an explicit shape is created for
-/// assumed size arrays to avoid undefined behaviors in codegen or the runtime.
+/// a fir.box with equivalent LBOUNDs.
 static mlir::Value
 createBoxForRuntimeBoundInquiry(mlir::Location loc, fir::FirOpBuilder &builder,
                                 const fir::ExtendedValue &array) {
-  if (!array.isAssumedSize())
-    return array.match(
-        [&](const fir::BoxValue &boxValue) -> mlir::Value {
-          // This entity is mapped to a fir.box that may not contain the local
-          // lower bound information if it is a dummy. Rebox it with the local
-          // shape information.
-          mlir::Value localShape = builder.createShape(loc, array);
-          mlir::Value oldBox = boxValue.getAddr();
-          return builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
-                                              localShape,
-                                              /*slice=*/mlir::Value{});
-        },
-        [&](const auto &) -> mlir::Value {
-          // This a pointer/allocatable, or an entity not yet tracked with a
-          // fir.box. For pointer/allocatable, createBox will forward the
-          // descriptor that contains the correct lower bound information. For
-          // other entities, a new fir.box will be made with the local lower
-          // bounds.
-          return builder.createBox(loc, array);
-        });
-  // Assumed sized are not meant to be emboxed. This could cause the undefined
-  // extent cannot safely be understood by the runtime/codegen that will
-  // consider that the dimension is empty and that the related LBOUND value must
-  // be one. Pretend that the related extent is one to get the correct LBOUND
-  // value.
-  llvm::SmallVector<mlir::Value> shape =
-      fir::factory::getExtents(loc, builder, array);
-  assert(!shape.empty() && "assumed size must have at least one dimension");
-  shape.back() = builder.createIntegerConstant(loc, builder.getIndexType(), 1);
-  auto safeToEmbox = array.match(
-      [&](const fir::CharArrayBoxValue &x) -> fir::ExtendedValue {
-        return fir::CharArrayBoxValue{x.getAddr(), x.getLen(), shape,
-                                      x.getLBounds()};
-      },
-      [&](const fir::ArrayBoxValue &x) -> fir::ExtendedValue {
-        return fir::ArrayBoxValue{x.getAddr(), shape, x.getLBounds()};
+  return array.match(
+      [&](const fir::BoxValue &boxValue) -> mlir::Value {
+        // This entity is mapped to a fir.box that may not contain the local
+        // lower bound information if it is a dummy. Rebox it with the local
+        // shape information.
+        mlir::Value localShape = builder.createShape(loc, array);
+        mlir::Value oldBox = boxValue.getAddr();
+        return builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
+                                            localShape,
+                                            /*slice=*/mlir::Value{});
       },
-      [&](const auto &) -> fir::ExtendedValue {
-        fir::emitFatalError(loc, "not an assumed size array");
+      [&](const auto &) -> mlir::Value {
+        // This is a pointer/allocatable, or an entity not yet tracked with a
+        // fir.box. For pointer/allocatable, createBox will forward the
+        // descriptor that contains the correct lower bound information. For
+        // other entities, a new fir.box will be made with the local lower
+        // bounds.
+        return builder.createBox(loc, array);
       });
-  return builder.createBox(loc, safeToEmbox);
 }
 
 // LBOUND

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

@@ -6,7 +6,6 @@
 //
 //===----------------------------------------------------------------------===//
 
-#include "flang/Optimizer/Builder/Array.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Factory.h"
@@ -822,6 +821,16 @@ static mlir::Type getEleTy(mlir::Type ty) {
   return ReferenceType::get(eleTy);
 }
 
+// This is an unsafe way to deduce this (won't be true in internal
+// procedure or inside select-rank for assumed-size). Only here to satisfy
+// legacy code until removed.
+static bool isAssumedSize(llvm::SmallVectorImpl<mlir::Value> &extents) {
+  if (extents.empty())
+    return false;
+  auto cstLen = fir::getIntIfConstant(extents.back());
+  return cstLen.has_value() && *cstLen == -1;
+}
+
 // Extract extents from the ShapeOp/ShapeShiftOp into the result vector.
 static bool getAdjustedExtents(mlir::Location loc,
                                mlir::PatternRewriter &rewriter,
@@ -840,7 +849,7 @@ static bool getAdjustedExtents(mlir::Location loc,
     emitFatalError(loc, "not a fir.shape/fir.shape_shift op");
   }
   auto idxTy = rewriter.getIndexType();
-  if (factory::isAssumedSize(result)) {
+  if (isAssumedSize(result)) {
     // Use slice information to compute the extent of the column.
     auto one = rewriter.create<mlir::arith::ConstantIndexOp>(loc, 1);
     mlir::Value size = one;

flang/test/Lower/HLFIR/assumed-size-cray-pointee.f90

@@ -0,0 +1,14 @@
+! Test lowering of assumed-size cray pointee. This is an
+! odd case where an assumed-size symbol is not a dummy.
+! Test that no bogus stack allocation is created for it
+! (it will take its address from the cray pointer when used).
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+subroutine assumed_size_cray_ptr
+  implicit none
+  pointer(ivar,var)
+  real :: var(*)
+end subroutine
+! CHECK-LABEL: func.func @_QPassumed_size_cray_ptr
+! CHECK-NOT: fir.alloca !fir.array<?xf32>
+! CHECK: return