xref: /freebsd/contrib/llvm-project/openmp/runtime/src/kmp_ftn_entry.h (revision 700637cbb5e582861067a11aaca4d053546871d2)
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 // For API with specific C vs. Fortran interfaces (ompc_* exists in
62 // kmp_csupport.cpp), only create GOMP versioned symbols of the API for the
63 // APPEND Fortran entries in this file. The GOMP versioned symbols of the C API
64 // will take place where the ompc_* functions are defined.
65 #if KMP_FTN_ENTRIES == KMP_FTN_APPEND
66 #define KMP_EXPAND_NAME_IF_APPEND(name) KMP_EXPAND_NAME(name)
67 #else
68 #define KMP_EXPAND_NAME_IF_APPEND(name) name
69 #endif
70 
FTN_SET_STACKSIZE(int KMP_DEREF arg)71 void FTN_STDCALL FTN_SET_STACKSIZE(int KMP_DEREF arg) {
72 #ifdef KMP_STUB
73   __kmps_set_stacksize(KMP_DEREF arg);
74 #else
75   // __kmp_aux_set_stacksize initializes the library if needed
76   __kmp_aux_set_stacksize((size_t)KMP_DEREF arg);
77 #endif
78 }
79 
FTN_SET_STACKSIZE_S(size_t KMP_DEREF arg)80 void FTN_STDCALL FTN_SET_STACKSIZE_S(size_t KMP_DEREF arg) {
81 #ifdef KMP_STUB
82   __kmps_set_stacksize(KMP_DEREF arg);
83 #else
84   // __kmp_aux_set_stacksize initializes the library if needed
85   __kmp_aux_set_stacksize(KMP_DEREF arg);
86 #endif
87 }
88 
FTN_GET_STACKSIZE(void)89 int FTN_STDCALL FTN_GET_STACKSIZE(void) {
90 #ifdef KMP_STUB
91   return (int)__kmps_get_stacksize();
92 #else
93   if (!__kmp_init_serial) {
94     __kmp_serial_initialize();
95   }
96   return (int)__kmp_stksize;
97 #endif
98 }
99 
FTN_GET_STACKSIZE_S(void)100 size_t FTN_STDCALL FTN_GET_STACKSIZE_S(void) {
101 #ifdef KMP_STUB
102   return __kmps_get_stacksize();
103 #else
104   if (!__kmp_init_serial) {
105     __kmp_serial_initialize();
106   }
107   return __kmp_stksize;
108 #endif
109 }
110 
FTN_SET_BLOCKTIME(int KMP_DEREF arg)111 void FTN_STDCALL FTN_SET_BLOCKTIME(int KMP_DEREF arg) {
112 #ifdef KMP_STUB
113   __kmps_set_blocktime(KMP_DEREF arg);
114 #else
115   int gtid, tid, bt = (KMP_DEREF arg);
116   kmp_info_t *thread;
117 
118   gtid = __kmp_entry_gtid();
119   tid = __kmp_tid_from_gtid(gtid);
120   thread = __kmp_thread_from_gtid(gtid);
121 
122   __kmp_aux_convert_blocktime(&bt);
123   __kmp_aux_set_blocktime(bt, thread, tid);
124 #endif
125 }
126 
127 // Gets blocktime in units used for KMP_BLOCKTIME, ms otherwise
FTN_GET_BLOCKTIME(void)128 int FTN_STDCALL FTN_GET_BLOCKTIME(void) {
129 #ifdef KMP_STUB
130   return __kmps_get_blocktime();
131 #else
132   int gtid, tid;
133   kmp_team_p *team;
134 
135   gtid = __kmp_entry_gtid();
136   tid = __kmp_tid_from_gtid(gtid);
137   team = __kmp_threads[gtid]->th.th_team;
138 
139   /* These must match the settings used in __kmp_wait_sleep() */
140   if (__kmp_dflt_blocktime == KMP_MAX_BLOCKTIME) {
141     KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d%cs\n", gtid,
142                   team->t.t_id, tid, KMP_MAX_BLOCKTIME, __kmp_blocktime_units));
143     return KMP_MAX_BLOCKTIME;
144   }
145 #ifdef KMP_ADJUST_BLOCKTIME
146   else if (__kmp_zero_bt && !get__bt_set(team, tid)) {
147     KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d%cs\n", gtid,
148                   team->t.t_id, tid, 0, __kmp_blocktime_units));
149     return 0;
150   }
151 #endif /* KMP_ADJUST_BLOCKTIME */
152   else {
153     int bt = get__blocktime(team, tid);
154     if (__kmp_blocktime_units == 'm')
155       bt = bt / 1000;
156     KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d%cs\n", gtid,
157                   team->t.t_id, tid, bt, __kmp_blocktime_units));
158     return bt;
159   }
160 #endif
161 }
162 
FTN_SET_LIBRARY_SERIAL(void)163 void FTN_STDCALL FTN_SET_LIBRARY_SERIAL(void) {
164 #ifdef KMP_STUB
165   __kmps_set_library(library_serial);
166 #else
167   // __kmp_user_set_library initializes the library if needed
168   __kmp_user_set_library(library_serial);
169 #endif
170 }
171 
FTN_SET_LIBRARY_TURNAROUND(void)172 void FTN_STDCALL FTN_SET_LIBRARY_TURNAROUND(void) {
173 #ifdef KMP_STUB
174   __kmps_set_library(library_turnaround);
175 #else
176   // __kmp_user_set_library initializes the library if needed
177   __kmp_user_set_library(library_turnaround);
178 #endif
179 }
180 
FTN_SET_LIBRARY_THROUGHPUT(void)181 void FTN_STDCALL FTN_SET_LIBRARY_THROUGHPUT(void) {
182 #ifdef KMP_STUB
183   __kmps_set_library(library_throughput);
184 #else
185   // __kmp_user_set_library initializes the library if needed
186   __kmp_user_set_library(library_throughput);
187 #endif
188 }
189 
FTN_SET_LIBRARY(int KMP_DEREF arg)190 void FTN_STDCALL FTN_SET_LIBRARY(int KMP_DEREF arg) {
191 #ifdef KMP_STUB
192   __kmps_set_library(KMP_DEREF arg);
193 #else
194   enum library_type lib;
195   lib = (enum library_type)KMP_DEREF arg;
196   // __kmp_user_set_library initializes the library if needed
197   __kmp_user_set_library(lib);
198 #endif
199 }
200 
FTN_GET_LIBRARY(void)201 int FTN_STDCALL FTN_GET_LIBRARY(void) {
202 #ifdef KMP_STUB
203   return __kmps_get_library();
204 #else
205   if (!__kmp_init_serial) {
206     __kmp_serial_initialize();
207   }
208   return ((int)__kmp_library);
209 #endif
210 }
211 
FTN_SET_DISP_NUM_BUFFERS(int KMP_DEREF arg)212 void FTN_STDCALL FTN_SET_DISP_NUM_BUFFERS(int KMP_DEREF arg) {
213 #ifdef KMP_STUB
214   ; // empty routine
215 #else
216   // ignore after initialization because some teams have already
217   // allocated dispatch buffers
218   int num_buffers = KMP_DEREF arg;
219   if (__kmp_init_serial == FALSE && num_buffers >= KMP_MIN_DISP_NUM_BUFF &&
220       num_buffers <= KMP_MAX_DISP_NUM_BUFF) {
221     __kmp_dispatch_num_buffers = num_buffers;
222   }
223 #endif
224 }
225 
FTN_SET_AFFINITY(void ** mask)226 int FTN_STDCALL FTN_SET_AFFINITY(void **mask) {
227 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
228   return -1;
229 #else
230   if (!TCR_4(__kmp_init_middle)) {
231     __kmp_middle_initialize();
232   }
233   __kmp_assign_root_init_mask();
234   return __kmp_aux_set_affinity(mask);
235 #endif
236 }
237 
FTN_GET_AFFINITY(void ** mask)238 int FTN_STDCALL FTN_GET_AFFINITY(void **mask) {
239 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
240   return -1;
241 #else
242   if (!TCR_4(__kmp_init_middle)) {
243     __kmp_middle_initialize();
244   }
245   __kmp_assign_root_init_mask();
246   int gtid = __kmp_get_gtid();
247   if (__kmp_threads[gtid]->th.th_team->t.t_level == 0 &&
248       __kmp_affinity.flags.reset) {
249     __kmp_reset_root_init_mask(gtid);
250   }
251   return __kmp_aux_get_affinity(mask);
252 #endif
253 }
254 
FTN_GET_AFFINITY_MAX_PROC(void)255 int FTN_STDCALL FTN_GET_AFFINITY_MAX_PROC(void) {
256 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
257   return 0;
258 #else
259   // We really only NEED serial initialization here.
260   if (!TCR_4(__kmp_init_middle)) {
261     __kmp_middle_initialize();
262   }
263   __kmp_assign_root_init_mask();
264   return __kmp_aux_get_affinity_max_proc();
265 #endif
266 }
267 
FTN_CREATE_AFFINITY_MASK(void ** mask)268 void FTN_STDCALL FTN_CREATE_AFFINITY_MASK(void **mask) {
269 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
270   *mask = NULL;
271 #else
272   // We really only NEED serial initialization here.
273   kmp_affin_mask_t *mask_internals;
274   if (!TCR_4(__kmp_init_middle)) {
275     __kmp_middle_initialize();
276   }
277   __kmp_assign_root_init_mask();
278   mask_internals = __kmp_affinity_dispatch->allocate_mask();
279   KMP_CPU_ZERO(mask_internals);
280   *mask = mask_internals;
281 #endif
282 }
283 
FTN_DESTROY_AFFINITY_MASK(void ** mask)284 void FTN_STDCALL FTN_DESTROY_AFFINITY_MASK(void **mask) {
285 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
286 // Nothing
287 #else
288   // We really only NEED serial initialization here.
289   kmp_affin_mask_t *mask_internals;
290   if (!TCR_4(__kmp_init_middle)) {
291     __kmp_middle_initialize();
292   }
293   __kmp_assign_root_init_mask();
294   if (__kmp_env_consistency_check) {
295     if (*mask == NULL) {
296       KMP_FATAL(AffinityInvalidMask, "kmp_destroy_affinity_mask");
297     }
298   }
299   mask_internals = (kmp_affin_mask_t *)(*mask);
300   __kmp_affinity_dispatch->deallocate_mask(mask_internals);
301   *mask = NULL;
302 #endif
303 }
304 
FTN_SET_AFFINITY_MASK_PROC(int KMP_DEREF proc,void ** mask)305 int FTN_STDCALL FTN_SET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
306 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
307   return -1;
308 #else
309   if (!TCR_4(__kmp_init_middle)) {
310     __kmp_middle_initialize();
311   }
312   __kmp_assign_root_init_mask();
313   return __kmp_aux_set_affinity_mask_proc(KMP_DEREF proc, mask);
314 #endif
315 }
316 
FTN_UNSET_AFFINITY_MASK_PROC(int KMP_DEREF proc,void ** mask)317 int FTN_STDCALL FTN_UNSET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
318 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
319   return -1;
320 #else
321   if (!TCR_4(__kmp_init_middle)) {
322     __kmp_middle_initialize();
323   }
324   __kmp_assign_root_init_mask();
325   return __kmp_aux_unset_affinity_mask_proc(KMP_DEREF proc, mask);
326 #endif
327 }
328 
FTN_GET_AFFINITY_MASK_PROC(int KMP_DEREF proc,void ** mask)329 int FTN_STDCALL FTN_GET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
330 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
331   return -1;
332 #else
333   if (!TCR_4(__kmp_init_middle)) {
334     __kmp_middle_initialize();
335   }
336   __kmp_assign_root_init_mask();
337   return __kmp_aux_get_affinity_mask_proc(KMP_DEREF proc, mask);
338 #endif
339 }
340 
341 /* ------------------------------------------------------------------------ */
342 
343 /* sets the requested number of threads for the next parallel region */
KMP_EXPAND_NAME(FTN_SET_NUM_THREADS)344 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NUM_THREADS)(int KMP_DEREF arg) {
345 #ifdef KMP_STUB
346 // Nothing.
347 #else
348   __kmp_set_num_threads(KMP_DEREF arg, __kmp_entry_gtid());
349 #endif
350 }
351 
352 /* returns the number of threads in current team */
KMP_EXPAND_NAME(FTN_GET_NUM_THREADS)353 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_THREADS)(void) {
354 #ifdef KMP_STUB
355   return 1;
356 #else
357   // __kmpc_bound_num_threads initializes the library if needed
358   return __kmpc_bound_num_threads(NULL);
359 #endif
360 }
361 
KMP_EXPAND_NAME(FTN_GET_MAX_THREADS)362 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_THREADS)(void) {
363 #ifdef KMP_STUB
364   return 1;
365 #else
366   int gtid;
367   kmp_info_t *thread;
368   if (!TCR_4(__kmp_init_middle)) {
369     __kmp_middle_initialize();
370   }
371   gtid = __kmp_entry_gtid();
372   thread = __kmp_threads[gtid];
373 #if KMP_AFFINITY_SUPPORTED
374   if (thread->th.th_team->t.t_level == 0 && !__kmp_affinity.flags.reset) {
375     __kmp_assign_root_init_mask();
376   }
377 #endif
378   // return thread -> th.th_team -> t.t_current_task[
379   // thread->th.th_info.ds.ds_tid ] -> icvs.nproc;
380   return thread->th.th_current_task->td_icvs.nproc;
381 #endif
382 }
383 
FTN_CONTROL_TOOL(int command,int modifier,void * arg)384 int FTN_STDCALL FTN_CONTROL_TOOL(int command, int modifier, void *arg) {
385 #if defined(KMP_STUB) || !OMPT_SUPPORT
386   return -2;
387 #else
388   OMPT_STORE_RETURN_ADDRESS(__kmp_entry_gtid());
389   if (!TCR_4(__kmp_init_middle)) {
390     return -2;
391   }
392   kmp_info_t *this_thr = __kmp_threads[__kmp_entry_gtid()];
393   ompt_task_info_t *parent_task_info = OMPT_CUR_TASK_INFO(this_thr);
394   parent_task_info->frame.enter_frame.ptr = OMPT_GET_FRAME_ADDRESS(0);
395   int ret = __kmp_control_tool(command, modifier, arg);
396   parent_task_info->frame.enter_frame.ptr = 0;
397   return ret;
398 #endif
399 }
400 
401 /* OpenMP 5.0 Memory Management support */
402 omp_allocator_handle_t FTN_STDCALL
FTN_INIT_ALLOCATOR(omp_memspace_handle_t KMP_DEREF m,int KMP_DEREF ntraits,omp_alloctrait_t tr[])403 FTN_INIT_ALLOCATOR(omp_memspace_handle_t KMP_DEREF m, int KMP_DEREF ntraits,
404                    omp_alloctrait_t tr[]) {
405 #ifdef KMP_STUB
406   return NULL;
407 #else
408   return __kmpc_init_allocator(__kmp_entry_gtid(), KMP_DEREF m,
409                                KMP_DEREF ntraits, tr);
410 #endif
411 }
412 
FTN_DESTROY_ALLOCATOR(omp_allocator_handle_t al)413 void FTN_STDCALL FTN_DESTROY_ALLOCATOR(omp_allocator_handle_t al) {
414 #ifndef KMP_STUB
415   __kmpc_destroy_allocator(__kmp_entry_gtid(), al);
416 #endif
417 }
FTN_SET_DEFAULT_ALLOCATOR(omp_allocator_handle_t al)418 void FTN_STDCALL FTN_SET_DEFAULT_ALLOCATOR(omp_allocator_handle_t al) {
419 #ifndef KMP_STUB
420   __kmpc_set_default_allocator(__kmp_entry_gtid(), al);
421 #endif
422 }
FTN_GET_DEFAULT_ALLOCATOR(void)423 omp_allocator_handle_t FTN_STDCALL FTN_GET_DEFAULT_ALLOCATOR(void) {
424 #ifdef KMP_STUB
425   return NULL;
426 #else
427   return __kmpc_get_default_allocator(__kmp_entry_gtid());
428 #endif
429 }
430 
431 /* OpenMP 6.0 (TR11) Memory Management support */
432 omp_memspace_handle_t FTN_STDCALL
FTN_GET_DEVICES_MEMSPACE(int KMP_DEREF ndevs,const int * devs,omp_memspace_handle_t KMP_DEREF memspace)433 FTN_GET_DEVICES_MEMSPACE(int KMP_DEREF ndevs, const int *devs,
434                          omp_memspace_handle_t KMP_DEREF memspace) {
435 #ifdef KMP_STUB
436   return NULL;
437 #else
438   return __kmp_get_devices_memspace(KMP_DEREF ndevs, devs, KMP_DEREF memspace,
439                                     0 /* host */);
440 #endif
441 }
442 
FTN_GET_DEVICE_MEMSPACE(int KMP_DEREF dev,omp_memspace_handle_t KMP_DEREF memspace)443 omp_memspace_handle_t FTN_STDCALL FTN_GET_DEVICE_MEMSPACE(
444     int KMP_DEREF dev, omp_memspace_handle_t KMP_DEREF memspace) {
445 #ifdef KMP_STUB
446   return NULL;
447 #else
448   int dev_num = KMP_DEREF dev;
449   return __kmp_get_devices_memspace(1, &dev_num, KMP_DEREF memspace, 0);
450 #endif
451 }
452 
453 omp_memspace_handle_t FTN_STDCALL
FTN_GET_DEVICES_AND_HOST_MEMSPACE(int KMP_DEREF ndevs,const int * devs,omp_memspace_handle_t KMP_DEREF memspace)454 FTN_GET_DEVICES_AND_HOST_MEMSPACE(int KMP_DEREF ndevs, const int *devs,
455                                   omp_memspace_handle_t KMP_DEREF memspace) {
456 #ifdef KMP_STUB
457   return NULL;
458 #else
459   return __kmp_get_devices_memspace(KMP_DEREF ndevs, devs, KMP_DEREF memspace,
460                                     1);
461 #endif
462 }
463 
FTN_GET_DEVICE_AND_HOST_MEMSPACE(int KMP_DEREF dev,omp_memspace_handle_t KMP_DEREF memspace)464 omp_memspace_handle_t FTN_STDCALL FTN_GET_DEVICE_AND_HOST_MEMSPACE(
465     int KMP_DEREF dev, omp_memspace_handle_t KMP_DEREF memspace) {
466 #ifdef KMP_STUB
467   return NULL;
468 #else
469   int dev_num = KMP_DEREF dev;
470   return __kmp_get_devices_memspace(1, &dev_num, KMP_DEREF memspace, 1);
471 #endif
472 }
473 
474 omp_memspace_handle_t FTN_STDCALL
FTN_GET_DEVICES_ALL_MEMSPACE(omp_memspace_handle_t KMP_DEREF memspace)475 FTN_GET_DEVICES_ALL_MEMSPACE(omp_memspace_handle_t KMP_DEREF memspace) {
476 #ifdef KMP_STUB
477   return NULL;
478 #else
479   return __kmp_get_devices_memspace(0, NULL, KMP_DEREF memspace, 1);
480 #endif
481 }
482 
483 omp_allocator_handle_t FTN_STDCALL
FTN_GET_DEVICES_ALLOCATOR(int KMP_DEREF ndevs,const int * devs,omp_allocator_handle_t KMP_DEREF memspace)484 FTN_GET_DEVICES_ALLOCATOR(int KMP_DEREF ndevs, const int *devs,
485                           omp_allocator_handle_t KMP_DEREF memspace) {
486 #ifdef KMP_STUB
487   return NULL;
488 #else
489   return __kmp_get_devices_allocator(KMP_DEREF ndevs, devs, KMP_DEREF memspace,
490                                      0 /* host */);
491 #endif
492 }
493 
FTN_GET_DEVICE_ALLOCATOR(int KMP_DEREF dev,omp_allocator_handle_t KMP_DEREF memspace)494 omp_allocator_handle_t FTN_STDCALL FTN_GET_DEVICE_ALLOCATOR(
495     int KMP_DEREF dev, omp_allocator_handle_t KMP_DEREF memspace) {
496 #ifdef KMP_STUB
497   return NULL;
498 #else
499   int dev_num = KMP_DEREF dev;
500   return __kmp_get_devices_allocator(1, &dev_num, KMP_DEREF memspace, 0);
501 #endif
502 }
503 
504 omp_allocator_handle_t FTN_STDCALL
FTN_GET_DEVICES_AND_HOST_ALLOCATOR(int KMP_DEREF ndevs,const int * devs,omp_allocator_handle_t KMP_DEREF memspace)505 FTN_GET_DEVICES_AND_HOST_ALLOCATOR(int KMP_DEREF ndevs, const int *devs,
506                                    omp_allocator_handle_t KMP_DEREF memspace) {
507 #ifdef KMP_STUB
508   return NULL;
509 #else
510   return __kmp_get_devices_allocator(KMP_DEREF ndevs, devs, KMP_DEREF memspace,
511                                      1);
512 #endif
513 }
514 
FTN_GET_DEVICE_AND_HOST_ALLOCATOR(int KMP_DEREF dev,omp_allocator_handle_t KMP_DEREF memspace)515 omp_allocator_handle_t FTN_STDCALL FTN_GET_DEVICE_AND_HOST_ALLOCATOR(
516     int KMP_DEREF dev, omp_allocator_handle_t KMP_DEREF memspace) {
517 #ifdef KMP_STUB
518   return NULL;
519 #else
520   int dev_num = KMP_DEREF dev;
521   return __kmp_get_devices_allocator(1, &dev_num, KMP_DEREF memspace, 1);
522 #endif
523 }
524 
525 omp_allocator_handle_t FTN_STDCALL
FTN_GET_DEVICES_ALL_ALLOCATOR(omp_allocator_handle_t KMP_DEREF memspace)526 FTN_GET_DEVICES_ALL_ALLOCATOR(omp_allocator_handle_t KMP_DEREF memspace) {
527 #ifdef KMP_STUB
528   return NULL;
529 #else
530   return __kmp_get_devices_allocator(0, NULL, KMP_DEREF memspace, 1);
531 #endif
532 }
533 
534 int FTN_STDCALL
FTN_GET_MEMSPACE_NUM_RESOURCES(omp_memspace_handle_t KMP_DEREF memspace)535 FTN_GET_MEMSPACE_NUM_RESOURCES(omp_memspace_handle_t KMP_DEREF memspace) {
536 #ifdef KMP_STUB
537   return 0;
538 #else
539   return __kmp_get_memspace_num_resources(KMP_DEREF memspace);
540 #endif
541 }
542 
543 omp_memspace_handle_t FTN_STDCALL
FTN_GET_SUBMEMSPACE(omp_memspace_handle_t KMP_DEREF memspace,int KMP_DEREF num_resources,int * resources)544 FTN_GET_SUBMEMSPACE(omp_memspace_handle_t KMP_DEREF memspace,
545                     int KMP_DEREF num_resources, int *resources) {
546 #ifdef KMP_STUB
547   return NULL;
548 #else
549   return __kmp_get_submemspace(KMP_DEREF memspace, KMP_DEREF num_resources,
550                                resources);
551 #endif
552 }
553 
554 /* OpenMP 5.0 affinity format support */
555 #ifndef KMP_STUB
__kmp_fortran_strncpy_truncate(char * buffer,size_t buf_size,char const * csrc,size_t csrc_size)556 static void __kmp_fortran_strncpy_truncate(char *buffer, size_t buf_size,
557                                            char const *csrc, size_t csrc_size) {
558   size_t capped_src_size = csrc_size;
559   if (csrc_size >= buf_size) {
560     capped_src_size = buf_size - 1;
561   }
562   KMP_STRNCPY_S(buffer, buf_size, csrc, capped_src_size);
563   if (csrc_size >= buf_size) {
564     KMP_DEBUG_ASSERT(buffer[buf_size - 1] == '\0');
565     buffer[buf_size - 1] = csrc[buf_size - 1];
566   } else {
567     for (size_t i = csrc_size; i < buf_size; ++i)
568       buffer[i] = ' ';
569   }
570 }
571 
572 // Convert a Fortran string to a C string by adding null byte
573 class ConvertedString {
574   char *buf;
575   kmp_info_t *th;
576 
577 public:
ConvertedString(char const * fortran_str,size_t size)578   ConvertedString(char const *fortran_str, size_t size) {
579     th = __kmp_get_thread();
580     buf = (char *)__kmp_thread_malloc(th, size + 1);
581     KMP_STRNCPY_S(buf, size + 1, fortran_str, size);
582     buf[size] = '\0';
583   }
~ConvertedString()584   ~ConvertedString() { __kmp_thread_free(th, buf); }
get()585   const char *get() const { return buf; }
586 };
587 #endif // KMP_STUB
588 
589 /*
590  * Set the value of the affinity-format-var ICV on the current device to the
591  * format specified in the argument.
592  */
KMP_EXPAND_NAME_IF_APPEND(FTN_SET_AFFINITY_FORMAT)593 void FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_SET_AFFINITY_FORMAT)(
594     char const *format, size_t size) {
595 #ifdef KMP_STUB
596   return;
597 #else
598   if (!__kmp_init_serial) {
599     __kmp_serial_initialize();
600   }
601   ConvertedString cformat(format, size);
602   // Since the __kmp_affinity_format variable is a C string, do not
603   // use the fortran strncpy function
604   __kmp_strncpy_truncate(__kmp_affinity_format, KMP_AFFINITY_FORMAT_SIZE,
605                          cformat.get(), KMP_STRLEN(cformat.get()));
606 #endif
607 }
608 
609 /*
610  * Returns the number of characters required to hold the entire affinity format
611  * specification (not including null byte character) and writes the value of the
612  * affinity-format-var ICV on the current device to buffer. If the return value
613  * is larger than size, the affinity format specification is truncated.
614  */
KMP_EXPAND_NAME_IF_APPEND(FTN_GET_AFFINITY_FORMAT)615 size_t FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_GET_AFFINITY_FORMAT)(
616     char *buffer, size_t size) {
617 #ifdef KMP_STUB
618   return 0;
619 #else
620   size_t format_size;
621   if (!__kmp_init_serial) {
622     __kmp_serial_initialize();
623   }
624   format_size = KMP_STRLEN(__kmp_affinity_format);
625   if (buffer && size) {
626     __kmp_fortran_strncpy_truncate(buffer, size, __kmp_affinity_format,
627                                    format_size);
628   }
629   return format_size;
630 #endif
631 }
632 
633 /*
634  * Prints the thread affinity information of the current thread in the format
635  * specified by the format argument. If the format is NULL or a zero-length
636  * string, the value of the affinity-format-var ICV is used.
637  */
KMP_EXPAND_NAME_IF_APPEND(FTN_DISPLAY_AFFINITY)638 void FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_DISPLAY_AFFINITY)(
639     char const *format, size_t size) {
640 #ifdef KMP_STUB
641   return;
642 #else
643   int gtid;
644   if (!TCR_4(__kmp_init_middle)) {
645     __kmp_middle_initialize();
646   }
647   __kmp_assign_root_init_mask();
648   gtid = __kmp_get_gtid();
649 #if KMP_AFFINITY_SUPPORTED
650   if (__kmp_threads[gtid]->th.th_team->t.t_level == 0 &&
651       __kmp_affinity.flags.reset) {
652     __kmp_reset_root_init_mask(gtid);
653   }
654 #endif
655   ConvertedString cformat(format, size);
656   __kmp_aux_display_affinity(gtid, cformat.get());
657 #endif
658 }
659 
660 /*
661  * Returns the number of characters required to hold the entire affinity format
662  * specification (not including null byte) and prints the thread affinity
663  * information of the current thread into the character string buffer with the
664  * size of size in the format specified by the format argument. If the format is
665  * NULL or a zero-length string, the value of the affinity-format-var ICV is
666  * used. The buffer must be allocated prior to calling the routine. If the
667  * return value is larger than size, the affinity format specification is
668  * truncated.
669  */
KMP_EXPAND_NAME_IF_APPEND(FTN_CAPTURE_AFFINITY)670 size_t FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_CAPTURE_AFFINITY)(
671     char *buffer, char const *format, size_t buf_size, size_t for_size) {
672 #if defined(KMP_STUB)
673   return 0;
674 #else
675   int gtid;
676   size_t num_required;
677   kmp_str_buf_t capture_buf;
678   if (!TCR_4(__kmp_init_middle)) {
679     __kmp_middle_initialize();
680   }
681   __kmp_assign_root_init_mask();
682   gtid = __kmp_get_gtid();
683 #if KMP_AFFINITY_SUPPORTED
684   if (__kmp_threads[gtid]->th.th_team->t.t_level == 0 &&
685       __kmp_affinity.flags.reset) {
686     __kmp_reset_root_init_mask(gtid);
687   }
688 #endif
689   __kmp_str_buf_init(&capture_buf);
690   ConvertedString cformat(format, for_size);
691   num_required = __kmp_aux_capture_affinity(gtid, cformat.get(), &capture_buf);
692   if (buffer && buf_size) {
693     __kmp_fortran_strncpy_truncate(buffer, buf_size, capture_buf.str,
694                                    capture_buf.used);
695   }
696   __kmp_str_buf_free(&capture_buf);
697   return num_required;
698 #endif
699 }
700 
KMP_EXPAND_NAME(FTN_GET_THREAD_NUM)701 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_NUM)(void) {
702 #ifdef KMP_STUB
703   return 0;
704 #else
705   int gtid;
706 
707 #if KMP_OS_DARWIN || KMP_OS_DRAGONFLY || KMP_OS_FREEBSD || KMP_OS_NETBSD ||    \
708     KMP_OS_OPENBSD || KMP_OS_HAIKU || KMP_OS_HURD || KMP_OS_SOLARIS ||         \
709     KMP_OS_AIX
710   gtid = __kmp_entry_gtid();
711 #elif KMP_OS_WINDOWS
712   if (!__kmp_init_parallel ||
713       (gtid = (int)((kmp_intptr_t)TlsGetValue(__kmp_gtid_threadprivate_key))) ==
714           0) {
715     // Either library isn't initialized or thread is not registered
716     // 0 is the correct TID in this case
717     return 0;
718   }
719   --gtid; // We keep (gtid+1) in TLS
720 #elif KMP_OS_LINUX || KMP_OS_WASI
721 #ifdef KMP_TDATA_GTID
722   if (__kmp_gtid_mode >= 3) {
723     if ((gtid = __kmp_gtid) == KMP_GTID_DNE) {
724       return 0;
725     }
726   } else {
727 #endif
728     if (!__kmp_init_parallel ||
729         (gtid = (int)((kmp_intptr_t)(
730              pthread_getspecific(__kmp_gtid_threadprivate_key)))) == 0) {
731       return 0;
732     }
733     --gtid;
734 #ifdef KMP_TDATA_GTID
735   }
736 #endif
737 #else
738 #error Unknown or unsupported OS
739 #endif
740 
741   return __kmp_tid_from_gtid(gtid);
742 #endif
743 }
744 
FTN_GET_NUM_KNOWN_THREADS(void)745 int FTN_STDCALL FTN_GET_NUM_KNOWN_THREADS(void) {
746 #ifdef KMP_STUB
747   return 1;
748 #else
749   if (!__kmp_init_serial) {
750     __kmp_serial_initialize();
751   }
752   /* NOTE: this is not syncronized, so it can change at any moment */
753   /* NOTE: this number also includes threads preallocated in hot-teams */
754   return TCR_4(__kmp_nth);
755 #endif
756 }
757 
KMP_EXPAND_NAME(FTN_GET_NUM_PROCS)758 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_PROCS)(void) {
759 #ifdef KMP_STUB
760   return 1;
761 #else
762   if (!TCR_4(__kmp_init_middle)) {
763     __kmp_middle_initialize();
764   }
765 #if KMP_AFFINITY_SUPPORTED
766   if (!__kmp_affinity.flags.reset) {
767     // only bind root here if its affinity reset is not requested
768     int gtid = __kmp_entry_gtid();
769     kmp_info_t *thread = __kmp_threads[gtid];
770     if (thread->th.th_team->t.t_level == 0) {
771       __kmp_assign_root_init_mask();
772     }
773   }
774 #endif
775   return __kmp_avail_proc;
776 #endif
777 }
778 
KMP_EXPAND_NAME(FTN_SET_NESTED)779 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NESTED)(int KMP_DEREF flag) {
780 #ifdef KMP_STUB
781   __kmps_set_nested(KMP_DEREF flag);
782 #else
783   kmp_info_t *thread;
784   /* For the thread-private internal controls implementation */
785   thread = __kmp_entry_thread();
786   KMP_INFORM(APIDeprecated, "omp_set_nested", "omp_set_max_active_levels");
787   __kmp_save_internal_controls(thread);
788   // Somewhat arbitrarily decide where to get a value for max_active_levels
789   int max_active_levels = get__max_active_levels(thread);
790   if (max_active_levels == 1)
791     max_active_levels = KMP_MAX_ACTIVE_LEVELS_LIMIT;
792   set__max_active_levels(thread, (KMP_DEREF flag) ? max_active_levels : 1);
793 #endif
794 }
795 
KMP_EXPAND_NAME(FTN_GET_NESTED)796 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NESTED)(void) {
797 #ifdef KMP_STUB
798   return __kmps_get_nested();
799 #else
800   kmp_info_t *thread;
801   thread = __kmp_entry_thread();
802   KMP_INFORM(APIDeprecated, "omp_get_nested", "omp_get_max_active_levels");
803   return get__max_active_levels(thread) > 1;
804 #endif
805 }
806 
KMP_EXPAND_NAME(FTN_SET_DYNAMIC)807 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_DYNAMIC)(int KMP_DEREF flag) {
808 #ifdef KMP_STUB
809   __kmps_set_dynamic(KMP_DEREF flag ? TRUE : FALSE);
810 #else
811   kmp_info_t *thread;
812   /* For the thread-private implementation of the internal controls */
813   thread = __kmp_entry_thread();
814   // !!! What if foreign thread calls it?
815   __kmp_save_internal_controls(thread);
816   set__dynamic(thread, KMP_DEREF flag ? true : false);
817 #endif
818 }
819 
KMP_EXPAND_NAME(FTN_GET_DYNAMIC)820 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_DYNAMIC)(void) {
821 #ifdef KMP_STUB
822   return __kmps_get_dynamic();
823 #else
824   kmp_info_t *thread;
825   thread = __kmp_entry_thread();
826   return get__dynamic(thread);
827 #endif
828 }
829 
KMP_EXPAND_NAME(FTN_IN_PARALLEL)830 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IN_PARALLEL)(void) {
831 #ifdef KMP_STUB
832   return 0;
833 #else
834   kmp_info_t *th = __kmp_entry_thread();
835   if (th->th.th_teams_microtask) {
836     // AC: r_in_parallel does not work inside teams construct where real
837     // parallel is inactive, but all threads have same root, so setting it in
838     // one team affects other teams.
839     // The solution is to use per-team nesting level
840     return (th->th.th_team->t.t_active_level ? 1 : 0);
841   } else
842     return (th->th.th_root->r.r_in_parallel ? FTN_TRUE : FTN_FALSE);
843 #endif
844 }
845 
KMP_EXPAND_NAME(FTN_SET_SCHEDULE)846 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_SCHEDULE)(kmp_sched_t KMP_DEREF kind,
847                                                    int KMP_DEREF modifier) {
848 #ifdef KMP_STUB
849   __kmps_set_schedule(KMP_DEREF kind, KMP_DEREF modifier);
850 #else
851   /* TO DO: For the per-task implementation of the internal controls */
852   __kmp_set_schedule(__kmp_entry_gtid(), KMP_DEREF kind, KMP_DEREF modifier);
853 #endif
854 }
855 
KMP_EXPAND_NAME(FTN_GET_SCHEDULE)856 void FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_SCHEDULE)(kmp_sched_t *kind,
857                                                    int *modifier) {
858 #ifdef KMP_STUB
859   __kmps_get_schedule(kind, modifier);
860 #else
861   /* TO DO: For the per-task implementation of the internal controls */
862   __kmp_get_schedule(__kmp_entry_gtid(), kind, modifier);
863 #endif
864 }
865 
KMP_EXPAND_NAME(FTN_SET_MAX_ACTIVE_LEVELS)866 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_MAX_ACTIVE_LEVELS)(int KMP_DEREF arg) {
867 #ifdef KMP_STUB
868 // Nothing.
869 #else
870   /* TO DO: We want per-task implementation of this internal control */
871   __kmp_set_max_active_levels(__kmp_entry_gtid(), KMP_DEREF arg);
872 #endif
873 }
874 
KMP_EXPAND_NAME(FTN_GET_MAX_ACTIVE_LEVELS)875 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_ACTIVE_LEVELS)(void) {
876 #ifdef KMP_STUB
877   return 0;
878 #else
879   /* TO DO: We want per-task implementation of this internal control */
880   if (!TCR_4(__kmp_init_middle)) {
881     __kmp_middle_initialize();
882   }
883   return __kmp_get_max_active_levels(__kmp_entry_gtid());
884 #endif
885 }
886 
KMP_EXPAND_NAME(FTN_GET_ACTIVE_LEVEL)887 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_ACTIVE_LEVEL)(void) {
888 #ifdef KMP_STUB
889   return 0; // returns 0 if it is called from the sequential part of the program
890 #else
891   /* TO DO: For the per-task implementation of the internal controls */
892   return __kmp_entry_thread()->th.th_team->t.t_active_level;
893 #endif
894 }
895 
KMP_EXPAND_NAME(FTN_GET_LEVEL)896 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_LEVEL)(void) {
897 #ifdef KMP_STUB
898   return 0; // returns 0 if it is called from the sequential part of the program
899 #else
900   /* TO DO: For the per-task implementation of the internal controls */
901   return __kmp_entry_thread()->th.th_team->t.t_level;
902 #endif
903 }
904 
905 int FTN_STDCALL
KMP_EXPAND_NAME(FTN_GET_ANCESTOR_THREAD_NUM)906 KMP_EXPAND_NAME(FTN_GET_ANCESTOR_THREAD_NUM)(int KMP_DEREF level) {
907 #ifdef KMP_STUB
908   return (KMP_DEREF level) ? (-1) : (0);
909 #else
910   return __kmp_get_ancestor_thread_num(__kmp_entry_gtid(), KMP_DEREF level);
911 #endif
912 }
913 
KMP_EXPAND_NAME(FTN_GET_TEAM_SIZE)914 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_TEAM_SIZE)(int KMP_DEREF level) {
915 #ifdef KMP_STUB
916   return (KMP_DEREF level) ? (-1) : (1);
917 #else
918   return __kmp_get_team_size(__kmp_entry_gtid(), KMP_DEREF level);
919 #endif
920 }
921 
KMP_EXPAND_NAME(FTN_GET_THREAD_LIMIT)922 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_LIMIT)(void) {
923 #ifdef KMP_STUB
924   return 1; // TO DO: clarify whether it returns 1 or 0?
925 #else
926   int gtid;
927   kmp_info_t *thread;
928   if (!__kmp_init_serial) {
929     __kmp_serial_initialize();
930   }
931 
932   gtid = __kmp_entry_gtid();
933   thread = __kmp_threads[gtid];
934   // If thread_limit for the target task is defined, return that instead of the
935   // regular task thread_limit
936   if (int thread_limit = thread->th.th_current_task->td_icvs.task_thread_limit)
937     return thread_limit;
938   return thread->th.th_current_task->td_icvs.thread_limit;
939 #endif
940 }
941 
KMP_EXPAND_NAME(FTN_IN_FINAL)942 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IN_FINAL)(void) {
943 #ifdef KMP_STUB
944   return 0; // TO DO: clarify whether it returns 1 or 0?
945 #else
946   if (!TCR_4(__kmp_init_parallel)) {
947     return 0;
948   }
949   return __kmp_entry_thread()->th.th_current_task->td_flags.final;
950 #endif
951 }
952 
KMP_EXPAND_NAME(FTN_GET_PROC_BIND)953 kmp_proc_bind_t FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PROC_BIND)(void) {
954 #ifdef KMP_STUB
955   return __kmps_get_proc_bind();
956 #else
957   return get__proc_bind(__kmp_entry_thread());
958 #endif
959 }
960 
KMP_EXPAND_NAME(FTN_GET_NUM_PLACES)961 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_PLACES)(void) {
962 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
963   return 0;
964 #else
965   if (!TCR_4(__kmp_init_middle)) {
966     __kmp_middle_initialize();
967   }
968   if (!KMP_AFFINITY_CAPABLE())
969     return 0;
970   if (!__kmp_affinity.flags.reset) {
971     // only bind root here if its affinity reset is not requested
972     int gtid = __kmp_entry_gtid();
973     kmp_info_t *thread = __kmp_threads[gtid];
974     if (thread->th.th_team->t.t_level == 0) {
975       __kmp_assign_root_init_mask();
976     }
977   }
978   return __kmp_affinity.num_masks;
979 #endif
980 }
981 
KMP_EXPAND_NAME(FTN_GET_PLACE_NUM_PROCS)982 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_NUM_PROCS)(int place_num) {
983 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
984   return 0;
985 #else
986   int i;
987   int retval = 0;
988   if (!TCR_4(__kmp_init_middle)) {
989     __kmp_middle_initialize();
990   }
991   if (!KMP_AFFINITY_CAPABLE())
992     return 0;
993   if (!__kmp_affinity.flags.reset) {
994     // only bind root here if its affinity reset is not requested
995     int gtid = __kmp_entry_gtid();
996     kmp_info_t *thread = __kmp_threads[gtid];
997     if (thread->th.th_team->t.t_level == 0) {
998       __kmp_assign_root_init_mask();
999     }
1000   }
1001   if (place_num < 0 || place_num >= (int)__kmp_affinity.num_masks)
1002     return 0;
1003   kmp_affin_mask_t *mask = KMP_CPU_INDEX(__kmp_affinity.masks, place_num);
1004   KMP_CPU_SET_ITERATE(i, mask) {
1005     if ((!KMP_CPU_ISSET(i, __kmp_affin_fullMask)) ||
1006         (!KMP_CPU_ISSET(i, mask))) {
1007       continue;
1008     }
1009     ++retval;
1010   }
1011   return retval;
1012 #endif
1013 }
1014 
KMP_EXPAND_NAME(FTN_GET_PLACE_PROC_IDS)1015 void FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_PROC_IDS)(int place_num,
1016                                                          int *ids) {
1017 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
1018 // Nothing.
1019 #else
1020   int i, j;
1021   if (!TCR_4(__kmp_init_middle)) {
1022     __kmp_middle_initialize();
1023   }
1024   if (!KMP_AFFINITY_CAPABLE())
1025     return;
1026   if (!__kmp_affinity.flags.reset) {
1027     // only bind root here if its affinity reset is not requested
1028     int gtid = __kmp_entry_gtid();
1029     kmp_info_t *thread = __kmp_threads[gtid];
1030     if (thread->th.th_team->t.t_level == 0) {
1031       __kmp_assign_root_init_mask();
1032     }
1033   }
1034   if (place_num < 0 || place_num >= (int)__kmp_affinity.num_masks)
1035     return;
1036   kmp_affin_mask_t *mask = KMP_CPU_INDEX(__kmp_affinity.masks, place_num);
1037   j = 0;
1038   KMP_CPU_SET_ITERATE(i, mask) {
1039     if ((!KMP_CPU_ISSET(i, __kmp_affin_fullMask)) ||
1040         (!KMP_CPU_ISSET(i, mask))) {
1041       continue;
1042     }
1043     ids[j++] = i;
1044   }
1045 #endif
1046 }
1047 
KMP_EXPAND_NAME(FTN_GET_PLACE_NUM)1048 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PLACE_NUM)(void) {
1049 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
1050   return -1;
1051 #else
1052   int gtid;
1053   kmp_info_t *thread;
1054   if (!TCR_4(__kmp_init_middle)) {
1055     __kmp_middle_initialize();
1056   }
1057   if (!KMP_AFFINITY_CAPABLE())
1058     return -1;
1059   gtid = __kmp_entry_gtid();
1060   thread = __kmp_thread_from_gtid(gtid);
1061   if (thread->th.th_team->t.t_level == 0 && !__kmp_affinity.flags.reset) {
1062     __kmp_assign_root_init_mask();
1063   }
1064   if (thread->th.th_current_place < 0)
1065     return -1;
1066   return thread->th.th_current_place;
1067 #endif
1068 }
1069 
KMP_EXPAND_NAME(FTN_GET_PARTITION_NUM_PLACES)1070 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_PARTITION_NUM_PLACES)(void) {
1071 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
1072   return 0;
1073 #else
1074   int gtid, num_places, first_place, last_place;
1075   kmp_info_t *thread;
1076   if (!TCR_4(__kmp_init_middle)) {
1077     __kmp_middle_initialize();
1078   }
1079   if (!KMP_AFFINITY_CAPABLE())
1080     return 0;
1081   gtid = __kmp_entry_gtid();
1082   thread = __kmp_thread_from_gtid(gtid);
1083   if (thread->th.th_team->t.t_level == 0 && !__kmp_affinity.flags.reset) {
1084     __kmp_assign_root_init_mask();
1085   }
1086   first_place = thread->th.th_first_place;
1087   last_place = thread->th.th_last_place;
1088   if (first_place < 0 || last_place < 0)
1089     return 0;
1090   if (first_place <= last_place)
1091     num_places = last_place - first_place + 1;
1092   else
1093     num_places = __kmp_affinity.num_masks - first_place + last_place + 1;
1094   return num_places;
1095 #endif
1096 }
1097 
1098 void FTN_STDCALL
KMP_EXPAND_NAME(FTN_GET_PARTITION_PLACE_NUMS)1099 KMP_EXPAND_NAME(FTN_GET_PARTITION_PLACE_NUMS)(int *place_nums) {
1100 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
1101 // Nothing.
1102 #else
1103   int i, gtid, place_num, first_place, last_place, start, end;
1104   kmp_info_t *thread;
1105   if (!TCR_4(__kmp_init_middle)) {
1106     __kmp_middle_initialize();
1107   }
1108   if (!KMP_AFFINITY_CAPABLE())
1109     return;
1110   gtid = __kmp_entry_gtid();
1111   thread = __kmp_thread_from_gtid(gtid);
1112   if (thread->th.th_team->t.t_level == 0 && !__kmp_affinity.flags.reset) {
1113     __kmp_assign_root_init_mask();
1114   }
1115   first_place = thread->th.th_first_place;
1116   last_place = thread->th.th_last_place;
1117   if (first_place < 0 || last_place < 0)
1118     return;
1119   if (first_place <= last_place) {
1120     start = first_place;
1121     end = last_place;
1122   } else {
1123     start = last_place;
1124     end = first_place;
1125   }
1126   for (i = 0, place_num = start; place_num <= end; ++place_num, ++i) {
1127     place_nums[i] = place_num;
1128   }
1129 #endif
1130 }
1131 
KMP_EXPAND_NAME(FTN_GET_NUM_TEAMS)1132 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_TEAMS)(void) {
1133 #ifdef KMP_STUB
1134   return 1;
1135 #else
1136   return __kmp_aux_get_num_teams();
1137 #endif
1138 }
1139 
KMP_EXPAND_NAME(FTN_GET_TEAM_NUM)1140 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_TEAM_NUM)(void) {
1141 #ifdef KMP_STUB
1142   return 0;
1143 #else
1144   return __kmp_aux_get_team_num();
1145 #endif
1146 }
1147 
KMP_EXPAND_NAME(FTN_GET_DEFAULT_DEVICE)1148 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_DEFAULT_DEVICE)(void) {
1149 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
1150   return 0;
1151 #else
1152   return __kmp_entry_thread()->th.th_current_task->td_icvs.default_device;
1153 #endif
1154 }
1155 
KMP_EXPAND_NAME(FTN_SET_DEFAULT_DEVICE)1156 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_DEFAULT_DEVICE)(int KMP_DEREF arg) {
1157 #if KMP_MIC || KMP_OS_DARWIN || defined(KMP_STUB)
1158 // Nothing.
1159 #else
1160   __kmp_entry_thread()->th.th_current_task->td_icvs.default_device =
1161       KMP_DEREF arg;
1162 #endif
1163 }
1164 
1165 // Get number of NON-HOST devices.
1166 // libomptarget, if loaded, provides this function in api.cpp.
1167 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)(void)
1168     KMP_WEAK_ATTRIBUTE_EXTERNAL;
KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)1169 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)(void) {
1170 #if KMP_MIC || KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1171   return 0;
1172 #else
1173   int (*fptr)();
1174   if ((*(void **)(&fptr) = KMP_DLSYM("__tgt_get_num_devices"))) {
1175     return (*fptr)();
1176   } else if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_num_devices"))) {
1177     return (*fptr)();
1178   } else if ((*(void **)(&fptr) = KMP_DLSYM("_Offload_number_of_devices"))) {
1179     return (*fptr)();
1180   } else { // liboffload & libomptarget don't exist
1181     return 0;
1182   }
1183 #endif // KMP_MIC || KMP_OS_DARWIN || KMP_OS_WINDOWS || defined(KMP_STUB)
1184 }
1185 
1186 // This function always returns true when called on host device.
1187 // Compiler/libomptarget should handle when it is called inside target region.
1188 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)(void)
1189     KMP_WEAK_ATTRIBUTE_EXTERNAL;
KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)1190 int FTN_STDCALL KMP_EXPAND_NAME(FTN_IS_INITIAL_DEVICE)(void) {
1191   return 1; // This is the host
1192 }
1193 
1194 // libomptarget, if loaded, provides this function
1195 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)(void)
1196     KMP_WEAK_ATTRIBUTE_EXTERNAL;
KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)1197 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)(void) {
1198   // same as omp_get_num_devices()
1199   return KMP_EXPAND_NAME(FTN_GET_NUM_DEVICES)();
1200 }
1201 
1202 #if defined(KMP_STUB)
1203 // Entries for stubs library
1204 // As all *target* functions are C-only parameters always passed by value
FTN_TARGET_ALLOC(size_t size,int device_num)1205 void *FTN_STDCALL FTN_TARGET_ALLOC(size_t size, int device_num) { return 0; }
1206 
FTN_TARGET_FREE(void * device_ptr,int device_num)1207 void FTN_STDCALL FTN_TARGET_FREE(void *device_ptr, int device_num) {}
1208 
FTN_TARGET_IS_PRESENT(void * ptr,int device_num)1209 int FTN_STDCALL FTN_TARGET_IS_PRESENT(void *ptr, int device_num) { return 0; }
1210 
FTN_TARGET_MEMCPY(void * dst,void * src,size_t length,size_t dst_offset,size_t src_offset,int dst_device,int src_device)1211 int FTN_STDCALL FTN_TARGET_MEMCPY(void *dst, void *src, size_t length,
1212                                   size_t dst_offset, size_t src_offset,
1213                                   int dst_device, int src_device) {
1214   return -1;
1215 }
1216 
FTN_TARGET_MEMCPY_RECT(void * dst,void * src,size_t element_size,int num_dims,const size_t * volume,const size_t * dst_offsets,const size_t * src_offsets,const size_t * dst_dimensions,const size_t * src_dimensions,int dst_device,int src_device)1217 int FTN_STDCALL FTN_TARGET_MEMCPY_RECT(
1218     void *dst, void *src, size_t element_size, int num_dims,
1219     const size_t *volume, const size_t *dst_offsets, const size_t *src_offsets,
1220     const size_t *dst_dimensions, const size_t *src_dimensions, int dst_device,
1221     int src_device) {
1222   return -1;
1223 }
1224 
FTN_TARGET_ASSOCIATE_PTR(void * host_ptr,void * device_ptr,size_t size,size_t device_offset,int device_num)1225 int FTN_STDCALL FTN_TARGET_ASSOCIATE_PTR(void *host_ptr, void *device_ptr,
1226                                          size_t size, size_t device_offset,
1227                                          int device_num) {
1228   return -1;
1229 }
1230 
FTN_TARGET_DISASSOCIATE_PTR(void * host_ptr,int device_num)1231 int FTN_STDCALL FTN_TARGET_DISASSOCIATE_PTR(void *host_ptr, int device_num) {
1232   return -1;
1233 }
1234 #endif // defined(KMP_STUB)
1235 
1236 #ifdef KMP_STUB
1237 typedef enum { UNINIT = -1, UNLOCKED, LOCKED } kmp_stub_lock_t;
1238 #endif /* KMP_STUB */
1239 
1240 #if KMP_USE_DYNAMIC_LOCK
FTN_INIT_LOCK_WITH_HINT(void ** user_lock,uintptr_t KMP_DEREF hint)1241 void FTN_STDCALL FTN_INIT_LOCK_WITH_HINT(void **user_lock,
1242                                          uintptr_t KMP_DEREF hint) {
1243 #ifdef KMP_STUB
1244   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1245 #else
1246   int gtid = __kmp_entry_gtid();
1247 #if OMPT_SUPPORT && OMPT_OPTIONAL
1248   OMPT_STORE_RETURN_ADDRESS(gtid);
1249 #endif
1250   __kmpc_init_lock_with_hint(NULL, gtid, user_lock, KMP_DEREF hint);
1251 #endif
1252 }
1253 
FTN_INIT_NEST_LOCK_WITH_HINT(void ** user_lock,uintptr_t KMP_DEREF hint)1254 void FTN_STDCALL FTN_INIT_NEST_LOCK_WITH_HINT(void **user_lock,
1255                                               uintptr_t KMP_DEREF hint) {
1256 #ifdef KMP_STUB
1257   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1258 #else
1259   int gtid = __kmp_entry_gtid();
1260 #if OMPT_SUPPORT && OMPT_OPTIONAL
1261   OMPT_STORE_RETURN_ADDRESS(gtid);
1262 #endif
1263   __kmpc_init_nest_lock_with_hint(NULL, gtid, user_lock, KMP_DEREF hint);
1264 #endif
1265 }
1266 #endif
1267 
1268 /* initialize the lock */
KMP_EXPAND_NAME(FTN_INIT_LOCK)1269 void FTN_STDCALL KMP_EXPAND_NAME(FTN_INIT_LOCK)(void **user_lock) {
1270 #ifdef KMP_STUB
1271   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1272 #else
1273   int gtid = __kmp_entry_gtid();
1274 #if OMPT_SUPPORT && OMPT_OPTIONAL
1275   OMPT_STORE_RETURN_ADDRESS(gtid);
1276 #endif
1277   __kmpc_init_lock(NULL, gtid, user_lock);
1278 #endif
1279 }
1280 
1281 /* initialize the lock */
KMP_EXPAND_NAME(FTN_INIT_NEST_LOCK)1282 void FTN_STDCALL KMP_EXPAND_NAME(FTN_INIT_NEST_LOCK)(void **user_lock) {
1283 #ifdef KMP_STUB
1284   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1285 #else
1286   int gtid = __kmp_entry_gtid();
1287 #if OMPT_SUPPORT && OMPT_OPTIONAL
1288   OMPT_STORE_RETURN_ADDRESS(gtid);
1289 #endif
1290   __kmpc_init_nest_lock(NULL, gtid, user_lock);
1291 #endif
1292 }
1293 
KMP_EXPAND_NAME(FTN_DESTROY_LOCK)1294 void FTN_STDCALL KMP_EXPAND_NAME(FTN_DESTROY_LOCK)(void **user_lock) {
1295 #ifdef KMP_STUB
1296   *((kmp_stub_lock_t *)user_lock) = UNINIT;
1297 #else
1298   int gtid = __kmp_entry_gtid();
1299 #if OMPT_SUPPORT && OMPT_OPTIONAL
1300   OMPT_STORE_RETURN_ADDRESS(gtid);
1301 #endif
1302   __kmpc_destroy_lock(NULL, gtid, user_lock);
1303 #endif
1304 }
1305 
KMP_EXPAND_NAME(FTN_DESTROY_NEST_LOCK)1306 void FTN_STDCALL KMP_EXPAND_NAME(FTN_DESTROY_NEST_LOCK)(void **user_lock) {
1307 #ifdef KMP_STUB
1308   *((kmp_stub_lock_t *)user_lock) = UNINIT;
1309 #else
1310   int gtid = __kmp_entry_gtid();
1311 #if OMPT_SUPPORT && OMPT_OPTIONAL
1312   OMPT_STORE_RETURN_ADDRESS(gtid);
1313 #endif
1314   __kmpc_destroy_nest_lock(NULL, gtid, user_lock);
1315 #endif
1316 }
1317 
KMP_EXPAND_NAME(FTN_SET_LOCK)1318 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_LOCK)(void **user_lock) {
1319 #ifdef KMP_STUB
1320   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1321     // TODO: Issue an error.
1322   }
1323   if (*((kmp_stub_lock_t *)user_lock) != UNLOCKED) {
1324     // TODO: Issue an error.
1325   }
1326   *((kmp_stub_lock_t *)user_lock) = LOCKED;
1327 #else
1328   int gtid = __kmp_entry_gtid();
1329 #if OMPT_SUPPORT && OMPT_OPTIONAL
1330   OMPT_STORE_RETURN_ADDRESS(gtid);
1331 #endif
1332   __kmpc_set_lock(NULL, gtid, user_lock);
1333 #endif
1334 }
1335 
KMP_EXPAND_NAME(FTN_SET_NEST_LOCK)1336 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NEST_LOCK)(void **user_lock) {
1337 #ifdef KMP_STUB
1338   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1339     // TODO: Issue an error.
1340   }
1341   (*((int *)user_lock))++;
1342 #else
1343   int gtid = __kmp_entry_gtid();
1344 #if OMPT_SUPPORT && OMPT_OPTIONAL
1345   OMPT_STORE_RETURN_ADDRESS(gtid);
1346 #endif
1347   __kmpc_set_nest_lock(NULL, gtid, user_lock);
1348 #endif
1349 }
1350 
KMP_EXPAND_NAME(FTN_UNSET_LOCK)1351 void FTN_STDCALL KMP_EXPAND_NAME(FTN_UNSET_LOCK)(void **user_lock) {
1352 #ifdef KMP_STUB
1353   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1354     // TODO: Issue an error.
1355   }
1356   if (*((kmp_stub_lock_t *)user_lock) == UNLOCKED) {
1357     // TODO: Issue an error.
1358   }
1359   *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
1360 #else
1361   int gtid = __kmp_entry_gtid();
1362 #if OMPT_SUPPORT && OMPT_OPTIONAL
1363   OMPT_STORE_RETURN_ADDRESS(gtid);
1364 #endif
1365   __kmpc_unset_lock(NULL, gtid, user_lock);
1366 #endif
1367 }
1368 
KMP_EXPAND_NAME(FTN_UNSET_NEST_LOCK)1369 void FTN_STDCALL KMP_EXPAND_NAME(FTN_UNSET_NEST_LOCK)(void **user_lock) {
1370 #ifdef KMP_STUB
1371   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1372     // TODO: Issue an error.
1373   }
1374   if (*((kmp_stub_lock_t *)user_lock) == UNLOCKED) {
1375     // TODO: Issue an error.
1376   }
1377   (*((int *)user_lock))--;
1378 #else
1379   int gtid = __kmp_entry_gtid();
1380 #if OMPT_SUPPORT && OMPT_OPTIONAL
1381   OMPT_STORE_RETURN_ADDRESS(gtid);
1382 #endif
1383   __kmpc_unset_nest_lock(NULL, gtid, user_lock);
1384 #endif
1385 }
1386 
KMP_EXPAND_NAME(FTN_TEST_LOCK)1387 int FTN_STDCALL KMP_EXPAND_NAME(FTN_TEST_LOCK)(void **user_lock) {
1388 #ifdef KMP_STUB
1389   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1390     // TODO: Issue an error.
1391   }
1392   if (*((kmp_stub_lock_t *)user_lock) == LOCKED) {
1393     return 0;
1394   }
1395   *((kmp_stub_lock_t *)user_lock) = LOCKED;
1396   return 1;
1397 #else
1398   int gtid = __kmp_entry_gtid();
1399 #if OMPT_SUPPORT && OMPT_OPTIONAL
1400   OMPT_STORE_RETURN_ADDRESS(gtid);
1401 #endif
1402   return __kmpc_test_lock(NULL, gtid, user_lock);
1403 #endif
1404 }
1405 
KMP_EXPAND_NAME(FTN_TEST_NEST_LOCK)1406 int FTN_STDCALL KMP_EXPAND_NAME(FTN_TEST_NEST_LOCK)(void **user_lock) {
1407 #ifdef KMP_STUB
1408   if (*((kmp_stub_lock_t *)user_lock) == UNINIT) {
1409     // TODO: Issue an error.
1410   }
1411   return ++(*((int *)user_lock));
1412 #else
1413   int gtid = __kmp_entry_gtid();
1414 #if OMPT_SUPPORT && OMPT_OPTIONAL
1415   OMPT_STORE_RETURN_ADDRESS(gtid);
1416 #endif
1417   return __kmpc_test_nest_lock(NULL, gtid, user_lock);
1418 #endif
1419 }
1420 
KMP_EXPAND_NAME(FTN_GET_WTIME)1421 double FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_WTIME)(void) {
1422 #ifdef KMP_STUB
1423   return __kmps_get_wtime();
1424 #else
1425   double data;
1426 #if !KMP_OS_LINUX
1427   // We don't need library initialization to get the time on Linux* OS. The
1428   // routine can be used to measure library initialization time on Linux* OS now
1429   if (!__kmp_init_serial) {
1430     __kmp_serial_initialize();
1431   }
1432 #endif
1433   __kmp_elapsed(&data);
1434   return data;
1435 #endif
1436 }
1437 
KMP_EXPAND_NAME(FTN_GET_WTICK)1438 double FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_WTICK)(void) {
1439 #ifdef KMP_STUB
1440   return __kmps_get_wtick();
1441 #else
1442   double data;
1443   if (!__kmp_init_serial) {
1444     __kmp_serial_initialize();
1445   }
1446   __kmp_elapsed_tick(&data);
1447   return data;
1448 #endif
1449 }
1450 
1451 /* ------------------------------------------------------------------------ */
1452 
FTN_MALLOC(size_t KMP_DEREF size)1453 void *FTN_STDCALL FTN_MALLOC(size_t KMP_DEREF size) {
1454   // kmpc_malloc initializes the library if needed
1455   return kmpc_malloc(KMP_DEREF size);
1456 }
1457 
FTN_ALIGNED_MALLOC(size_t KMP_DEREF size,size_t KMP_DEREF alignment)1458 void *FTN_STDCALL FTN_ALIGNED_MALLOC(size_t KMP_DEREF size,
1459                                      size_t KMP_DEREF alignment) {
1460   // kmpc_aligned_malloc initializes the library if needed
1461   return kmpc_aligned_malloc(KMP_DEREF size, KMP_DEREF alignment);
1462 }
1463 
FTN_CALLOC(size_t KMP_DEREF nelem,size_t KMP_DEREF elsize)1464 void *FTN_STDCALL FTN_CALLOC(size_t KMP_DEREF nelem, size_t KMP_DEREF elsize) {
1465   // kmpc_calloc initializes the library if needed
1466   return kmpc_calloc(KMP_DEREF nelem, KMP_DEREF elsize);
1467 }
1468 
FTN_REALLOC(void * KMP_DEREF ptr,size_t KMP_DEREF size)1469 void *FTN_STDCALL FTN_REALLOC(void *KMP_DEREF ptr, size_t KMP_DEREF size) {
1470   // kmpc_realloc initializes the library if needed
1471   return kmpc_realloc(KMP_DEREF ptr, KMP_DEREF size);
1472 }
1473 
FTN_KFREE(void * KMP_DEREF ptr)1474 void FTN_STDCALL FTN_KFREE(void *KMP_DEREF ptr) {
1475   // does nothing if the library is not initialized
1476   kmpc_free(KMP_DEREF ptr);
1477 }
1478 
FTN_SET_WARNINGS_ON(void)1479 void FTN_STDCALL FTN_SET_WARNINGS_ON(void) {
1480 #ifndef KMP_STUB
1481   __kmp_generate_warnings = kmp_warnings_explicit;
1482 #endif
1483 }
1484 
FTN_SET_WARNINGS_OFF(void)1485 void FTN_STDCALL FTN_SET_WARNINGS_OFF(void) {
1486 #ifndef KMP_STUB
1487   __kmp_generate_warnings = FALSE;
1488 #endif
1489 }
1490 
FTN_SET_DEFAULTS(char const * str,int len)1491 void FTN_STDCALL FTN_SET_DEFAULTS(char const *str
1492 #ifndef PASS_ARGS_BY_VALUE
1493                                   ,
1494                                   int len
1495 #endif
1496 ) {
1497 #ifndef KMP_STUB
1498 #ifdef PASS_ARGS_BY_VALUE
1499   int len = (int)KMP_STRLEN(str);
1500 #endif
1501   __kmp_aux_set_defaults(str, len);
1502 #endif
1503 }
1504 
1505 /* ------------------------------------------------------------------------ */
1506 
1507 /* returns the status of cancellation */
KMP_EXPAND_NAME(FTN_GET_CANCELLATION)1508 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_CANCELLATION)(void) {
1509 #ifdef KMP_STUB
1510   return 0 /* false */;
1511 #else
1512   // initialize the library if needed
1513   if (!__kmp_init_serial) {
1514     __kmp_serial_initialize();
1515   }
1516   return __kmp_omp_cancellation;
1517 #endif
1518 }
1519 
FTN_GET_CANCELLATION_STATUS(int cancel_kind)1520 int FTN_STDCALL FTN_GET_CANCELLATION_STATUS(int cancel_kind) {
1521 #ifdef KMP_STUB
1522   return 0 /* false */;
1523 #else
1524   return __kmp_get_cancellation_status(cancel_kind);
1525 #endif
1526 }
1527 
1528 /* returns the maximum allowed task priority */
KMP_EXPAND_NAME(FTN_GET_MAX_TASK_PRIORITY)1529 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_TASK_PRIORITY)(void) {
1530 #ifdef KMP_STUB
1531   return 0;
1532 #else
1533   if (!__kmp_init_serial) {
1534     __kmp_serial_initialize();
1535   }
1536   return __kmp_max_task_priority;
1537 #endif
1538 }
1539 
1540 // This function will be defined in libomptarget. When libomptarget is not
1541 // loaded, we assume we are on the host and return KMP_HOST_DEVICE.
1542 // Compiler/libomptarget will handle this if called inside target.
1543 int FTN_STDCALL FTN_GET_DEVICE_NUM(void) KMP_WEAK_ATTRIBUTE_EXTERNAL;
FTN_GET_DEVICE_NUM(void)1544 int FTN_STDCALL FTN_GET_DEVICE_NUM(void) {
1545   return KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)();
1546 }
1547 
1548 // Compiler will ensure that this is only called from host in sequential region
KMP_EXPAND_NAME(FTN_PAUSE_RESOURCE)1549 int FTN_STDCALL KMP_EXPAND_NAME(FTN_PAUSE_RESOURCE)(kmp_pause_status_t kind,
1550                                                     int device_num) {
1551 #ifdef KMP_STUB
1552   return 1; // just fail
1553 #else
1554   if (kind == kmp_stop_tool_paused)
1555     return 1; // stop_tool must not be specified
1556   if (device_num == KMP_EXPAND_NAME(FTN_GET_INITIAL_DEVICE)())
1557     return __kmpc_pause_resource(kind);
1558   else {
1559     int (*fptr)(kmp_pause_status_t, int);
1560     if ((*(void **)(&fptr) = KMP_DLSYM("tgt_pause_resource")))
1561       return (*fptr)(kind, device_num);
1562     else
1563       return 1; // just fail if there is no libomptarget
1564   }
1565 #endif
1566 }
1567 
1568 // Compiler will ensure that this is only called from host in sequential region
1569 int FTN_STDCALL
KMP_EXPAND_NAME(FTN_PAUSE_RESOURCE_ALL)1570     KMP_EXPAND_NAME(FTN_PAUSE_RESOURCE_ALL)(kmp_pause_status_t kind) {
1571 #ifdef KMP_STUB
1572   return 1; // just fail
1573 #else
1574   int fails = 0;
1575   int (*fptr)(kmp_pause_status_t, int);
1576   if ((*(void **)(&fptr) = KMP_DLSYM("tgt_pause_resource")))
1577     fails = (*fptr)(kind, KMP_DEVICE_ALL); // pause devices
1578   fails += __kmpc_pause_resource(kind); // pause host
1579   return fails;
1580 #endif
1581 }
1582 
1583 // Returns the maximum number of nesting levels supported by implementation
FTN_GET_SUPPORTED_ACTIVE_LEVELS(void)1584 int FTN_STDCALL FTN_GET_SUPPORTED_ACTIVE_LEVELS(void) {
1585 #ifdef KMP_STUB
1586   return 1;
1587 #else
1588   return KMP_MAX_ACTIVE_LEVELS_LIMIT;
1589 #endif
1590 }
1591 
FTN_FULFILL_EVENT(kmp_event_t * event)1592 void FTN_STDCALL FTN_FULFILL_EVENT(kmp_event_t *event) {
1593 #ifndef KMP_STUB
1594   __kmp_fulfill_event(event);
1595 #endif
1596 }
1597 
1598 // nteams-var per-device ICV
FTN_SET_NUM_TEAMS(int KMP_DEREF num_teams)1599 void FTN_STDCALL FTN_SET_NUM_TEAMS(int KMP_DEREF num_teams) {
1600 #ifdef KMP_STUB
1601 // Nothing.
1602 #else
1603   if (!__kmp_init_serial) {
1604     __kmp_serial_initialize();
1605   }
1606   __kmp_set_num_teams(KMP_DEREF num_teams);
1607 #endif
1608 }
FTN_GET_MAX_TEAMS(void)1609 int FTN_STDCALL FTN_GET_MAX_TEAMS(void) {
1610 #ifdef KMP_STUB
1611   return 1;
1612 #else
1613   if (!__kmp_init_serial) {
1614     __kmp_serial_initialize();
1615   }
1616   return __kmp_get_max_teams();
1617 #endif
1618 }
1619 // teams-thread-limit-var per-device ICV
FTN_SET_TEAMS_THREAD_LIMIT(int KMP_DEREF limit)1620 void FTN_STDCALL FTN_SET_TEAMS_THREAD_LIMIT(int KMP_DEREF limit) {
1621 #ifdef KMP_STUB
1622 // Nothing.
1623 #else
1624   if (!__kmp_init_serial) {
1625     __kmp_serial_initialize();
1626   }
1627   __kmp_set_teams_thread_limit(KMP_DEREF limit);
1628 #endif
1629 }
FTN_GET_TEAMS_THREAD_LIMIT(void)1630 int FTN_STDCALL FTN_GET_TEAMS_THREAD_LIMIT(void) {
1631 #ifdef KMP_STUB
1632   return 1;
1633 #else
1634   if (!__kmp_init_serial) {
1635     __kmp_serial_initialize();
1636   }
1637   return __kmp_get_teams_thread_limit();
1638 #endif
1639 }
1640 
1641 /// TODO: Include the `omp.h` of the current build
1642 /* OpenMP 5.1 interop */
1643 typedef intptr_t omp_intptr_t;
1644 
1645 /* 0..omp_get_num_interop_properties()-1 are reserved for implementation-defined
1646  * properties */
1647 typedef enum omp_interop_property {
1648   omp_ipr_fr_id = -1,
1649   omp_ipr_fr_name = -2,
1650   omp_ipr_vendor = -3,
1651   omp_ipr_vendor_name = -4,
1652   omp_ipr_device_num = -5,
1653   omp_ipr_platform = -6,
1654   omp_ipr_device = -7,
1655   omp_ipr_device_context = -8,
1656   omp_ipr_targetsync = -9,
1657   omp_ipr_first = -9
1658 } omp_interop_property_t;
1659 
1660 #define omp_interop_none 0
1661 
1662 typedef enum omp_interop_rc {
1663   omp_irc_no_value = 1,
1664   omp_irc_success = 0,
1665   omp_irc_empty = -1,
1666   omp_irc_out_of_range = -2,
1667   omp_irc_type_int = -3,
1668   omp_irc_type_ptr = -4,
1669   omp_irc_type_str = -5,
1670   omp_irc_other = -6
1671 } omp_interop_rc_t;
1672 
1673 typedef enum omp_interop_fr {
1674   omp_ifr_cuda = 1,
1675   omp_ifr_cuda_driver = 2,
1676   omp_ifr_opencl = 3,
1677   omp_ifr_sycl = 4,
1678   omp_ifr_hip = 5,
1679   omp_ifr_level_zero = 6,
1680   omp_ifr_last = 7
1681 } omp_interop_fr_t;
1682 
1683 typedef void *omp_interop_t;
1684 
1685 // libomptarget, if loaded, provides this function
FTN_GET_NUM_INTEROP_PROPERTIES(const omp_interop_t interop)1686 int FTN_STDCALL FTN_GET_NUM_INTEROP_PROPERTIES(const omp_interop_t interop) {
1687 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1688   return 0;
1689 #else
1690   int (*fptr)(const omp_interop_t);
1691   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_num_interop_properties")))
1692     return (*fptr)(interop);
1693   return 0;
1694 #endif
1695 }
1696 
1697 /// TODO Convert FTN_GET_INTEROP_XXX functions into a macro like interop.cpp
1698 // libomptarget, if loaded, provides this function
FTN_GET_INTEROP_INT(const omp_interop_t interop,omp_interop_property_t property_id,int * err)1699 intptr_t FTN_STDCALL FTN_GET_INTEROP_INT(const omp_interop_t interop,
1700                                          omp_interop_property_t property_id,
1701                                          int *err) {
1702 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1703   return 0;
1704 #else
1705   intptr_t (*fptr)(const omp_interop_t, omp_interop_property_t, int *);
1706   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_interop_int")))
1707     return (*fptr)(interop, property_id, err);
1708   return 0;
1709 #endif
1710 }
1711 
1712 // libomptarget, if loaded, provides this function
FTN_GET_INTEROP_PTR(const omp_interop_t interop,omp_interop_property_t property_id,int * err)1713 void *FTN_STDCALL FTN_GET_INTEROP_PTR(const omp_interop_t interop,
1714                                       omp_interop_property_t property_id,
1715                                       int *err) {
1716 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1717   return nullptr;
1718 #else
1719   void *(*fptr)(const omp_interop_t, omp_interop_property_t, int *);
1720   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_interop_ptr")))
1721     return (*fptr)(interop, property_id, err);
1722   return nullptr;
1723 #endif
1724 }
1725 
1726 // libomptarget, if loaded, provides this function
FTN_GET_INTEROP_STR(const omp_interop_t interop,omp_interop_property_t property_id,int * err)1727 const char *FTN_STDCALL FTN_GET_INTEROP_STR(const omp_interop_t interop,
1728                                             omp_interop_property_t property_id,
1729                                             int *err) {
1730 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1731   return nullptr;
1732 #else
1733   const char *(*fptr)(const omp_interop_t, omp_interop_property_t, int *);
1734   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_interop_str")))
1735     return (*fptr)(interop, property_id, err);
1736   return nullptr;
1737 #endif
1738 }
1739 
1740 // libomptarget, if loaded, provides this function
FTN_GET_INTEROP_NAME(const omp_interop_t interop,omp_interop_property_t property_id)1741 const char *FTN_STDCALL FTN_GET_INTEROP_NAME(
1742     const omp_interop_t interop, omp_interop_property_t property_id) {
1743 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1744   return nullptr;
1745 #else
1746   const char *(*fptr)(const omp_interop_t, omp_interop_property_t);
1747   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_interop_name")))
1748     return (*fptr)(interop, property_id);
1749   return nullptr;
1750 #endif
1751 }
1752 
1753 // libomptarget, if loaded, provides this function
FTN_GET_INTEROP_TYPE_DESC(const omp_interop_t interop,omp_interop_property_t property_id)1754 const char *FTN_STDCALL FTN_GET_INTEROP_TYPE_DESC(
1755     const omp_interop_t interop, omp_interop_property_t property_id) {
1756 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1757   return nullptr;
1758 #else
1759   const char *(*fptr)(const omp_interop_t, omp_interop_property_t);
1760   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_interop_type_desc")))
1761     return (*fptr)(interop, property_id);
1762   return nullptr;
1763 #endif
1764 }
1765 
1766 // libomptarget, if loaded, provides this function
FTN_GET_INTEROP_RC_DESC(const omp_interop_t interop,omp_interop_property_t property_id)1767 const char *FTN_STDCALL FTN_GET_INTEROP_RC_DESC(
1768     const omp_interop_t interop, omp_interop_property_t property_id) {
1769 #if KMP_OS_DARWIN || KMP_OS_WASI || defined(KMP_STUB)
1770   return nullptr;
1771 #else
1772   const char *(*fptr)(const omp_interop_t, omp_interop_property_t);
1773   if ((*(void **)(&fptr) = KMP_DLSYM_NEXT("omp_get_interop_rec_desc")))
1774     return (*fptr)(interop, property_id);
1775   return nullptr;
1776 #endif
1777 }
1778 
1779 // display environment variables when requested
FTN_DISPLAY_ENV(int verbose)1780 void FTN_STDCALL FTN_DISPLAY_ENV(int verbose) {
1781 #ifndef KMP_STUB
1782   __kmp_omp_display_env(verbose);
1783 #endif
1784 }
1785 
FTN_IN_EXPLICIT_TASK(void)1786 int FTN_STDCALL FTN_IN_EXPLICIT_TASK(void) {
1787 #ifdef KMP_STUB
1788   return 0;
1789 #else
1790   int gtid = __kmp_entry_gtid();
1791   return __kmp_thread_from_gtid(gtid)->th.th_current_task->td_flags.tasktype;
1792 #endif
1793 }
1794 
1795 // GCC compatibility (versioned symbols)
1796 #ifdef KMP_USE_VERSION_SYMBOLS
1797 
1798 /* These following sections create versioned symbols for the
1799    omp_* routines. The KMP_VERSION_SYMBOL macro expands the API name and
1800    then maps it to a versioned symbol.
1801    libgomp ``versions'' its symbols (OMP_1.0, OMP_2.0, OMP_3.0, ...) while also
1802    retaining the default version which libomp uses: VERSION (defined in
1803    exports_so.txt). If you want to see the versioned symbols for libgomp.so.1
1804    then just type:
1805 
1806    objdump -T /path/to/libgomp.so.1 | grep omp_
1807 
1808    Example:
1809    Step 1) Create __kmp_api_omp_set_num_threads_10_alias which is alias of
1810      __kmp_api_omp_set_num_threads
1811    Step 2) Set __kmp_api_omp_set_num_threads_10_alias to version:
1812      omp_set_num_threads@OMP_1.0
1813    Step 2B) Set __kmp_api_omp_set_num_threads to default version:
1814      omp_set_num_threads@@VERSION
1815 */
1816 
1817 // OMP_1.0 versioned symbols
1818 KMP_VERSION_SYMBOL(FTN_SET_NUM_THREADS, 10, "OMP_1.0");
1819 KMP_VERSION_SYMBOL(FTN_GET_NUM_THREADS, 10, "OMP_1.0");
1820 KMP_VERSION_SYMBOL(FTN_GET_MAX_THREADS, 10, "OMP_1.0");
1821 KMP_VERSION_SYMBOL(FTN_GET_THREAD_NUM, 10, "OMP_1.0");
1822 KMP_VERSION_SYMBOL(FTN_GET_NUM_PROCS, 10, "OMP_1.0");
1823 KMP_VERSION_SYMBOL(FTN_IN_PARALLEL, 10, "OMP_1.0");
1824 KMP_VERSION_SYMBOL(FTN_SET_DYNAMIC, 10, "OMP_1.0");
1825 KMP_VERSION_SYMBOL(FTN_GET_DYNAMIC, 10, "OMP_1.0");
1826 KMP_VERSION_SYMBOL(FTN_SET_NESTED, 10, "OMP_1.0");
1827 KMP_VERSION_SYMBOL(FTN_GET_NESTED, 10, "OMP_1.0");
1828 KMP_VERSION_SYMBOL(FTN_INIT_LOCK, 10, "OMP_1.0");
1829 KMP_VERSION_SYMBOL(FTN_INIT_NEST_LOCK, 10, "OMP_1.0");
1830 KMP_VERSION_SYMBOL(FTN_DESTROY_LOCK, 10, "OMP_1.0");
1831 KMP_VERSION_SYMBOL(FTN_DESTROY_NEST_LOCK, 10, "OMP_1.0");
1832 KMP_VERSION_SYMBOL(FTN_SET_LOCK, 10, "OMP_1.0");
1833 KMP_VERSION_SYMBOL(FTN_SET_NEST_LOCK, 10, "OMP_1.0");
1834 KMP_VERSION_SYMBOL(FTN_UNSET_LOCK, 10, "OMP_1.0");
1835 KMP_VERSION_SYMBOL(FTN_UNSET_NEST_LOCK, 10, "OMP_1.0");
1836 KMP_VERSION_SYMBOL(FTN_TEST_LOCK, 10, "OMP_1.0");
1837 KMP_VERSION_SYMBOL(FTN_TEST_NEST_LOCK, 10, "OMP_1.0");
1838 
1839 // OMP_2.0 versioned symbols
1840 KMP_VERSION_SYMBOL(FTN_GET_WTICK, 20, "OMP_2.0");
1841 KMP_VERSION_SYMBOL(FTN_GET_WTIME, 20, "OMP_2.0");
1842 
1843 // OMP_3.0 versioned symbols
1844 KMP_VERSION_SYMBOL(FTN_SET_SCHEDULE, 30, "OMP_3.0");
1845 KMP_VERSION_SYMBOL(FTN_GET_SCHEDULE, 30, "OMP_3.0");
1846 KMP_VERSION_SYMBOL(FTN_GET_THREAD_LIMIT, 30, "OMP_3.0");
1847 KMP_VERSION_SYMBOL(FTN_SET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1848 KMP_VERSION_SYMBOL(FTN_GET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1849 KMP_VERSION_SYMBOL(FTN_GET_ANCESTOR_THREAD_NUM, 30, "OMP_3.0");
1850 KMP_VERSION_SYMBOL(FTN_GET_LEVEL, 30, "OMP_3.0");
1851 KMP_VERSION_SYMBOL(FTN_GET_TEAM_SIZE, 30, "OMP_3.0");
1852 KMP_VERSION_SYMBOL(FTN_GET_ACTIVE_LEVEL, 30, "OMP_3.0");
1853 
1854 // the lock routines have a 1.0 and 3.0 version
1855 KMP_VERSION_SYMBOL(FTN_INIT_LOCK, 30, "OMP_3.0");
1856 KMP_VERSION_SYMBOL(FTN_INIT_NEST_LOCK, 30, "OMP_3.0");
1857 KMP_VERSION_SYMBOL(FTN_DESTROY_LOCK, 30, "OMP_3.0");
1858 KMP_VERSION_SYMBOL(FTN_DESTROY_NEST_LOCK, 30, "OMP_3.0");
1859 KMP_VERSION_SYMBOL(FTN_SET_LOCK, 30, "OMP_3.0");
1860 KMP_VERSION_SYMBOL(FTN_SET_NEST_LOCK, 30, "OMP_3.0");
1861 KMP_VERSION_SYMBOL(FTN_UNSET_LOCK, 30, "OMP_3.0");
1862 KMP_VERSION_SYMBOL(FTN_UNSET_NEST_LOCK, 30, "OMP_3.0");
1863 KMP_VERSION_SYMBOL(FTN_TEST_LOCK, 30, "OMP_3.0");
1864 KMP_VERSION_SYMBOL(FTN_TEST_NEST_LOCK, 30, "OMP_3.0");
1865 
1866 // OMP_3.1 versioned symbol
1867 KMP_VERSION_SYMBOL(FTN_IN_FINAL, 31, "OMP_3.1");
1868 
1869 // OMP_4.0 versioned symbols
1870 KMP_VERSION_SYMBOL(FTN_GET_PROC_BIND, 40, "OMP_4.0");
1871 KMP_VERSION_SYMBOL(FTN_GET_NUM_TEAMS, 40, "OMP_4.0");
1872 KMP_VERSION_SYMBOL(FTN_GET_TEAM_NUM, 40, "OMP_4.0");
1873 KMP_VERSION_SYMBOL(FTN_GET_CANCELLATION, 40, "OMP_4.0");
1874 KMP_VERSION_SYMBOL(FTN_GET_DEFAULT_DEVICE, 40, "OMP_4.0");
1875 KMP_VERSION_SYMBOL(FTN_SET_DEFAULT_DEVICE, 40, "OMP_4.0");
1876 KMP_VERSION_SYMBOL(FTN_IS_INITIAL_DEVICE, 40, "OMP_4.0");
1877 KMP_VERSION_SYMBOL(FTN_GET_NUM_DEVICES, 40, "OMP_4.0");
1878 
1879 // OMP_4.5 versioned symbols
1880 KMP_VERSION_SYMBOL(FTN_GET_MAX_TASK_PRIORITY, 45, "OMP_4.5");
1881 KMP_VERSION_SYMBOL(FTN_GET_NUM_PLACES, 45, "OMP_4.5");
1882 KMP_VERSION_SYMBOL(FTN_GET_PLACE_NUM_PROCS, 45, "OMP_4.5");
1883 KMP_VERSION_SYMBOL(FTN_GET_PLACE_PROC_IDS, 45, "OMP_4.5");
1884 KMP_VERSION_SYMBOL(FTN_GET_PLACE_NUM, 45, "OMP_4.5");
1885 KMP_VERSION_SYMBOL(FTN_GET_PARTITION_NUM_PLACES, 45, "OMP_4.5");
1886 KMP_VERSION_SYMBOL(FTN_GET_PARTITION_PLACE_NUMS, 45, "OMP_4.5");
1887 KMP_VERSION_SYMBOL(FTN_GET_INITIAL_DEVICE, 45, "OMP_4.5");
1888 
1889 // OMP_5.0 versioned symbols
1890 // KMP_VERSION_SYMBOL(FTN_GET_DEVICE_NUM, 50, "OMP_5.0");
1891 KMP_VERSION_SYMBOL(FTN_PAUSE_RESOURCE, 50, "OMP_5.0");
1892 KMP_VERSION_SYMBOL(FTN_PAUSE_RESOURCE_ALL, 50, "OMP_5.0");
1893 // The C versions (KMP_FTN_PLAIN) of these symbols are in kmp_csupport.c
1894 #if KMP_FTN_ENTRIES == KMP_FTN_APPEND
1895 KMP_VERSION_SYMBOL(FTN_CAPTURE_AFFINITY, 50, "OMP_5.0");
1896 KMP_VERSION_SYMBOL(FTN_DISPLAY_AFFINITY, 50, "OMP_5.0");
1897 KMP_VERSION_SYMBOL(FTN_GET_AFFINITY_FORMAT, 50, "OMP_5.0");
1898 KMP_VERSION_SYMBOL(FTN_SET_AFFINITY_FORMAT, 50, "OMP_5.0");
1899 #endif
1900 // KMP_VERSION_SYMBOL(FTN_GET_SUPPORTED_ACTIVE_LEVELS, 50, "OMP_5.0");
1901 // KMP_VERSION_SYMBOL(FTN_FULFILL_EVENT, 50, "OMP_5.0");
1902 
1903 #endif // KMP_USE_VERSION_SYMBOLS
1904 
1905 #ifdef __cplusplus
1906 } // extern "C"
1907 #endif // __cplusplus
1908 
1909 // end of file //
1910