[FLANG] Fix for Stop statements in Fortran emissary API (llvm#1299)

Author: ronlieb

flang-rt/lib/runtime/main.cpp

@@ -12,6 +12,7 @@
 #include <cfenv>
 #include <cstdio>
 #include <cstdlib>
+#include <thread>
 
 static void ConfigureFloatingPoint() {
 #ifdef feclearexcept // a macro in some environments; omit std::
@@ -26,7 +27,10 @@ static void ConfigureFloatingPoint() {
 #endif
 }
 
+std::thread::id _main_thread_id = std::this_thread::get_id();
 extern "C" {
+std::thread::id RTNAME(GetMainThreadId)() { return _main_thread_id; }
+
 void RTNAME(ProgramStart)(int argc, const char *argv[], const char *envp[],
     const EnvironmentDefaultList *envDefaults) {
   std::atexit(Fortran::runtime::NotifyOtherImagesOfNormalEnd);

flang-rt/lib/runtime/stop.cpp

@@ -13,9 +13,11 @@
 #include "flang-rt/runtime/file.h"
 #include "flang-rt/runtime/io-error.h"
 #include "flang-rt/runtime/terminator.h"
+#include "flang/Runtime/main.h"
 #include <cfenv>
 #include <cstdio>
 #include <cstdlib>
+#include <thread>
 
 #ifdef HAVE_BACKTRACE
 #include BACKTRACE_HEADER
@@ -79,6 +81,8 @@ static void CloseAllExternalUnits(const char *why) {
     std::fputc('\n', stderr);
     DescribeIEEESignaledExceptions();
   }
+  if (RTNAME(GetMainThreadId)() != std::this_thread::get_id())
+    std::abort();
   std::exit(code);
 }
 
@@ -94,6 +98,8 @@ static void CloseAllExternalUnits(const char *why) {
     }
     DescribeIEEESignaledExceptions();
   }
+  if (RTNAME(GetMainThreadId)() != std::this_thread::get_id())
+    std::abort();
   if (isErrorStop) {
     std::exit(EXIT_FAILURE);
   } else {

flang/include/flang/Runtime/main.h

@@ -11,10 +11,12 @@
 
 #include "flang/Runtime/c-or-cpp.h"
 #include "flang/Runtime/entry-names.h"
+#include <thread>
 
 struct EnvironmentDefaultList;
 
 FORTRAN_EXTERN_C_BEGIN
+std::thread::id RTNAME(GetMainThreadId)();
 void RTNAME(ProgramStart)(
     int, const char *[], const char *[], const struct EnvironmentDefaultList *);
 void RTNAME(ByteswapOption)(void); // -byteswapio

offload/DeviceRTL/include/EmissaryIds.h

@@ -53,6 +53,7 @@ typedef enum {
   _FortranAAbort_idx,
   _FortranAStopStatementText_idx,
   _FortranAioBeginExternalFormattedOutput_idx,
+  _FortranAStopStatement_idx,
 } offload_emis_fortrt_idx;
 
 /// This structure is created by emisExtractArgBuf to make it easier

offload/DeviceRTL/src/EmissaryFortrt.cpp

@@ -33,9 +33,13 @@ uint32_t omp_get_num_threads();
 uint32_t omp_get_team_num();
 uint32_t omp_get_num_teams();
 
+// All Fortran Runtime Functions pass 4 extra args to assist with
+// defered execution and debug. The host variadic wrappers do not use
+// these arguments when calling the actual Fortran runtime.
 #define _EXTRA_ARGS                                                            \
   omp_get_thread_num(), omp_get_num_threads(), omp_get_team_num(),             \
       omp_get_num_teams()
+#define _START_ARGS(idx) _PACK_EMIS_IDS(EMIS_ID_FORTRT, idx), _EXTRA_ARGS,
 
 void *_FortranAioBeginExternalListOutput(uint32_t a1, const char *a2,
                                          uint32_t a3) {
@@ -116,15 +120,20 @@ bool _FortranAioOutputLogical(void *cookie, bool barg) {
       cookie, barg);
 }
 void _FortranAAbort() {
-  _emissary_exec(_PACK_EMIS_IDS(EMIS_ID_FORTRT, _FortranAAbort_idx));
+  _emissary_exec(_PACK_EMIS_IDS(EMIS_ID_FORTRT, _FortranAAbort_idx),
+                 _EXTRA_ARGS);
   // When  host service _FortranAAbort finishes, we must die from the device.
   __builtin_trap();
 }
+void _FortranAStopStatement(int32_t a1, bool a2, bool a3) {
+  _emissary_exec(_PACK_EMIS_IDS(EMIS_ID_FORTRT, _FortranAStopStatement_idx),
+                 _EXTRA_ARGS, a1, a2, a3);
+  __builtin_trap();
+}
 void _FortranAStopStatementText(char *errmsg, int64_t a1, bool a2, bool a3) {
-  // TODO: must use string length from a1 arg
   errmsg[a1 - 1] = (char)0;
   _emissary_exec(_PACK_EMIS_IDS(EMIS_ID_FORTRT, _FortranAStopStatementText_idx),
-                 errmsg, a1, a2, a3);
+                 _EXTRA_ARGS, errmsg, a1, a2, a3);
   __builtin_trap();
 }
 

offload/DeviceRTL/src/exports

@@ -23,7 +23,7 @@ printf_*
 f90print*
 fprintf_*
 
-_FortranAio*
+_FortranA*
 __ockl_dm_alloc
 __ockl_dm_dealloc
 __asan*

offload/plugins-nextgen/common/src/EmissaryFortrt.cpp

@@ -52,6 +52,7 @@ bool _FortranAioOutputComplex64(void *cookie, double re, double im);
 bool _FortranAioOutputLogical(void *cookie, bool truth);
 void _FortranAAbort();
 void _FortranAStopStatementText(char *errmsg, int64_t a1, bool a2, bool a3);
+void _FortranAStopStatement(int32_t a1, bool a2, bool a3);
 
 //  Save the cookie because deferred functions have execution reordered.
 static void *_list_started_cookie = nullptr;
@@ -212,6 +213,17 @@ extern void V_FortranAStopStatementText(void *fnptr, ...) {
   bool b3 = (bool)a3;
   _FortranAStopStatementText(errmsg, a1, b2, b3);
 }
+extern void V_FortranAStopStatement(void *fnptr, ...) {
+  va_list args;
+  va_start(args, fnptr);
+  int32_t a1 = va_arg(args, int32_t);
+  uint32_t a2 = va_arg(args, uint32_t);
+  uint32_t a3 = va_arg(args, uint32_t);
+  va_end(args);
+  bool b2 = (bool)a2;
+  bool b3 = (bool)a3;
+  _FortranAStopStatement(a1, b2, b3);
+}
 } // end extern "C"
 
 // Static vars used to defer functions to reorder execution by thread and team.
@@ -367,6 +379,11 @@ extern "C" emis_return_t EmissaryFortrt(char *data, emisArgBuf_t *ab) {
     fnptr = (void *)V_FortranAStopStatementText;
     break;
   }
+  case _FortranAStopStatement_idx: {
+    defer_for_reorder = false;
+    fnptr = (void *)V_FortranAStopStatement;
+    break;
+  }
   case _FortranAio_INVALID:
   default: {
     defer_for_reorder = false;