[flang-commits] [flang] 90e9fcb - [flang] Set declared type when NULLIFY a polymorphic pointer
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Mon Oct 31 03:03:19 PDT 2022
Author: Valentin Clement
Date: 2022-10-31T11:03:13+01:00
New Revision: 90e9fcbb68a3afa3ac25aa54555355634554c349
URL: https://github.com/llvm/llvm-project/commit/90e9fcbb68a3afa3ac25aa54555355634554c349
DIFF: https://github.com/llvm/llvm-project/commit/90e9fcbb68a3afa3ac25aa54555355634554c349.diff
LOG: [flang] Set declared type when NULLIFY a polymorphic pointer
Fortran standard 7.3.2.3 point 7 mentions that a diassociated
pointer dynamic type is its declared type.
in 9.7.2 note 1, when a NULLIFY statement is applied to a polymorphic pointer,
its dynamic type becomes the same as its declared type.
This patch enforce these standard points by calling the runtime function
`PointerNullifyDerived` with the declared type descriptor.
Reviewed By: jeanPerier
Differential Revision: https://reviews.llvm.org/D136948
Added:
flang/test/Lower/nullify-polymoprhic.f90
Modified:
flang/include/flang/Optimizer/Builder/MutableBox.h
flang/include/flang/Optimizer/Builder/Runtime/Derived.h
flang/lib/Lower/Allocatable.cpp
flang/lib/Lower/Bridge.cpp
flang/lib/Optimizer/Builder/MutableBox.cpp
flang/lib/Optimizer/Builder/Runtime/Derived.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Optimizer/Builder/MutableBox.h b/flang/include/flang/Optimizer/Builder/MutableBox.h
index 3d04bbf2387db..95083df37bc20 100644
--- a/flang/include/flang/Optimizer/Builder/MutableBox.h
+++ b/flang/include/flang/Optimizer/Builder/MutableBox.h
@@ -74,7 +74,8 @@ void associateMutableBoxWithRemap(fir::FirOpBuilder &builder,
/// previously associated/allocated. The function generates code that sets the
/// address field of the MutableBoxValue to zero.
void disassociateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc,
- const fir::MutableBoxValue &box);
+ const fir::MutableBoxValue &box,
+ bool polymorphicSetType = true);
/// Generate code to conditionally reallocate a MutableBoxValue with a new
/// shape, lower bounds, and LEN parameters if it is unallocated or if its
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
index a5e1083be3acc..816d561d38913 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
@@ -16,6 +16,7 @@ class Location;
namespace fir {
class FirOpBuilder;
+class RecordType;
}
namespace fir::runtime {
@@ -30,5 +31,11 @@ void genDerivedTypeInitialize(fir::FirOpBuilder &builder, mlir::Location loc,
void genDerivedTypeDestroy(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value box);
+/// Generate call to `PointerNullifyDerived` runtime function to nullify
+/// and set the correct dynamic type to a boxed derived type.
+void genNullifyDerivedType(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value box, fir::RecordType derivedType,
+ unsigned rank = 0);
+
} // namespace fir::runtime
#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H
diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp
index c454fcb637e17..57d4ae1fa13ef 100644
--- a/flang/lib/Lower/Allocatable.cpp
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -720,7 +720,8 @@ fir::MutableBoxValue Fortran::lower::createMutableBox(
fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
- fir::factory::disassociateMutableBox(builder, loc, box);
+ fir::factory::disassociateMutableBox(builder, loc, box,
+ /*polymorphicSetType=*/false);
return box;
}
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index db8c2b7afbb8d..46df999734be6 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -32,6 +32,7 @@
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Runtime/Character.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"
#include "flang/Optimizer/Builder/Runtime/Ragged.h"
#include "flang/Optimizer/Builder/Todo.h"
diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp
index d2f3b2164b0d0..d1fc09c750ab7 100644
--- a/flang/lib/Optimizer/Builder/MutableBox.cpp
+++ b/flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -646,7 +646,18 @@ void fir::factory::associateMutableBoxWithRemap(
void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
mlir::Location loc,
- const fir::MutableBoxValue &box) {
+ const fir::MutableBoxValue &box,
+ bool polymorphicSetType) {
+ if (box.isPolymorphic() && polymorphicSetType) {
+ // 7.3.2.3 point 7. The dynamic type of a disassociated pointer is the
+ // same as its declared type.
+ auto boxTy = box.getBoxTy().dyn_cast<fir::BaseBoxType>();
+ auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy.getEleTy());
+ if (auto recTy = eleTy.dyn_cast<fir::RecordType>())
+ fir::runtime::genNullifyDerivedType(builder, loc, box.getAddr(), recTy,
+ box.rank());
+ return;
+ }
MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
}
diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
index 0f2bf274cc75f..8700c9ef1254b 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
@@ -9,7 +9,10 @@
#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Optimizer/Support/InternalNames.h"
#include "flang/Runtime/derived-api.h"
+#include "flang/Runtime/pointer.h"
using namespace Fortran::runtime;
@@ -33,3 +36,29 @@ void fir::runtime::genDerivedTypeDestroy(fir::FirOpBuilder &builder,
auto args = fir::runtime::createArguments(builder, loc, fTy, box);
builder.create<fir::CallOp>(loc, func, args);
}
+
+void fir::runtime::genNullifyDerivedType(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value box,
+ fir::RecordType derivedType,
+ unsigned rank) {
+ std::string typeDescName =
+ fir::NameUniquer::getTypeDescriptorName(derivedType.getName());
+ fir::GlobalOp typeDescGlobal = builder.getNamedGlobal(typeDescName);
+ if (!typeDescGlobal)
+ fir::emitFatalError(loc, "no type descriptor found for NULLIFY");
+ auto typeDescAddr = builder.create<fir::AddrOfOp>(
+ loc, fir::ReferenceType::get(typeDescGlobal.getType()),
+ typeDescGlobal.getSymbol());
+ mlir::func::FuncOp callee =
+ fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyDerived)>(loc,
+ builder);
+ llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().getInputs();
+ llvm::SmallVector<mlir::Value> args;
+ args.push_back(builder.createConvert(loc, inputTypes[0], box));
+ args.push_back(builder.createConvert(loc, inputTypes[1], typeDescAddr));
+ mlir::Value rankCst = builder.createIntegerConstant(loc, inputTypes[2], rank);
+ mlir::Value c0 = builder.createIntegerConstant(loc, inputTypes[3], 0);
+ args.push_back(rankCst);
+ args.push_back(c0);
+ builder.create<fir::CallOp>(loc, callee, args);
+}
diff --git a/flang/test/Lower/nullify-polymoprhic.f90 b/flang/test/Lower/nullify-polymoprhic.f90
new file mode 100644
index 0000000000000..7c9ac9c01d9a7
--- /dev/null
+++ b/flang/test/Lower/nullify-polymoprhic.f90
@@ -0,0 +1,53 @@
+! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
+
+module poly
+ type p1
+ integer :: a
+ integer :: b
+ contains
+ procedure, nopass :: proc1 => proc1_p1
+ end type
+
+ type, extends(p1) :: p2
+ integer :: c
+ contains
+ procedure, nopass :: proc1 => proc1_p2
+ end type
+
+contains
+
+ subroutine proc1_p1()
+ print*, 'call proc1_p1'
+ end subroutine
+
+ subroutine proc1_p2()
+ print*, 'call proc1_p2'
+ end subroutine
+
+ subroutine test_nullify()
+ class(p1), pointer :: c
+
+ allocate(p2::c)
+ call c%proc1()
+
+ nullify(c) ! c dynamic type must be reset to p1
+
+ call c%proc1()
+ end subroutine
+end module
+
+program test
+ use poly
+ call test_nullify()
+end
+
+! CHECK-LABEL: func.func @_QMpolyPtest_nullify()
+! CHECK: %[[C_DESC:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>> {bindc_name = "c", uniq_name = "_QMpolyFtest_nullifyEc"}
+! CHECK: %[[C_ADDR:.*]] = fir.alloca !fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>> {uniq_name = "_QMpolyFtest_nullifyEc.addr"}
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+! CHECK: %[[DECLARED_TYPE:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref<!fir.type<{{.*}}>>
+! CHECK: %[[C_DESC_CAST:.*]] = fir.convert %[[C_DESC]] : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[TYPE_DESC_CAST:.*]] = fir.convert %[[DECLARED_TYPE]] : (!fir.ref<!fir.type<{{.*}}>>) -> !fir.ref<none>
+! CHECK: %[[RANK:.*]] = arith.constant 0 : i32
+! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32
+! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[C_DESC_CAST]], %[[TYPE_DESC_CAST]], %[[RANK]], %[[CORANK]]) : (!fir.ref<!fir.box<none>>, !fir.ref<none>, i32, i32) -> none
More information about the flang-commits
mailing list