diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index a3888111430a0..c40bcb886bc7c 100644 --- a/flang/docs/Intrinsics.md +++ b/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, SLEEP, 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 | diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h index 275878a0b2ad1..04f6ab4a35bb0 100644 --- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h +++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h @@ -339,6 +339,7 @@ struct IntrinsicLibrary { fir::ExtendedValue genStorageSize(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef); + void genSignalSubroutine(llvm::ArrayRef); void genSleep(llvm::ArrayRef); void genSystemClock(llvm::ArrayRef); mlir::Value genTand(mlir::Type, llvm::ArrayRef); diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h index a92e03afa60d7..737c631e45c1f 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h @@ -20,6 +20,7 @@ namespace mlir { class Location; +class Type; class Value; } // namespace mlir @@ -65,9 +66,16 @@ void genTransferSize(fir::FirOpBuilder &builder, mlir::Location loc, 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 diff --git a/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h index 99558cf03d4ff..c9884ef7df8bb 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h @@ -137,6 +137,14 @@ constexpr TypeBuilderFunc getModel() { }; } template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return fir::LLVMPointerType::get( + context, + mlir::FunctionType::get(context, /*inputs=*/{}, /*results*/ {})); + }; +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return fir::ReferenceType::get( diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h index 515e9eb3e7b5e..7d0952206fc19 100644 --- a/flang/include/flang/Runtime/extensions.h +++ b/flang/include/flang/Runtime/extensions.h @@ -16,6 +16,7 @@ #define FORTRAN_PROCEDURE_NAME(name) name##_ +#include "flang/Runtime/entry-names.h" #include #include @@ -37,6 +38,9 @@ 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); diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 7d5c545b67eb5..fea8180bbf2f3 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1401,6 +1401,15 @@ 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}}, @@ -1422,9 +1431,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())}; diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 467ee7810c68a..273aee3733bfa 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -550,6 +550,10 @@ static constexpr IntrinsicHandler handlers[]{ {"shiftl", &I::genShift}, {"shiftr", &I::genShift}, {"sign", &I::genSign}, + {"signal", + &I::genSignalSubroutine, + {{{"number", asValue}, {"handler", asAddr}, {"status", asAddr}}}, + /*isElemental=*/false}, {"size", &I::genSize, {{{"array", asBox}, @@ -5579,6 +5583,18 @@ mlir::Value IntrinsicLibrary::genShiftA(mlir::Type resultType, shifted); } +// SIGNAL +void IntrinsicLibrary::genSignalSubroutine( + llvm::ArrayRef 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 args) { diff --git a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp index 9058ff6325b12..638bfd60a246a 100644 --- a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp +++ b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp @@ -21,6 +21,7 @@ #include "flang/Semantics/tools.h" #include "llvm/Support/Debug.h" #include +#include #define DEBUG_TYPE "flang-lower-runtime" @@ -237,6 +238,50 @@ void fir::runtime::genSystemClock(fir::FirOpBuilder &builder, makeCall(getRuntimeFunc(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(number.getType())); + mlir::Type int64 = builder.getIntegerType(64); + number = builder.create(loc, int64, number); + + mlir::Type handlerUnwrappedTy = fir::unwrapRefType(handler.getType()); + if (mlir::isa_and_nonnull(handlerUnwrappedTy)) { + // pass the integer as a function pointer like one would to signal(2) + handler = builder.create(loc, handler); + mlir::Type fnPtrTy = fir::LLVMPointerType::get( + mlir::FunctionType::get(handler.getContext(), {}, {})); + handler = builder.create(loc, fnPtrTy, handler); + } else { + assert(mlir::isa(handler.getType())); + handler = builder.create(loc, handler); + } + + mlir::func::FuncOp func{ + fir::runtime::getRuntimeFunc(loc, builder)}; + mlir::Value stat = + builder.create(loc, func, mlir::ValueRange{number, handler}) + ->getResult(0); + + // return status code via status argument (if present) + if (status) { + assert(mlir::isa(fir::unwrapRefType(status.getType()))); + // status might be dynamically optional, so test if it is present + mlir::Value isPresent = + builder.create(loc, builder.getI1Type(), status); + builder.genIfOp(loc, /*results=*/{}, isPresent, /*withElseRegion=*/false) + .genThen([&]() { + stat = builder.create( + loc, fir::unwrapRefType(status.getType()), stat); + builder.create(loc, stat, status); + }) + .end(); + } +} + void fir::runtime::genSleep(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value seconds) { mlir::Type int64 = builder.getIntegerType(64); @@ -244,4 +289,4 @@ void fir::runtime::genSleep(fir::FirOpBuilder &builder, mlir::Location loc, mlir::func::FuncOp func{ fir::runtime::getRuntimeFunc(loc, builder)}; builder.create(loc, func, seconds); -} \ No newline at end of file +} diff --git a/flang/runtime/extensions.cpp b/flang/runtime/extensions.cpp index 6170937f839a6..3ac98000335d7 100644 --- a/flang/runtime/extensions.cpp +++ b/flang/runtime/extensions.cpp @@ -18,6 +18,7 @@ #include "flang/Runtime/io-api.h" #include #include +#include #include #ifdef _WIN32 @@ -116,6 +117,17 @@ 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(reinterpret_cast(result)); +} + // CALL SLEEP(SECONDS) void RTNAME(Sleep)(std::int64_t seconds) { // ensure that conversion to unsigned makes sense, diff --git a/flang/test/Lower/Intrinsics/signal.f90 b/flang/test/Lower/Intrinsics/signal.f90 new file mode 100644 index 0000000000000..d6678000677e1 --- /dev/null +++ b/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 {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, uniq_name = "_QMmFsetup_signalsEoptional_status"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_14:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QMmFsetup_signalsEstat"} : (!fir.ref) -> (!fir.ref, !fir.ref) + + 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 : (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 : (i64, () -> ()) -> i64 +! CHECK: %[[VAL_27:.*]] = fir.is_present %[[VAL_14]]#1 : (!fir.ref) -> 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 +! 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 +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_29]] : (i32) -> i64 +! CHECK: %[[VAL_32:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_32]] : (i32) -> !fir.llvm_ptr<() -> ()> +! CHECK: %[[VAL_34:.*]] = fir.call @_FortranASignal(%[[VAL_31]], %[[VAL_33]]) fastmath : (i64, !fir.llvm_ptr<() -> ()>) -> i64 +! CHECK: %[[VAL_35:.*]] = fir.is_present %[[VAL_14]]#1 : (!fir.ref) -> 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 +! 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 : (i64, () -> ()) -> i64 +! CHECK: %[[VAL_43:.*]] = fir.is_present %[[VAL_2]]#1 : (!fir.ref) -> 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 +! CHECK: } + end subroutine +end module