[flang] Add MALLOC and FREE intrinsics for Cray pointers (#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.

Author: DavidTruby

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 |

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>);

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);

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));
 

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},

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,

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) {

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());
   }
 }
 

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 *

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