[flang] Handle reversed bounds and negative length in inlined allocation

[clementval]

Summary

ALLOCATE statement allows reversed bounds (see Fortran 2018 9.7.1.2
point 1) in which case the extents are zero.

The same applies for the character length provided in the type spec that
can be negative. In which case the new length is zero.

Use genMaxWithZero to deal with these cases.

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

Co-authored-by: Jean Perier <[e-mail]>

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Optimizer/Builder/MutableBox.cpp

 
 static llvm::SmallVector<mlir::Value>
 getNewLengths(fir::FirOpBuilder &builder, mlir::Location loc,
               const fir::MutableBoxValue &box, mlir::ValueRange lenParams) {
   llvm::SmallVector<mlir::Value> lengths;
   auto idxTy = builder.getIndexType();
   if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
     if (charTy.getLen() == fir::CharacterType::unknownLen()) {
-      if (box.hasNonDeferredLenParams())
+      if (box.hasNonDeferredLenParams()) {
         lengths.emplace_back(
             builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0]));
-      else if (!lenParams.empty())
-        lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0]));
-      else
+      } else if (!lenParams.empty()) {
+        mlir::Value len =
+            fir::factory::genMaxWithZero(builder, loc, lenParams[0]);
+        lengths.emplace_back(builder.createConvert(loc, idxTy, len));
+      } else {
         fir::emitFatalError(
             loc, "could not deduce character lengths in character allocation");
       }
     }
+  }
   return lengths;
 }
 
 static mlir::Value allocateAndInitNewStorage(fir::FirOpBuilder &builder,
                                              mlir::Location loc,
                                              const fir::MutableBoxValue &box,
                                              mlir::ValueRange extents,
                                              mlir::ValueRange lenParams,

 void fir::factory::genInlinedAllocation(fir::FirOpBuilder &builder,
                                         mlir::Location loc,
                                         const fir::MutableBoxValue &box,
                                         mlir::ValueRange lbounds,
                                         mlir::ValueRange extents,
                                         mlir::ValueRange lenParams,
                                         llvm::StringRef allocName) {
   auto lengths = getNewLengths(builder, loc, box, lenParams);
+  llvm::SmallVector<mlir::Value> safeExtents;
+  for (mlir::Value extent : extents)
+    safeExtents.push_back(fir::factory::genMaxWithZero(builder, loc, extent));
   auto heap = builder.create<fir::AllocMemOp>(loc, box.getBaseTy(), allocName,
-                                              lengths, extents);
-  MutablePropertyWriter{builder, loc, box}.updateMutableBox(heap, lbounds,
-                                                            extents, lengths);
+                                              lengths, safeExtents);
+  MutablePropertyWriter{builder, loc, box}.updateMutableBox(
+      heap, lbounds, safeExtents, lengths);
   if (box.getEleTy().isa<fir::RecordType>()) {
     // TODO: skip runtime initialization if this is not required. Currently,
     // there is no way to know here if a derived type needs it or not. But the
     // information is available at compile time and could be reflected here
     // somehow.
     mlir::Value irBox = fir::factory::getMutableIRBox(builder, loc, box);
     fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
   }

flang/test/Lower/allocatables.f90

subroutine foodim1()
   ! CHECK: %[[nullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
   ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
 
   ! Test allocation of local allocatables
   allocate(x(42:100))
   ! CHECK-DAG: %[[c42:.*]] = fir.convert %c42{{.*}} : (i32) -> index
   ! CHECK-DAG: %[[c100:.*]] = fir.convert %c100_i32 : (i32) -> index
   ! CHECK-DAG: %[[diff:.*]] = arith.subi %[[c100]], %[[c42]] : index
-  ! CHECK: %[[extent:.*]] = arith.addi %[[diff]], %c1{{.*}} : index
+  ! CHECK: %[[rawExtent:.*]] = arith.addi %[[diff]], %c1{{.*}} : index
+  ! CHECK: %[[extentPositive:.*]] = arith.cmpi sgt, %[[rawExtent]], %c0{{.*}} : index
+  ! CHECK: %[[extent:.*]] = arith.select %[[extentPositive]], %[[rawExtent]], %c0{{.*}} : index
   ! CHECK: %[[alloc:.*]] = fir.allocmem !fir.array<?xf32>, %[[extent]] {{{.*}}uniq_name = "_QFfoodim1Ex.alloc"}
   ! CHECK-DAG: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
   ! CHECK-DAG: fir.store %[[extent]] to %[[xExtVar]] : !fir.ref<index>
   ! CHECK-DAG: fir.store %[[c42]] to %[[xLbVar]] : !fir.ref<index>
 
   ! Test reading allocatable bounds and extents
   print *, x(42)
   ! CHECK-DAG: fir.load %[[xLbVar]] : !fir.ref<index>
subroutine char_deferred(n)
   allocate(character(10):: c)
   ! CHECK: %[[c10:.]] = fir.convert %c10_i32 : (i32) -> index
   ! CHECK: fir.allocmem !fir.char<1,?>(%[[c10]] : index) {{{.*}}uniq_name = "_QFchar_deferredEc.alloc"}
   ! CHECK: fir.store %[[c10]] to %[[cLenVar]] : !fir.ref<index>
   deallocate(c)
   ! CHECK: fir.freemem %{{.*}}
   allocate(character(n):: c)
   ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
-  ! CHECK: %[[ni:.*]] = fir.convert %[[n]] : (i32) -> index
+  ! CHECK: %[[nPositive:.*]] = arith.cmpi sgt, %[[n]], %c0{{.*}} : i32
+  ! CHECK: %[[ns:.*]] = arith.select %[[nPositive]], %[[n]], %c0{{.*}} : i32
+  ! CHECK: %[[ni:.*]] = fir.convert %[[ns]] : (i32) -> index
   ! CHECK: fir.allocmem !fir.char<1,?>(%[[ni]] : index) {{{.*}}uniq_name = "_QFchar_deferredEc.alloc"}
   ! CHECK: fir.store %[[ni]] to %[[cLenVar]] : !fir.ref<index>
 
   call bar(c)
   ! CHECK-DAG: %[[cLen:.*]] = fir.load %[[cLenVar]] : !fir.ref<index>
   ! CHECK-DAG: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,?>>>
   ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
   ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>