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