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 // 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 (int)__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  int num_buffers = KMP_DEREF arg;
206  if (__kmp_init_serial == FALSE && num_buffers >= KMP_MIN_DISP_NUM_BUFF &&
207  num_buffers <= KMP_MAX_DISP_NUM_BUFF) {
208  __kmp_dispatch_num_buffers = num_buffers;
209  }
210 #endif
211 }
212 
213 int FTN_STDCALL FTN_SET_AFFINITY(void **mask) {
214 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
215  return -1;
216 #else
217  if (!TCR_4(__kmp_init_middle)) {
218  __kmp_middle_initialize();
219  }
220  return __kmp_aux_set_affinity(mask);
221 #endif
222 }
223 
224 int FTN_STDCALL FTN_GET_AFFINITY(void **mask) {
225 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
226  return -1;
227 #else
228  if (!TCR_4(__kmp_init_middle)) {
229  __kmp_middle_initialize();
230  }
231  return __kmp_aux_get_affinity(mask);
232 #endif
233 }
234 
235 int FTN_STDCALL FTN_GET_AFFINITY_MAX_PROC(void) {
236 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
237  return 0;
238 #else
239  // We really only NEED serial initialization here.
240  if (!TCR_4(__kmp_init_middle)) {
241  __kmp_middle_initialize();
242  }
243  return __kmp_aux_get_affinity_max_proc();
244 #endif
245 }
246 
247 void FTN_STDCALL FTN_CREATE_AFFINITY_MASK(void **mask) {
248 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
249  *mask = NULL;
250 #else
251  // We really only NEED serial initialization here.
252  kmp_affin_mask_t *mask_internals;
253  if (!TCR_4(__kmp_init_middle)) {
254  __kmp_middle_initialize();
255  }
256  mask_internals = __kmp_affinity_dispatch->allocate_mask();
257  KMP_CPU_ZERO(mask_internals);
258  *mask = mask_internals;
259 #endif
260 }
261 
262 void FTN_STDCALL FTN_DESTROY_AFFINITY_MASK(void **mask) {
263 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
264 // Nothing
265 #else
266  // We really only NEED serial initialization here.
267  kmp_affin_mask_t *mask_internals;
268  if (!TCR_4(__kmp_init_middle)) {
269  __kmp_middle_initialize();
270  }
271  if (__kmp_env_consistency_check) {
272  if (*mask == NULL) {
273  KMP_FATAL(AffinityInvalidMask, "kmp_destroy_affinity_mask");
274  }
275  }
276  mask_internals = (kmp_affin_mask_t *)(*mask);
277  __kmp_affinity_dispatch->deallocate_mask(mask_internals);
278  *mask = NULL;
279 #endif
280 }
281 
282 int FTN_STDCALL FTN_SET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
283 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
284  return -1;
285 #else
286  if (!TCR_4(__kmp_init_middle)) {
287  __kmp_middle_initialize();
288  }
289  return __kmp_aux_set_affinity_mask_proc(KMP_DEREF proc, mask);
290 #endif
291 }
292 
293 int FTN_STDCALL FTN_UNSET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
294 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
295  return -1;
296 #else
297  if (!TCR_4(__kmp_init_middle)) {
298  __kmp_middle_initialize();
299  }
300  return __kmp_aux_unset_affinity_mask_proc(KMP_DEREF proc, mask);
301 #endif
302 }
303 
304 int FTN_STDCALL FTN_GET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
305 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
306  return -1;
307 #else
308  if (!TCR_4(__kmp_init_middle)) {
309  __kmp_middle_initialize();
310  }
311  return __kmp_aux_get_affinity_mask_proc(KMP_DEREF proc, mask);
312 #endif
313 }
314 
315 /* ------------------------------------------------------------------------ */
316 
317 /* sets the requested number of threads for the next parallel region */
318 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NUM_THREADS)(int KMP_DEREF arg) {
319 #ifdef KMP_STUB
320 // Nothing.
321 #else
322  __kmp_set_num_threads(KMP_DEREF arg, __kmp_entry_gtid());
323 #endif
324 }
325 
326 /* returns the number of threads in current team */
327 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_THREADS)(void) {
328 #ifdef KMP_STUB
329  return 1;
330 #else
331  // __kmpc_bound_num_threads initializes the library if needed
332  return __kmpc_bound_num_threads(NULL);
333 #endif
334 }
335 
336 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_THREADS)(void) {
337 #ifdef KMP_STUB
338  return 1;
339 #else
340  int gtid;
341  kmp_info_t *thread;
342  if (!TCR_4(__kmp_init_middle)) {
343  __kmp_middle_initialize();
344  }
345  gtid = __kmp_entry_gtid();
346  thread = __kmp_threads[gtid];
347  // return thread -> th.th_team -> t.t_current_task[
348  // thread->th.th_info.ds.ds_tid ] -> icvs.nproc;
349  return thread->th.th_current_task->td_icvs.nproc;
350 #endif
351 }
352 
353 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 
530 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_NUM)(void) {
531 #ifdef KMP_STUB
532  return 0;
533 #else
534  int gtid;
535 
536 #if KMP_OS_DARWIN || KMP_OS_DRAGONFLY || KMP_OS_FREEBSD || KMP_OS_NETBSD || \
537  KMP_OS_HURD || KMP_OS_OPENBSD
538  gtid = __kmp_entry_gtid();
539 #elif KMP_OS_WINDOWS
540  if (!__kmp_init_parallel ||
541  (gtid = (int)((kmp_intptr_t)TlsGetValue(__kmp_gtid_threadprivate_key))) ==
542  0) {
543  // Either library isn't initialized or thread is not registered
544  // 0 is the correct TID in this case
545  return 0;
546  }
547  --gtid; // We keep (gtid+1) in TLS
548 #elif KMP_OS_LINUX
549 #ifdef KMP_TDATA_GTID
550  if (__kmp_gtid_mode >= 3) {
551  if ((gtid = __kmp_gtid) == KMP_GTID_DNE) {
552  return 0;
553  }
554  } else {
555 #endif
556  if (!__kmp_init_parallel ||
557  (gtid = (int)((kmp_intptr_t)(
558  pthread_getspecific(__kmp_gtid_threadprivate_key)))) == 0) {
559  return 0;
560  }
561  --gtid;
562 #ifdef KMP_TDATA_GTID
563  }
564 #endif
565 #else
566 #error Unknown or unsupported OS
567 #endif
568 
569  return __kmp_tid_from_gtid(gtid);
570 #endif
571 }
572 
573 int FTN_STDCALL FTN_GET_NUM_KNOWN_THREADS(void) {
574 #ifdef KMP_STUB
575  return 1;
576 #else
577  if (!__kmp_init_serial) {
578  __kmp_serial_initialize();
579  }
580  /* NOTE: this is not syncronized, so it can change at any moment */
581  /* NOTE: this number also includes threads preallocated in hot-teams */
582  return TCR_4(__kmp_nth);
583 #endif
584 }
585 
586 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_PROCS)(void) {
587 #ifdef KMP_STUB
588  return 1;
589 #else
590  if (!TCR_4(__kmp_init_middle)) {
591  __kmp_middle_initialize();
592  }
593  return __kmp_avail_proc;
594 #endif
595 }
596 
597 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NESTED)(int KMP_DEREF flag) {
598  KMP_INFORM(APIDeprecated, "omp_set_nested", "omp_set_max_active_levels");
599 #ifdef KMP_STUB
600  __kmps_set_nested(KMP_DEREF flag);
601 #else
602  kmp_info_t *thread;
603  /* For the thread-private internal controls implementation */
604  thread = __kmp_entry_thread();
605  __kmp_save_internal_controls(thread);
606  // Somewhat arbitrarily decide where to get a value for max_active_levels
607  int max_active_levels = get__max_active_levels(thread);
608  if (max_active_levels == 1)
609  max_active_levels = KMP_MAX_ACTIVE_LEVELS_LIMIT;
610  set__max_active_levels(thread, (KMP_DEREF flag) ? max_active_levels : 1);
611 #endif
612 }
613 
614 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NESTED)(void) {
615  KMP_INFORM(APIDeprecated, "omp_get_nested", "omp_get_max_active_levels");
616 #ifdef KMP_STUB
617  return __kmps_get_nested();
618 #else
619  kmp_info_t *thread;
620  thread = __kmp_entry_thread();
621  return get__max_active_levels(thread) > 1;
622 #endif
623 }
624 
625 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_DYNAMIC)(int KMP_DEREF flag) {
626 #ifdef KMP_STUB
627  __kmps_set_dynamic(KMP_DEREF flag ? TRUE : FALSE);
628 #else
629  kmp_info_t *thread;
630  /* For the thread-private implementation of the internal controls */
631  thread = __kmp_entry_thread();
632  // !!! What if foreign thread calls it?
633  __kmp_save_internal_controls(thread);
634  set__dynamic(thread, KMP_DEREF flag ? true : false);
635 #endif
636 }
637 
638 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_DYNAMIC)(void) {
639 #ifdef KMP_STUB
640  return __kmps_get_dynamic();
641 #else
642  kmp_info_t *thread;
643  thread = __kmp_entry_thread();
644  return get__dynamic(thread);
645 #endif
646 }
647 
648 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IN_PARALLEL)(void) {
649 #ifdef KMP_STUB
650  return 0;
651 #else
652  kmp_info_t *th = __kmp_entry_thread();
653  if (th->th.th_teams_microtask) {
654  // AC: r_in_parallel does not work inside teams construct where real
655  // parallel is inactive, but all threads have same root, so setting it in
656  // one team affects other teams.
657  // The solution is to use per-team nesting level
658  return (th->th.th_team->t.t_active_level ? 1 : 0);
659  } else
660  return (th->th.th_root->r.r_in_parallel ? FTN_TRUE : FTN_FALSE);
661 #endif
662 }
663 
664 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_SCHEDULE)(kmp_sched_t KMP_DEREF kind,
665  int KMP_DEREF modifier) {
666 #ifdef KMP_STUB
667  __kmps_set_schedule(KMP_DEREF kind, KMP_DEREF modifier);
668 #else
669  /* TO DO: For the per-task implementation of the internal controls */
670  __kmp_set_schedule(__kmp_entry_gtid(), KMP_DEREF kind, KMP_DEREF modifier);
671 #endif
672 }
673 
674 void FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_SCHEDULE)(kmp_sched_t *kind,
675  int *modifier) {
676 #ifdef KMP_STUB
677  __kmps_get_schedule(kind, modifier);
678 #else
679  /* TO DO: For the per-task implementation of the internal controls */
680  __kmp_get_schedule(__kmp_entry_gtid(), kind, modifier);
681 #endif
682 }
683 
684 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_MAX_ACTIVE_LEVELS)(int KMP_DEREF arg) {
685 #ifdef KMP_STUB
686 // Nothing.
687 #else
688  /* TO DO: We want per-task implementation of this internal control */
689  __kmp_set_max_active_levels(__kmp_entry_gtid(), KMP_DEREF arg);
690 #endif
691 }
692 
693 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_ACTIVE_LEVELS)(void) {
694 #ifdef KMP_STUB
695  return 0;
696 #else
697  /* TO DO: We want per-task implementation of this internal control */
698  return __kmp_get_max_active_levels(__kmp_entry_gtid());
699 #endif
700 }
701 
702 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_ACTIVE_LEVEL)(void) {
703 #ifdef KMP_STUB
704  return 0; // returns 0 if it is called from the sequential part of the program
705 #else
706  /* TO DO: For the per-task implementation of the internal controls */
707  return __kmp_entry_thread()->th.th_team->t.t_active_level;
708 #endif
709 }
710 
711 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_LEVEL)(void) {
712 #ifdef KMP_STUB
713  return 0; // returns 0 if it is called from the sequential part of the program
714 #else
715  /* TO DO: For the per-task implementation of the internal controls */
716  return __kmp_entry_thread()->th.th_team->t.t_level;
717 #endif
718 }
719 
720 int FTN_STDCALL
721 KMP_EXPAND_NAME(FTN_GET_ANCESTOR_THREAD_NUM)(int KMP_DEREF level) {
722 #ifdef KMP_STUB
723  return (KMP_DEREF level) ? (-1) : (0);
724 #else
725  return __kmp_get_ancestor_thread_num(__kmp_entry_gtid(), KMP_DEREF level);
726 #endif
727 }
728 
729 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_TEAM_SIZE)(int KMP_DEREF level) {
730 #ifdef KMP_STUB
731  return (KMP_DEREF level) ? (-1) : (1);
732 #else
733  return __kmp_get_team_size(__kmp_entry_gtid(), KMP_DEREF level);
734 #endif
735 }
736 
737 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_LIMIT)(void) {
738 #ifdef KMP_STUB
739  return 1; // TO DO: clarify whether it returns 1 or 0?
740 #else
741  int gtid;
742  kmp_info_t *thread;
743  if (!__kmp_init_serial) {
744  __kmp_serial_initialize();
745  }
746 
747  gtid = __kmp_entry_gtid();
748  thread = __kmp_threads[gtid];
749  return thread->th.th_current_task->td_icvs.thread_limit;
750 #endif
751 }
752 
753 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IN_FINAL)(void) {
754 #ifdef KMP_STUB
755  return 0; // TO DO: clarify whether it returns 1 or 0?
756 #else
757  if (!TCR_4(__kmp_init_parallel)) {
758  return 0;
759  }
760  return __kmp_entry_thread()->th.th_current_task->td_flags.final;
761 #endif
762 }
763 
764 kmp_proc_bind_t FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PROC_BIND)(void) {
765 #ifdef KMP_STUB
766  return __kmps_get_proc_bind();
767 #else
768  return get__proc_bind(__kmp_entry_thread());
769 #endif
770 }
771 
772 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_PLACES)(void) {
773 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
774  return 0;
775 #else
776  if (!TCR_4(__kmp_init_middle)) {
777  __kmp_middle_initialize();
778  }
779  if (!KMP_AFFINITY_CAPABLE())
780  return 0;
781  return __kmp_affinity_num_masks;
782 #endif
783 }
784 
785 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_NUM_PROCS)(int place_num) {
786 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
787  return 0;
788 #else
789  int i;
790  int retval = 0;
791  if (!TCR_4(__kmp_init_middle)) {
792  __kmp_middle_initialize();
793  }
794  if (!KMP_AFFINITY_CAPABLE())
795  return 0;
796  if (place_num < 0 || place_num >= (int)__kmp_affinity_num_masks)
797  return 0;
798  kmp_affin_mask_t *mask = KMP_CPU_INDEX(__kmp_affinity_masks, place_num);
799  KMP_CPU_SET_ITERATE(i, mask) {
800  if ((!KMP_CPU_ISSET(i, __kmp_affin_fullMask)) ||
801  (!KMP_CPU_ISSET(i, mask))) {
802  continue;
803  }
804  ++retval;
805  }
806  return retval;
807 #endif
808 }
809 
810 void FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_PROC_IDS)(int place_num,
811  int *ids) {
812 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
813 // Nothing.
814 #else
815  int i, j;
816  if (!TCR_4(__kmp_init_middle)) {
817  __kmp_middle_initialize();
818  }
819  if (!KMP_AFFINITY_CAPABLE())
820  return;
821  if (place_num < 0 || place_num >= (int)__kmp_affinity_num_masks)
822  return;
823  kmp_affin_mask_t *mask = KMP_CPU_INDEX(__kmp_affinity_masks, place_num);
824  j = 0;
825  KMP_CPU_SET_ITERATE(i, mask) {
826  if ((!KMP_CPU_ISSET(i, __kmp_affin_fullMask)) ||
827  (!KMP_CPU_ISSET(i, mask))) {
828  continue;
829  }
830  ids[j++] = i;
831  }
832 #endif
833 }
834 
835 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_NUM)(void) {
836 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
837  return -1;
838 #else
839  int gtid;
840  kmp_info_t *thread;
841  if (!TCR_4(__kmp_init_middle)) {
842  __kmp_middle_initialize();
843  }
844  if (!KMP_AFFINITY_CAPABLE())
845  return -1;
846  gtid = __kmp_entry_gtid();
847  thread = __kmp_thread_from_gtid(gtid);
848  if (thread->th.th_current_place < 0)
849  return -1;
850  return thread->th.th_current_place;
851 #endif
852 }
853 
854 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PARTITION_NUM_PLACES)(void) {
855 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
856  return 0;
857 #else
858  int gtid, num_places, first_place, last_place;
859  kmp_info_t *thread;
860  if (!TCR_4(__kmp_init_middle)) {
861  __kmp_middle_initialize();
862  }
863  if (!KMP_AFFINITY_CAPABLE())
864  return 0;
865  gtid = __kmp_entry_gtid();
866  thread = __kmp_thread_from_gtid(gtid);
867  first_place = thread->th.th_first_place;
868  last_place = thread->th.th_last_place;
869  if (first_place < 0 || last_place < 0)
870  return 0;
871  if (first_place <= last_place)
872  num_places = last_place - first_place + 1;
873  else
874  num_places = __kmp_affinity_num_masks - first_place + last_place + 1;
875  return num_places;
876 #endif
877 }
878 
879 void FTN_STDCALL
880 KMP_EXPAND_NAME(FTN_GET_PARTITION_PLACE_NUMS)(int *place_nums) {
881 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
882 // Nothing.
883 #else
884  int i, gtid, place_num, first_place, last_place, start, end;
885  kmp_info_t *thread;
886  if (!TCR_4(__kmp_init_middle)) {
887  __kmp_middle_initialize();
888  }
889  if (!KMP_AFFINITY_CAPABLE())
890  return;
891  gtid = __kmp_entry_gtid();
892  thread = __kmp_thread_from_gtid(gtid);
893  first_place = thread->th.th_first_place;
894  last_place = thread->th.th_last_place;
895  if (first_place < 0 || last_place < 0)
896  return;
897  if (first_place <= last_place) {
898  start = first_place;
899  end = last_place;
900  } else {
901  start = last_place;
902  end = first_place;
903  }
904  for (i = 0, place_num = start; place_num <= end; ++place_num, ++i) {
905  place_nums[i] = place_num;
906  }
907 #endif
908 }
909 
910 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_TEAMS)(void) {
911 #ifdef KMP_STUB
912  return 1;
913 #else
914  return __kmp_aux_get_num_teams();
915 #endif
916 }
917 
918 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_TEAM_NUM)(void) {
919 #ifdef KMP_STUB
920  return 0;
921 #else
922  return __kmp_aux_get_team_num();
923 #endif
924 }
925 
926 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_DEFAULT_DEVICE)(void) {
927 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
928  return 0;
929 #else
930  return __kmp_entry_thread()->th.th_current_task->td_icvs.default_device;
931 #endif
932 }
933 
934 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_DEFAULT_DEVICE)(int KMP_DEREF arg) {
935 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
936 // Nothing.
937 #else
938  __kmp_entry_thread()->th.th_current_task->td_icvs.default_device =
939  KMP_DEREF arg;
940 #endif
941 }
942 
943 // Get number of NON-HOST devices.
944 // libomptarget, if loaded, provides this function in api.cpp.
945 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)(void)
946  KMP_WEAK_ATTRIBUTE_EXTERNAL;
947 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)(void) {
948 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
949  return 0;
950 #else
951  int (*fptr)();
952  if ((*(void **)(&fptr) = KMP_DLSYM("__tgt_get_num_devices"))) {
953  return (*fptr)();
954  } else if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_num_devices"))) {
955  return (*fptr)();
956  } else if ((*(void **)(&fptr) = KMP_DLSYM("_Offload_number_of_devices"))) {
957  return (*fptr)();
958  } else { // liboffload & libomptarget don't exist
959  return 0;
960  }
961 #endif // KMP_MIC || KMP_OS_DARWIN || KMP_OS_WINDOWS || defined(KMP_STUB)
962 }
963 
964 // This function always returns true when called on host device.
965 // Compiler/libomptarget should handle when it is called inside target region.
966 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)(void)
967  KMP_WEAK_ATTRIBUTE_EXTERNAL;
968 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)(void) {
969  return 1; // This is the host
970 }
971 
972 // libomptarget, if loaded, provides this function
973 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)(void)
974  KMP_WEAK_ATTRIBUTE_EXTERNAL;
975 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)(void) {
976  // same as omp_get_num_devices()
977  return KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)();
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_EXTERNAL;
1322 int FTN_STDCALL FTN_GET_DEVICE_NUM(void) {
1323  return KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)();
1324 }
1325 
1326 // Compiler will ensure that this is only called from host in sequential region
1327 int FTN_STDCALL FTN_PAUSE_RESOURCE(kmp_pause_status_t kind, int device_num) {
1328 #ifdef KMP_STUB
1329  return 1; // just fail
1330 #else
1331  if (device_num == KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)())
1332  return __kmpc_pause_resource(kind);
1333  else {
1334  int (*fptr)(kmp_pause_status_t, int);
1335  if ((*(void **)(&fptr) = KMP_DLSYM("tgt_pause_resource")))
1336  return (*fptr)(kind, device_num);
1337  else
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  int (*fptr)(kmp_pause_status_t, int);
1350  if ((*(void **)(&fptr) = KMP_DLSYM("tgt_pause_resource")))
1351  fails = (*fptr)(kind, KMP_DEVICE_ALL); // pause devices
1352  fails += __kmpc_pause_resource(kind); // pause host
1353  return fails;
1354 #endif
1355 }
1356 
1357 // Returns the maximum number of nesting levels supported by implementation
1358 int FTN_STDCALL FTN_GET_SUPPORTED_ACTIVE_LEVELS(void) {
1359 #ifdef KMP_STUB
1360  return 1;
1361 #else
1362  return KMP_MAX_ACTIVE_LEVELS_LIMIT;
1363 #endif
1364 }
1365 
1366 void FTN_STDCALL FTN_FULFILL_EVENT(kmp_event_t *event) {
1367 #ifndef KMP_STUB
1368  __kmp_fulfill_event(event);
1369 #endif
1370 }
1371 
1372 // nteams-var per-device ICV
1373 void FTN_STDCALL FTN_SET_NUM_TEAMS(int KMP_DEREF num_teams) {
1374 #ifdef KMP_STUB
1375 // Nothing.
1376 #else
1377  if (!__kmp_init_serial) {
1378  __kmp_serial_initialize();
1379  }
1380  __kmp_set_num_teams(KMP_DEREF num_teams);
1381 #endif
1382 }
1383 int FTN_STDCALL FTN_GET_MAX_TEAMS(void) {
1384 #ifdef KMP_STUB
1385  return 1;
1386 #else
1387  if (!__kmp_init_serial) {
1388  __kmp_serial_initialize();
1389  }
1390  return __kmp_get_max_teams();
1391 #endif
1392 }
1393 // teams-thread-limit-var per-device ICV
1394 void FTN_STDCALL FTN_SET_TEAMS_THREAD_LIMIT(int KMP_DEREF limit) {
1395 #ifdef KMP_STUB
1396 // Nothing.
1397 #else
1398  if (!__kmp_init_serial) {
1399  __kmp_serial_initialize();
1400  }
1401  __kmp_set_teams_thread_limit(KMP_DEREF limit);
1402 #endif
1403 }
1404 int FTN_STDCALL FTN_GET_TEAMS_THREAD_LIMIT(void) {
1405 #ifdef KMP_STUB
1406  return 1;
1407 #else
1408  if (!__kmp_init_serial) {
1409  __kmp_serial_initialize();
1410  }
1411  return __kmp_get_teams_thread_limit();
1412 #endif
1413 }
1414 
1415 // display environment variables when requested
1416 void FTN_STDCALL FTN_DISPLAY_ENV(int verbose) {
1417 #ifndef KMP_STUB
1418  __kmp_omp_display_env(verbose);
1419 #endif
1420 }
1421 
1422 // GCC compatibility (versioned symbols)
1423 #ifdef KMP_USE_VERSION_SYMBOLS
1424 
1425 /* These following sections create versioned symbols for the
1426  omp_* routines. The KMP_VERSION_SYMBOL macro expands the API name and
1427  then maps it to a versioned symbol.
1428  libgomp ``versions'' its symbols (OMP_1.0, OMP_2.0, OMP_3.0, ...) while also
1429  retaining the default version which libomp uses: VERSION (defined in
1430  exports_so.txt). If you want to see the versioned symbols for libgomp.so.1
1431  then just type:
1432 
1433  objdump -T /path/to/libgomp.so.1 | grep omp_
1434 
1435  Example:
1436  Step 1) Create __kmp_api_omp_set_num_threads_10_alias which is alias of
1437  __kmp_api_omp_set_num_threads
1438  Step 2) Set __kmp_api_omp_set_num_threads_10_alias to version:
1439  omp_set_num_threads@OMP_1.0
1440  Step 2B) Set __kmp_api_omp_set_num_threads to default version:
1441  omp_set_num_threads@@VERSION
1442 */
1443 
1444 // OMP_1.0 versioned symbols
1445 KMP_VERSION_SYMBOL(FTN_SET_NUM_THREADS, 10, "OMP_1.0");
1446 KMP_VERSION_SYMBOL(FTN_GET_NUM_THREADS, 10, "OMP_1.0");
1447 KMP_VERSION_SYMBOL(FTN_GET_MAX_THREADS, 10, "OMP_1.0");
1448 KMP_VERSION_SYMBOL(FTN_GET_THREAD_NUM, 10, "OMP_1.0");
1449 KMP_VERSION_SYMBOL(FTN_GET_NUM_PROCS, 10, "OMP_1.0");
1450 KMP_VERSION_SYMBOL(FTN_IN_PARALLEL, 10, "OMP_1.0");
1451 KMP_VERSION_SYMBOL(FTN_SET_DYNAMIC, 10, "OMP_1.0");
1452 KMP_VERSION_SYMBOL(FTN_GET_DYNAMIC, 10, "OMP_1.0");
1453 KMP_VERSION_SYMBOL(FTN_SET_NESTED, 10, "OMP_1.0");
1454 KMP_VERSION_SYMBOL(FTN_GET_NESTED, 10, "OMP_1.0");
1455 KMP_VERSION_SYMBOL(FTN_INIT_LOCK, 10, "OMP_1.0");
1456 KMP_VERSION_SYMBOL(FTN_INIT_NEST_LOCK, 10, "OMP_1.0");
1457 KMP_VERSION_SYMBOL(FTN_DESTROY_LOCK, 10, "OMP_1.0");
1458 KMP_VERSION_SYMBOL(FTN_DESTROY_NEST_LOCK, 10, "OMP_1.0");
1459 KMP_VERSION_SYMBOL(FTN_SET_LOCK, 10, "OMP_1.0");
1460 KMP_VERSION_SYMBOL(FTN_SET_NEST_LOCK, 10, "OMP_1.0");
1461 KMP_VERSION_SYMBOL(FTN_UNSET_LOCK, 10, "OMP_1.0");
1462 KMP_VERSION_SYMBOL(FTN_UNSET_NEST_LOCK, 10, "OMP_1.0");
1463 KMP_VERSION_SYMBOL(FTN_TEST_LOCK, 10, "OMP_1.0");
1464 KMP_VERSION_SYMBOL(FTN_TEST_NEST_LOCK, 10, "OMP_1.0");
1465 
1466 // OMP_2.0 versioned symbols
1467 KMP_VERSION_SYMBOL(FTN_GET_WTICK, 20, "OMP_2.0");
1468 KMP_VERSION_SYMBOL(FTN_GET_WTIME, 20, "OMP_2.0");
1469 
1470 // OMP_3.0 versioned symbols
1471 KMP_VERSION_SYMBOL(FTN_SET_SCHEDULE, 30, "OMP_3.0");
1472 KMP_VERSION_SYMBOL(FTN_GET_SCHEDULE, 30, "OMP_3.0");
1473 KMP_VERSION_SYMBOL(FTN_GET_THREAD_LIMIT, 30, "OMP_3.0");
1474 KMP_VERSION_SYMBOL(FTN_SET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1475 KMP_VERSION_SYMBOL(FTN_GET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1476 KMP_VERSION_SYMBOL(FTN_GET_ANCESTOR_THREAD_NUM, 30, "OMP_3.0");
1477 KMP_VERSION_SYMBOL(FTN_GET_LEVEL, 30, "OMP_3.0");
1478 KMP_VERSION_SYMBOL(FTN_GET_TEAM_SIZE, 30, "OMP_3.0");
1479 KMP_VERSION_SYMBOL(FTN_GET_ACTIVE_LEVEL, 30, "OMP_3.0");
1480 
1481 // the lock routines have a 1.0 and 3.0 version
1482 KMP_VERSION_SYMBOL(FTN_INIT_LOCK, 30, "OMP_3.0");
1483 KMP_VERSION_SYMBOL(FTN_INIT_NEST_LOCK, 30, "OMP_3.0");
1484 KMP_VERSION_SYMBOL(FTN_DESTROY_LOCK, 30, "OMP_3.0");
1485 KMP_VERSION_SYMBOL(FTN_DESTROY_NEST_LOCK, 30, "OMP_3.0");
1486 KMP_VERSION_SYMBOL(FTN_SET_LOCK, 30, "OMP_3.0");
1487 KMP_VERSION_SYMBOL(FTN_SET_NEST_LOCK, 30, "OMP_3.0");
1488 KMP_VERSION_SYMBOL(FTN_UNSET_LOCK, 30, "OMP_3.0");
1489 KMP_VERSION_SYMBOL(FTN_UNSET_NEST_LOCK, 30, "OMP_3.0");
1490 KMP_VERSION_SYMBOL(FTN_TEST_LOCK, 30, "OMP_3.0");
1491 KMP_VERSION_SYMBOL(FTN_TEST_NEST_LOCK, 30, "OMP_3.0");
1492 
1493 // OMP_3.1 versioned symbol
1494 KMP_VERSION_SYMBOL(FTN_IN_FINAL, 31, "OMP_3.1");
1495 
1496 // OMP_4.0 versioned symbols
1497 KMP_VERSION_SYMBOL(FTN_GET_PROC_BIND, 40, "OMP_4.0");
1498 KMP_VERSION_SYMBOL(FTN_GET_NUM_TEAMS, 40, "OMP_4.0");
1499 KMP_VERSION_SYMBOL(FTN_GET_TEAM_NUM, 40, "OMP_4.0");
1500 KMP_VERSION_SYMBOL(FTN_GET_CANCELLATION, 40, "OMP_4.0");
1501 KMP_VERSION_SYMBOL(FTN_GET_DEFAULT_DEVICE, 40, "OMP_4.0");
1502 KMP_VERSION_SYMBOL(FTN_SET_DEFAULT_DEVICE, 40, "OMP_4.0");
1503 KMP_VERSION_SYMBOL(FTN_IS_INITIAL_DEVICE, 40, "OMP_4.0");
1504 KMP_VERSION_SYMBOL(FTN_GET_NUM_DEVICES, 40, "OMP_4.0");
1505 
1506 // OMP_4.5 versioned symbols
1507 KMP_VERSION_SYMBOL(FTN_GET_MAX_TASK_PRIORITY, 45, "OMP_4.5");
1508 KMP_VERSION_SYMBOL(FTN_GET_NUM_PLACES, 45, "OMP_4.5");
1509 KMP_VERSION_SYMBOL(FTN_GET_PLACE_NUM_PROCS, 45, "OMP_4.5");
1510 KMP_VERSION_SYMBOL(FTN_GET_PLACE_PROC_IDS, 45, "OMP_4.5");
1511 KMP_VERSION_SYMBOL(FTN_GET_PLACE_NUM, 45, "OMP_4.5");
1512 KMP_VERSION_SYMBOL(FTN_GET_PARTITION_NUM_PLACES, 45, "OMP_4.5");
1513 KMP_VERSION_SYMBOL(FTN_GET_PARTITION_PLACE_NUMS, 45, "OMP_4.5");
1514 KMP_VERSION_SYMBOL(FTN_GET_INITIAL_DEVICE, 45, "OMP_4.5");
1515 
1516 // OMP_5.0 versioned symbols
1517 // KMP_VERSION_SYMBOL(FTN_GET_DEVICE_NUM, 50, "OMP_5.0");
1518 // KMP_VERSION_SYMBOL(FTN_PAUSE_RESOURCE, 50, "OMP_5.0");
1519 // KMP_VERSION_SYMBOL(FTN_PAUSE_RESOURCE_ALL, 50, "OMP_5.0");
1520 // KMP_VERSION_SYMBOL(FTN_GET_SUPPORTED_ACTIVE_LEVELS, 50, "OMP_5.0");
1521 // KMP_VERSION_SYMBOL(FTN_FULFILL_EVENT, 50, "OMP_5.0");
1522 
1523 #endif // KMP_USE_VERSION_SYMBOLS
1524 
1525 #ifdef __cplusplus
1526 } // extern "C"
1527 #endif // __cplusplus
1528 
1529 // end of file //
KMP_EXPORT kmp_int32 __kmpc_bound_num_threads(ident_t *)