[flang] Unlimited polymoprhic allocation with intrinsic type spec

[clementval]

Summary

An unlimited polymoprhic entity can be allocated with a derived type
spec or an intrinsic type spec. This patch add the generation of the
runtime function call when the allocation is done with an intrinsic
type spec.

[PeteSteinfeld]

Aside from the one nit, things build and test correctly and look good. I don't understand this code very well, though, so @jeanPerier should approve.

flang/lib/Lower/Allocatable.cpp

522

Did you mean to say "derived type specific information"?

[jeanPerier]

Small nit. LGTM otherwise.

flang/lib/Lower/Allocatable.cpp

509

Could you name the argument corank instead of c0 to help readers ? (I saw it is named like that below, but I guess it could also be changed).

[clementval]

flang/lib/Lower/Allocatable.cpp

509

Sure. I'll update that.

522

It stand for derived-type specification but often abbreviated like that in the code (see derivedTypeSpec() below)

[clementval]

Address review comments

flang/lib/Lower/Allocatable.cpp

void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box,
                   mlir::Location loc) {
     const Fortran::semantics::DeclTypeSpec *typeSpec =
         getIfAllocateStmtTypeSpec();
 
     // No type spec provided in allocate statement so the declared type spec is
     // used.
     if (!typeSpec)
       typeSpec = &alloc.type;
+    assert(typeSpec && "type spec missing for polymorphic allocation");
+
+    // Set up the descriptor for allocation for intrinsic type spec on
+    // unlimited polymorphic entity.
+    if (typeSpec->AsIntrinsic() &&
+        fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) {
+      mlir::func::FuncOp callee =
+          box.isPointer()
+              ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyIntrinsic)>(
+                    loc, builder)
+              : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableInitIntrinsic)>(
+                    loc, builder);
+
+      llvm::ArrayRef<mlir::Type> inputTypes =
+          callee.getFunctionType().getInputs();
+      llvm::SmallVector<mlir::Value> args;
+      args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
+      mlir::Value category = builder.createIntegerConstant(
+          loc, inputTypes[1],
+          static_cast<int32_t>(typeSpec->AsIntrinsic()->category()));
+      mlir::Value kind = builder.createIntegerConstant(
+          loc, inputTypes[2],
+          Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value());
+      mlir::Value rank = builder.createIntegerConstant(
+          loc, inputTypes[3], alloc.getSymbol().Rank());
+      mlir::Value corank = builder.createIntegerConstant(loc, inputTypes[4], 0);
+      args.push_back(category);
+      args.push_back(kind);
+      args.push_back(rank);
+      args.push_back(corank);
+      builder.create<fir::CallOp>(loc, callee, args);
+      return;
+    }
 
     // Do not generate calls for non derived-type type spec.
     if (!typeSpec->AsDerived())
       return;
 
-    assert(typeSpec && "type spec missing for polymorphic allocation");
+    // Set up descriptor for allocation with derived type spec.
     std::string typeName =
         Fortran::lower::mangle::mangleName(typeSpec->derivedTypeSpec());
     std::string typeDescName =
         fir::NameUniquer::getTypeDescriptorName(typeName);
 
     auto typeDescGlobal =
         builder.getModule().lookupSymbol<fir::GlobalOp>(typeDescName);
     if (!typeDescGlobal)
void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box,
 
     llvm::ArrayRef<mlir::Type> inputTypes =
         callee.getFunctionType().getInputs();
     llvm::SmallVector<mlir::Value> args;
     args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
     args.push_back(builder.createConvert(loc, inputTypes[1], typeDescAddr));
     mlir::Value rank = builder.createIntegerConstant(loc, inputTypes[2],
                                                      alloc.getSymbol().Rank());
-    mlir::Value c0 = builder.createIntegerConstant(loc, inputTypes[3], 0);
+    mlir::Value corank = builder.createIntegerConstant(loc, inputTypes[3], 0);
     args.push_back(rank);
-    args.push_back(c0);
+    args.push_back(corank);
     builder.create<fir::CallOp>(loc, callee, args);
   }
 
   /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the
   /// allocate statement. Returns a null pointer otherwise.
   const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const {
     if (const auto &typeSpec =
             std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t))

flang/test/Lower/allocatable-polymorphic.f90

 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C2_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
 
 ! CHECK: %[[C3_CAST:.*]] = fir.convert %[[C3]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C3_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
 
 ! CHECK: %[[C4_CAST:.*]] = fir.convert %[[C4]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C4_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
 
+  subroutine test_unlimited_polymorphic_with_intrinsic_type_spec()
+    class(*), allocatable :: p
+    class(*), pointer :: ptr
+    allocate(integer::p)
+    deallocate(p)
+
+    allocate(real::ptr)
+    deallocate(ptr)
+
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolyPtest_unlimited_polymorphic_with_intrinsic_type_spec() {
+! CHECK: %[[P:.*]] = fir.alloca !fir.class<!fir.heap<none>> {bindc_name = "p", uniq_name = "_QMpolyFtest_unlimited_polymorphic_with_intrinsic_type_specEp"}
+! CHECK: %[[PTR:.*]] = fir.alloca !fir.class<!fir.ptr<none>> {bindc_name = "ptr", uniq_name = "_QMpolyFtest_unlimited_polymorphic_with_intrinsic_type_specEptr"}
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[CAT:.*]] = arith.constant 0 : i32
+! CHECK: %[[KIND:.*]] = arith.constant 4 : i32
+! CHECK: %[[RANK:.*]] = arith.constant 0 : i32
+! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableInitIntrinsic(%[[BOX_NONE]], %[[CAT]], %[[KIND]], %[[RANK]], %[[CORANK]]) {{.*}} : (!fir.ref<!fir.box<none>>, i32, i32, i32, i32) -> none
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[PTR]] : (!fir.ref<!fir.class<!fir.ptr<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[CAT:.*]] = arith.constant 1 : i32
+! CHECK: %[[KIND:.*]] = arith.constant 4 : i32
+! CHECK: %[[RANK:.*]] = arith.constant 0 : i32
+! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32
+! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyIntrinsic(%[[BOX_NONE]], %[[CAT]], %[[KIND]], %[[RANK]], %[[CORANK]]) {{.*}} : (!fir.ref<!fir.box<none>>, i32, i32, i32, i32) -> none
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[PTR]] : (!fir.ref<!fir.class<!fir.ptr<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
   ! Test code generation of deallocate
   subroutine test_deallocate()
     class(p1), allocatable :: p
 
     allocate(p)
     deallocate(p)
   end subroutine