[flang-commits] [flang] b2b680a - [flang] Unlimited polymoprhic allocation with intrinsic type spec

[Valentin Clement via flang-commits]

Author: Valentin Clement
Date: 2022-12-16T21:20:28+01:00
New Revision: b2b680a5abe831fd2a21adc2480affeceda9c274

URL: https://github.com/llvm/llvm-project/commit/b2b680a5abe831fd2a21adc2480affeceda9c274
DIFF: https://github.com/llvm/llvm-project/commit/b2b680a5abe831fd2a21adc2480affeceda9c274.diff

LOG: [flang] Unlimited polymoprhic allocation with intrinsic type spec

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.

Reviewed By: jeanPerier

Differential Revision: https://reviews.llvm.org/D140207

Added: 
    

Modified: 
    flang/lib/Lower/Allocatable.cpp
    flang/test/Lower/allocatable-polymorphic.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp
index e58a3c2c6be3f..eb367dfbb68f5 100644
--- a/flang/lib/Lower/Allocatable.cpp
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -481,12 +481,45 @@ class AllocateStmtHelper {
     // 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 =
@@ -513,9 +546,9 @@ class AllocateStmtHelper {
     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);
   }
 

diff  --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90
index e71cea90fb650..d8e849248fbb2 100644
--- a/flang/test/Lower/allocatable-polymorphic.f90
+++ b/flang/test/Lower/allocatable-polymorphic.f90
@@ -345,6 +345,38 @@ subroutine test_allocatable()
 ! 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