aboutsummaryrefslogtreecommitdiff
path: root/flang-rt/lib
diff options
context:
space:
mode:
Diffstat (limited to 'flang-rt/lib')
-rw-r--r--flang-rt/lib/cuda/allocator.cpp11
-rw-r--r--flang-rt/lib/runtime/descriptor.cpp157
-rw-r--r--flang-rt/lib/runtime/edit-output.cpp7
-rw-r--r--flang-rt/lib/runtime/environment.cpp20
-rw-r--r--flang-rt/lib/runtime/extensions.cpp77
-rw-r--r--flang-rt/lib/runtime/io-stmt.cpp28
-rw-r--r--flang-rt/lib/runtime/iostat.cpp2
-rw-r--r--flang-rt/lib/runtime/type-code.cpp2
-rw-r--r--flang-rt/lib/runtime/unit.cpp7
9 files changed, 283 insertions, 28 deletions
diff --git a/flang-rt/lib/cuda/allocator.cpp b/flang-rt/lib/cuda/allocator.cpp
index 5436051..dc3ce0ee 100644
--- a/flang-rt/lib/cuda/allocator.cpp
+++ b/flang-rt/lib/cuda/allocator.cpp
@@ -19,8 +19,6 @@
#include "flang/Runtime/CUDA/common.h"
#include "flang/Support/Fortran.h"
-#include "cuda_runtime.h"
-
namespace Fortran::runtime::cuda {
struct DeviceAllocation {
@@ -133,6 +131,15 @@ void RTDEF(CUFRegisterAllocator)() {
allocatorRegistry.Register(
kUnifiedAllocatorPos, {&CUFAllocUnified, CUFFreeUnified});
}
+
+cudaStream_t RTDECL(CUFGetAssociatedStream)(void *p) {
+ int pos = findAllocation(p);
+ if (pos >= 0) {
+ cudaStream_t stream = deviceAllocations[pos].stream;
+ return stream;
+ }
+ return nullptr;
+}
}
void *CUFAllocPinned(
diff --git a/flang-rt/lib/runtime/descriptor.cpp b/flang-rt/lib/runtime/descriptor.cpp
index 5ede5f9..75bea97 100644
--- a/flang-rt/lib/runtime/descriptor.cpp
+++ b/flang-rt/lib/runtime/descriptor.cpp
@@ -292,14 +292,161 @@ RT_API_ATTRS void Descriptor::Check() const {
// TODO
}
-void Descriptor::Dump(FILE *f) const {
+static const char *GetTypeStr(ISO::CFI_type_t type, bool dumpRawType) {
+ if (dumpRawType) {
+#define CASE(x) \
+ case (x): \
+ return #x;
+ switch (type) {
+ CASE(CFI_type_signed_char)
+ CASE(CFI_type_short)
+ CASE(CFI_type_int)
+ CASE(CFI_type_long)
+ CASE(CFI_type_long_long)
+ CASE(CFI_type_size_t)
+ CASE(CFI_type_int8_t)
+ CASE(CFI_type_int16_t)
+ CASE(CFI_type_int32_t)
+ CASE(CFI_type_int64_t)
+ CASE(CFI_type_int128_t)
+ CASE(CFI_type_int_least8_t)
+ CASE(CFI_type_int_least16_t)
+ CASE(CFI_type_int_least32_t)
+ CASE(CFI_type_int_least64_t)
+ CASE(CFI_type_int_least128_t)
+ CASE(CFI_type_int_fast8_t)
+ CASE(CFI_type_int_fast16_t)
+ CASE(CFI_type_int_fast32_t)
+ CASE(CFI_type_int_fast64_t)
+ CASE(CFI_type_int_fast128_t)
+ CASE(CFI_type_intmax_t)
+ CASE(CFI_type_intptr_t)
+ CASE(CFI_type_ptrdiff_t)
+ CASE(CFI_type_half_float)
+ CASE(CFI_type_bfloat)
+ CASE(CFI_type_float)
+ CASE(CFI_type_double)
+ CASE(CFI_type_extended_double)
+ CASE(CFI_type_long_double)
+ CASE(CFI_type_float128)
+ CASE(CFI_type_half_float_Complex)
+ CASE(CFI_type_bfloat_Complex)
+ CASE(CFI_type_float_Complex)
+ CASE(CFI_type_double_Complex)
+ CASE(CFI_type_extended_double_Complex)
+ CASE(CFI_type_long_double_Complex)
+ CASE(CFI_type_float128_Complex)
+ CASE(CFI_type_Bool)
+ CASE(CFI_type_char)
+ CASE(CFI_type_cptr)
+ CASE(CFI_type_struct)
+ CASE(CFI_type_char16_t)
+ CASE(CFI_type_char32_t)
+ CASE(CFI_type_uint8_t)
+ CASE(CFI_type_uint16_t)
+ CASE(CFI_type_uint32_t)
+ CASE(CFI_type_uint64_t)
+ CASE(CFI_type_uint128_t)
+ default:
+ return nullptr;
+ }
+#undef CASE
+ }
+ TypeCode code{type};
+ if (!code.IsValid()) {
+ return "invalid";
+ }
+ auto categoryAndKind{code.GetCategoryAndKind()};
+ if (!categoryAndKind) {
+ return nullptr;
+ }
+ TypeCategory tcat{categoryAndKind->first};
+ int kind{categoryAndKind->second};
+
+#define CASE(cat, k) \
+ case (k): \
+ return #cat "(kind=" #k ")";
+ switch (tcat) {
+ case TypeCategory::Integer:
+ switch (kind) {
+ CASE(INTEGER, 1)
+ CASE(INTEGER, 2)
+ CASE(INTEGER, 4)
+ CASE(INTEGER, 8)
+ CASE(INTEGER, 16)
+ }
+ break;
+ case TypeCategory::Unsigned:
+ switch (kind) {
+ CASE(UNSIGNED, 1)
+ CASE(UNSIGNED, 2)
+ CASE(UNSIGNED, 4)
+ CASE(UNSIGNED, 8)
+ CASE(UNSIGNED, 16)
+ }
+ break;
+ case TypeCategory::Real:
+ switch (kind) {
+ CASE(REAL, 2)
+ CASE(REAL, 3)
+ CASE(REAL, 4)
+ CASE(REAL, 8)
+ CASE(REAL, 10)
+ CASE(REAL, 16)
+ }
+ break;
+ case TypeCategory::Complex:
+ switch (kind) {
+ CASE(COMPLEX, 2)
+ CASE(COMPLEX, 3)
+ CASE(COMPLEX, 4)
+ CASE(COMPLEX, 8)
+ CASE(COMPLEX, 10)
+ CASE(COMPLEX, 16)
+ }
+ break;
+ case TypeCategory::Character:
+ switch (kind) {
+ CASE(CHARACTER, 1)
+ CASE(CHARACTER, 2)
+ CASE(CHARACTER, 4)
+ }
+ break;
+ case TypeCategory::Logical:
+ switch (kind) {
+ CASE(LOGICAL, 1)
+ CASE(LOGICAL, 2)
+ CASE(LOGICAL, 4)
+ CASE(LOGICAL, 8)
+ }
+ break;
+ case TypeCategory::Derived:
+ return "DERIVED";
+ }
+#undef CASE
+ return nullptr;
+}
+
+void Descriptor::Dump(FILE *f, bool dumpRawType) const {
std::fprintf(f, "Descriptor @ %p:\n", reinterpret_cast<const void *>(this));
std::fprintf(f, " base_addr %p\n", raw_.base_addr);
- std::fprintf(f, " elem_len %zd\n", static_cast<std::size_t>(raw_.elem_len));
+ std::fprintf(f, " elem_len %zd\n", ElementBytes());
std::fprintf(f, " version %d\n", static_cast<int>(raw_.version));
- std::fprintf(f, " rank %d\n", static_cast<int>(raw_.rank));
- std::fprintf(f, " type %d\n", static_cast<int>(raw_.type));
- std::fprintf(f, " attribute %d\n", static_cast<int>(raw_.attribute));
+ std::fprintf(f, " rank %d%s\n", rank(), rank() ? "" : " (scalar)");
+ int ty{static_cast<int>(raw_.type)};
+ if (const char *tyStr{GetTypeStr(raw_.type, dumpRawType)}) {
+ std::fprintf(f, " type %d \"%s\"\n", ty, tyStr);
+ } else {
+ std::fprintf(f, " type %d\n", ty);
+ }
+ int attr{static_cast<int>(raw_.attribute)};
+ if (IsPointer()) {
+ std::fprintf(f, " attribute %d (pointer) \n", attr);
+ } else if (IsAllocatable()) {
+ std::fprintf(f, " attribute %d (allocatable)\n", attr);
+ } else {
+ std::fprintf(f, " attribute %d\n", attr);
+ }
std::fprintf(f, " extra %d\n", static_cast<int>(raw_.extra));
std::fprintf(f, " addendum %d\n", static_cast<int>(HasAddendum()));
std::fprintf(f, " alloc_idx %d\n", static_cast<int>(GetAllocIdx()));
diff --git a/flang-rt/lib/runtime/edit-output.cpp b/flang-rt/lib/runtime/edit-output.cpp
index f90b6fb..73dba35 100644
--- a/flang-rt/lib/runtime/edit-output.cpp
+++ b/flang-rt/lib/runtime/edit-output.cpp
@@ -175,9 +175,10 @@ bool RT_API_ATTRS EditIntegerOutput(IoStatementState &io, const DataEdit &edit,
}
if (edit.IsListDirected()) {
int total{std::max(leadingSpaces, 1) + subTotal};
- if (io.GetConnectionState().NeedAdvance(static_cast<std::size_t>(total)) &&
- !io.AdvanceRecord()) {
- return false;
+ if (io.GetConnectionState().NeedAdvance(static_cast<std::size_t>(total))) {
+ if (!io.AdvanceRecord()) {
+ return false;
+ }
}
leadingSpaces = 1;
} else if (!edit.width) {
diff --git a/flang-rt/lib/runtime/environment.cpp b/flang-rt/lib/runtime/environment.cpp
index 97ac562..be4f730 100644
--- a/flang-rt/lib/runtime/environment.cpp
+++ b/flang-rt/lib/runtime/environment.cpp
@@ -17,6 +17,10 @@
#ifdef _WIN32
extern char **_environ;
+#elif defined(__FreeBSD__)
+// FreeBSD has environ in crt rather than libc. Using "extern char** environ"
+// in the code of a shared library makes it fail to link with -Wl,--no-undefined
+// See https://reviews.freebsd.org/D30842#840642
#else
extern char **environ;
#endif
@@ -104,6 +108,11 @@ void ExecutionEnvironment::Configure(int ac, const char *av[],
#ifdef _WIN32
envp = _environ;
+#elif defined(__FreeBSD__)
+ auto envpp{reinterpret_cast<char ***>(dlsym(RTLD_DEFAULT, "environ"))};
+ if (envpp) {
+ envp = *envpp;
+ }
#else
envp = environ;
#endif
@@ -132,6 +141,17 @@ void ExecutionEnvironment::Configure(int ac, const char *av[],
}
}
+ if (auto *x{std::getenv("FORT_TRUNCATE_STREAM")}) {
+ char *end;
+ auto n{std::strtol(x, &end, 10)};
+ if (n >= 0 && n <= 1 && *end == '\0') {
+ truncateStream = n != 0;
+ } else {
+ std::fprintf(stderr,
+ "Fortran runtime: FORT_TRUNCATE_STREAM=%s is invalid; ignored\n", x);
+ }
+ }
+
if (auto *x{std::getenv("NO_STOP_MESSAGE")}) {
char *end;
auto n{std::strtol(x, &end, 10)};
diff --git a/flang-rt/lib/runtime/extensions.cpp b/flang-rt/lib/runtime/extensions.cpp
index 19e7514..100046f 100644
--- a/flang-rt/lib/runtime/extensions.cpp
+++ b/flang-rt/lib/runtime/extensions.cpp
@@ -12,6 +12,7 @@
#include "flang/Runtime/extensions.h"
#include "unit.h"
#include "flang-rt/runtime/descriptor.h"
+#include "flang-rt/runtime/lock.h"
#include "flang-rt/runtime/terminator.h"
#include "flang-rt/runtime/tools.h"
#include "flang/Runtime/command.h"
@@ -23,6 +24,7 @@
#include <cstdio>
#include <cstring>
#include <ctime>
+#include <limits>
#include <signal.h>
#include <stdlib.h>
#include <thread>
@@ -60,6 +62,11 @@ inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
namespace Fortran::runtime {
+#define GFC_RAND_A 16807
+#define GFC_RAND_M 2147483647
+static unsigned rand_seed = 1;
+static Lock rand_seed_lock;
+
// Common implementation that could be used for either SECNDS() or DSECNDS(),
// which are defined for float or double.
template <typename T> T SecndsImpl(T *refTime) {
@@ -163,6 +170,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)
@@ -398,6 +416,65 @@ std::int64_t RTNAME(time)() { return time(nullptr); }
// MCLOCK: returns accumulated CPU time in ticks
std::int32_t FORTRAN_PROCEDURE_NAME(mclock)() { return std::clock(); }
+static void _internal_srand(int seed) { rand_seed = seed ? seed : 123459876; }
+
+// IRAND(I)
+int RTNAME(Irand)(int *i) {
+ int j;
+ if (i)
+ j = *i;
+ else
+ j = 0;
+
+ rand_seed_lock.Take();
+ switch (j) {
+ case 0:
+ break;
+ case 1:
+ _internal_srand(0);
+ break;
+ default:
+ _internal_srand(j);
+ break;
+ }
+
+ rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
+ j = (int)rand_seed;
+ rand_seed_lock.Drop();
+ return j;
+}
+
+// RAND(I)
+float RTNAME(Rand)(int *i, const char *sourceFile, int line) {
+ unsigned mask = 0;
+ constexpr int radix = std::numeric_limits<float>::radix;
+ constexpr int digits = std::numeric_limits<float>::digits;
+ if (radix == 2) {
+ mask = ~(unsigned)0u << (32 - digits + 1);
+ } else if (radix == 16) {
+ mask = ~(unsigned)0u << ((8 - digits) * 4 + 1);
+ } else {
+ Terminator terminator{sourceFile, line};
+ terminator.Crash("Radix unknown value.");
+ }
+ return ((unsigned)(RTNAME(Irand)(i) - 1) & mask) * (float)0x1.p-31f;
+}
+
+// SRAND(SEED)
+void FORTRAN_PROCEDURE_NAME(srand)(int *seed) {
+ rand_seed_lock.Take();
+ _internal_srand(*seed);
+ rand_seed_lock.Drop();
+}
+
+void RTNAME(ShowDescriptor)(const Fortran::runtime::Descriptor *descr) {
+ if (descr) {
+ descr->Dump(stderr, /*dumpRawType=*/false);
+ } else {
+ std::fprintf(stderr, "NULL\n");
+ }
+}
+
// Extension procedures related to I/O
namespace io {
diff --git a/flang-rt/lib/runtime/io-stmt.cpp b/flang-rt/lib/runtime/io-stmt.cpp
index b958f23..a88fbe6 100644
--- a/flang-rt/lib/runtime/io-stmt.cpp
+++ b/flang-rt/lib/runtime/io-stmt.cpp
@@ -1109,20 +1109,20 @@ ChildListIoStatementState<DIR>::ChildListIoStatementState(
ChildIo &child, const char *sourceFile, int sourceLine)
: ChildIoStatementState<DIR>{child, sourceFile, sourceLine} {
#if !defined(RT_DEVICE_AVOID_RECURSION)
- if constexpr (DIR == Direction::Input) {
- if (const auto *listInput{child.parent()
- .get_if<ListDirectedStatementState<Direction::Input>>()}) {
- this->set_eatComma(listInput->eatComma());
- this->namelistGroup_ = listInput->namelistGroup();
- if (auto *childListInput{child.parent()
- .get_if<ChildListIoStatementState<Direction::Input>>()}) {
- // Child list input whose parent is child list input: can advance
- // if the parent can.
- this->canAdvance_ = childListInput->CanAdvance();
- } else {
- // Child list input of top-level list input: can advance.
- this->canAdvance_ = true;
- }
+ if (const auto *listParent{
+ child.parent().get_if<ListDirectedStatementState<DIR>>()}) {
+ if constexpr (DIR == Direction::Input) {
+ this->set_eatComma(listParent->eatComma());
+ this->namelistGroup_ = listParent->namelistGroup();
+ }
+ if (auto *childListParent{
+ child.parent().get_if<ChildListIoStatementState<DIR>>()}) {
+ // Child list I/O whose parent is child list I/O: can advance
+ // if the parent can.
+ this->canAdvance_ = childListParent->CanAdvance();
+ } else {
+ // Child list I/O of top-level list I/O: can advance.
+ this->canAdvance_ = true;
}
}
#else
diff --git a/flang-rt/lib/runtime/iostat.cpp b/flang-rt/lib/runtime/iostat.cpp
index 0f8bfb8..c2577e7 100644
--- a/flang-rt/lib/runtime/iostat.cpp
+++ b/flang-rt/lib/runtime/iostat.cpp
@@ -6,7 +6,7 @@
//
//===----------------------------------------------------------------------===//
-#include "flang/Runtime/iostat.h"
+#include "flang-rt/runtime/iostat.h"
namespace Fortran::runtime::io {
RT_OFFLOAD_API_GROUP_BEGIN
diff --git a/flang-rt/lib/runtime/type-code.cpp b/flang-rt/lib/runtime/type-code.cpp
index 9ecde01..68093de 100644
--- a/flang-rt/lib/runtime/type-code.cpp
+++ b/flang-rt/lib/runtime/type-code.cpp
@@ -92,7 +92,7 @@ RT_API_ATTRS TypeCode::TypeCode(TypeCategory f, int kind) {
raw_ = CFI_type_extended_double_Complex;
break;
case 16:
- raw_ = CFI_type_long_double_Complex;
+ raw_ = CFI_type_float128_Complex;
break;
}
break;
diff --git a/flang-rt/lib/runtime/unit.cpp b/flang-rt/lib/runtime/unit.cpp
index 549fbea..bc98cfd 100644
--- a/flang-rt/lib/runtime/unit.cpp
+++ b/flang-rt/lib/runtime/unit.cpp
@@ -783,8 +783,11 @@ void ExternalFileUnit::DoEndfile(IoErrorHandler &handler) {
frameOffsetInFile_ += recordOffsetInFrame_ + furthestPositionInRecord;
recordOffsetInFrame_ = 0;
FlushOutput(handler);
- Truncate(frameOffsetInFile_, handler);
- TruncateFrame(frameOffsetInFile_, handler);
+ if (access != Access::Stream || executionEnvironment.truncateStream) {
+ // Stream output after positioning truncates with some compilers.
+ Truncate(frameOffsetInFile_, handler);
+ TruncateFrame(frameOffsetInFile_, handler);
+ }
BeginRecord();
impliedEndfile_ = false;
anyWriteSinceLastPositioning_ = false;
generated by cgit v1.1 at 2026-01-06 12:50:16 +0000