[flang][Runtime] Add SIGNAL intrinisic

flang/docs/Intrinsics.md

@@ -757,7 +757,7 @@ This phase currently supports all the intrinsic procedures listed above but the
 | 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 |
-| 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, SYSTEM_CLOCK |
+| 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_CLOCK |
 | Atomic intrinsic subroutines | ATOMIC_ADD |
 | Collective intrinsic subroutines | CO_REDUCE |
 | Library subroutines | FDATE, GETLOG |
@@ -908,4 +908,3 @@ used in constant expressions have currently no folding support at all.
   - If a condition occurs that would assign a nonzero value to `CMDSTAT` but the `CMDSTAT` variable is not present, error termination is initiated.
     - On POSIX-compatible systems, the child process (async process) will be terminated with no effect on the parent process (continues).
     - On Windows, error termination is not initiated.
-

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

@@ -339,6 +339,8 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genStorageSize(mlir::Type,
                                     llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  void genSignalSubroutine(llvm::ArrayRef<fir::ExtendedValue>);
+  void genSleep(llvm::ArrayRef<fir::ExtendedValue>);
   void genSystemClock(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genTand(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genTrailz(mlir::Type, llvm::ArrayRef<mlir::Value>);

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

@@ -20,6 +20,7 @@
 
 namespace mlir {
 class Location;
+class Type;
 class Value;
 } // namespace mlir
 
@@ -64,6 +65,17 @@ void genTransferSize(fir::FirOpBuilder &builder, mlir::Location loc,
 /// all intrinsic arguments are optional and may appear here as mlir::Value{}
 void genSystemClock(fir::FirOpBuilder &, mlir::Location, mlir::Value count,
                     mlir::Value rate, mlir::Value max);
+
+// generate signal runtime call
+// CALL SIGNAL(NUMBER, HANDLER [, STATUS])
+// status can be {} or a value. It may also be dynamically absent
+void genSignal(fir::FirOpBuilder &builder, mlir::Location loc,
+               mlir::Value number, mlir::Value handler, mlir::Value status);
+
+/// generate sleep runtime call
+void genSleep(fir::FirOpBuilder &builder, mlir::Location loc,
+              mlir::Value seconds);
+
 } // namespace runtime
 } // namespace fir
 

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

@@ -137,6 +137,14 @@ constexpr TypeBuilderFunc getModel<void *>() {
   };
 }
 template <>
+constexpr TypeBuilderFunc getModel<void (*)(int)>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::LLVMPointerType::get(
+        context,
+        mlir::FunctionType::get(context, /*inputs=*/{}, /*results*/ {}));
+  };
+}
+template <>
 constexpr TypeBuilderFunc getModel<void **>() {
   return [](mlir::MLIRContext *context) -> mlir::Type {
     return fir::ReferenceType::get(

flang/include/flang/Runtime/extensions.h

@@ -12,8 +12,11 @@
 #ifndef FORTRAN_RUNTIME_EXTENSIONS_H_
 #define FORTRAN_RUNTIME_EXTENSIONS_H_
 
+#include "flang/Runtime/entry-names.h"
+
 #define FORTRAN_PROCEDURE_NAME(name) name##_
 
+#include "flang/Runtime/entry-names.h"
 #include <cstddef>
 #include <cstdint>
 
@@ -35,5 +38,11 @@ void FORTRAN_PROCEDURE_NAME(getarg)(
 // GNU extension subroutine GETLOG(C).
 void FORTRAN_PROCEDURE_NAME(getlog)(char *name, std::int64_t length);
 
+// GNU extension function STATUS = SIGNAL(number, handler)
+std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int));
+
+// GNU extension subroutine SLEEP(SECONDS)
+void RTNAME(Sleep)(std::int64_t seconds);
+
 } // extern "C"
 #endif // FORTRAN_RUNTIME_EXTENSIONS_H_

flang/lib/Evaluate/intrinsics.cpp

@@ -1395,6 +1395,19 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"count_max", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"signal",
+        {{"number", AnyInt, Rank::scalar, Optionality::required,
+             common::Intent::In},
+            // note: any pointer also accepts AnyInt
+            {"handler", AnyPointer, Rank::scalar, Optionality::required,
+                common::Intent::In},
+            {"status", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"sleep",
+        {{"seconds", AnyInt, Rank::scalar, Optionality::required,
+            common::Intent::In}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
 };
 
 // TODO: Intrinsic subroutine EVENT_QUERY
@@ -1412,9 +1425,12 @@ static DynamicType GetBuiltinDerivedType(
   auto iter{
       builtinsScope->find(semantics::SourceName{which, std::strlen(which)})};
   if (iter == builtinsScope->cend()) {
+    // keep the string all together
+    // clang-format off
     common::die(
         "INTERNAL: The __fortran_builtins module does not define the type '%s'",
         which);
+    // clang-format on
   }
   const semantics::Symbol &symbol{*iter->second};
   const semantics::Scope &scope{DEREF(symbol.scope())};

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -550,12 +550,17 @@ static constexpr IntrinsicHandler handlers[]{
     {"shiftl", &I::genShift<mlir::arith::ShLIOp>},
     {"shiftr", &I::genShift<mlir::arith::ShRUIOp>},
     {"sign", &I::genSign},
+    {"signal",
+     &I::genSignalSubroutine,
+     {{{"number", asValue}, {"handler", asAddr}, {"status", asAddr}}},
+     /*isElemental=*/false},
     {"size",
      &I::genSize,
      {{{"array", asBox},
        {"dim", asAddr, handleDynamicOptional},
        {"kind", asValue}}},
      /*isElemental=*/false},
+    {"sleep", &I::genSleep, {{{"seconds", asValue}}}, /*isElemental=*/false},
     {"spacing", &I::genSpacing},
     {"spread",
      &I::genSpread,
@@ -5578,6 +5583,18 @@ mlir::Value IntrinsicLibrary::genShiftA(mlir::Type resultType,
                                                shifted);
 }
 
+// SIGNAL
+void IntrinsicLibrary::genSignalSubroutine(
+    llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 2 || args.size() == 3);
+  mlir::Value number = fir::getBase(args[0]);
+  mlir::Value handler = fir::getBase(args[1]);
+  mlir::Value status;
+  if (args.size() == 3)
+    status = fir::getBase(args[2]);
+  fir::runtime::genSignal(builder, loc, number, handler, status);
+}
+
 // SIGN
 mlir::Value IntrinsicLibrary::genSign(mlir::Type resultType,
                                       llvm::ArrayRef<mlir::Value> args) {
@@ -5924,6 +5941,12 @@ void IntrinsicLibrary::genSystemClock(llvm::ArrayRef<fir::ExtendedValue> args) {
                                fir::getBase(args[1]), fir::getBase(args[2]));
 }
 
+// SLEEP
+void IntrinsicLibrary::genSleep(llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1 && "SLEEP has one compulsory argument");
+  fir::runtime::genSleep(builder, loc, fir::getBase(args[0]));
+}
+
 // TRANSFER
 fir::ExtendedValue
 IntrinsicLibrary::genTransfer(mlir::Type resultType,

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

@@ -12,6 +12,7 @@
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Parser/parse-tree.h"
+#include "flang/Runtime/extensions.h"
 #include "flang/Runtime/misc-intrinsic.h"
 #include "flang/Runtime/pointer.h"
 #include "flang/Runtime/random.h"
@@ -20,6 +21,7 @@
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/Debug.h"
 #include <optional>
+#include <signal.h>
 
 #define DEBUG_TYPE "flang-lower-runtime"
 
@@ -235,3 +237,56 @@ void fir::runtime::genSystemClock(fir::FirOpBuilder &builder,
   if (max)
     makeCall(getRuntimeFunc<mkRTKey(SystemClockCountMax)>(loc, builder), max);
 }
+
+// CALL SIGNAL(NUMBER, HANDLER [, STATUS])
+// The definition of the SIGNAL intrinsic allows HANDLER to be a function
+// pointer or an integer. STATUS can be dynamically optional
+void fir::runtime::genSignal(fir::FirOpBuilder &builder, mlir::Location loc,
+                             mlir::Value number, mlir::Value handler,
+                             mlir::Value status) {
+  assert(mlir::isa<mlir::IntegerType>(number.getType()));
+  mlir::Type int64 = builder.getIntegerType(64);
+  number = builder.create<fir::ConvertOp>(loc, int64, number);
+
+  mlir::Type handlerUnwrappedTy = fir::unwrapRefType(handler.getType());
+  if (mlir::isa_and_nonnull<mlir::IntegerType>(handlerUnwrappedTy)) {
+    // pass the integer as a function pointer like one would to signal(2)
+    handler = builder.create<fir::LoadOp>(loc, handler);
+    mlir::Type fnPtrTy = fir::LLVMPointerType::get(
+        mlir::FunctionType::get(handler.getContext(), {}, {}));
+    handler = builder.create<fir::ConvertOp>(loc, fnPtrTy, handler);
+  } else {
+    assert(mlir::isa<fir::BoxProcType>(handler.getType()));
+    handler = builder.create<fir::BoxAddrOp>(loc, handler);
+  }
+
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(Signal)>(loc, builder)};
+  mlir::Value stat =
+      builder.create<fir::CallOp>(loc, func, mlir::ValueRange{number, handler})
+          ->getResult(0);
+
+  // return status code via status argument (if present)
+  if (status) {
+    assert(mlir::isa<mlir::IntegerType>(fir::unwrapRefType(status.getType())));
+    // status might be dynamically optional, so test if it is present
+    mlir::Value isPresent =
+        builder.create<IsPresentOp>(loc, builder.getI1Type(), status);
+    builder.genIfOp(loc, /*results=*/{}, isPresent, /*withElseRegion=*/false)
+        .genThen([&]() {
+          stat = builder.create<fir::ConvertOp>(
+              loc, fir::unwrapRefType(status.getType()), stat);
+          builder.create<fir::StoreOp>(loc, stat, status);
+        })
+        .end();
+  }
+}
+
+void fir::runtime::genSleep(fir::FirOpBuilder &builder, mlir::Location loc,
+                            mlir::Value seconds) {
+  mlir::Type int64 = builder.getIntegerType(64);
+  seconds = builder.create<fir::ConvertOp>(loc, int64, seconds);
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(Sleep)>(loc, builder)};
+  builder.create<fir::CallOp>(loc, func, seconds);
+}

flang/runtime/extensions.cpp

@@ -14,8 +14,12 @@
 #include "tools.h"
 #include "flang/Runtime/command.h"
 #include "flang/Runtime/descriptor.h"
+#include "flang/Runtime/entry-names.h"
 #include "flang/Runtime/io-api.h"
+#include <chrono>
 #include <ctime>
+#include <signal.h>
+#include <thread>
 
 #ifdef _WIN32
 inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
@@ -113,5 +117,26 @@ void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {
 #endif
 }
 
+std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {
+  // using auto for portability:
+  // on Windows, this is a void *
+  // on POSIX, this has the same type as handler
+  auto result = signal(number, handler);
+
+  // GNU defines the intrinsic as returning an integer, not a pointer. So we
+  // have to reinterpret_cast
+  return static_cast<int64_t>(reinterpret_cast<std::uintptr_t>(result));
+}
+
+// CALL SLEEP(SECONDS)
+void RTNAME(Sleep)(std::int64_t seconds) {
+  // ensure that conversion to unsigned makes sense,
+  // sleep(0) is an immidiate return anyway
+  if (seconds < 1) {
+    return;
+  }
+  std::this_thread::sleep_for(std::chrono::seconds(seconds));
+}
+
 } // namespace Fortran::runtime
 } // extern "C"

flang/test/Lower/Intrinsics/signal.f90

@@ -0,0 +1,77 @@
+! test lowering of the SIGNAL intrinsic subroutine
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+module m
+contains
+! CHECK-LABEL:   func.func @handler(
+! CHECK-SAME:                       %[[VAL_0:.*]]: i32 {fir.bindc_name = "signum"}) attributes {fir.bindc_name = "handler"} {
+  subroutine handler(signum) bind(C)
+    use iso_c_binding, only: c_int
+    integer(c_int), value :: signum
+  end subroutine
+
+! CHECK-LABEL:   func.func @_QMmPsetup_signals(
+! CHECK-SAME:                                  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "optional_status", fir.optional}) {
+  subroutine setup_signals(optional_status)
+    ! not portable accross systems
+    integer, parameter :: SIGFPE = 8
+    integer, parameter :: SIGUSR1 = 10
+    integer, parameter :: SIGUSR2 = 12
+    integer, parameter :: SIGPIPE = 13
+    integer, parameter :: SIG_IGN = 1
+    integer :: stat = 0
+    integer, optional, intent(out) :: optional_status
+
+! CHECK:           %[[VAL_1:.*]] = fir.alloca i32
+! CHECK:           %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<intent_out, optional>, uniq_name = "_QMmFsetup_signalsEoptional_status"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:           %[[VAL_14:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QMmFsetup_signalsEstat"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+
+    call signal(SIGFPE, handler)
+! CHECK:           %[[VAL_15:.*]] = arith.constant 8 : i32
+! CHECK:           %[[VAL_16:.*]] = fir.address_of(@handler) : (i32) -> ()
+! CHECK:           %[[VAL_17:.*]] = fir.emboxproc %[[VAL_16]] : ((i32) -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:           %[[VAL_18:.*]] = fir.convert %[[VAL_15]] : (i32) -> i64
+! CHECK:           %[[VAL_19:.*]] = fir.box_addr %[[VAL_17]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:           %[[VAL_20:.*]] = fir.call @_FortranASignal(%[[VAL_18]], %[[VAL_19]]) fastmath<contract> : (i64, () -> ()) -> i64
+
+    call signal(SIGUSR1, handler, stat)
+! CHECK:           %[[VAL_21:.*]] = arith.constant 10 : i32
+! CHECK:           %[[VAL_22:.*]] = fir.address_of(@handler) : (i32) -> ()
+! CHECK:           %[[VAL_23:.*]] = fir.emboxproc %[[VAL_22]] : ((i32) -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:           %[[VAL_24:.*]] = fir.convert %[[VAL_21]] : (i32) -> i64
+! CHECK:           %[[VAL_25:.*]] = fir.box_addr %[[VAL_23]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:           %[[VAL_26:.*]] = fir.call @_FortranASignal(%[[VAL_24]], %[[VAL_25]]) fastmath<contract> : (i64, () -> ()) -> i64
+! CHECK:           %[[VAL_27:.*]] = fir.is_present %[[VAL_14]]#1 : (!fir.ref<i32>) -> i1
+! CHECK:           fir.if %[[VAL_27]] {
+! CHECK:             %[[VAL_28:.*]] = fir.convert %[[VAL_26]] : (i64) -> i32
+! CHECK:             fir.store %[[VAL_28]] to %[[VAL_14]]#1 : !fir.ref<i32>
+! CHECK:           }
+
+    call signal(SIGUSR2, SIG_IGN, stat)
+! CHECK:           %[[VAL_29:.*]] = arith.constant 12 : i32
+! CHECK:           %[[VAL_30:.*]] = arith.constant 1 : i32
+! CHECK:           fir.store %[[VAL_30]] to %[[VAL_1]] : !fir.ref<i32>
+! CHECK:           %[[VAL_31:.*]] = fir.convert %[[VAL_29]] : (i32) -> i64
+! CHECK:           %[[VAL_32:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:           %[[VAL_33:.*]] = fir.convert %[[VAL_32]] : (i32) -> !fir.llvm_ptr<() -> ()>
+! CHECK:           %[[VAL_34:.*]] = fir.call @_FortranASignal(%[[VAL_31]], %[[VAL_33]]) fastmath<contract> : (i64, !fir.llvm_ptr<() -> ()>) -> i64
+! CHECK:           %[[VAL_35:.*]] = fir.is_present %[[VAL_14]]#1 : (!fir.ref<i32>) -> i1
+! CHECK:           fir.if %[[VAL_35]] {
+! CHECK:             %[[VAL_36:.*]] = fir.convert %[[VAL_34]] : (i64) -> i32
+! CHECK:             fir.store %[[VAL_36]] to %[[VAL_14]]#1 : !fir.ref<i32>
+! CHECK:           }
+
+    call signal(SIGPIPE, handler, optional_status)
+! CHECK:           %[[VAL_37:.*]] = arith.constant 13 : i32
+! CHECK:           %[[VAL_38:.*]] = fir.address_of(@handler) : (i32) -> ()
+! CHECK:           %[[VAL_39:.*]] = fir.emboxproc %[[VAL_38]] : ((i32) -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:           %[[VAL_40:.*]] = fir.convert %[[VAL_37]] : (i32) -> i64
+! CHECK:           %[[VAL_41:.*]] = fir.box_addr %[[VAL_39]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:           %[[VAL_42:.*]] = fir.call @_FortranASignal(%[[VAL_40]], %[[VAL_41]]) fastmath<contract> : (i64, () -> ()) -> i64
+! CHECK:           %[[VAL_43:.*]] = fir.is_present %[[VAL_2]]#1 : (!fir.ref<i32>) -> i1
+! CHECK:           fir.if %[[VAL_43]] {
+! CHECK:             %[[VAL_44:.*]] = fir.convert %[[VAL_42]] : (i64) -> i32
+! CHECK:             fir.store %[[VAL_44]] to %[[VAL_2]]#1 : !fir.ref<i32>
+! CHECK:           }
+  end subroutine
+end module

flang/test/Lower/Intrinsics/sleep.f90

@@ -0,0 +1,27 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+
+subroutine test_sleep()
+! CHECK-LABEL:   func.func @_QPtest_sleep() {
+
+  call sleep(1_2)
+! CHECK:           %[[VAL_0:.*]] = arith.constant 1 : i16
+! CHECK:           %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (i16) -> i64
+! CHECK:           %[[VAL_2:.*]] = fir.call @_FortranASleep(%[[VAL_1]]) fastmath<contract> : (i64) -> none
+
+  call sleep(1_4)
+! CHECK:           %[[VAL_3:.*]] = arith.constant 1 : i32
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> i64
+! CHECK:           %[[VAL_5:.*]] = fir.call @_FortranASleep(%[[VAL_4]]) fastmath<contract> : (i64) -> none
+
+  call sleep(1_8)
+! CHECK:           %[[VAL_6:.*]] = arith.constant 1 : i64
+! CHECK:           %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> i64
+! CHECK:           %[[VAL_8:.*]] = fir.call @_FortranASleep(%[[VAL_7]]) fastmath<contract> : (i64) -> none
+
+  call sleep(1_16)
+! CHECK:           %[[VAL_9:.*]] = arith.constant 1 : i128
+! CHECK:           %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i128) -> i64
+! CHECK:           %[[VAL_11:.*]] = fir.call @_FortranASleep(%[[VAL_10]]) fastmath<contract> : (i64) -> none
+end
+! CHECK:           return
+! CHECK:         }