[flang] Support FLUSH as an intrinsic subroutine (llvm#165942)

Previously `FLUSH` was only recognized in statement form (e.g.
`flush(unit)`); a
subroutine invocation `call flush(unit)` was treated as a generic user
call with
no special semantics. This change teaches lowering/semantics to handle
`CALL FLUSH` equivalently.

Fixes llvm#119418

Author: Saldivarcher

flang-rt/lib/runtime/extensions.cpp

@@ -163,6 +163,17 @@ void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {
   Cookie cookie{IONAME(BeginFlush)(unit, __FILE__, __LINE__)};
   IONAME(EndIoStatement)(cookie);
 }
+
+void RTNAME(Flush)(int unit) {
+  // We set the `unit == -1` on the `flush()` case, so flush all units.
+  if (unit < 0) {
+    Terminator terminator{__FILE__, __LINE__};
+    IoErrorHandler handler{terminator};
+    ExternalFileUnit::FlushAll(handler);
+    return;
+  }
+  FORTRAN_PROCEDURE_NAME(flush)(unit);
+}
 } // namespace io
 
 // CALL FDATE(DATE)

flang/docs/Intrinsics.md

@@ -1288,6 +1288,40 @@ program chdir_func
 end program chdir_func
 ```
 
+### Non-Standard Intrinsics: FLUSH
+
+#### Description
+`FLUSH(UNIT)` causes all pending I/O operations for the file connected to the
+specified unit to be completed. If `UNIT` is omitted, all units are flushed.
+
+#### Arguments
+
+|            |                                                                                                   |
+|------------|---------------------------------------------------------------------------------------------------|
+| `UNIT`     | (Optional) The unit number of an open file. If omitted, all open units are flushed. The type shall be `INTEGER`. |
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** Subroutine
+- **Syntax:** `CALL FLUSH([UNIT])`
+
+#### Example
+```Fortran
+program demo_flush
+  integer :: unit
+
+  ! Flush all units
+  call flush()
+
+  ! Flush specific unit
+  open(unit=10, file='output.dat')
+  write(10, *) 'Data'
+  call flush(10)
+  close(10)
+end program demo_flush
+```
+
 ### Non-Standard Intrinsics: FSEEK and FTELL
 
 #### Description

flang/include/flang/Optimizer/Builder/IntrinsicCall.h

@@ -254,6 +254,7 @@ struct IntrinsicLibrary {
   template <Extremum, ExtremumBehavior>
   mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
+  void genFlush(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genFraction(mlir::Type resultType,
                           mlir::ArrayRef<mlir::Value> args);
   void genFree(mlir::ArrayRef<fir::ExtendedValue> args);

flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h

@@ -51,6 +51,8 @@ mlir::Value genDsecnds(fir::FirOpBuilder &builder, mlir::Location loc,
 void genEtime(fir::FirOpBuilder &builder, mlir::Location loc,
               mlir::Value values, mlir::Value time);
 
+void genFlush(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value unit);
+
 void genFree(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value ptr);
 
 mlir::Value genFseek(fir::FirOpBuilder &builder, mlir::Location loc,

flang/include/flang/Runtime/extensions.h

@@ -34,6 +34,7 @@ double RTNAME(Dsecnds)(double *refTime, const char *sourceFile, int line);
 
 // CALL FLUSH(n) antedates the Fortran 2003 FLUSH statement.
 void FORTRAN_PROCEDURE_NAME(flush)(const int &unit);
+void RTNAME(Flush)(int unit);
 
 // GNU extension subroutine FDATE
 void FORTRAN_PROCEDURE_NAME(fdate)(char *string, std::int64_t length);

flang/lib/Evaluate/intrinsics.cpp

@@ -1597,6 +1597,10 @@ static const IntrinsicInterface intrinsicSubroutine[]{
     {"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {},
         Rank::elemental, IntrinsicClass::impureSubroutine},
     {"free", {{"ptr", Addressable}}, {}},
+    {"flush",
+        {{"unit", AnyInt, Rank::scalar, Optionality::optional,
+            common::Intent::In}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"fseek",
         {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar},
             {"whence", AnyInt, Rank::scalar},

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -91,6 +91,11 @@ static bool isStaticallyAbsent(llvm::ArrayRef<mlir::Value> args,
                                size_t argIndex) {
   return args.size() <= argIndex || !args[argIndex];
 }
+static bool isOptional(mlir::Value value) {
+  auto varIface = mlir::dyn_cast_or_null<fir::FortranVariableOpInterface>(
+      value.getDefiningOp());
+  return varIface && varIface.isOptional();
+}
 
 /// Test if an ExtendedValue is present. This is used to test if an intrinsic
 /// argument is present at compile time. This does not imply that the related
@@ -303,6 +308,10 @@ static constexpr IntrinsicHandler handlers[]{
        {"back", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
     {"floor", &I::genFloor},
+    {"flush",
+     &I::genFlush,
+     {{{"unit", asAddr}}},
+     /*isElemental=*/false},
     {"fraction", &I::genFraction},
     {"free", &I::genFree},
     {"fseek",
@@ -3942,6 +3951,40 @@ mlir::Value IntrinsicLibrary::genFloor(mlir::Type resultType,
   return builder.createConvert(loc, resultType, floor);
 }
 
+// FLUSH
+void IntrinsicLibrary::genFlush(llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+
+  mlir::Value unit;
+  if (isStaticallyAbsent(args[0]))
+    // Give a sentinal value of `-1` on the `()` case.
+    unit = builder.createIntegerConstant(loc, builder.getI32Type(), -1);
+  else {
+    unit = fir::getBase(args[0]);
+    if (isOptional(unit)) {
+      mlir::Value isPresent =
+          fir::IsPresentOp::create(builder, loc, builder.getI1Type(), unit);
+      unit = builder
+                 .genIfOp(loc, builder.getI32Type(), isPresent,
+                          /*withElseRegion=*/true)
+                 .genThen([&]() {
+                   mlir::Value loaded = fir::LoadOp::create(builder, loc, unit);
+                   fir::ResultOp::create(builder, loc, loaded);
+                 })
+                 .genElse([&]() {
+                   mlir::Value negOne = builder.createIntegerConstant(
+                       loc, builder.getI32Type(), -1);
+                   fir::ResultOp::create(builder, loc, negOne);
+                 })
+                 .getResults()[0];
+    } else {
+      unit = fir::LoadOp::create(builder, loc, unit);
+    }
+  }
+
+  fir::runtime::genFlush(builder, loc, unit);
+}
+
 // FRACTION
 mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
                                           llvm::ArrayRef<mlir::Value> args) {
@@ -6298,12 +6341,6 @@ IntrinsicLibrary::genCharacterCompare(mlir::Type resultType,
       fir::getBase(args[1]), fir::getLen(args[1]));
 }
 
-static bool isOptional(mlir::Value value) {
-  auto varIface = mlir::dyn_cast_or_null<fir::FortranVariableOpInterface>(
-      value.getDefiningOp());
-  return varIface && varIface.isOptional();
-}
-
 // LOC
 fir::ExtendedValue
 IntrinsicLibrary::genLoc(mlir::Type resultType,

flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp

@@ -137,6 +137,15 @@ void fir::runtime::genEtime(fir::FirOpBuilder &builder, mlir::Location loc,
   fir::CallOp::create(builder, loc, runtimeFunc, args);
 }
 
+void fir::runtime::genFlush(fir::FirOpBuilder &builder, mlir::Location loc,
+                            mlir::Value unit) {
+  auto runtimeFunc = fir::runtime::getRuntimeFunc<mkRTKey(Flush)>(loc, builder);
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, runtimeFunc.getFunctionType(), unit);
+
+  fir::CallOp::create(builder, 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);

flang/test/Lower/Intrinsics/flush.f90

@@ -0,0 +1,41 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+!
+! Test lowering of intrinsic subroutine FLUSH with and without optional UNIT argument.
+!
+! CHECK-LABEL: func.func @_QPflush_all()
+! CHECK: %[[UNIT:.*]] = arith.constant -1 : i32
+! CHECK: fir.call @_FortranAFlush(%[[UNIT]]) fastmath<contract> : (i32) -> ()
+! CHECK: return
+subroutine flush_all()
+  call flush() ! flush all units
+end subroutine
+
+! CHECK-LABEL: func.func @_QPflush_unit()
+! CHECK: %[[ALLOCA:.*]] = fir.alloca i32
+! CHECK: %[[UNITC:.*]] = arith.constant 10 : i32
+! CHECK: fir.store %[[UNITC]] to %[[ALLOCA]] : !fir.ref<i32>
+! CHECK: %[[LOADED:.*]] = fir.load %[[ALLOCA]] : !fir.ref<i32>
+! CHECK: fir.call @_FortranAFlush(%[[LOADED]]) fastmath<contract> : (i32) -> ()
+! CHECK: return
+subroutine flush_unit()
+  call flush(10) ! flush specific unit
+end subroutine
+
+! CHECK-LABEL: func.func @_QPflush_optional(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<i32> {fir.bindc_name = "unit", fir.optional}) {
+! CHECK: %[[DECL:.*]]:2 = hlfir.declare %[[ARG0]] dummy_scope %{{.*}} {fortran_attrs = #fir.var_attrs<optional>, uniq_name = "_QFflush_optionalEunit"} : (!fir.ref<i32>, !fir.dscope) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[IS_PRESENT:.*]] = fir.is_present %[[DECL]]#0 : (!fir.ref<i32>) -> i1
+! CHECK: %[[UNIT:.*]] = fir.if %[[IS_PRESENT]] -> (i32) {
+! CHECK:   %[[LOADED:.*]] = fir.load %[[DECL]]#0 : !fir.ref<i32>
+! CHECK:   fir.result %[[LOADED]] : i32
+! CHECK: } else {
+! CHECK:   %[[DEFAULT:.*]] = arith.constant -1 : i32
+! CHECK:   fir.result %[[DEFAULT]] : i32
+! CHECK: }
+! CHECK: fir.call @_FortranAFlush(%[[UNIT]]) fastmath<contract> : (i32) -> ()
+! CHECK: return
+subroutine flush_optional(unit)
+  integer, optional :: unit
+  call flush(unit) ! flush with dynamically optional argument
+end subroutine