contrib/openmp/runtime/src/kmp_ftn_entry.h

   1 /*
   2  * kmp_ftn_entry.h -- Fortran entry linkage support for OpenMP.
   3  */
   4
   5 //===----------------------------------------------------------------------===//
   6 //
   7 //                     The LLVM Compiler Infrastructure
   8 //
   9 // This file is dual licensed under the MIT and the University of Illinois Open
  10 // Source Licenses. See LICENSE.txt for details.
  11 //
  12 //===----------------------------------------------------------------------===//
  13
  14 #ifndef FTN_STDCALL
  15 #error The support file kmp_ftn_entry.h should not be compiled by itself.
  16 #endif
  17
  18 #ifdef KMP_STUB
  19 #include "kmp_stub.h"
  20 #endif
  21
  22 #include "kmp_i18n.h"
  23
  24 #if OMP_50_ENABLED
  25 // For affinity format functions
  26 #include "kmp_io.h"
  27 #include "kmp_str.h"
  28 #endif
  29
  30 #if OMPT_SUPPORT
  31 #include "ompt-specific.h"
  32 #endif
  33
  34 #ifdef __cplusplus
  35 extern "C" {
  36 #endif // __cplusplus
  37
  38 /* For compatibility with the Gnu/MS Open MP codegen, omp_set_num_threads(),
  39  * omp_set_nested(), and omp_set_dynamic() [in lowercase on MS, and w/o
  40  * a trailing underscore on Linux* OS] take call by value integer arguments.
  41  * + omp_set_max_active_levels()
  42  * + omp_set_schedule()
  43  *
  44  * For backward compatibility with 9.1 and previous Intel compiler, these
  45  * entry points take call by reference integer arguments. */
  46 #ifdef KMP_GOMP_COMPAT
  47 #if (KMP_FTN_ENTRIES == KMP_FTN_PLAIN) || (KMP_FTN_ENTRIES == KMP_FTN_UPPER)
  48 #define PASS_ARGS_BY_VALUE 1
  49 #endif
  50 #endif
  51 #if KMP_OS_WINDOWS
  52 #if (KMP_FTN_ENTRIES == KMP_FTN_PLAIN) || (KMP_FTN_ENTRIES == KMP_FTN_APPEND)
  53 #define PASS_ARGS_BY_VALUE 1
  54 #endif
  55 #endif
  56
  57 // This macro helps to reduce code duplication.
  58 #ifdef PASS_ARGS_BY_VALUE
  59 #define KMP_DEREF
  60 #else
  61 #define KMP_DEREF *
  62 #endif
  63
  64 void FTN_STDCALL FTN_SET_STACKSIZE(int KMP_DEREF arg) {
  65 #ifdef KMP_STUB
  66   __kmps_set_stacksize(KMP_DEREF arg);
  67 #else
  68   // __kmp_aux_set_stacksize initializes the library if needed
  69   __kmp_aux_set_stacksize((size_t)KMP_DEREF arg);
  70 #endif
  71 }
  72
  73 void FTN_STDCALL FTN_SET_STACKSIZE_S(size_t KMP_DEREF arg) {
  74 #ifdef KMP_STUB
  75   __kmps_set_stacksize(KMP_DEREF arg);
  76 #else
  77   // __kmp_aux_set_stacksize initializes the library if needed
  78   __kmp_aux_set_stacksize(KMP_DEREF arg);
  79 #endif
  80 }
  81
  82 int FTN_STDCALL FTN_GET_STACKSIZE(void) {
  83 #ifdef KMP_STUB
  84   return __kmps_get_stacksize();
  85 #else
  86   if (!__kmp_init_serial) {
  87     __kmp_serial_initialize();
  88   }
  89   return (int)__kmp_stksize;
  90 #endif
  91 }
  92
  93 size_t FTN_STDCALL FTN_GET_STACKSIZE_S(void) {
  94 #ifdef KMP_STUB
  95   return __kmps_get_stacksize();
  96 #else
  97   if (!__kmp_init_serial) {
  98     __kmp_serial_initialize();
  99   }
 100   return __kmp_stksize;
 101 #endif
 102 }
 103
 104 void FTN_STDCALL FTN_SET_BLOCKTIME(int KMP_DEREF arg) {
 105 #ifdef KMP_STUB
 106   __kmps_set_blocktime(KMP_DEREF arg);
 107 #else
 108   int gtid, tid;
 109   kmp_info_t *thread;
 110
 111   gtid = __kmp_entry_gtid();
 112   tid = __kmp_tid_from_gtid(gtid);
 113   thread = __kmp_thread_from_gtid(gtid);
 114
 115   __kmp_aux_set_blocktime(KMP_DEREF arg, thread, tid);
 116 #endif
 117 }
 118
 119 int FTN_STDCALL FTN_GET_BLOCKTIME(void) {
 120 #ifdef KMP_STUB
 121   return __kmps_get_blocktime();
 122 #else
 123   int gtid, tid;
 124   kmp_info_t *thread;
 125   kmp_team_p *team;
 126
 127   gtid = __kmp_entry_gtid();
 128   tid = __kmp_tid_from_gtid(gtid);
 129   thread = __kmp_thread_from_gtid(gtid);
 130   team = __kmp_threads[gtid]->th.th_team;
 131
 132   /* These must match the settings used in __kmp_wait_sleep() */
 133   if (__kmp_dflt_blocktime == KMP_MAX_BLOCKTIME) {
 134     KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n", gtid,
 135                   team->t.t_id, tid, KMP_MAX_BLOCKTIME));
 136     return KMP_MAX_BLOCKTIME;
 137   }
 138 #ifdef KMP_ADJUST_BLOCKTIME
 139   else if (__kmp_zero_bt && !get__bt_set(team, tid)) {
 140     KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n", gtid,
 141                   team->t.t_id, tid, 0));
 142     return 0;
 143   }
 144 #endif /* KMP_ADJUST_BLOCKTIME */
 145   else {
 146     KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n", gtid,
 147                   team->t.t_id, tid, get__blocktime(team, tid)));
 148     return get__blocktime(team, tid);
 149   }
 150 #endif
 151 }
 152
 153 void FTN_STDCALL FTN_SET_LIBRARY_SERIAL(void) {
 154 #ifdef KMP_STUB
 155   __kmps_set_library(library_serial);
 156 #else
 157   // __kmp_user_set_library initializes the library if needed
 158   __kmp_user_set_library(library_serial);
 159 #endif
 160 }
 161
 162 void FTN_STDCALL FTN_SET_LIBRARY_TURNAROUND(void) {
 163 #ifdef KMP_STUB
 164   __kmps_set_library(library_turnaround);
 165 #else
 166   // __kmp_user_set_library initializes the library if needed
 167   __kmp_user_set_library(library_turnaround);
 168 #endif
 169 }
 170
 171 void FTN_STDCALL FTN_SET_LIBRARY_THROUGHPUT(void) {
 172 #ifdef KMP_STUB
 173   __kmps_set_library(library_throughput);
 174 #else
 175   // __kmp_user_set_library initializes the library if needed
 176   __kmp_user_set_library(library_throughput);
 177 #endif
 178 }
 179
 180 void FTN_STDCALL FTN_SET_LIBRARY(int KMP_DEREF arg) {
 181 #ifdef KMP_STUB
 182   __kmps_set_library(KMP_DEREF arg);
 183 #else
 184   enum library_type lib;
 185   lib = (enum library_type)KMP_DEREF arg;
 186   // __kmp_user_set_library initializes the library if needed
 187   __kmp_user_set_library(lib);
 188 #endif
 189 }
 190
 191 int FTN_STDCALL FTN_GET_LIBRARY(void) {
 192 #ifdef KMP_STUB
 193   return __kmps_get_library();
 194 #else
 195   if (!__kmp_init_serial) {
 196     __kmp_serial_initialize();
 197   }
 198   return ((int)__kmp_library);
 199 #endif
 200 }
 201
 202 void FTN_STDCALL FTN_SET_DISP_NUM_BUFFERS(int KMP_DEREF arg) {
 203 #ifdef KMP_STUB
 204   ; // empty routine
 205 #else
 206   // ignore after initialization because some teams have already
 207   // allocated dispatch buffers
 208   if (__kmp_init_serial == 0 && (KMP_DEREF arg) > 0)
 209     __kmp_dispatch_num_buffers = KMP_DEREF arg;
 210 #endif
 211 }
 212
 213 int FTN_STDCALL FTN_SET_AFFINITY(void **mask) {
 214 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 215   return -1;
 216 #else
 217   if (!TCR_4(__kmp_init_middle)) {
 218     __kmp_middle_initialize();
 219   }
 220   return __kmp_aux_set_affinity(mask);
 221 #endif
 222 }
 223
 224 int FTN_STDCALL FTN_GET_AFFINITY(void **mask) {
 225 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 226   return -1;
 227 #else
 228   if (!TCR_4(__kmp_init_middle)) {
 229     __kmp_middle_initialize();
 230   }
 231   return __kmp_aux_get_affinity(mask);
 232 #endif
 233 }
 234
 235 int FTN_STDCALL FTN_GET_AFFINITY_MAX_PROC(void) {
 236 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 237   return 0;
 238 #else
 239   // We really only NEED serial initialization here.
 240   if (!TCR_4(__kmp_init_middle)) {
 241     __kmp_middle_initialize();
 242   }
 243   return __kmp_aux_get_affinity_max_proc();
 244 #endif
 245 }
 246
 247 void FTN_STDCALL FTN_CREATE_AFFINITY_MASK(void **mask) {
 248 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 249   *mask = NULL;
 250 #else
 251   // We really only NEED serial initialization here.
 252   kmp_affin_mask_t *mask_internals;
 253   if (!TCR_4(__kmp_init_middle)) {
 254     __kmp_middle_initialize();
 255   }
 256   mask_internals = __kmp_affinity_dispatch->allocate_mask();
 257   KMP_CPU_ZERO(mask_internals);
 258   *mask = mask_internals;
 259 #endif
 260 }
 261
 262 void FTN_STDCALL FTN_DESTROY_AFFINITY_MASK(void **mask) {
 263 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 264 // Nothing
 265 #else
 266   // We really only NEED serial initialization here.
 267   kmp_affin_mask_t *mask_internals;
 268   if (!TCR_4(__kmp_init_middle)) {
 269     __kmp_middle_initialize();
 270   }
 271   if (__kmp_env_consistency_check) {
 272     if (*mask == NULL) {
 273       KMP_FATAL(AffinityInvalidMask, "kmp_destroy_affinity_mask");
 274     }
 275   }
 276   mask_internals = (kmp_affin_mask_t *)(*mask);
 277   __kmp_affinity_dispatch->deallocate_mask(mask_internals);
 278   *mask = NULL;
 279 #endif
 280 }
 281
 282 int FTN_STDCALL FTN_SET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
 283 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 284   return -1;
 285 #else
 286   if (!TCR_4(__kmp_init_middle)) {
 287     __kmp_middle_initialize();
 288   }
 289   return __kmp_aux_set_affinity_mask_proc(KMP_DEREF proc, mask);
 290 #endif
 291 }
 292
 293 int FTN_STDCALL FTN_UNSET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
 294 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 295   return -1;
 296 #else
 297   if (!TCR_4(__kmp_init_middle)) {
 298     __kmp_middle_initialize();
 299   }
 300   return __kmp_aux_unset_affinity_mask_proc(KMP_DEREF proc, mask);
 301 #endif
 302 }
 303
 304 int FTN_STDCALL FTN_GET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
 305 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 306   return -1;
 307 #else
 308   if (!TCR_4(__kmp_init_middle)) {
 309     __kmp_middle_initialize();
 310   }
 311   return __kmp_aux_get_affinity_mask_proc(KMP_DEREF proc, mask);
 312 #endif
 313 }
 314
 315 /* ------------------------------------------------------------------------ */
 316
 317 /* sets the requested number of threads for the next parallel region */
 318 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NUM_THREADS)(int KMP_DEREF arg) {
 319 #ifdef KMP_STUB
 320 // Nothing.
 321 #else
 322   __kmp_set_num_threads(KMP_DEREF arg, __kmp_entry_gtid());
 323 #endif
 324 }
 325
 326 /* returns the number of threads in current team */
 327 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_THREADS)(void) {
 328 #ifdef KMP_STUB
 329   return 1;
 330 #else
 331   // __kmpc_bound_num_threads initializes the library if needed
 332   return __kmpc_bound_num_threads(NULL);
 333 #endif
 334 }
 335
 336 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_THREADS)(void) {
 337 #ifdef KMP_STUB
 338   return 1;
 339 #else
 340   int gtid;
 341   kmp_info_t *thread;
 342   if (!TCR_4(__kmp_init_middle)) {
 343     __kmp_middle_initialize();
 344   }
 345   gtid = __kmp_entry_gtid();
 346   thread = __kmp_threads[gtid];
 347   // return thread -> th.th_team -> t.t_current_task[
 348   // thread->th.th_info.ds.ds_tid ] -> icvs.nproc;
 349   return thread->th.th_current_task->td_icvs.nproc;
 350 #endif
 351 }
 352
 353 #if OMP_50_ENABLED
 354 int FTN_STDCALL FTN_CONTROL_TOOL(int command, int modifier, void *arg) {
 355 #if defined(KMP_STUB) || !OMPT_SUPPORT
 356   return -2;
 357 #else
 358   OMPT_STORE_RETURN_ADDRESS(__kmp_entry_gtid());
 359   if (!TCR_4(__kmp_init_middle)) {
 360     return -2;
 361   }
 362   kmp_info_t *this_thr = __kmp_threads[__kmp_entry_gtid()];
 363   ompt_task_info_t *parent_task_info = OMPT_CUR_TASK_INFO(this_thr);
 364   parent_task_info->frame.enter_frame.ptr = OMPT_GET_FRAME_ADDRESS(0);
 365   int ret = __kmp_control_tool(command, modifier, arg);
 366   parent_task_info->frame.enter_frame.ptr = 0;
 367   return ret;
 368 #endif
 369 }
 370
 371 /* OpenMP 5.0 Memory Management support */
 372 void FTN_STDCALL FTN_SET_DEFAULT_ALLOCATOR(const omp_allocator_t *allocator) {
 373 #ifndef KMP_STUB
 374   __kmpc_set_default_allocator(__kmp_entry_gtid(), allocator);
 375 #endif
 376 }
 377 const omp_allocator_t *FTN_STDCALL FTN_GET_DEFAULT_ALLOCATOR(void) {
 378 #ifdef KMP_STUB
 379   return NULL;
 380 #else
 381   return __kmpc_get_default_allocator(__kmp_entry_gtid());
 382 #endif
 383 }
 384 void *FTN_STDCALL FTN_ALLOC(size_t size, const omp_allocator_t *allocator) {
 385 #ifdef KMP_STUB
 386   return malloc(size);
 387 #else
 388   return __kmpc_alloc(__kmp_entry_gtid(), size, allocator);
 389 #endif
 390 }
 391 void FTN_STDCALL FTN_FREE(void *ptr, const omp_allocator_t *allocator) {
 392 #ifdef KMP_STUB
 393   free(ptr);
 394 #else
 395   __kmpc_free(__kmp_entry_gtid(), ptr, allocator);
 396 #endif
 397 }
 398
 399 /* OpenMP 5.0 affinity format support */
 400
 401 #ifndef KMP_STUB
 402 static void __kmp_fortran_strncpy_truncate(char *buffer, size_t buf_size,
 403                                            char const *csrc, size_t csrc_size) {
 404   size_t capped_src_size = csrc_size;
 405   if (csrc_size >= buf_size) {
 406     capped_src_size = buf_size - 1;
 407   }
 408   KMP_STRNCPY_S(buffer, buf_size, csrc, capped_src_size);
 409   if (csrc_size >= buf_size) {
 410     KMP_DEBUG_ASSERT(buffer[buf_size - 1] == '\0');
 411     buffer[buf_size - 1] = csrc[buf_size - 1];
 412   } else {
 413     for (size_t i = csrc_size; i < buf_size; ++i)
 414       buffer[i] = ' ';
 415   }
 416 }
 417
 418 // Convert a Fortran string to a C string by adding null byte
 419 class ConvertedString {
 420   char *buf;
 421   kmp_info_t *th;
 422
 423 public:
 424   ConvertedString(char const *fortran_str, size_t size) {
 425     th = __kmp_get_thread();
 426     buf = (char *)__kmp_thread_malloc(th, size + 1);
 427     KMP_STRNCPY_S(buf, size + 1, fortran_str, size);
 428     buf[size] = '\0';
 429   }
 430   ~ConvertedString() { __kmp_thread_free(th, buf); }
 431   const char *get() const { return buf; }
 432 };
 433 #endif // KMP_STUB
 434
 435 /*
 436  * Set the value of the affinity-format-var ICV on the current device to the
 437  * format specified in the argument.
 438 */
 439 void FTN_STDCALL FTN_SET_AFFINITY_FORMAT(char const *format, size_t size) {
 440 #ifdef KMP_STUB
 441   return;
 442 #else
 443   if (!__kmp_init_serial) {
 444     __kmp_serial_initialize();
 445   }
 446   ConvertedString cformat(format, size);
 447   // Since the __kmp_affinity_format variable is a C string, do not
 448   // use the fortran strncpy function
 449   __kmp_strncpy_truncate(__kmp_affinity_format, KMP_AFFINITY_FORMAT_SIZE,
 450                          cformat.get(), KMP_STRLEN(cformat.get()));
 451 #endif
 452 }
 453
 454 /*
 455  * Returns the number of characters required to hold the entire affinity format
 456  * specification (not including null byte character) and writes the value of the
 457  * affinity-format-var ICV on the current device to buffer. If the return value
 458  * is larger than size, the affinity format specification is truncated.
 459 */
 460 size_t FTN_STDCALL FTN_GET_AFFINITY_FORMAT(char *buffer, size_t size) {
 461 #ifdef KMP_STUB
 462   return 0;
 463 #else
 464   size_t format_size;
 465   if (!__kmp_init_serial) {
 466     __kmp_serial_initialize();
 467   }
 468   format_size = KMP_STRLEN(__kmp_affinity_format);
 469   if (buffer && size) {
 470     __kmp_fortran_strncpy_truncate(buffer, size, __kmp_affinity_format,
 471                                    format_size);
 472   }
 473   return format_size;
 474 #endif
 475 }
 476
 477 /*
 478  * Prints the thread affinity information of the current thread in the format
 479  * specified by the format argument. If the format is NULL or a zero-length
 480  * string, the value of the affinity-format-var ICV is used.
 481 */
 482 void FTN_STDCALL FTN_DISPLAY_AFFINITY(char const *format, size_t size) {
 483 #ifdef KMP_STUB
 484   return;
 485 #else
 486   int gtid;
 487   if (!TCR_4(__kmp_init_middle)) {
 488     __kmp_middle_initialize();
 489   }
 490   gtid = __kmp_get_gtid();
 491   ConvertedString cformat(format, size);
 492   __kmp_aux_display_affinity(gtid, cformat.get());
 493 #endif
 494 }
 495
 496 /*
 497  * Returns the number of characters required to hold the entire affinity format
 498  * specification (not including null byte) and prints the thread affinity
 499  * information of the current thread into the character string buffer with the
 500  * size of size in the format specified by the format argument. If the format is
 501  * NULL or a zero-length string, the value of the affinity-format-var ICV is
 502  * used. The buffer must be allocated prior to calling the routine. If the
 503  * return value is larger than size, the affinity format specification is
 504  * truncated.
 505 */
 506 size_t FTN_STDCALL FTN_CAPTURE_AFFINITY(char *buffer, char const *format,
 507                                         size_t buf_size, size_t for_size) {
 508 #if defined(KMP_STUB)
 509   return 0;
 510 #else
 511   int gtid;
 512   size_t num_required;
 513   kmp_str_buf_t capture_buf;
 514   if (!TCR_4(__kmp_init_middle)) {
 515     __kmp_middle_initialize();
 516   }
 517   gtid = __kmp_get_gtid();
 518   __kmp_str_buf_init(&capture_buf);
 519   ConvertedString cformat(format, for_size);
 520   num_required = __kmp_aux_capture_affinity(gtid, cformat.get(), &capture_buf);
 521   if (buffer && buf_size) {
 522     __kmp_fortran_strncpy_truncate(buffer, buf_size, capture_buf.str,
 523                                    capture_buf.used);
 524   }
 525   __kmp_str_buf_free(&capture_buf);
 526   return num_required;
 527 #endif
 528 }
 529 #endif /* OMP_50_ENABLED */
 530
 531 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_NUM)(void) {
 532 #ifdef KMP_STUB
 533   return 0;
 534 #else
 535   int gtid;
 536
 537 #if KMP_OS_DARWIN || KMP_OS_DRAGONFLY || KMP_OS_FREEBSD || KMP_OS_NETBSD ||    \
 538         KMP_OS_HURD
 539   gtid = __kmp_entry_gtid();
 540 #elif KMP_OS_WINDOWS
 541   if (!__kmp_init_parallel ||
 542       (gtid = (int)((kmp_intptr_t)TlsGetValue(__kmp_gtid_threadprivate_key))) ==
 543           0) {
 544     // Either library isn't initialized or thread is not registered
 545     // 0 is the correct TID in this case
 546     return 0;
 547   }
 548   --gtid; // We keep (gtid+1) in TLS
 549 #elif KMP_OS_LINUX
 550 #ifdef KMP_TDATA_GTID
 551   if (__kmp_gtid_mode >= 3) {
 552     if ((gtid = __kmp_gtid) == KMP_GTID_DNE) {
 553       return 0;
 554     }
 555   } else {
 556 #endif
 557     if (!__kmp_init_parallel ||
 558         (gtid = (kmp_intptr_t)(
 559              pthread_getspecific(__kmp_gtid_threadprivate_key))) == 0) {
 560       return 0;
 561     }
 562     --gtid;
 563 #ifdef KMP_TDATA_GTID
 564   }
 565 #endif
 566 #else
 567 #error Unknown or unsupported OS
 568 #endif
 569
 570   return __kmp_tid_from_gtid(gtid);
 571 #endif
 572 }
 573
 574 int FTN_STDCALL FTN_GET_NUM_KNOWN_THREADS(void) {
 575 #ifdef KMP_STUB
 576   return 1;
 577 #else
 578   if (!__kmp_init_serial) {
 579     __kmp_serial_initialize();
 580   }
 581   /* NOTE: this is not syncronized, so it can change at any moment */
 582   /* NOTE: this number also includes threads preallocated in hot-teams */
 583   return TCR_4(__kmp_nth);
 584 #endif
 585 }
 586
 587 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_PROCS)(void) {
 588 #ifdef KMP_STUB
 589   return 1;
 590 #else
 591   if (!TCR_4(__kmp_init_middle)) {
 592     __kmp_middle_initialize();
 593   }
 594   return __kmp_avail_proc;
 595 #endif
 596 }
 597
 598 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NESTED)(int KMP_DEREF flag) {
 599 #ifdef KMP_STUB
 600   __kmps_set_nested(KMP_DEREF flag);
 601 #else
 602   kmp_info_t *thread;
 603   /* For the thread-private internal controls implementation */
 604   thread = __kmp_entry_thread();
 605   __kmp_save_internal_controls(thread);
 606   set__nested(thread, ((KMP_DEREF flag) ? TRUE : FALSE));
 607 #endif
 608 }
 609
 610 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NESTED)(void) {
 611 #ifdef KMP_STUB
 612   return __kmps_get_nested();
 613 #else
 614   kmp_info_t *thread;
 615   thread = __kmp_entry_thread();
 616   return get__nested(thread);
 617 #endif
 618 }
 619
 620 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_DYNAMIC)(int KMP_DEREF flag) {
 621 #ifdef KMP_STUB
 622   __kmps_set_dynamic(KMP_DEREF flag ? TRUE : FALSE);
 623 #else
 624   kmp_info_t *thread;
 625   /* For the thread-private implementation of the internal controls */
 626   thread = __kmp_entry_thread();
 627   // !!! What if foreign thread calls it?
 628   __kmp_save_internal_controls(thread);
 629   set__dynamic(thread, KMP_DEREF flag ? TRUE : FALSE);
 630 #endif
 631 }
 632
 633 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_DYNAMIC)(void) {
 634 #ifdef KMP_STUB
 635   return __kmps_get_dynamic();
 636 #else
 637   kmp_info_t *thread;
 638   thread = __kmp_entry_thread();
 639   return get__dynamic(thread);
 640 #endif
 641 }
 642
 643 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IN_PARALLEL)(void) {
 644 #ifdef KMP_STUB
 645   return 0;
 646 #else
 647   kmp_info_t *th = __kmp_entry_thread();
 648 #if OMP_40_ENABLED
 649   if (th->th.th_teams_microtask) {
 650     // AC: r_in_parallel does not work inside teams construct where real
 651     // parallel is inactive, but all threads have same root, so setting it in
 652     // one team affects other teams.
 653     // The solution is to use per-team nesting level
 654     return (th->th.th_team->t.t_active_level ? 1 : 0);
 655   } else
 656 #endif /* OMP_40_ENABLED */
 657     return (th->th.th_root->r.r_in_parallel ? FTN_TRUE : FTN_FALSE);
 658 #endif
 659 }
 660
 661 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_SCHEDULE)(kmp_sched_t KMP_DEREF kind,
 662                                                    int KMP_DEREF modifier) {
 663 #ifdef KMP_STUB
 664   __kmps_set_schedule(KMP_DEREF kind, KMP_DEREF modifier);
 665 #else
 666   /* TO DO: For the per-task implementation of the internal controls */
 667   __kmp_set_schedule(__kmp_entry_gtid(), KMP_DEREF kind, KMP_DEREF modifier);
 668 #endif
 669 }
 670
 671 void FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_SCHEDULE)(kmp_sched_t *kind,
 672                                                    int *modifier) {
 673 #ifdef KMP_STUB
 674   __kmps_get_schedule(kind, modifier);
 675 #else
 676   /* TO DO: For the per-task implementation of the internal controls */
 677   __kmp_get_schedule(__kmp_entry_gtid(), kind, modifier);
 678 #endif
 679 }
 680
 681 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_MAX_ACTIVE_LEVELS)(int KMP_DEREF arg) {
 682 #ifdef KMP_STUB
 683 // Nothing.
 684 #else
 685   /* TO DO: We want per-task implementation of this internal control */
 686   __kmp_set_max_active_levels(__kmp_entry_gtid(), KMP_DEREF arg);
 687 #endif
 688 }
 689
 690 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_ACTIVE_LEVELS)(void) {
 691 #ifdef KMP_STUB
 692   return 0;
 693 #else
 694   /* TO DO: We want per-task implementation of this internal control */
 695   return __kmp_get_max_active_levels(__kmp_entry_gtid());
 696 #endif
 697 }
 698
 699 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_ACTIVE_LEVEL)(void) {
 700 #ifdef KMP_STUB
 701   return 0; // returns 0 if it is called from the sequential part of the program
 702 #else
 703   /* TO DO: For the per-task implementation of the internal controls */
 704   return __kmp_entry_thread()->th.th_team->t.t_active_level;
 705 #endif
 706 }
 707
 708 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_LEVEL)(void) {
 709 #ifdef KMP_STUB
 710   return 0; // returns 0 if it is called from the sequential part of the program
 711 #else
 712   /* TO DO: For the per-task implementation of the internal controls */
 713   return __kmp_entry_thread()->th.th_team->t.t_level;
 714 #endif
 715 }
 716
 717 int FTN_STDCALL
 718     KMP_EXPAND_NAME(FTN_GET_ANCESTOR_THREAD_NUM)(int KMP_DEREF level) {
 719 #ifdef KMP_STUB
 720   return (KMP_DEREF level) ? (-1) : (0);
 721 #else
 722   return __kmp_get_ancestor_thread_num(__kmp_entry_gtid(), KMP_DEREF level);
 723 #endif
 724 }
 725
 726 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_TEAM_SIZE)(int KMP_DEREF level) {
 727 #ifdef KMP_STUB
 728   return (KMP_DEREF level) ? (-1) : (1);
 729 #else
 730   return __kmp_get_team_size(__kmp_entry_gtid(), KMP_DEREF level);
 731 #endif
 732 }
 733
 734 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_LIMIT)(void) {
 735 #ifdef KMP_STUB
 736   return 1; // TO DO: clarify whether it returns 1 or 0?
 737 #else
 738   if (!__kmp_init_serial) {
 739     __kmp_serial_initialize();
 740   }
 741   /* global ICV */
 742   return __kmp_cg_max_nth;
 743 #endif
 744 }
 745
 746 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IN_FINAL)(void) {
 747 #ifdef KMP_STUB
 748   return 0; // TO DO: clarify whether it returns 1 or 0?
 749 #else
 750   if (!TCR_4(__kmp_init_parallel)) {
 751     return 0;
 752   }
 753   return __kmp_entry_thread()->th.th_current_task->td_flags.final;
 754 #endif
 755 }
 756
 757 #if OMP_40_ENABLED
 758
 759 kmp_proc_bind_t FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PROC_BIND)(void) {
 760 #ifdef KMP_STUB
 761   return __kmps_get_proc_bind();
 762 #else
 763   return get__proc_bind(__kmp_entry_thread());
 764 #endif
 765 }
 766
 767 #if OMP_45_ENABLED
 768 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_PLACES)(void) {
 769 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 770   return 0;
 771 #else
 772   if (!TCR_4(__kmp_init_middle)) {
 773     __kmp_middle_initialize();
 774   }
 775   if (!KMP_AFFINITY_CAPABLE())
 776     return 0;
 777   return __kmp_affinity_num_masks;
 778 #endif
 779 }
 780
 781 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_NUM_PROCS)(int place_num) {
 782 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 783   return 0;
 784 #else
 785   int i;
 786   int retval = 0;
 787   if (!TCR_4(__kmp_init_middle)) {
 788     __kmp_middle_initialize();
 789   }
 790   if (!KMP_AFFINITY_CAPABLE())
 791     return 0;
 792   if (place_num < 0 || place_num >= (int)__kmp_affinity_num_masks)
 793     return 0;
 794   kmp_affin_mask_t *mask = KMP_CPU_INDEX(__kmp_affinity_masks, place_num);
 795   KMP_CPU_SET_ITERATE(i, mask) {
 796     if ((!KMP_CPU_ISSET(i, __kmp_affin_fullMask)) ||
 797         (!KMP_CPU_ISSET(i, mask))) {
 798       continue;
 799     }
 800     ++retval;
 801   }
 802   return retval;
 803 #endif
 804 }
 805
 806 void FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_PROC_IDS)(int place_num,
 807                                                          int *ids) {
 808 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 809 // Nothing.
 810 #else
 811   int i, j;
 812   if (!TCR_4(__kmp_init_middle)) {
 813     __kmp_middle_initialize();
 814   }
 815   if (!KMP_AFFINITY_CAPABLE())
 816     return;
 817   if (place_num < 0 || place_num >= (int)__kmp_affinity_num_masks)
 818     return;
 819   kmp_affin_mask_t *mask = KMP_CPU_INDEX(__kmp_affinity_masks, place_num);
 820   j = 0;
 821   KMP_CPU_SET_ITERATE(i, mask) {
 822     if ((!KMP_CPU_ISSET(i, __kmp_affin_fullMask)) ||
 823         (!KMP_CPU_ISSET(i, mask))) {
 824       continue;
 825     }
 826     ids[j++] = i;
 827   }
 828 #endif
 829 }
 830
 831 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_NUM)(void) {
 832 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 833   return -1;
 834 #else
 835   int gtid;
 836   kmp_info_t *thread;
 837   if (!TCR_4(__kmp_init_middle)) {
 838     __kmp_middle_initialize();
 839   }
 840   if (!KMP_AFFINITY_CAPABLE())
 841     return -1;
 842   gtid = __kmp_entry_gtid();
 843   thread = __kmp_thread_from_gtid(gtid);
 844   if (thread->th.th_current_place < 0)
 845     return -1;
 846   return thread->th.th_current_place;
 847 #endif
 848 }
 849
 850 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PARTITION_NUM_PLACES)(void) {
 851 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 852   return 0;
 853 #else
 854   int gtid, num_places, first_place, last_place;
 855   kmp_info_t *thread;
 856   if (!TCR_4(__kmp_init_middle)) {
 857     __kmp_middle_initialize();
 858   }
 859   if (!KMP_AFFINITY_CAPABLE())
 860     return 0;
 861   gtid = __kmp_entry_gtid();
 862   thread = __kmp_thread_from_gtid(gtid);
 863   first_place = thread->th.th_first_place;
 864   last_place = thread->th.th_last_place;
 865   if (first_place < 0 || last_place < 0)
 866     return 0;
 867   if (first_place <= last_place)
 868     num_places = last_place - first_place + 1;
 869   else
 870     num_places = __kmp_affinity_num_masks - first_place + last_place + 1;
 871   return num_places;
 872 #endif
 873 }
 874
 875 void
 876     FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PARTITION_PLACE_NUMS)(int *place_nums) {
 877 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
 878 // Nothing.
 879 #else
 880   int i, gtid, place_num, first_place, last_place, start, end;
 881   kmp_info_t *thread;
 882   if (!TCR_4(__kmp_init_middle)) {
 883     __kmp_middle_initialize();
 884   }
 885   if (!KMP_AFFINITY_CAPABLE())
 886     return;
 887   gtid = __kmp_entry_gtid();
 888   thread = __kmp_thread_from_gtid(gtid);
 889   first_place = thread->th.th_first_place;
 890   last_place = thread->th.th_last_place;
 891   if (first_place < 0 || last_place < 0)
 892     return;
 893   if (first_place <= last_place) {
 894     start = first_place;
 895     end = last_place;
 896   } else {
 897     start = last_place;
 898     end = first_place;
 899   }
 900   for (i = 0, place_num = start; place_num <= end; ++place_num, ++i) {
 901     place_nums[i] = place_num;
 902   }
 903 #endif
 904 }
 905 #endif
 906
 907 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_TEAMS)(void) {
 908 #ifdef KMP_STUB
 909   return 1;
 910 #else
 911   return __kmp_aux_get_num_teams();
 912 #endif
 913 }
 914
 915 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_TEAM_NUM)(void) {
 916 #ifdef KMP_STUB
 917   return 0;
 918 #else
 919   return __kmp_aux_get_team_num();
 920 #endif
 921 }
 922
 923 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_DEFAULT_DEVICE)(void) {
 924 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
 925   return 0;
 926 #else
 927   return __kmp_entry_thread()->th.th_current_task->td_icvs.default_device;
 928 #endif
 929 }
 930
 931 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_DEFAULT_DEVICE)(int KMP_DEREF arg) {
 932 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
 933 // Nothing.
 934 #else
 935   __kmp_entry_thread()->th.th_current_task->td_icvs.default_device =
 936       KMP_DEREF arg;
 937 #endif
 938 }
 939
 940 // Get number of NON-HOST devices.
 941 // libomptarget, if loaded, provides this function in api.cpp.
 942 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)(void) KMP_WEAK_ATTRIBUTE;
 943 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)(void) {
 944 #if KMP_MIC || KMP_OS_DARWIN || KMP_OS_WINDOWS || defined(KMP_STUB)
 945   return 0;
 946 #else
 947   int (*fptr)();
 948   if ((*(void **)(&fptr) = dlsym(RTLD_DEFAULT, "_Offload_number_of_devices"))) {
 949     return (*fptr)();
 950   } else if ((*(void **)(&fptr) = dlsym(RTLD_NEXT, "omp_get_num_devices"))) {
 951     return (*fptr)();
 952   } else { // liboffload & libomptarget don't exist
 953     return 0;
 954   }
 955 #endif // KMP_MIC || KMP_OS_DARWIN || KMP_OS_WINDOWS || defined(KMP_STUB)
 956 }
 957
 958 // This function always returns true when called on host device.
 959 // Compilier/libomptarget should handle when it is called inside target region.
 960 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)(void) KMP_WEAK_ATTRIBUTE;
 961 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)(void) {
 962   return 1; // This is the host
 963 }
 964
 965 #endif // OMP_40_ENABLED
 966
 967 #if OMP_45_ENABLED
 968 // OpenMP 4.5 entries
 969
 970 // libomptarget, if loaded, provides this function
 971 int FTN_STDCALL FTN_GET_INITIAL_DEVICE(void) KMP_WEAK_ATTRIBUTE;
 972 int FTN_STDCALL FTN_GET_INITIAL_DEVICE(void) {
 973 #if KMP_MIC || KMP_OS_DARWIN || KMP_OS_WINDOWS || defined(KMP_STUB)
 974   return KMP_HOST_DEVICE;
 975 #else
 976   int (*fptr)();
 977   if ((*(void **)(&fptr) = dlsym(RTLD_NEXT, "omp_get_initial_device"))) {
 978     return (*fptr)();
 979   } else { // liboffload & libomptarget don't exist
 980     return KMP_HOST_DEVICE;
 981   }
 982 #endif
 983 }
 984
 985 #if defined(KMP_STUB)
 986 // Entries for stubs library
 987 // As all *target* functions are C-only parameters always passed by value
 988 void *FTN_STDCALL FTN_TARGET_ALLOC(size_t size, int device_num) { return 0; }
 989
 990 void FTN_STDCALL FTN_TARGET_FREE(void *device_ptr, int device_num) {}
 991
 992 int FTN_STDCALL FTN_TARGET_IS_PRESENT(void *ptr, int device_num) { return 0; }
 993
 994 int FTN_STDCALL FTN_TARGET_MEMCPY(void *dst, void *src, size_t length,
 995                                   size_t dst_offset, size_t src_offset,
 996                                   int dst_device, int src_device) {
 997   return -1;
 998 }
 999
1000 int FTN_STDCALL FTN_TARGET_MEMCPY_RECT(
1001     void *dst, void *src, size_t element_size, int num_dims,
1002     const size_t *volume, const size_t *dst_offsets, const size_t *src_offsets,
1003     const size_t *dst_dimensions, const size_t *src_dimensions, int dst_device,
1004     int src_device) {
1005   return -1;
1006 }
1007
1008 int FTN_STDCALL FTN_TARGET_ASSOCIATE_PTR(void *host_ptr, void *device_ptr,
1009                                          size_t size, size_t device_offset,
1010                                          int device_num) {
1011   return -1;
1012 }
1013
1014 int FTN_STDCALL FTN_TARGET_DISASSOCIATE_PTR(void *host_ptr, int device_num) {
1015   return -1;
1016 }
1017 #endif // defined(KMP_STUB)
1018 #endif // OMP_45_ENABLED
1019
1020 #ifdef KMP_STUB
1021 typedef enum { UNINIT = -1, UNLOCKED, LOCKED } kmp_stub_lock_t;
1022 #endif /* KMP_STUB */
1023
1024 #if KMP_USE_DYNAMIC_LOCK
1025 void FTN_STDCALL FTN_INIT_LOCK_WITH_HINT(void **user_lock,
1026                                          uintptr_t KMP_DEREF hint) {
1027 #ifdef KMP_STUB
1028   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1029 #else
1030   int gtid = __kmp_entry_gtid();
1031 #if OMPT_SUPPORT && OMPT_OPTIONAL
1032   OMPT_STORE_RETURN_ADDRESS(gtid);
1033 #endif
1034   __kmpc_init_lock_with_hint(NULL, gtid, user_lock, KMP_DEREF hint);
1035 #endif
1036 }
1037
1038 void FTN_STDCALL FTN_INIT_NEST_LOCK_WITH_HINT(void **user_lock,
1039                                               uintptr_t KMP_DEREF hint) {
1040 #ifdef KMP_STUB
1041   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1042 #else
1043   int gtid = __kmp_entry_gtid();
1044 #if OMPT_SUPPORT && OMPT_OPTIONAL
1045   OMPT_STORE_RETURN_ADDRESS(gtid);
1046 #endif
1047   __kmpc_init_nest_lock_with_hint(NULL, gtid, user_lock, KMP_DEREF hint);
1048 #endif
1049 }
1050 #endif
1051
1052 /* initialize the lock */
1053 void FTN_STDCALL KMP_EXPAND_NAME(FTN_INIT_LOCK)(void **user_lock) {
1054 #ifdef KMP_STUB
1055   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1056 #else
1057   int gtid = __kmp_entry_gtid();
1058 #if OMPT_SUPPORT && OMPT_OPTIONAL
1059   OMPT_STORE_RETURN_ADDRESS(gtid);
1060 #endif
1061   __kmpc_init_lock(NULL, gtid, user_lock);
1062 #endif
1063 }
1064
1065 /* initialize the lock */
1066 void FTN_STDCALL KMP_EXPAND_NAME(FTN_INIT_NEST_LOCK)(void **user_lock) {
1067 #ifdef KMP_STUB
1068   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1069 #else
1070   int gtid = __kmp_entry_gtid();
1071 #if OMPT_SUPPORT && OMPT_OPTIONAL
1072   OMPT_STORE_RETURN_ADDRESS(gtid);
1073 #endif
1074   __kmpc_init_nest_lock(NULL, gtid, user_lock);
1075 #endif
1076 }
1077
1078 void FTN_STDCALL KMP_EXPAND_NAME(FTN_DESTROY_LOCK)(void **user_lock) {
1079 #ifdef KMP_STUB
1080   *((kmp_stub_lock_t *)user_lock) = UNINIT;
1081 #else
1082   int gtid = __kmp_entry_gtid();
1083 #if OMPT_SUPPORT && OMPT_OPTIONAL
1084   OMPT_STORE_RETURN_ADDRESS(gtid);
1085 #endif
1086   __kmpc_destroy_lock(NULL, gtid, user_lock);
1087 #endif
1088 }
1089
1090 void FTN_STDCALL KMP_EXPAND_NAME(FTN_DESTROY_NEST_LOCK)(void **user_lock) {
1091 #ifdef KMP_STUB
1092   *((kmp_stub_lock_t *)user_lock) = UNINIT;
1093 #else
1094   int gtid = __kmp_entry_gtid();
1095 #if OMPT_SUPPORT && OMPT_OPTIONAL
1096   OMPT_STORE_RETURN_ADDRESS(gtid);
1097 #endif
1098   __kmpc_destroy_nest_lock(NULL, gtid, user_lock);
1099 #endif
1100 }
1101
1102 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_LOCK)(void **user_lock) {
1103 #ifdef KMP_STUB
1104   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1105     // TODO: Issue an error.
1106   }
1107   if (*((kmp_stub_lock_t *)user_lock) != UNLOCKED) {
1108     // TODO: Issue an error.
1109   }
1110   *((kmp_stub_lock_t *)user_lock) = LOCKED;
1111 #else
1112   int gtid = __kmp_entry_gtid();
1113 #if OMPT_SUPPORT && OMPT_OPTIONAL
1114   OMPT_STORE_RETURN_ADDRESS(gtid);
1115 #endif
1116   __kmpc_set_lock(NULL, gtid, user_lock);
1117 #endif
1118 }
1119
1120 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NEST_LOCK)(void **user_lock) {
1121 #ifdef KMP_STUB
1122   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1123     // TODO: Issue an error.
1124   }
1125   (*((int *)user_lock))++;
1126 #else
1127   int gtid = __kmp_entry_gtid();
1128 #if OMPT_SUPPORT && OMPT_OPTIONAL
1129   OMPT_STORE_RETURN_ADDRESS(gtid);
1130 #endif
1131   __kmpc_set_nest_lock(NULL, gtid, user_lock);
1132 #endif
1133 }
1134
1135 void FTN_STDCALL KMP_EXPAND_NAME(FTN_UNSET_LOCK)(void **user_lock) {
1136 #ifdef KMP_STUB
1137   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1138     // TODO: Issue an error.
1139   }
1140   if (*((kmp_stub_lock_t *)user_lock) == UNLOCKED) {
1141     // TODO: Issue an error.
1142   }
1143   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1144 #else
1145   int gtid = __kmp_entry_gtid();
1146 #if OMPT_SUPPORT && OMPT_OPTIONAL
1147   OMPT_STORE_RETURN_ADDRESS(gtid);
1148 #endif
1149   __kmpc_unset_lock(NULL, gtid, user_lock);
1150 #endif
1151 }
1152
1153 void FTN_STDCALL KMP_EXPAND_NAME(FTN_UNSET_NEST_LOCK)(void **user_lock) {
1154 #ifdef KMP_STUB
1155   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1156     // TODO: Issue an error.
1157   }
1158   if (*((kmp_stub_lock_t *)user_lock) == UNLOCKED) {
1159     // TODO: Issue an error.
1160   }
1161   (*((int *)user_lock))--;
1162 #else
1163   int gtid = __kmp_entry_gtid();
1164 #if OMPT_SUPPORT && OMPT_OPTIONAL
1165   OMPT_STORE_RETURN_ADDRESS(gtid);
1166 #endif
1167   __kmpc_unset_nest_lock(NULL, gtid, user_lock);
1168 #endif
1169 }
1170
1171 int FTN_STDCALL KMP_EXPAND_NAME(FTN_TEST_LOCK)(void **user_lock) {
1172 #ifdef KMP_STUB
1173   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1174     // TODO: Issue an error.
1175   }
1176   if (*((kmp_stub_lock_t *)user_lock) == LOCKED) {
1177     return 0;
1178   }
1179   *((kmp_stub_lock_t *)user_lock) = LOCKED;
1180   return 1;
1181 #else
1182   int gtid = __kmp_entry_gtid();
1183 #if OMPT_SUPPORT && OMPT_OPTIONAL
1184   OMPT_STORE_RETURN_ADDRESS(gtid);
1185 #endif
1186   return __kmpc_test_lock(NULL, gtid, user_lock);
1187 #endif
1188 }
1189
1190 int FTN_STDCALL KMP_EXPAND_NAME(FTN_TEST_NEST_LOCK)(void **user_lock) {
1191 #ifdef KMP_STUB
1192   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1193     // TODO: Issue an error.
1194   }
1195   return ++(*((int *)user_lock));
1196 #else
1197   int gtid = __kmp_entry_gtid();
1198 #if OMPT_SUPPORT && OMPT_OPTIONAL
1199   OMPT_STORE_RETURN_ADDRESS(gtid);
1200 #endif
1201   return __kmpc_test_nest_lock(NULL, gtid, user_lock);
1202 #endif
1203 }
1204
1205 double FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_WTIME)(void) {
1206 #ifdef KMP_STUB
1207   return __kmps_get_wtime();
1208 #else
1209   double data;
1210 #if !KMP_OS_LINUX
1211   // We don't need library initialization to get the time on Linux* OS. The
1212   // routine can be used to measure library initialization time on Linux* OS now
1213   if (!__kmp_init_serial) {
1214     __kmp_serial_initialize();
1215   }
1216 #endif
1217   __kmp_elapsed(&data);
1218   return data;
1219 #endif
1220 }
1221
1222 double FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_WTICK)(void) {
1223 #ifdef KMP_STUB
1224   return __kmps_get_wtick();
1225 #else
1226   double data;
1227   if (!__kmp_init_serial) {
1228     __kmp_serial_initialize();
1229   }
1230   __kmp_elapsed_tick(&data);
1231   return data;
1232 #endif
1233 }
1234
1235 /* ------------------------------------------------------------------------ */
1236
1237 void *FTN_STDCALL FTN_MALLOC(size_t KMP_DEREF size) {
1238   // kmpc_malloc initializes the library if needed
1239   return kmpc_malloc(KMP_DEREF size);
1240 }
1241
1242 void *FTN_STDCALL FTN_ALIGNED_MALLOC(size_t KMP_DEREF size,
1243                                      size_t KMP_DEREF alignment) {
1244   // kmpc_aligned_malloc initializes the library if needed
1245   return kmpc_aligned_malloc(KMP_DEREF size, KMP_DEREF alignment);
1246 }
1247
1248 void *FTN_STDCALL FTN_CALLOC(size_t KMP_DEREF nelem, size_t KMP_DEREF elsize) {
1249   // kmpc_calloc initializes the library if needed
1250   return kmpc_calloc(KMP_DEREF nelem, KMP_DEREF elsize);
1251 }
1252
1253 void *FTN_STDCALL FTN_REALLOC(void *KMP_DEREF ptr, size_t KMP_DEREF size) {
1254   // kmpc_realloc initializes the library if needed
1255   return kmpc_realloc(KMP_DEREF ptr, KMP_DEREF size);
1256 }
1257
1258 void FTN_STDCALL FTN_KFREE(void *KMP_DEREF ptr) {
1259   // does nothing if the library is not initialized
1260   kmpc_free(KMP_DEREF ptr);
1261 }
1262
1263 void FTN_STDCALL FTN_SET_WARNINGS_ON(void) {
1264 #ifndef KMP_STUB
1265   __kmp_generate_warnings = kmp_warnings_explicit;
1266 #endif
1267 }
1268
1269 void FTN_STDCALL FTN_SET_WARNINGS_OFF(void) {
1270 #ifndef KMP_STUB
1271   __kmp_generate_warnings = FALSE;
1272 #endif
1273 }
1274
1275 void FTN_STDCALL FTN_SET_DEFAULTS(char const *str
1276 #ifndef PASS_ARGS_BY_VALUE
1277                                   ,
1278                                   int len
1279 #endif
1280                                   ) {
1281 #ifndef KMP_STUB
1282 #ifdef PASS_ARGS_BY_VALUE
1283   int len = (int)KMP_STRLEN(str);
1284 #endif
1285   __kmp_aux_set_defaults(str, len);
1286 #endif
1287 }
1288
1289 /* ------------------------------------------------------------------------ */
1290
1291 #if OMP_40_ENABLED
1292 /* returns the status of cancellation */
1293 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_CANCELLATION)(void) {
1294 #ifdef KMP_STUB
1295   return 0 /* false */;
1296 #else
1297   // initialize the library if needed
1298   if (!__kmp_init_serial) {
1299     __kmp_serial_initialize();
1300   }
1301   return __kmp_omp_cancellation;
1302 #endif
1303 }
1304
1305 int FTN_STDCALL FTN_GET_CANCELLATION_STATUS(int cancel_kind) {
1306 #ifdef KMP_STUB
1307   return 0 /* false */;
1308 #else
1309   return __kmp_get_cancellation_status(cancel_kind);
1310 #endif
1311 }
1312
1313 #endif // OMP_40_ENABLED
1314
1315 #if OMP_45_ENABLED
1316 /* returns the maximum allowed task priority */
1317 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_TASK_PRIORITY)(void) {
1318 #ifdef KMP_STUB
1319   return 0;
1320 #else
1321   if (!__kmp_init_serial) {
1322     __kmp_serial_initialize();
1323   }
1324   return __kmp_max_task_priority;
1325 #endif
1326 }
1327 #endif
1328
1329 #if OMP_50_ENABLED
1330 // This function will be defined in libomptarget. When libomptarget is not
1331 // loaded, we assume we are on the host and return KMP_HOST_DEVICE.
1332 // Compiler/libomptarget will handle this if called inside target.
1333 int FTN_STDCALL FTN_GET_DEVICE_NUM(void) KMP_WEAK_ATTRIBUTE;
1334 int FTN_STDCALL FTN_GET_DEVICE_NUM(void) { return KMP_HOST_DEVICE; }
1335 #endif // OMP_50_ENABLED
1336
1337 // GCC compatibility (versioned symbols)
1338 #ifdef KMP_USE_VERSION_SYMBOLS
1339
1340 /* These following sections create versioned symbols for the
1341    omp_* routines. The KMP_VERSION_SYMBOL macro expands the API name and
1342    then maps it to a versioned symbol.
1343    libgomp ``versions'' its symbols (OMP_1.0, OMP_2.0, OMP_3.0, ...) while also
1344    retaining the default version which libomp uses: VERSION (defined in
1345    exports_so.txt). If you want to see the versioned symbols for libgomp.so.1
1346    then just type:
1347
1348    objdump -T /path/to/libgomp.so.1 | grep omp_
1349
1350    Example:
1351    Step 1) Create __kmp_api_omp_set_num_threads_10_alias which is alias of
1352      __kmp_api_omp_set_num_threads
1353    Step 2) Set __kmp_api_omp_set_num_threads_10_alias to version:
1354      omp_set_num_threads@OMP_1.0
1355    Step 2B) Set __kmp_api_omp_set_num_threads to default version:
1356      omp_set_num_threads@@VERSION
1357 */
1358
1359 // OMP_1.0 versioned symbols
1360 KMP_VERSION_SYMBOL(FTN_SET_NUM_THREADS, 10, "OMP_1.0");
1361 KMP_VERSION_SYMBOL(FTN_GET_NUM_THREADS, 10, "OMP_1.0");
1362 KMP_VERSION_SYMBOL(FTN_GET_MAX_THREADS, 10, "OMP_1.0");
1363 KMP_VERSION_SYMBOL(FTN_GET_THREAD_NUM, 10, "OMP_1.0");
1364 KMP_VERSION_SYMBOL(FTN_GET_NUM_PROCS, 10, "OMP_1.0");
1365 KMP_VERSION_SYMBOL(FTN_IN_PARALLEL, 10, "OMP_1.0");
1366 KMP_VERSION_SYMBOL(FTN_SET_DYNAMIC, 10, "OMP_1.0");
1367 KMP_VERSION_SYMBOL(FTN_GET_DYNAMIC, 10, "OMP_1.0");
1368 KMP_VERSION_SYMBOL(FTN_SET_NESTED, 10, "OMP_1.0");
1369 KMP_VERSION_SYMBOL(FTN_GET_NESTED, 10, "OMP_1.0");
1370 KMP_VERSION_SYMBOL(FTN_INIT_LOCK, 10, "OMP_1.0");
1371 KMP_VERSION_SYMBOL(FTN_INIT_NEST_LOCK, 10, "OMP_1.0");
1372 KMP_VERSION_SYMBOL(FTN_DESTROY_LOCK, 10, "OMP_1.0");
1373 KMP_VERSION_SYMBOL(FTN_DESTROY_NEST_LOCK, 10, "OMP_1.0");
1374 KMP_VERSION_SYMBOL(FTN_SET_LOCK, 10, "OMP_1.0");
1375 KMP_VERSION_SYMBOL(FTN_SET_NEST_LOCK, 10, "OMP_1.0");
1376 KMP_VERSION_SYMBOL(FTN_UNSET_LOCK, 10, "OMP_1.0");
1377 KMP_VERSION_SYMBOL(FTN_UNSET_NEST_LOCK, 10, "OMP_1.0");
1378 KMP_VERSION_SYMBOL(FTN_TEST_LOCK, 10, "OMP_1.0");
1379 KMP_VERSION_SYMBOL(FTN_TEST_NEST_LOCK, 10, "OMP_1.0");
1380
1381 // OMP_2.0 versioned symbols
1382 KMP_VERSION_SYMBOL(FTN_GET_WTICK, 20, "OMP_2.0");
1383 KMP_VERSION_SYMBOL(FTN_GET_WTIME, 20, "OMP_2.0");
1384
1385 // OMP_3.0 versioned symbols
1386 KMP_VERSION_SYMBOL(FTN_SET_SCHEDULE, 30, "OMP_3.0");
1387 KMP_VERSION_SYMBOL(FTN_GET_SCHEDULE, 30, "OMP_3.0");
1388 KMP_VERSION_SYMBOL(FTN_GET_THREAD_LIMIT, 30, "OMP_3.0");
1389 KMP_VERSION_SYMBOL(FTN_SET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1390 KMP_VERSION_SYMBOL(FTN_GET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1391 KMP_VERSION_SYMBOL(FTN_GET_ANCESTOR_THREAD_NUM, 30, "OMP_3.0");
1392 KMP_VERSION_SYMBOL(FTN_GET_LEVEL, 30, "OMP_3.0");
1393 KMP_VERSION_SYMBOL(FTN_GET_TEAM_SIZE, 30, "OMP_3.0");
1394 KMP_VERSION_SYMBOL(FTN_GET_ACTIVE_LEVEL, 30, "OMP_3.0");
1395
1396 // the lock routines have a 1.0 and 3.0 version
1397 KMP_VERSION_SYMBOL(FTN_INIT_LOCK, 30, "OMP_3.0");
1398 KMP_VERSION_SYMBOL(FTN_INIT_NEST_LOCK, 30, "OMP_3.0");
1399 KMP_VERSION_SYMBOL(FTN_DESTROY_LOCK, 30, "OMP_3.0");
1400 KMP_VERSION_SYMBOL(FTN_DESTROY_NEST_LOCK, 30, "OMP_3.0");
1401 KMP_VERSION_SYMBOL(FTN_SET_LOCK, 30, "OMP_3.0");
1402 KMP_VERSION_SYMBOL(FTN_SET_NEST_LOCK, 30, "OMP_3.0");
1403 KMP_VERSION_SYMBOL(FTN_UNSET_LOCK, 30, "OMP_3.0");
1404 KMP_VERSION_SYMBOL(FTN_UNSET_NEST_LOCK, 30, "OMP_3.0");
1405 KMP_VERSION_SYMBOL(FTN_TEST_LOCK, 30, "OMP_3.0");
1406 KMP_VERSION_SYMBOL(FTN_TEST_NEST_LOCK, 30, "OMP_3.0");
1407
1408 // OMP_3.1 versioned symbol
1409 KMP_VERSION_SYMBOL(FTN_IN_FINAL, 31, "OMP_3.1");
1410
1411 #if OMP_40_ENABLED
1412 // OMP_4.0 versioned symbols
1413 KMP_VERSION_SYMBOL(FTN_GET_PROC_BIND, 40, "OMP_4.0");
1414 KMP_VERSION_SYMBOL(FTN_GET_NUM_TEAMS, 40, "OMP_4.0");
1415 KMP_VERSION_SYMBOL(FTN_GET_TEAM_NUM, 40, "OMP_4.0");
1416 KMP_VERSION_SYMBOL(FTN_GET_CANCELLATION, 40, "OMP_4.0");
1417 KMP_VERSION_SYMBOL(FTN_GET_DEFAULT_DEVICE, 40, "OMP_4.0");
1418 KMP_VERSION_SYMBOL(FTN_SET_DEFAULT_DEVICE, 40, "OMP_4.0");
1419 KMP_VERSION_SYMBOL(FTN_IS_INITIAL_DEVICE, 40, "OMP_4.0");
1420 KMP_VERSION_SYMBOL(FTN_GET_NUM_DEVICES, 40, "OMP_4.0");
1421 #endif /* OMP_40_ENABLED */
1422
1423 #if OMP_45_ENABLED
1424 // OMP_4.5 versioned symbols
1425 KMP_VERSION_SYMBOL(FTN_GET_MAX_TASK_PRIORITY, 45, "OMP_4.5");
1426 KMP_VERSION_SYMBOL(FTN_GET_NUM_PLACES, 45, "OMP_4.5");
1427 KMP_VERSION_SYMBOL(FTN_GET_PLACE_NUM_PROCS, 45, "OMP_4.5");
1428 KMP_VERSION_SYMBOL(FTN_GET_PLACE_PROC_IDS, 45, "OMP_4.5");
1429 KMP_VERSION_SYMBOL(FTN_GET_PLACE_NUM, 45, "OMP_4.5");
1430 KMP_VERSION_SYMBOL(FTN_GET_PARTITION_NUM_PLACES, 45, "OMP_4.5");
1431 KMP_VERSION_SYMBOL(FTN_GET_PARTITION_PLACE_NUMS, 45, "OMP_4.5");
1432 // KMP_VERSION_SYMBOL(FTN_GET_INITIAL_DEVICE, 45, "OMP_4.5");
1433 #endif
1434
1435 #if OMP_50_ENABLED
1436 // OMP_5.0 versioned symbols
1437 // KMP_VERSION_SYMBOL(FTN_GET_DEVICE_NUM, 50, "OMP_5.0");
1438 #endif
1439
1440 #endif // KMP_USE_VERSION_SYMBOLS
1441
1442 #ifdef __cplusplus
1443 } // extern "C"
1444 #endif // __cplusplus
1445
1446 // end of file //