#include "flang/Lower/Mangler.h"
#include "flang/Lower/Runtime.h"
#include "flang/Lower/StatementContext.h"
+#include "flang/Lower/Support/Utils.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Optimizer/Builder/BoxValue.h"
#include "flang/Optimizer/Builder/Character.h"
mlir::Value genSpacing(mlir::Type resultType,
llvm::ArrayRef<mlir::Value> args);
fir::ExtendedValue genSpread(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+ fir::ExtendedValue genStorageSize(mlir::Type,
+ llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
void genSystemClock(llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genTrailz(mlir::Type, llvm::ArrayRef<mlir::Value>);
&I::genSpread,
{{{"source", asBox}, {"dim", asValue}, {"ncopies", asValue}}},
/*isElemental=*/false},
+ {"storage_size",
+ &I::genStorageSize,
+ {{{"a", asInquired}, {"kind", asValue}}},
+ /*isElemental=*/false},
{"sum",
&I::genSum,
{{{"array", asBox},
return readAndAddCleanUp(resultMutableBox, resultType, "SPREAD");
}
+// STORAGE_SIZE
+fir::ExtendedValue
+IntrinsicLibrary::genStorageSize(mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 2 || args.size() == 1);
+ mlir::Value box = fir::getBase(args[0]);
+ mlir::Type boxTy = box.getType();
+ mlir::Type kindTy = builder.getDefaultIntegerType();
+ bool needRuntimeCheck = false;
+ std::string errorMsg;
+
+ if (fir::isUnlimitedPolymorphicType(boxTy) &&
+ (fir::isAllocatableType(boxTy) || fir::isPointerType(boxTy))) {
+ needRuntimeCheck = true;
+ errorMsg =
+ fir::isPointerType(boxTy)
+ ? "unlimited polymorphic disassociated POINTER in STORAGE_SIZE"
+ : "unlimited polymorphic unallocated ALLOCATABLE in STORAGE_SIZE";
+ } else if (fir::isPolymorphicType(boxTy) && fir::isPointerType(boxTy)) {
+ needRuntimeCheck = true;
+ errorMsg = "polymorphic disassociated POINTER in STORAGE_SIZE";
+ }
+ const fir::MutableBoxValue *mutBox = args[0].getBoxOf<fir::MutableBoxValue>();
+ if (needRuntimeCheck && mutBox) {
+ mlir::Value isNotAllocOrAssoc =
+ fir::factory::genIsNotAllocatedOrAssociatedTest(builder, loc, *mutBox);
+ builder.genIfThen(loc, isNotAllocOrAssoc)
+ .genThen([&]() {
+ fir::runtime::genReportFatalUserError(builder, loc, errorMsg);
+ })
+ .end();
+ }
+
+ // Handle optional kind argument
+ bool absentKind = isStaticallyAbsent(args, 1);
+ if (!absentKind) {
+ mlir::Operation *defKind = fir::getBase(args[1]).getDefiningOp();
+ assert(mlir::isa<mlir::arith::ConstantOp>(*defKind) &&
+ "kind not a constant");
+ auto constOp = mlir::dyn_cast<mlir::arith::ConstantOp>(*defKind);
+ kindTy = builder.getIntegerType(
+ builder.getKindMap().getIntegerBitsize(fir::toInt(constOp)));
+ }
+
+ if (box.getType().isa<fir::ReferenceType>())
+ box = builder.create<fir::LoadOp>(loc, box);
+ mlir::Value eleSize = builder.create<fir::BoxEleSizeOp>(loc, kindTy, box);
+ mlir::Value c8 = builder.createIntegerConstant(loc, kindTy, 8);
+ return builder.create<mlir::arith::MulIOp>(loc, eleSize, c8);
+}
+
// SUM
fir::ExtendedValue
IntrinsicLibrary::genSum(mlir::Type resultType,
--- /dev/null
+! RUN: bbc -emit-fir -polymorphic-type %s -o - | FileCheck %s
+
+module storage_size_test
+ type :: p1
+ integer :: a
+ end type
+
+ type, extends(p1) :: p2
+ integer :: b
+ end type
+
+contains
+
+ integer function unlimited_polymorphic_pointer(p) result(size)
+ class(*), pointer :: p
+ size = storage_size(p)
+ end function
+
+! CHECK-LABEL: func.func @_QMstorage_size_testPunlimited_polymorphic_pointer(
+! CHECK-SAME: %[[P:.*]]: !fir.ref<!fir.class<!fir.ptr<none>>> {fir.bindc_name = "p"}) -> i32 {
+! CHECK: %[[SIZE:.*]] = fir.alloca i32 {bindc_name = "size", uniq_name = "_QMstorage_size_testFunlimited_polymorphic_pointerEsize"}
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.ptr<none>>>
+! CHECK: %[[P_ADDR:.*]] = fir.box_addr %[[LOAD_P]] : (!fir.class<!fir.ptr<none>>) -> !fir.ptr<none>
+! CHECK: %[[P_ADDR_I64:.*]] = fir.convert %[[P_ADDR]] : (!fir.ptr<none>) -> i64
+! CHECK: %[[C0:.*]] = arith.constant 0 : i64
+! CHECK: %[[IS_NULL_ADDR:.*]] = arith.cmpi eq, %[[P_ADDR_I64]], %[[C0]] : i64
+! CHECK: fir.if %[[IS_NULL_ADDR]] {
+! CHECK: %{{.*}} = fir.call @_FortranAReportFatalUserError(%{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<i8>, !fir.ref<i8>, i32) -> none
+! CHECK: }
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.ptr<none>>>
+! CHECK: %[[ELE_SIZE:.*]] = fir.box_elesize %[[LOAD_P]] : (!fir.class<!fir.ptr<none>>) -> i32
+! CHECK: %[[C8:.*]] = arith.constant 8 : i32
+! CHECK: %[[BITS:.*]] = arith.muli %[[ELE_SIZE]], %[[C8]] : i32
+! CHECK: fir.store %[[BITS]] to %[[SIZE]] : !fir.ref<i32>
+! CHECK: %[[RES:.*]] = fir.load %[[SIZE]] : !fir.ref<i32>
+! CHECK: return %[[RES]] : i32
+
+ integer function unlimited_polymorphic_allocatable(p) result(size)
+ class(*), allocatable :: p
+ size = storage_size(p)
+ end function
+
+! CHECK-LABEL: func.func @_QMstorage_size_testPunlimited_polymorphic_allocatable(
+! CHECK-SAME: %[[P:.*]]: !fir.ref<!fir.class<!fir.heap<none>>> {fir.bindc_name = "p"}) -> i32 {
+! CHECK: %[[SIZE:.*]] = fir.alloca i32 {bindc_name = "size", uniq_name = "_QMstorage_size_testFunlimited_polymorphic_allocatableEsize"}
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK: %[[P_ADDR:.*]] = fir.box_addr %[[LOAD_P]] : (!fir.class<!fir.heap<none>>) -> !fir.heap<none>
+! CHECK: %[[P_ADDR_I64:.*]] = fir.convert %[[P_ADDR]] : (!fir.heap<none>) -> i64
+! CHECK: %[[C0:.*]] = arith.constant 0 : i64
+! CHECK: %[[IS_NULL_ADDR:.*]] = arith.cmpi eq, %[[P_ADDR_I64]], %[[C0]] : i64
+! CHECK: fir.if %[[IS_NULL_ADDR]] {
+! CHECK: %{{.*}} = fir.call @_FortranAReportFatalUserError(%{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<i8>, !fir.ref<i8>, i32) -> none
+! CHECK: }
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK: %[[ELE_SIZE:.*]] = fir.box_elesize %[[LOAD_P]] : (!fir.class<!fir.heap<none>>) -> i32
+! CHECK: %[[C8:.*]] = arith.constant 8 : i32
+! CHECK: %[[BITS:.*]] = arith.muli %[[ELE_SIZE]], %[[C8]] : i32
+! CHECK: fir.store %[[BITS]] to %[[SIZE]] : !fir.ref<i32>
+! CHECK: %[[RES:.*]] = fir.load %[[SIZE]] : !fir.ref<i32>
+! CHECK: return %[[RES]] : i32
+
+ integer function polymorphic_pointer(p) result(size)
+ class(p1), pointer :: p
+ size = storage_size(p)
+ end function
+
+! CHECK-LABEL: func.func @_QMstorage_size_testPpolymorphic_pointer(
+! CHECK-SAME: %[[P:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>>> {fir.bindc_name = "p"}) -> i32 {
+! CHECK: %[[SIZE:.*]] = fir.alloca i32 {bindc_name = "size", uniq_name = "_QMstorage_size_testFpolymorphic_pointerEsize"}
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>>>
+! CHECK: %[[P_ADDR:.*]] = fir.box_addr %[[LOAD_P]] : (!fir.class<!fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>>) -> !fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>
+! CHECK: %[[P_ADDR_I64:.*]] = fir.convert %[[P_ADDR]] : (!fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>) -> i64
+! CHECK: %[[C0:.*]] = arith.constant 0 : i64
+! CHECK: %[[IS_NULL_ADDR:.*]] = arith.cmpi eq, %[[P_ADDR_I64]], %[[C0]] : i64
+! CHECK: fir.if %[[IS_NULL_ADDR]] {
+! CHECK: %{{.*}} = fir.call @_FortranAReportFatalUserError(%{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<i8>, !fir.ref<i8>, i32) -> none
+! CHECK: }
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>>>
+! CHECK: %[[ELE_SIZE:.*]] = fir.box_elesize %[[LOAD_P]] : (!fir.class<!fir.ptr<!fir.type<_QMstorage_size_testTp1{a:i32}>>>) -> i32
+! CHECK: %[[C8:.*]] = arith.constant 8 : i32
+! CHECK: %[[BITS:.*]] = arith.muli %[[ELE_SIZE]], %[[C8]] : i32
+! CHECK: fir.store %[[BITS]] to %[[SIZE]] : !fir.ref<i32>
+! CHECK: %[[RES:.*]] = fir.load %[[SIZE]] : !fir.ref<i32>
+! CHECK: return %[[RES]] : i32
+
+ integer function polymorphic(p) result(size)
+ class(p1) :: p
+ size = storage_size(p)
+ end function
+
+! CHECK-LABEL: func.func @_QMstorage_size_testPpolymorphic(
+! CHECK-SAME: %[[P:.*]]: !fir.class<!fir.type<_QMstorage_size_testTp1{a:i32}>> {fir.bindc_name = "p"}) -> i32 {
+! CHECK: %[[SIZE:.*]] = fir.alloca i32 {bindc_name = "size", uniq_name = "_QMstorage_size_testFpolymorphicEsize"}
+! CHECK: %[[ELE_SIZE:.*]] = fir.box_elesize %[[P]] : (!fir.class<!fir.type<_QMstorage_size_testTp1{a:i32}>>) -> i32
+! CHECK: %[[C8:.*]] = arith.constant 8 : i32
+! CHECK: %[[BITS:.*]] = arith.muli %[[ELE_SIZE]], %[[C8]] : i32
+! CHECK: fir.store %[[BITS]] to %[[SIZE]] : !fir.ref<i32>
+! CHECK: %[[RES:.*]] = fir.load %[[SIZE]] : !fir.ref<i32>
+! CHECK: return %[[RES]] : i32
+
+ integer(8) function polymorphic_rank(p) result(size)
+ class(p1) :: p
+ size = storage_size(p, 8)
+ end function
+
+! CHECK-LABEL: func.func @_QMstorage_size_testPpolymorphic_rank(
+! CHECK-SAME: %[[P:.*]]: !fir.class<!fir.type<_QMstorage_size_testTp1{a:i32}>> {fir.bindc_name = "p"}) -> i64 {
+! CHECK: %[[SIZE:.*]] = fir.alloca i64 {bindc_name = "size", uniq_name = "_QMstorage_size_testFpolymorphic_rankEsize"}
+! CHECK: %[[ELE_SIZE:.*]] = fir.box_elesize %[[P]] : (!fir.class<!fir.type<_QMstorage_size_testTp1{a:i32}>>) -> i64
+! CHECK: %[[C8:.*]] = arith.constant 8 : i64
+! CHECK: %[[BITS:.*]] = arith.muli %[[ELE_SIZE]], %[[C8]] : i64
+! CHECK: fir.store %[[BITS]] to %[[SIZE]] : !fir.ref<i64>
+! CHECK: %[[RES:.*]] = fir.load %[[SIZE]] : !fir.ref<i64>
+! CHECK: return %[[RES]] : i64
+
+end module