[flang-commits] [flang] [flang] Add MALLOC and FREE intrinsics for Cray pointers (PR #110018)
David Truby via flang-commits
flang-commits at lists.llvm.org
Wed Sep 25 10:29:56 PDT 2024
https://github.com/DavidTruby created https://github.com/llvm/llvm-project/pull/110018
MALLOC and FREE are extensions provided by gfortran, Intel Fortran and
classic flang to allocate memory for Cray pointers. These are used in
some legacy codes such as libexodus.
All the above compilers accept using MALLOC and FREE with integers as
well, despite that this will often signify a bug in user code. We should
accept the same as the other compilers for compatibility.
>From 5fce5e20b508fa793a6ba868765c51b8989ceed4 Mon Sep 17 00:00:00 2001
From: David Truby <david.truby at arm.com>
Date: Tue, 24 Sep 2024 14:42:48 +0100
Subject: [PATCH] [flang] Add MALLOC and FREE intrinsics for Cray pointers
MALLOC and FREE are extensions provided by gfortran, Intel Fortran and
classic flang to allocate memory for Cray pointers. These are used in
some legacy codes such as libexodus.
All the above compilers accept using MALLOC and FREE with integers as
well, despite that this will often signify a bug in user code. We should
accept the same as the other compilers for compatibility.
---
flang/docs/Intrinsics.md | 4 +-
.../flang/Optimizer/Builder/IntrinsicCall.h | 2 +
.../Optimizer/Builder/Runtime/Intrinsics.h | 4 +
flang/include/flang/Runtime/extensions.h | 4 +
flang/lib/Evaluate/intrinsics.cpp | 2 +
flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 15 ++++
.../Optimizer/Builder/Runtime/Intrinsics.cpp | 20 +++++
flang/lib/Semantics/check-call.cpp | 14 ++++
flang/runtime/extensions.cpp | 8 ++
flang/test/Lower/Intrinsics/free.f90 | 66 ++++++++++++++++
flang/test/Lower/Intrinsics/malloc.f90 | 75 +++++++++++++++++++
flang/test/Semantics/free.f90 | 33 ++++++++
12 files changed, 245 insertions(+), 2 deletions(-)
create mode 100644 flang/test/Lower/Intrinsics/free.f90
create mode 100644 flang/test/Lower/Intrinsics/malloc.f90
create mode 100644 flang/test/Semantics/free.f90
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index 87716731ead855..d6f48a7fd87d7b 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -700,7 +700,7 @@ IBCHNG, ISHA, ISHC, ISHL, IXOR
IARG, IARGC, NARGS, NUMARG
BADDRESS, IADDR
CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, LOC
-MALLOC
+MALLOC, FREE
```
### Library subroutine
@@ -765,7 +765,7 @@ This phase currently supports all the intrinsic procedures listed above but the
| Coarray intrinsic functions | COSHAPE |
| Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
| Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
-| Non-standard intrinsic functions | AND, OR, XOR, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, GETPID, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
+| Non-standard intrinsic functions | AND, OR, XOR, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, GETPID, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC, FREE |
| Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SIGNAL, SLEEP, SYSTEM, SYSTEM_CLOCK |
| Atomic intrinsic subroutines | ATOMIC_ADD |
| Collective intrinsic subroutines | CO_REDUCE |
diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
index 78bb82b17d4050..ca4030816b1a09 100644
--- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
+++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
@@ -249,6 +249,7 @@ struct IntrinsicLibrary {
mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
mlir::Value genFraction(mlir::Type resultType,
mlir::ArrayRef<mlir::Value> args);
+ void genFree(mlir::ArrayRef<fir::ExtendedValue> args);
fir::ExtendedValue genGetCwd(std::optional<mlir::Type> resultType,
llvm::ArrayRef<fir::ExtendedValue> args);
void genGetCommand(mlir::ArrayRef<fir::ExtendedValue> args);
@@ -315,6 +316,7 @@ struct IntrinsicLibrary {
fir::ExtendedValue genLen(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genLenTrim(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genLoc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+ mlir::Value genMalloc(mlir::Type, llvm::ArrayRef<mlir::Value>);
template <typename Shift>
mlir::Value genMask(mlir::Type, llvm::ArrayRef<mlir::Value>);
fir::ExtendedValue genMatmul(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
index 240de5a899d37b..f62071a49e3bf6 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
@@ -47,6 +47,10 @@ void genDateAndTime(fir::FirOpBuilder &, mlir::Location,
void genEtime(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value values, mlir::Value time);
+void genFree(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value ptr);
+mlir::Value genMalloc(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value size);
+
void genRandomInit(fir::FirOpBuilder &, mlir::Location, mlir::Value repeatable,
mlir::Value imageDistinct);
void genRandomNumber(fir::FirOpBuilder &, mlir::Location, mlir::Value harvest);
diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h
index fef651f3b2eedb..8b7607be7e999a 100644
--- a/flang/include/flang/Runtime/extensions.h
+++ b/flang/include/flang/Runtime/extensions.h
@@ -28,6 +28,8 @@ void FORTRAN_PROCEDURE_NAME(flush)(const int &unit);
// GNU extension subroutine FDATE
void FORTRAN_PROCEDURE_NAME(fdate)(char *string, std::int64_t length);
+void RTNAME(Free)(std::intptr_t ptr);
+
// GNU Fortran 77 compatibility function IARGC.
std::int32_t FORTRAN_PROCEDURE_NAME(iargc)();
@@ -38,6 +40,8 @@ void FORTRAN_PROCEDURE_NAME(getarg)(
// GNU extension subroutine GETLOG(C).
void FORTRAN_PROCEDURE_NAME(getlog)(char *name, std::int64_t length);
+std::intptr_t RTNAME(Malloc)(std::size_t size);
+
// GNU extension function STATUS = SIGNAL(number, handler)
std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int));
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 17a09c080e72c4..a89e9732228cbc 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -620,6 +620,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"log10", {{"x", SameReal}}, SameReal},
{"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical},
{"log_gamma", {{"x", SameReal}}, SameReal},
+ {"malloc", {{"size", AnyInt}}, SubscriptInt},
{"matmul",
{{"matrix_a", AnyLogical, Rank::vector},
{"matrix_b", AnyLogical, Rank::matrix}},
@@ -1409,6 +1410,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{
{}, Rank::elemental, IntrinsicClass::impureSubroutine},
{"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {},
Rank::elemental, IntrinsicClass::impureSubroutine},
+ {"free", {{"ptr", Addressable}}, {}},
{"get_command",
{{"command", DefaultChar, Rank::scalar, Optionality::optional,
common::Intent::Out},
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index 4e6d92213c1241..86f7d14c6592b4 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -265,6 +265,7 @@ static constexpr IntrinsicHandler handlers[]{
/*isElemental=*/false},
{"floor", &I::genFloor},
{"fraction", &I::genFraction},
+ {"free", &I::genFree},
{"get_command",
&I::genGetCommand,
{{{"command", asBox, handleDynamicOptional},
@@ -436,6 +437,7 @@ static constexpr IntrinsicHandler handlers[]{
{"lle", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sle>},
{"llt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::slt>},
{"loc", &I::genLoc, {{{"x", asBox}}}, /*isElemental=*/false},
+ {"malloc", &I::genMalloc},
{"maskl", &I::genMask<mlir::arith::ShLIOp>},
{"maskr", &I::genMask<mlir::arith::ShRUIOp>},
{"matmul",
@@ -3581,6 +3583,12 @@ mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
fir::runtime::genFraction(builder, loc, fir::getBase(args[0])));
}
+void IntrinsicLibrary::genFree(llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 1);
+
+ fir::runtime::genFree(builder, loc, fir::getBase(args[0]));
+}
+
// GETCWD
fir::ExtendedValue
IntrinsicLibrary::genGetCwd(std::optional<mlir::Type> resultType,
@@ -5307,6 +5315,13 @@ IntrinsicLibrary::genLoc(mlir::Type resultType,
.getResults()[0];
}
+mlir::Value IntrinsicLibrary::genMalloc(mlir::Type resultType,
+ llvm::ArrayRef<mlir::Value> args) {
+ assert(args.size() == 1);
+ return builder.createConvert(loc, resultType,
+ fir::runtime::genMalloc(builder, loc, args[0]));
+}
+
// MASKL, MASKR
template <typename Shift>
mlir::Value IntrinsicLibrary::genMask(mlir::Type resultType,
diff --git a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
index aff3cadc3c300d..cf2483d36c0274 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
@@ -120,6 +120,26 @@ void fir::runtime::genEtime(fir::FirOpBuilder &builder, mlir::Location loc,
builder.create<fir::CallOp>(loc, runtimeFunc, args);
}
+void fir::runtime::genFree(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value ptr) {
+ auto runtimeFunc = fir::runtime::getRuntimeFunc<mkRTKey(Free)>(loc, builder);
+ mlir::Type intPtrTy = builder.getIntPtrType();
+
+ builder.create<fir::CallOp>(loc, runtimeFunc,
+ builder.createConvert(loc, intPtrTy, ptr));
+}
+
+mlir::Value fir::runtime::genMalloc(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value size) {
+ auto runtimeFunc =
+ fir::runtime::getRuntimeFunc<mkRTKey(Malloc)>(loc, builder);
+ auto argTy = runtimeFunc.getArgumentTypes()[0];
+ return builder
+ .create<fir::CallOp>(loc, runtimeFunc,
+ builder.createConvert(loc, argTy, size))
+ .getResult(0);
+}
+
void fir::runtime::genRandomInit(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value repeatable,
mlir::Value imageDistinct) {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 71d1c083c31278..31079174239c24 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1600,6 +1600,18 @@ static void CheckMaxMin(const characteristics::Procedure &proc,
}
}
+static void CheckFree(evaluate::ActualArguments &arguments,
+ parser::ContextualMessages &messages) {
+ if (arguments.size() != 1) {
+ messages.Say("FREE expects a single argument"_err_en_US);
+ }
+ auto arg = arguments[0];
+ if (const Symbol * symbol{evaluate::UnwrapWholeSymbolDataRef(arg)};
+ !symbol || !symbol->test(Symbol::Flag::CrayPointer)) {
+ messages.Say("FREE should only be used with Cray pointers"_warn_en_US);
+ }
+}
+
// MOVE_ALLOC (F'2023 16.9.147)
static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
parser::ContextualMessages &messages) {
@@ -1885,6 +1897,8 @@ static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,
CheckReduce(arguments, context.foldingContext());
} else if (intrinsic.name == "transfer") {
CheckTransfer(arguments, context, scope);
+ } else if (intrinsic.name == "free") {
+ CheckFree(arguments, context.foldingContext().messages());
}
}
diff --git a/flang/runtime/extensions.cpp b/flang/runtime/extensions.cpp
index be3833db88b07a..4412a9cbeb6d21 100644
--- a/flang/runtime/extensions.cpp
+++ b/flang/runtime/extensions.cpp
@@ -96,6 +96,10 @@ void FORTRAN_PROCEDURE_NAME(fdate)(char *arg, std::int64_t length) {
CopyAndPad(arg, str, length, 24);
}
+std::intptr_t RTNAME(Malloc)(std::size_t size) {
+ return reinterpret_cast<std::intptr_t>(std::malloc(size));
+}
+
// RESULT = IARGC()
std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }
@@ -124,6 +128,10 @@ void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {
#endif
}
+void RTNAME(Free)(std::intptr_t ptr) {
+ std::free(reinterpret_cast<void *>(ptr));
+}
+
std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {
// using auto for portability:
// on Windows, this is a void *
diff --git a/flang/test/Lower/Intrinsics/free.f90 b/flang/test/Lower/Intrinsics/free.f90
new file mode 100644
index 00000000000000..bb8d38e737aa72
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/free.f90
@@ -0,0 +1,66 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func.func @_QPfree_ptr() {
+subroutine free_ptr()
+ integer :: x
+ pointer (ptr_x, x)
+ ! CHECK: %[[X:.*]] = fir.alloca !fir.box<!fir.ptr<i32>>
+ ! CHECK: %[[X_PTR:.*]] = fir.alloca i64 {bindc_name = "ptr_x", uniq_name = "_QFfree_ptrEptr_x"}
+ ! CHECK: %[[X_PTR_DECL:.*]]:2 = hlfir.declare %[[X_PTR]] {uniq_name = "_QFfree_ptrEptr_x"} : (!fir.ref<i64>) -> (!fir.ref<i64>, !fir.ref<i64>)
+ ! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFfree_ptrEx"} : (!fir.ref<!fir.box<!fir.ptr<i32>>>) -> (!fir.ref<!fir.box<!fir.ptr<i32>>>, !fir.ref<!fir.box<!fir.ptr<i32>>>)
+ ! CHECK: %[[X_LD:.*]] = fir.load %[[X_PTR_DECL]]#0 : !fir.ref<i64>
+ ! CHECK: %[[VOID:.*]] = fir.call @_FortranAFree(%[[X_LD]]) fastmath<contract> : (i64) -> none
+ ! CHECK: return
+ call free(ptr_x)
+end subroutine
+
+! gfortran allows free to be used on integers, so we accept it with a warning.
+
+! CHECK-LABEL: func.func @_QPfree_i8() {
+subroutine free_i8
+ integer (kind=1) :: x
+ ! CHECK: %[[X:.*]] = fir.alloca i8 {bindc_name = "x", uniq_name = "_QFfree_i8Ex"}
+ ! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFfree_i8Ex"} : (!fir.ref<i8>) -> (!fir.ref<i8>, !fir.ref<i8>)
+ ! CHECK: %[[X_LD:.*]] = fir.load %[[X_DECL]]#0 : !fir.ref<i8>
+ ! CHECK: %[[X_I64:.*]] = fir.convert %[[X_LD]] : (i8) -> i64
+ ! CHECK: %[[VOID:.*]] = fir.call @_FortranAFree(%[[X_I64]]) fastmath<contract> : (i64) -> none
+ ! CHECK: return
+ call free(x)
+end subroutine
+
+
+! CHECK-LABEL: func.func @_QPfree_i16() {
+subroutine free_i16
+ integer (kind=2) :: x
+ ! CHECK: %[[X:.*]] = fir.alloca i16 {bindc_name = "x", uniq_name = "_QFfree_i16Ex"}
+ ! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFfree_i16Ex"} : (!fir.ref<i16>) -> (!fir.ref<i16>, !fir.ref<i16>)
+ ! CHECK: %[[X_LD:.*]] = fir.load %[[X_DECL]]#0 : !fir.ref<i16>
+ ! CHECK: %[[X_I64:.*]] = fir.convert %[[X_LD]] : (i16) -> i64
+ ! CHECK: %[[VOID:.*]] = fir.call @_FortranAFree(%[[X_I64]]) fastmath<contract> : (i64) -> none
+ ! CHECK: return
+ call free(x)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPfree_i32() {
+subroutine free_i32
+ integer (kind=4) :: x
+ ! CHECK: %[[X:.*]] = fir.alloca i32 {bindc_name = "x", uniq_name = "_QFfree_i32Ex"}
+ ! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFfree_i32Ex"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+ ! CHECK: %[[X_LD:.*]] = fir.load %[[X_DECL]]#0 : !fir.ref<i32>
+ ! CHECK: %[[X_I64:.*]] = fir.convert %[[X_LD]] : (i32) -> i64
+ ! CHECK: %[[VOID:.*]] = fir.call @_FortranAFree(%[[X_I64]]) fastmath<contract> : (i64) -> none
+ ! CHECK: return
+ call free(x)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPfree_i64() {
+subroutine free_i64
+ integer (kind=8) :: x
+ ! CHECK: %[[X:.*]] = fir.alloca i64 {bindc_name = "x", uniq_name = "_QFfree_i64Ex"}
+ ! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFfree_i64Ex"} : (!fir.ref<i64>) -> (!fir.ref<i64>, !fir.ref<i64>)
+ ! CHECK: %[[X_LD:.*]] = fir.load %[[X_DECL]]#0 : !fir.ref<i64>
+ ! CHECK: %[[VOID:.*]] = fir.call @_FortranAFree(%[[X_LD]]) fastmath<contract> : (i64) -> none
+ ! CHECK: return
+ call free(x)
+end subroutine
diff --git a/flang/test/Lower/Intrinsics/malloc.f90 b/flang/test/Lower/Intrinsics/malloc.f90
new file mode 100644
index 00000000000000..4a9b65bf7ae181
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/malloc.f90
@@ -0,0 +1,75 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func.func @_QPmalloc_ptr() {
+subroutine malloc_ptr()
+ integer :: x
+ pointer (ptr_x, x)
+ ! CHECK: %[[X:.*]] = fir.alloca !fir.box<!fir.ptr<i32>>
+ ! CHECK: %[[X_PTR:.*]] = fir.alloca i64 {bindc_name = "ptr_x", uniq_name = "_QFmalloc_ptrEptr_x"}
+ ! CHECK: %[[X_PTR_DECL:.*]]:2 = hlfir.declare %[[X_PTR]] {uniq_name = "_QFmalloc_ptrEptr_x"} : (!fir.ref<i64>) -> (!fir.ref<i64>, !fir.ref<i64>)
+ ! CHECK: %[[CST:.*]] = arith.constant 4 : i32
+ ! CHECK: %[[CST_I64:.*]] = fir.convert %[[CST]] : (i32) -> i64
+ ! CHECK: %[[ALLOC:.*]] = fir.call @_FortranAMalloc(%[[CST_I64]]) fastmath<contract> : (i64) -> i64
+ ! CHECK: hlfir.assign %[[ALLOC]] to %[[X_PTR_DECL]]#0 : i64, !fir.ref<i64>
+ ! CHECK: return
+ ptr_x = malloc(4)
+end subroutine
+
+! gfortran allows malloc to be assigned to integers, so we accept it.
+
+! CHECK-LABEL: func.func @_QPmalloc_i8() {
+subroutine malloc_i8()
+ integer(kind=1) :: x
+! CHECK: %[[X:.*]] = fir.alloca i8 {bindc_name = "x", uniq_name = "_QFmalloc_i8Ex"}
+! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFmalloc_i8Ex"} : (!fir.ref<i8>) -> (!fir.ref<i8>, !fir.ref<i8>)
+! CHECK: %[[CST:.*]] = arith.constant 1 : i32
+! CHECK: %[[CST_I64:.*]] = fir.convert %[[CST]] : (i32) -> i64
+! CHECK: %[[ALLOC:.*]] = fir.call @_FortranAMalloc(%[[CST_I64]]) fastmath<contract> : (i64) -> i64
+! CHECK: %[[ALLOC_I8:.*]] = fir.convert %[[ALLOC]] : (i64) -> i8
+! CHECK: hlfir.assign %[[ALLOC_I8]] to %[[X_DECL]]#0 : i8, !fir.ref<i8>
+! CHECK: return
+ x = malloc(1)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPmalloc_i16() {
+subroutine malloc_i16()
+ integer(kind=2) :: x
+! CHECK: %[[X:.*]] = fir.alloca i16 {bindc_name = "x", uniq_name = "_QFmalloc_i16Ex"}
+! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFmalloc_i16Ex"} : (!fir.ref<i16>) -> (!fir.ref<i16>, !fir.ref<i16>)
+! CHECK: %[[CST:.*]] = arith.constant 1 : i32
+! CHECK: %[[CST_I64:.*]] = fir.convert %[[CST]] : (i32) -> i64
+! CHECK: %[[ALLOC:.*]] = fir.call @_FortranAMalloc(%[[CST_I64]]) fastmath<contract> : (i64) -> i64
+! CHECK: %[[ALLOC_I16:.*]] = fir.convert %[[ALLOC]] : (i64) -> i16
+! CHECK: hlfir.assign %[[ALLOC_I16]] to %[[X_DECL]]#0 : i16, !fir.ref<i16>
+! CHECK: return
+ x = malloc(1)
+end subroutine
+
+
+! CHECK-LABEL: func.func @_QPmalloc_i32() {
+subroutine malloc_i32()
+ integer(kind=4) :: x
+! CHECK: %[[X:.*]] = fir.alloca i32 {bindc_name = "x", uniq_name = "_QFmalloc_i32Ex"}
+! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFmalloc_i32Ex"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[CST:.*]] = arith.constant 1 : i32
+! CHECK: %[[CST_I64:.*]] = fir.convert %[[CST]] : (i32) -> i64
+! CHECK: %[[ALLOC:.*]] = fir.call @_FortranAMalloc(%[[CST_I64]]) fastmath<contract> : (i64) -> i64
+! CHECK: %[[ALLOC_I32:.*]] = fir.convert %[[ALLOC]] : (i64) -> i32
+! CHECK: hlfir.assign %[[ALLOC_I32]] to %[[X_DECL]]#0 : i32, !fir.ref<i32>
+! CHECK: return
+ x = malloc(1)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPmalloc_i64() {
+subroutine malloc_i64()
+ integer(kind=8) :: x
+! CHECK: %[[X:.*]] = fir.alloca i64 {bindc_name = "x", uniq_name = "_QFmalloc_i64Ex"}
+! CHECK: %[[X_DECL:.*]]:2 = hlfir.declare %[[X]] {uniq_name = "_QFmalloc_i64Ex"} : (!fir.ref<i64>) -> (!fir.ref<i64>, !fir.ref<i64>)
+! CHECK: %[[CST:.*]] = arith.constant 1 : i32
+! CHECK: %[[CST_I64:.*]] = fir.convert %[[CST]] : (i32) -> i64
+! CHECK: %[[ALLOC:.*]] = fir.call @_FortranAMalloc(%[[CST_I64]]) fastmath<contract> : (i64) -> i64
+! CHECK: hlfir.assign %[[ALLOC]] to %[[X_DECL]]#0 : i64, !fir.ref<i64>
+! CHECK: return
+ x = malloc(1)
+end subroutine
diff --git a/flang/test/Semantics/free.f90 b/flang/test/Semantics/free.f90
new file mode 100644
index 00000000000000..6332f03b19cd89
--- /dev/null
+++ b/flang/test/Semantics/free.f90
@@ -0,0 +1,33 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+
+! Accept free of cray pointer without warning
+subroutine free_cptr()
+ integer :: x
+ pointer(ptr_x, x)
+ call free(ptr_x)
+end subroutine
+
+subroutine free_i8()
+ integer(kind=1) :: x
+ ! WARNING: FREE should only be used with Cray pointers
+ call free(x)
+end subroutine
+
+
+subroutine free_i16()
+ integer(kind=2) :: x
+ ! WARNING: FREE should only be used with Cray pointers
+ call free(x)
+end subroutine
+
+subroutine free_i32()
+ integer(kind=4) :: x
+ ! WARNING: FREE should only be used with Cray pointers
+ call free(x)
+end subroutine
+
+subroutine free_i64()
+ integer(kind=8) :: x
+ ! WARNING: FREE should only be used with Cray pointers
+ call free(x)
+end subroutine
More information about the flang-commits
mailing list