contrib/llvm-project/openmp/runtime/src/kmp_ftn_entry.h

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