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 // 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 
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 
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 
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 
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 
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;
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_set_blocktime(KMP_DEREF arg, thread, tid);
123 #endif
124 }
125 
126 int FTN_STDCALL FTN_GET_BLOCKTIME(void) {
127 #ifdef KMP_STUB
128  return __kmps_get_blocktime();
129 #else
130  int gtid, tid;
131  kmp_team_p *team;
132 
133  gtid = __kmp_entry_gtid();
134  tid = __kmp_tid_from_gtid(gtid);
135  team = __kmp_threads[gtid]->th.th_team;
136 
137  /* These must match the settings used in __kmp_wait_sleep() */
138  if (__kmp_dflt_blocktime == KMP_MAX_BLOCKTIME) {
139  KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n", gtid,
140  team->t.t_id, tid, KMP_MAX_BLOCKTIME));
141  return KMP_MAX_BLOCKTIME;
142  }
143 #ifdef KMP_ADJUST_BLOCKTIME
144  else if (__kmp_zero_bt && !get__bt_set(team, tid)) {
145  KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n", gtid,
146  team->t.t_id, tid, 0));
147  return 0;
148  }
149 #endif /* KMP_ADJUST_BLOCKTIME */
150  else {
151  KF_TRACE(10, ("kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n", gtid,
152  team->t.t_id, tid, get__blocktime(team, tid)));
153  return get__blocktime(team, tid);
154  }
155 #endif
156 }
157 
158 void FTN_STDCALL FTN_SET_LIBRARY_SERIAL(void) {
159 #ifdef KMP_STUB
160  __kmps_set_library(library_serial);
161 #else
162  // __kmp_user_set_library initializes the library if needed
163  __kmp_user_set_library(library_serial);
164 #endif
165 }
166 
167 void FTN_STDCALL FTN_SET_LIBRARY_TURNAROUND(void) {
168 #ifdef KMP_STUB
169  __kmps_set_library(library_turnaround);
170 #else
171  // __kmp_user_set_library initializes the library if needed
172  __kmp_user_set_library(library_turnaround);
173 #endif
174 }
175 
176 void FTN_STDCALL FTN_SET_LIBRARY_THROUGHPUT(void) {
177 #ifdef KMP_STUB
178  __kmps_set_library(library_throughput);
179 #else
180  // __kmp_user_set_library initializes the library if needed
181  __kmp_user_set_library(library_throughput);
182 #endif
183 }
184 
185 void FTN_STDCALL FTN_SET_LIBRARY(int KMP_DEREF arg) {
186 #ifdef KMP_STUB
187  __kmps_set_library(KMP_DEREF arg);
188 #else
189  enum library_type lib;
190  lib = (enum library_type)KMP_DEREF arg;
191  // __kmp_user_set_library initializes the library if needed
192  __kmp_user_set_library(lib);
193 #endif
194 }
195 
196 int FTN_STDCALL FTN_GET_LIBRARY(void) {
197 #ifdef KMP_STUB
198  return __kmps_get_library();
199 #else
200  if (!__kmp_init_serial) {
201  __kmp_serial_initialize();
202  }
203  return ((int)__kmp_library);
204 #endif
205 }
206 
207 void FTN_STDCALL FTN_SET_DISP_NUM_BUFFERS(int KMP_DEREF arg) {
208 #ifdef KMP_STUB
209  ; // empty routine
210 #else
211  // ignore after initialization because some teams have already
212  // allocated dispatch buffers
213  int num_buffers = KMP_DEREF arg;
214  if (__kmp_init_serial == FALSE && num_buffers >= KMP_MIN_DISP_NUM_BUFF &&
215  num_buffers <= KMP_MAX_DISP_NUM_BUFF) {
216  __kmp_dispatch_num_buffers = num_buffers;
217  }
218 #endif
219 }
220 
221 int FTN_STDCALL FTN_SET_AFFINITY(void **mask) {
222 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
223  return -1;
224 #else
225  if (!TCR_4(__kmp_init_middle)) {
226  __kmp_middle_initialize();
227  }
228  __kmp_assign_root_init_mask();
229  return __kmp_aux_set_affinity(mask);
230 #endif
231 }
232 
233 int FTN_STDCALL FTN_GET_AFFINITY(void **mask) {
234 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
235  return -1;
236 #else
237  if (!TCR_4(__kmp_init_middle)) {
238  __kmp_middle_initialize();
239  }
240  __kmp_assign_root_init_mask();
241  return __kmp_aux_get_affinity(mask);
242 #endif
243 }
244 
245 int FTN_STDCALL FTN_GET_AFFINITY_MAX_PROC(void) {
246 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
247  return 0;
248 #else
249  // We really only NEED serial initialization here.
250  if (!TCR_4(__kmp_init_middle)) {
251  __kmp_middle_initialize();
252  }
253  __kmp_assign_root_init_mask();
254  return __kmp_aux_get_affinity_max_proc();
255 #endif
256 }
257 
258 void FTN_STDCALL FTN_CREATE_AFFINITY_MASK(void **mask) {
259 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
260  *mask = NULL;
261 #else
262  // We really only NEED serial initialization here.
263  kmp_affin_mask_t *mask_internals;
264  if (!TCR_4(__kmp_init_middle)) {
265  __kmp_middle_initialize();
266  }
267  __kmp_assign_root_init_mask();
268  mask_internals = __kmp_affinity_dispatch->allocate_mask();
269  KMP_CPU_ZERO(mask_internals);
270  *mask = mask_internals;
271 #endif
272 }
273 
274 void FTN_STDCALL FTN_DESTROY_AFFINITY_MASK(void **mask) {
275 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
276 // Nothing
277 #else
278  // We really only NEED serial initialization here.
279  kmp_affin_mask_t *mask_internals;
280  if (!TCR_4(__kmp_init_middle)) {
281  __kmp_middle_initialize();
282  }
283  __kmp_assign_root_init_mask();
284  if (__kmp_env_consistency_check) {
285  if (*mask == NULL) {
286  KMP_FATAL(AffinityInvalidMask, "kmp_destroy_affinity_mask");
287  }
288  }
289  mask_internals = (kmp_affin_mask_t *)(*mask);
290  __kmp_affinity_dispatch->deallocate_mask(mask_internals);
291  *mask = NULL;
292 #endif
293 }
294 
295 int FTN_STDCALL FTN_SET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
296 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
297  return -1;
298 #else
299  if (!TCR_4(__kmp_init_middle)) {
300  __kmp_middle_initialize();
301  }
302  __kmp_assign_root_init_mask();
303  return __kmp_aux_set_affinity_mask_proc(KMP_DEREF proc, mask);
304 #endif
305 }
306 
307 int FTN_STDCALL FTN_UNSET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
308 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
309  return -1;
310 #else
311  if (!TCR_4(__kmp_init_middle)) {
312  __kmp_middle_initialize();
313  }
314  __kmp_assign_root_init_mask();
315  return __kmp_aux_unset_affinity_mask_proc(KMP_DEREF proc, mask);
316 #endif
317 }
318 
319 int FTN_STDCALL FTN_GET_AFFINITY_MASK_PROC(int KMP_DEREF proc, void **mask) {
320 #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
321  return -1;
322 #else
323  if (!TCR_4(__kmp_init_middle)) {
324  __kmp_middle_initialize();
325  }
326  __kmp_assign_root_init_mask();
327  return __kmp_aux_get_affinity_mask_proc(KMP_DEREF proc, mask);
328 #endif
329 }
330 
331 /* ------------------------------------------------------------------------ */
332 
333 /* sets the requested number of threads for the next parallel region */
334 void FTN_STDCALL KMP_EXPAND_NAME(FTN_SET_NUM_THREADS)(int KMP_DEREF arg) {
335 #ifdef KMP_STUB
336 // Nothing.
337 #else
338  __kmp_set_num_threads(KMP_DEREF arg, __kmp_entry_gtid());
339 #endif
340 }
341 
342 /* returns the number of threads in current team */
343 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_NUM_THREADS)(void) {
344 #ifdef KMP_STUB
345  return 1;
346 #else
347  // __kmpc_bound_num_threads initializes the library if needed
348  return __kmpc_bound_num_threads(NULL);
349 #endif
350 }
351 
352 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_MAX_THREADS)(void) {
353 #ifdef KMP_STUB
354  return 1;
355 #else
356  int gtid;
357  kmp_info_t *thread;
358  if (!TCR_4(__kmp_init_middle)) {
359  __kmp_middle_initialize();
360  }
361  __kmp_assign_root_init_mask();
362  gtid = __kmp_entry_gtid();
363  thread = __kmp_threads[gtid];
364  // return thread -> th.th_team -> t.t_current_task[
365  // thread->th.th_info.ds.ds_tid ] -> icvs.nproc;
366  return thread->th.th_current_task->td_icvs.nproc;
367 #endif
368 }
369 
370 int FTN_STDCALL FTN_CONTROL_TOOL(int command, int modifier, void *arg) {
371 #if defined(KMP_STUB) || !OMPT_SUPPORT
372  return -2;
373 #else
374  OMPT_STORE_RETURN_ADDRESS(__kmp_entry_gtid());
375  if (!TCR_4(__kmp_init_middle)) {
376  return -2;
377  }
378  kmp_info_t *this_thr = __kmp_threads[__kmp_entry_gtid()];
379  ompt_task_info_t *parent_task_info = OMPT_CUR_TASK_INFO(this_thr);
380  parent_task_info->frame.enter_frame.ptr = OMPT_GET_FRAME_ADDRESS(0);
381  int ret = __kmp_control_tool(command, modifier, arg);
382  parent_task_info->frame.enter_frame.ptr = 0;
383  return ret;
384 #endif
385 }
386 
387 /* OpenMP 5.0 Memory Management support */
388 omp_allocator_handle_t FTN_STDCALL
389 FTN_INIT_ALLOCATOR(omp_memspace_handle_t KMP_DEREF m, int KMP_DEREF ntraits,
390  omp_alloctrait_t tr[]) {
391 #ifdef KMP_STUB
392  return NULL;
393 #else
394  return __kmpc_init_allocator(__kmp_entry_gtid(), KMP_DEREF m,
395  KMP_DEREF ntraits, tr);
396 #endif
397 }
398 
399 void FTN_STDCALL FTN_DESTROY_ALLOCATOR(omp_allocator_handle_t al) {
400 #ifndef KMP_STUB
401  __kmpc_destroy_allocator(__kmp_entry_gtid(), al);
402 #endif
403 }
404 void FTN_STDCALL FTN_SET_DEFAULT_ALLOCATOR(omp_allocator_handle_t al) {
405 #ifndef KMP_STUB
406  __kmpc_set_default_allocator(__kmp_entry_gtid(), al);
407 #endif
408 }
409 omp_allocator_handle_t FTN_STDCALL FTN_GET_DEFAULT_ALLOCATOR(void) {
410 #ifdef KMP_STUB
411  return NULL;
412 #else
413  return __kmpc_get_default_allocator(__kmp_entry_gtid());
414 #endif
415 }
416 
417 /* OpenMP 5.0 affinity format support */
418 #ifndef KMP_STUB
419 static void __kmp_fortran_strncpy_truncate(char *buffer, size_t buf_size,
420  char const *csrc, size_t csrc_size) {
421  size_t capped_src_size = csrc_size;
422  if (csrc_size >= buf_size) {
423  capped_src_size = buf_size - 1;
424  }
425  KMP_STRNCPY_S(buffer, buf_size, csrc, capped_src_size);
426  if (csrc_size >= buf_size) {
427  KMP_DEBUG_ASSERT(buffer[buf_size - 1] == '\0');
428  buffer[buf_size - 1] = csrc[buf_size - 1];
429  } else {
430  for (size_t i = csrc_size; i < buf_size; ++i)
431  buffer[i] = ' ';
432  }
433 }
434 
435 // Convert a Fortran string to a C string by adding null byte
436 class ConvertedString {
437  char *buf;
438  kmp_info_t *th;
439 
440 public:
441  ConvertedString(char const *fortran_str, size_t size) {
442  th = __kmp_get_thread();
443  buf = (char *)__kmp_thread_malloc(th, size + 1);
444  KMP_STRNCPY_S(buf, size + 1, fortran_str, size);
445  buf[size] = '\0';
446  }
447  ~ConvertedString() { __kmp_thread_free(th, buf); }
448  const char *get() const { return buf; }
449 };
450 #endif // KMP_STUB
451 
452 /*
453  * Set the value of the affinity-format-var ICV on the current device to the
454  * format specified in the argument.
455  */
456 void FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_SET_AFFINITY_FORMAT)(
457  char const *format, size_t size) {
458 #ifdef KMP_STUB
459  return;
460 #else
461  if (!__kmp_init_serial) {
462  __kmp_serial_initialize();
463  }
464  ConvertedString cformat(format, size);
465  // Since the __kmp_affinity_format variable is a C string, do not
466  // use the fortran strncpy function
467  __kmp_strncpy_truncate(__kmp_affinity_format, KMP_AFFINITY_FORMAT_SIZE,
468  cformat.get(), KMP_STRLEN(cformat.get()));
469 #endif
470 }
471 
472 /*
473  * Returns the number of characters required to hold the entire affinity format
474  * specification (not including null byte character) and writes the value of the
475  * affinity-format-var ICV on the current device to buffer. If the return value
476  * is larger than size, the affinity format specification is truncated.
477  */
478 size_t FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_GET_AFFINITY_FORMAT)(
479  char *buffer, size_t size) {
480 #ifdef KMP_STUB
481  return 0;
482 #else
483  size_t format_size;
484  if (!__kmp_init_serial) {
485  __kmp_serial_initialize();
486  }
487  format_size = KMP_STRLEN(__kmp_affinity_format);
488  if (buffer && size) {
489  __kmp_fortran_strncpy_truncate(buffer, size, __kmp_affinity_format,
490  format_size);
491  }
492  return format_size;
493 #endif
494 }
495 
496 /*
497  * Prints the thread affinity information of the current thread in the format
498  * specified by the format argument. If the format is NULL or a zero-length
499  * string, the value of the affinity-format-var ICV is used.
500  */
501 void FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_DISPLAY_AFFINITY)(
502  char const *format, size_t size) {
503 #ifdef KMP_STUB
504  return;
505 #else
506  int gtid;
507  if (!TCR_4(__kmp_init_middle)) {
508  __kmp_middle_initialize();
509  }
510  __kmp_assign_root_init_mask();
511  gtid = __kmp_get_gtid();
512  ConvertedString cformat(format, size);
513  __kmp_aux_display_affinity(gtid, cformat.get());
514 #endif
515 }
516 
517 /*
518  * Returns the number of characters required to hold the entire affinity format
519  * specification (not including null byte) and prints the thread affinity
520  * information of the current thread into the character string buffer with the
521  * size of size in the format specified by the format argument. If the format is
522  * NULL or a zero-length string, the value of the affinity-format-var ICV is
523  * used. The buffer must be allocated prior to calling the routine. If the
524  * return value is larger than size, the affinity format specification is
525  * truncated.
526  */
527 size_t FTN_STDCALL KMP_EXPAND_NAME_IF_APPEND(FTN_CAPTURE_AFFINITY)(
528  char *buffer, char const *format, size_t buf_size, size_t for_size) {
529 #if defined(KMP_STUB)
530  return 0;
531 #else
532  int gtid;
533  size_t num_required;
534  kmp_str_buf_t capture_buf;
535  if (!TCR_4(__kmp_init_middle)) {
536  __kmp_middle_initialize();
537  }
538  __kmp_assign_root_init_mask();
539  gtid = __kmp_get_gtid();
540  __kmp_str_buf_init(&capture_buf);
541  ConvertedString cformat(format, for_size);
542  num_required = __kmp_aux_capture_affinity(gtid, cformat.get(), &capture_buf);
543  if (buffer && buf_size) {
544  __kmp_fortran_strncpy_truncate(buffer, buf_size, capture_buf.str,
545  capture_buf.used);
546  }
547  __kmp_str_buf_free(&capture_buf);
548  return num_required;
549 #endif
550 }
551 
552 int FTN_STDCALL KMP_EXPAND_NAME(FTN_GET_THREAD_NUM)(void) {
553 #ifdef KMP_STUB
554  return 0;
555 #else
556  int gtid;
557 
558 #if KMP_OS_DARWIN || KMP_OS_DRAGONFLY || KMP_OS_FREEBSD || KMP_OS_NETBSD || \
559  KMP_OS_HURD || KMP_OS_OPENBSD
560  gtid = __kmp_entry_gtid();
561 #elif KMP_OS_WINDOWS
562  if (!__kmp_init_parallel ||
563  (gtid = (int)((kmp_intptr_t)TlsGetValue(__kmp_gtid_threadprivate_key))) ==
564  0) {
565  // Either library isn't initialized or thread is not registered
566  // 0 is the correct TID in this case
567  return 0;
568  }
569  --gtid; // We keep (gtid+1) in TLS
570 #elif KMP_OS_LINUX
571 #ifdef KMP_TDATA_GTID
572  if (__kmp_gtid_mode >= 3) {
573  if ((gtid = __kmp_gtid) == KMP_GTID_DNE) {
574  return 0;
575  }
576  } else {
577 #endif
578  if (!__kmp_init_parallel ||
579  (gtid = (int)((kmp_intptr_t)(
580  pthread_getspecific(__kmp_gtid_threadprivate_key)))) == 0) {
581  return 0;
582  }
583  --gtid;
584 #ifdef KMP_TDATA_GTID