Change host associations so they are not "promoted" to !fir.ptr (#1324)

* Change host associations so they are not "promoted" to !fir.ptr
(POINTER) variables. The promotion negatively impacts alias analysis and
performance.

In the initial implementation of the feature, host associated variables
were always passed as if they had been declared with the POINTER
attribute even when they had not been. These changes allow non-pointer,
non-allocatable variables to be passed as !fir.ref or !fir.box and
maintain the non-aliasing properties of the original host associated
variable whenever appropriate.

This change also allows descriptors to be created which are not
interoperatble with BIND(C) but do allow a variable to be boxed with its
properties. These properties can then be passed to internal procedures
without loss of information from the host. An attribute can be used to
force a descriptor to be created in a normalized form compatible with
the BIND(C) requirements from the standard.

* Use denormalized descriptors everywhere by default. This is a departure
from using interoperable descriptors by default.

* Fix error in creating box_addr with a bad type.

Author: schweitzpgi

flang/include/flang/Lower/ConvertExpr.h

@@ -206,7 +206,8 @@ mlir::Value createSubroutineCall(AbstractConverter &converter,
 // pass-by-ref semantics for a VALUE parameter. The optimizer may be able to
 // eliminate these.
 inline mlir::NamedAttribute getAdaptToByRefAttr(fir::FirOpBuilder &builder) {
-  return {mlir::Identifier::get("adapt.valuebyref", builder.getContext()),
+  return {mlir::Identifier::get(fir::getAdaptToByRefAttrName(),
+                                builder.getContext()),
           builder.getUnitAttr()};
 }
 

flang/include/flang/Optimizer/Dialect/FIROps.h

@@ -38,6 +38,14 @@ mlir::ParseResult parseSelector(mlir::OpAsmParser &parser,
                                 mlir::OpAsmParser::OperandType &selector,
                                 mlir::Type &type);
 
+static constexpr llvm::StringRef getAdaptToByRefAttrName() {
+  return "adapt.valuebyref";
+}
+
+static constexpr llvm::StringRef getNormalizedLowerBoundAttrName() {
+  return "normalized.lb";
+}
+
 } // namespace fir
 
 #define GET_OP_CLASSES

flang/lib/Lower/HostAssociations.cpp

@@ -124,12 +124,12 @@ class CapturedSymbols {
 
 /// Class defining simple scalars are captured in internal procedures.
 /// Simple scalars are non character intrinsic scalars. They are captured
-/// as !fir.ptr<T> (.e.g !fir.ptr<i32> for INTEGER(4)).
+/// as `!fir.ref<T>`, for example `!fir.ref<i32>` for `INTEGER*4`.
 class CapturedSimpleScalars : public CapturedSymbols<CapturedSimpleScalars> {
 public:
   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                             const Fortran::semantics::Symbol &sym) {
-    return fir::PointerType::get(converter.genType(sym));
+    return fir::ReferenceType::get(converter.genType(sym));
   }
 
   static void instantiateHostTuple(const InstantiateHostTuple &args,
@@ -311,21 +311,21 @@ class CapturedAllocatableAndPointer
 };
 
 /// Class defining how arrays are captured inside internal procedures.
-/// Array are captured via a fir.box<fir.ptr<T>> pointer descriptor that
-/// belongs to the host tuple. This allows capturing lower bounds, which
-/// a non pointer descriptor (fir.box<T>) would not allow.
+/// Array are captured via a `fir.box<fir.array<T>>` descriptor that belongs to
+/// the host tuple. This allows capturing lower bounds, which can be done by
+/// providing a ShapeShiftOp argument to the EmboxOp.
 class CapturedArrays : public CapturedSymbols<CapturedArrays> {
 
   // Note: Constant shape arrays are not specialized (their base address would
   // be sufficient information inside the tuple). They could be specialized in
-  // a later FIR pass, or A CapturedStaticShapeArrays could be added to deal
+  // a later FIR pass, or a CapturedStaticShapeArrays could be added to deal
   // with them here.
 public:
   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                             const Fortran::semantics::Symbol &sym) {
     mlir::Type type = converter.genType(sym);
     assert(type.isa<fir::SequenceType>() && "must be a sequence type");
-    return fir::BoxType::get(fir::PointerType::get(type));
+    return fir::BoxType::get(type);
   }
 
   static void instantiateHostTuple(const InstantiateHostTuple &args,
@@ -398,7 +398,10 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
       // a null base address).
       if (Fortran::semantics::IsOptional(sym)) {
         auto boxTy = box.getType().cast<fir::BoxType>();
-        auto addr = builder.create<fir::BoxAddrOp>(loc, boxTy.getEleTy(), box);
+        auto eleTy = boxTy.getEleTy();
+        if (!fir::isa_ref_type(eleTy))
+           eleTy = builder.getRefType(eleTy);
+        auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
         mlir::Value isPresent = builder.genIsNotNull(loc, addr);
         auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
         box = builder.create<mlir::SelectOp>(loc, isPresent, box, absentBox);
@@ -435,6 +438,7 @@ typename T::Result
 walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
                       const Fortran::semantics::Symbol &sym) {
   if (isDerivedWithLengthParameters(sym))
+    // Should be boxed.
     TODO(converter.genLocation(sym.name()),
          "host associated derived type with length parameters");
   Fortran::lower::BoxAnalyzer ba;

flang/lib/Optimizer/Builder/BoxValue.cpp

@@ -182,15 +182,13 @@ llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
 /// always be called, so it should not have any functional side effects,
 /// the const is here to enforce that.
 bool fir::MutableBoxValue::verify() const {
-  auto type = fir::dyn_cast_ptrEleTy(getAddr().getType());
+  mlir::Type type = fir::dyn_cast_ptrEleTy(getAddr().getType());
   if (!type)
     return false;
   auto box = type.dyn_cast<fir::BoxType>();
   if (!box)
     return false;
-  auto eleTy = box.getEleTy();
-  if (!eleTy.isa<fir::PointerType>() && !eleTy.isa<fir::HeapType>())
-    return false;
+  // A boxed value always takes a memory reference,
 
   auto nParams = lenParams.size();
   if (isCharacter()) {

flang/lib/Optimizer/Builder/MutableBox.cpp

@@ -47,8 +47,10 @@ class MutablePropertyReader {
   /// 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);
@@ -242,9 +244,11 @@ class MutablePropertyWriter {
         // unknown or constant lengths.
         auto bt = box.getBaseTy();
         auto addrTy = addr.getType();
-        auto type = addrTy.isa<fir::HeapType>()      ? fir::HeapType::get(bt)
-                    : addrTy.isa<fir::PointerType>() ? fir::PointerType::get(bt)
-                                                     : builder.getRefType(bt);
+        auto type = addrTy.isa<fir::HeapType>()
+                        ? fir::HeapType::get(bt)
+                        : addrTy.isa<fir::PointerType>()
+                              ? fir::PointerType::get(bt)
+                              : builder.getRefType(bt);
         cleanedAddr = builder.createConvert(loc, type, addr);
         if (charTy.getLen() == fir::CharacterType::unknownLen())
           cleanedLengths.append(lengths.begin(), lengths.end());

flang/lib/Optimizer/CodeGen/CodeGen.cpp

@@ -1482,13 +1482,19 @@ struct XEmboxOpConversion : public EmboxCommonConversion<fir::cg::XEmboxOp> {
         }
       }
       if (!skipNext) {
-        // store lower bound (normally 0)
+        // Lower bound is normalized to 0 for BIND(C) interoperability.
         auto lb = zero;
-        if (eleTy.isa<fir::PointerType>() || eleTy.isa<fir::HeapType>()) {
+        bool isaPointerOrAllocatable =
+            eleTy.isa<fir::PointerType>() || eleTy.isa<fir::HeapType>();
+        // Lower bound is defaults to 1 for POINTER, ALLOCATABLE, and
+        // denormalized descriptors.
+        if (isaPointerOrAllocatable || !normalizedLowerBound(xbox))
           lb = one;
-          if (hasShift)
-            lb = operands[shiftOff];
-        }
+        // If there is a shifted origin and this is not a normalized descriptor
+        // then use the value from the shift op as the lower bound.
+        if (hasShift &&
+            (isaPointerOrAllocatable || !normalizedLowerBound(xbox)))
+          lb = operands[shiftOff];
         dest = insertLowerBound(rewriter, loc, dest, descIdx, lb);
 
         // store extent
@@ -1547,6 +1553,13 @@ struct XEmboxOpConversion : public EmboxCommonConversion<fir::cg::XEmboxOp> {
     rewriter.replaceOp(xbox, result);
     return success();
   }
+
+  /// Return true if `xbox` has a normalized lower bounds attribute. A box value
+  /// that is neither a POINTER nor an ALLOCATABLE should be normalized to a
+  /// zero origin lower bound for interoperability with BIND(C).
+  inline static bool normalizedLowerBound(fir::cg::XEmboxOp xbox) {
+    return xbox->hasAttr(fir::getNormalizedLowerBoundAttrName());
+  }
 };
 
 /// Create a new box given a box reference.

flang/test/Fir/box.fir

@@ -145,10 +145,10 @@ func @box6(%0 : !fir.ref<!fir.array<?x?x?x?xf32>>, %1 : index, %2 : index) -> i3
   // CHECK: %[[sdp2:.*]] = sdiv i64 %[[dp2]], 2
   // CHECK: %[[cmp:.*]] = icmp sgt i64 %[[sdp2]], 0
   // CHECK: %[[extent:.*]] = select i1 %[[cmp]], i64 %[[sdp2]], i64 0
-  // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } { float* undef, i64 4, i32 20180515, i8 2, i8 25, i8 0, i8 0, [2 x [3 x i64]] [{{\[}}3 x i64] [i64 0, i64 undef, i64 undef], [3 x i64] undef] }, i64 %[[extent]], 7, 0, 1
+  // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } { float* undef, i64 4, i32 20180515, i8 2, i8 25, i8 0, i8 0, [2 x [3 x i64]] [{{\[}}3 x i64] [i64 1, i64 undef, i64 undef], [3 x i64] undef] }, i64 %[[extent]], 7, 0, 1
   // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } %{{.*}}, i64 800, 7, 0, 2
   // CHECK: %[[op25:.*]] = add i64 25000, %[[i100p40]]
-  // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } %{{.*}}, i64 0, 7, 1, 0
+  // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } %{{.*}}, i64 1, 7, 1, 0
   // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } %{{.*}}, i64 4, 7, 1, 1
   // CHECK: insertvalue { float*, i64, i32, i8, i8, i8, i8, [2 x [3 x i64]] } %{{.*}}, i64 120000, 7, 1, 2
   // CHECK: %[[op300:.*]] = add i64 300000, %[[op25]]

flang/test/Fir/embox.fir

@@ -13,7 +13,7 @@ func @_QPtest_slice() {
 // CHECK:  %[[a3:.*]] = getelementptr [20 x i32], [20 x i32]* %[[a2]], i64 0, i64 0, 
 // CHECK:  %[[a4:.*]] = insertvalue { i32*, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]] }  
 // CHECK:  { i32* undef, i64 4, i32 20180515, i8 1, i8 9, i8 0, i8 0, [1 x [3 x i64]] 
-// CHECK: [i64 0, i64 5, i64 8]] }, i32* %[[a3]], 0, 
+// CHECK: [i64 1, i64 5, i64 8]] }, i32* %[[a3]], 0, 
 // CHECK:  store { i32*, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]] } %[[a4]], { i32*, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]] }* %[[a1]], align 8
 // CHECK:  call void @_QPtest_callee({ i32*, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]] }* %[[a1]]), 
   %c20 = arith.constant 20 : index
@@ -40,7 +40,7 @@ func @_QPtest_dt_slice() {
 // CHECK:  %[[a4:.*]] = getelementptr [20 x %_QFtest_dt_sliceTt], [20 x %_QFtest_dt_sliceTt]* %[[a3]], i64 0, i64 0, i32 0,
 // CHECK: %[[a5:.*]] = insertvalue { i32*, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]] }
 // CHECK-SAME: { i32* undef, i64 4, i32 20180515, i8 1, i8 9, i8 0, i8 0, [1 x [3 x i64]]
-// CHECK-SAME: [i64 0, i64 5, i64 mul
+// CHECK-SAME: [i64 1, i64 5, i64 mul
 // CHECK-SAME: (i64 ptrtoint (%_QFtest_dt_sliceTt* getelementptr (%_QFtest_dt_sliceTt, %_QFtest_dt_sliceTt* null, i64 1) to i64), i64 2)]] }
 // CHECK-SAME: , i32* %[[a4]], 0