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 //
8 // The LLVM Compiler Infrastructure
9 //
10 // This file is dual licensed under the MIT and the University of Illinois Open
11 // Source Licenses. See LICENSE.txt for details.
12 //
13 //===----------------------------------------------------------------------===//
14 
15 
16 #ifndef FTN_STDCALL
17 # error The support file kmp_ftn_entry.h should not be compiled by itself.
18 #endif
19 
20 #ifdef KMP_STUB
21  #include "kmp_stub.h"
22 #endif
23 
24 #include "kmp_i18n.h"
25 
26 #ifdef __cplusplus
27  extern "C" {
28 #endif // __cplusplus
29 
30 /*
31  * For compatibility with the Gnu/MS Open MP codegen, omp_set_num_threads(),
32  * omp_set_nested(), and omp_set_dynamic() [in lowercase on MS, and w/o
33  * a trailing underscore on Linux* OS] take call by value integer arguments.
34  * + omp_set_max_active_levels()
35  * + omp_set_schedule()
36  *
37  * For backward compatibility with 9.1 and previous Intel compiler, these
38  * entry points take call by reference integer arguments.
39  */
40 #ifdef KMP_GOMP_COMPAT
41 # if (KMP_FTN_ENTRIES == KMP_FTN_PLAIN) || (KMP_FTN_ENTRIES == KMP_FTN_UPPER)
42 # define PASS_ARGS_BY_VALUE 1
43 # endif
44 #endif
45 #if KMP_OS_WINDOWS
46 # if (KMP_FTN_ENTRIES == KMP_FTN_PLAIN) || (KMP_FTN_ENTRIES == KMP_FTN_APPEND)
47 # define PASS_ARGS_BY_VALUE 1
48 # endif
49 #endif
50 
51 // This macro helps to reduce code duplication.
52 #ifdef PASS_ARGS_BY_VALUE
53  #define KMP_DEREF
54 #else
55  #define KMP_DEREF *
56 #endif
57 
58 void FTN_STDCALL
59 FTN_SET_STACKSIZE( int KMP_DEREF arg )
60 {
61  #ifdef KMP_STUB
62  __kmps_set_stacksize( KMP_DEREF arg );
63  #else
64  // __kmp_aux_set_stacksize initializes the library if needed
65  __kmp_aux_set_stacksize( (size_t) KMP_DEREF arg );
66  #endif
67 }
68 
69 void FTN_STDCALL
70 FTN_SET_STACKSIZE_S( size_t KMP_DEREF arg )
71 {
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( KMP_DEREF arg );
77  #endif
78 }
79 
80 int FTN_STDCALL
81 FTN_GET_STACKSIZE( void )
82 {
83  #ifdef KMP_STUB
84  return __kmps_get_stacksize();
85  #else
86  if ( ! __kmp_init_serial ) {
87  __kmp_serial_initialize();
88  };
89  return (int)__kmp_stksize;
90  #endif
91 }
92 
93 size_t FTN_STDCALL
94 FTN_GET_STACKSIZE_S( void )
95 {
96  #ifdef KMP_STUB
97  return __kmps_get_stacksize();
98  #else
99  if ( ! __kmp_init_serial ) {
100  __kmp_serial_initialize();
101  };
102  return __kmp_stksize;
103  #endif
104 }
105 
106 void FTN_STDCALL
107 FTN_SET_BLOCKTIME( int KMP_DEREF arg )
108 {
109  #ifdef KMP_STUB
110  __kmps_set_blocktime( KMP_DEREF arg );
111  #else
112  int gtid, tid;
113  kmp_info_t *thread;
114 
115  gtid = __kmp_entry_gtid();
116  tid = __kmp_tid_from_gtid(gtid);
117  thread = __kmp_thread_from_gtid(gtid);
118 
119  __kmp_aux_set_blocktime( KMP_DEREF arg, thread, tid );
120  #endif
121 }
122 
123 int FTN_STDCALL
124 FTN_GET_BLOCKTIME( void )
125 {
126  #ifdef KMP_STUB
127  return __kmps_get_blocktime();
128  #else
129  int gtid, tid;
130  kmp_info_t *thread;
131  kmp_team_p *team;
132 
133  gtid = __kmp_entry_gtid();
134  tid = __kmp_tid_from_gtid(gtid);
135  thread = __kmp_thread_from_gtid(gtid);
136  team = __kmp_threads[ gtid ] -> th.th_team;
137 
138  /* These must match the settings used in __kmp_wait_sleep() */
139  if ( __kmp_dflt_blocktime == KMP_MAX_BLOCKTIME ) {
140  KF_TRACE(10, ( "kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n",
141  gtid, team->t.t_id, tid, KMP_MAX_BLOCKTIME) );
142  return KMP_MAX_BLOCKTIME;
143  }
144 #ifdef KMP_ADJUST_BLOCKTIME
145  else if ( __kmp_zero_bt && !get__bt_set( team, tid ) ) {
146  KF_TRACE(10, ( "kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n",
147  gtid, team->t.t_id, tid, 0) );
148  return 0;
149  }
150 #endif /* KMP_ADJUST_BLOCKTIME */
151  else {
152  KF_TRACE(10, ( "kmp_get_blocktime: T#%d(%d:%d), blocktime=%d\n",
153  gtid, team->t.t_id, tid, get__blocktime( team, tid ) ) );
154  return get__blocktime( team, tid );
155  };
156  #endif
157 }
158 
159 void FTN_STDCALL
160 FTN_SET_LIBRARY_SERIAL( void )
161 {
162  #ifdef KMP_STUB
163  __kmps_set_library( library_serial );
164  #else
165  // __kmp_user_set_library initializes the library if needed
166  __kmp_user_set_library( library_serial );
167  #endif
168 }
169 
170 void FTN_STDCALL
171 FTN_SET_LIBRARY_TURNAROUND( void )
172 {
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 
181 void FTN_STDCALL
182 FTN_SET_LIBRARY_THROUGHPUT( void )
183 {
184  #ifdef KMP_STUB
185  __kmps_set_library( library_throughput );
186  #else
187  // __kmp_user_set_library initializes the library if needed
188  __kmp_user_set_library( library_throughput );
189  #endif
190 }
191 
192 void FTN_STDCALL
193 FTN_SET_LIBRARY( int KMP_DEREF arg )
194 {
195  #ifdef KMP_STUB
196  __kmps_set_library( KMP_DEREF arg );
197  #else
198  enum library_type lib;
199  lib = (enum library_type) KMP_DEREF arg;
200  // __kmp_user_set_library initializes the library if needed
201  __kmp_user_set_library( lib );
202  #endif
203 }
204 
205 int FTN_STDCALL
206 FTN_GET_LIBRARY (void)
207 {
208  #ifdef KMP_STUB
209  return __kmps_get_library();
210  #else
211  if ( ! __kmp_init_serial ) {
212  __kmp_serial_initialize();
213  }
214  return ((int) __kmp_library);
215  #endif
216 }
217 
218 int FTN_STDCALL
219 FTN_SET_AFFINITY( void **mask )
220 {
221  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
222  return -1;
223  #else
224  if ( ! TCR_4(__kmp_init_middle) ) {
225  __kmp_middle_initialize();
226  }
227  return __kmp_aux_set_affinity( mask );
228  #endif
229 }
230 
231 int FTN_STDCALL
232 FTN_GET_AFFINITY( void **mask )
233 {
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  return __kmp_aux_get_affinity( mask );
241  #endif
242 }
243 
244 int FTN_STDCALL
245 FTN_GET_AFFINITY_MAX_PROC( void )
246 {
247  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
248  return 0;
249  #else
250  //
251  // We really only NEED serial initialization here.
252  //
253  if ( ! TCR_4(__kmp_init_middle) ) {
254  __kmp_middle_initialize();
255  }
256  if ( ! ( KMP_AFFINITY_CAPABLE() ) ) {
257  return 0;
258  }
259 
260  #if KMP_GROUP_AFFINITY
261  if ( __kmp_num_proc_groups > 1 ) {
262  return (int)KMP_CPU_SETSIZE;
263  }
264  #endif /* KMP_GROUP_AFFINITY */
265  return __kmp_xproc;
266  #endif
267 }
268 
269 void FTN_STDCALL
270 FTN_CREATE_AFFINITY_MASK( void **mask )
271 {
272  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
273  *mask = NULL;
274  #else
275  //
276  // We really only NEED serial initialization here.
277  //
278  if ( ! TCR_4(__kmp_init_middle) ) {
279  __kmp_middle_initialize();
280  }
281  *mask = kmpc_malloc( __kmp_affin_mask_size );
282  KMP_CPU_ZERO( (kmp_affin_mask_t *)(*mask) );
283  #endif
284 }
285 
286 void FTN_STDCALL
287 FTN_DESTROY_AFFINITY_MASK( void **mask )
288 {
289  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
290  // Nothing
291  #else
292  //
293  // We really only NEED serial initialization here.
294  //
295  if ( ! TCR_4(__kmp_init_middle) ) {
296  __kmp_middle_initialize();
297  }
298  if ( __kmp_env_consistency_check ) {
299  if ( *mask == NULL ) {
300  KMP_FATAL( AffinityInvalidMask, "kmp_destroy_affinity_mask" );
301  }
302  }
303  kmpc_free( *mask );
304  *mask = NULL;
305  #endif
306 }
307 
308 int FTN_STDCALL
309 FTN_SET_AFFINITY_MASK_PROC( int KMP_DEREF proc, void **mask )
310 {
311  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
312  return -1;
313  #else
314  if ( ! TCR_4(__kmp_init_middle) ) {
315  __kmp_middle_initialize();
316  }
317  return __kmp_aux_set_affinity_mask_proc( KMP_DEREF proc, mask );
318  #endif
319 }
320 
321 int FTN_STDCALL
322 FTN_UNSET_AFFINITY_MASK_PROC( int KMP_DEREF proc, void **mask )
323 {
324  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
325  return -1;
326  #else
327  if ( ! TCR_4(__kmp_init_middle) ) {
328  __kmp_middle_initialize();
329  }
330  return __kmp_aux_unset_affinity_mask_proc( KMP_DEREF proc, mask );
331  #endif
332 }
333 
334 int FTN_STDCALL
335 FTN_GET_AFFINITY_MASK_PROC( int KMP_DEREF proc, void **mask )
336 {
337  #if defined(KMP_STUB) || !KMP_AFFINITY_SUPPORTED
338  return -1;
339  #else
340  if ( ! TCR_4(__kmp_init_middle) ) {
341  __kmp_middle_initialize();
342  }
343  return __kmp_aux_get_affinity_mask_proc( KMP_DEREF proc, mask );
344  #endif
345 }
346 
347 
348 /* ------------------------------------------------------------------------ */
349 
350 /* sets the requested number of threads for the next parallel region */
351 
352 void FTN_STDCALL
353 xexpand(FTN_SET_NUM_THREADS)( int KMP_DEREF arg )
354 {
355  #ifdef KMP_STUB
356  // Nothing.
357  #else
358  __kmp_set_num_threads( KMP_DEREF arg, __kmp_entry_gtid() );
359  #endif
360 }
361 
362 
363 /* returns the number of threads in current team */
364 int FTN_STDCALL
365 xexpand(FTN_GET_NUM_THREADS)( void )
366 {
367  #ifdef KMP_STUB
368  return 1;
369  #else
370  // __kmpc_bound_num_threads initializes the library if needed
371  return __kmpc_bound_num_threads(NULL);
372  #endif
373 }
374 
375 int FTN_STDCALL
376 xexpand(FTN_GET_MAX_THREADS)( void )
377 {
378  #ifdef KMP_STUB
379  return 1;
380  #else
381  int gtid;
382  kmp_info_t *thread;
383  if ( ! TCR_4(__kmp_init_middle) ) {
384  __kmp_middle_initialize();
385  }
386  gtid = __kmp_entry_gtid();
387  thread = __kmp_threads[ gtid ];
388  //return thread -> th.th_team -> t.t_current_task[ thread->th.th_info.ds.ds_tid ] -> icvs.nproc;
389  return thread -> th.th_current_task -> td_icvs.nproc;
390  #endif
391 }
392 
393 int FTN_STDCALL
394 xexpand(FTN_GET_THREAD_NUM)( void )
395 {
396  #ifdef KMP_STUB
397  return 0;
398  #else
399  int gtid;
400 
401  #if KMP_OS_DARWIN || KMP_OS_FREEBSD
402  gtid = __kmp_entry_gtid();
403  #elif KMP_OS_WINDOWS
404  if (!__kmp_init_parallel ||
405  (gtid = (int)((kmp_intptr_t)TlsGetValue( __kmp_gtid_threadprivate_key ))) == 0) {
406  // Either library isn't initialized or thread is not registered
407  // 0 is the correct TID in this case
408  return 0;
409  }
410  --gtid; // We keep (gtid+1) in TLS
411  #elif KMP_OS_LINUX
412  #ifdef KMP_TDATA_GTID
413  if ( __kmp_gtid_mode >= 3 ) {
414  if ((gtid = __kmp_gtid) == KMP_GTID_DNE) {
415  return 0;
416  }
417  } else {
418  #endif
419  if (!__kmp_init_parallel ||
420  (gtid = (kmp_intptr_t)(pthread_getspecific( __kmp_gtid_threadprivate_key ))) == 0) {
421  return 0;
422  }
423  --gtid;
424  #ifdef KMP_TDATA_GTID
425  }
426  #endif
427  #else
428  #error Unknown or unsupported OS
429  #endif
430 
431  return __kmp_tid_from_gtid( gtid );
432  #endif
433 }
434 
435 int FTN_STDCALL
436 FTN_GET_NUM_KNOWN_THREADS( void )
437 {
438  #ifdef KMP_STUB
439  return 1;
440  #else
441  if ( ! __kmp_init_serial ) {
442  __kmp_serial_initialize();
443  }
444  /* NOTE: this is not syncronized, so it can change at any moment */
445  /* NOTE: this number also includes threads preallocated in hot-teams */
446  return TCR_4(__kmp_nth);
447  #endif
448 }
449 
450 int FTN_STDCALL
451 xexpand(FTN_GET_NUM_PROCS)( void )
452 {
453  #ifdef KMP_STUB
454  return 1;
455  #else
456  if ( ! TCR_4(__kmp_init_middle) ) {
457  __kmp_middle_initialize();
458  }
459  return __kmp_avail_proc;
460  #endif
461 }
462 
463 void FTN_STDCALL
464 xexpand(FTN_SET_NESTED)( int KMP_DEREF flag )
465 {
466  #ifdef KMP_STUB
467  __kmps_set_nested( KMP_DEREF flag );
468  #else
469  kmp_info_t *thread;
470  /* For the thread-private internal controls implementation */
471  thread = __kmp_entry_thread();
472  __kmp_save_internal_controls( thread );
473  set__nested( thread, ( (KMP_DEREF flag) ? TRUE : FALSE ) );
474  #endif
475 }
476 
477 
478 int FTN_STDCALL
479 xexpand(FTN_GET_NESTED)( void )
480 {
481  #ifdef KMP_STUB
482  return __kmps_get_nested();
483  #else
484  kmp_info_t *thread;
485  thread = __kmp_entry_thread();
486  return get__nested( thread );
487  #endif
488 }
489 
490 void FTN_STDCALL
491 xexpand(FTN_SET_DYNAMIC)( int KMP_DEREF flag )
492 {
493  #ifdef KMP_STUB
494  __kmps_set_dynamic( KMP_DEREF flag ? TRUE : FALSE );
495  #else
496  kmp_info_t *thread;
497  /* For the thread-private implementation of the internal controls */
498  thread = __kmp_entry_thread();
499  // !!! What if foreign thread calls it?
500  __kmp_save_internal_controls( thread );
501  set__dynamic( thread, KMP_DEREF flag ? TRUE : FALSE );
502  #endif
503 }
504 
505 
506 int FTN_STDCALL
507 xexpand(FTN_GET_DYNAMIC)( void )
508 {
509  #ifdef KMP_STUB
510  return __kmps_get_dynamic();
511  #else
512  kmp_info_t *thread;
513  thread = __kmp_entry_thread();
514  return get__dynamic( thread );
515  #endif
516 }
517 
518 int FTN_STDCALL
519 xexpand(FTN_IN_PARALLEL)( void )
520 {
521  #ifdef KMP_STUB
522  return 0;
523  #else
524  kmp_info_t *th = __kmp_entry_thread();
525 #if OMP_40_ENABLED
526  if ( th->th.th_teams_microtask ) {
527  // AC: r_in_parallel does not work inside teams construct
528  // where real parallel is inactive, but all threads have same root,
529  // so setting it in one team affects other teams.
530  // The solution is to use per-team nesting level
531  return ( th->th.th_team->t.t_active_level ? 1 : 0 );
532  }
533  else
534 #endif /* OMP_40_ENABLED */
535  return ( th->th.th_root->r.r_in_parallel ? FTN_TRUE : FTN_FALSE );
536  #endif
537 }
538 
539 void FTN_STDCALL
540 xexpand(FTN_SET_SCHEDULE)( kmp_sched_t KMP_DEREF kind, int KMP_DEREF modifier )
541 {
542  #ifdef KMP_STUB
543  __kmps_set_schedule( KMP_DEREF kind, KMP_DEREF modifier );
544  #else
545  /* TO DO */
546  /* For the per-task implementation of the internal controls */
547  __kmp_set_schedule( __kmp_entry_gtid(), KMP_DEREF kind, KMP_DEREF modifier );
548  #endif
549 }
550 
551 void FTN_STDCALL
552 xexpand(FTN_GET_SCHEDULE)( kmp_sched_t * kind, int * modifier )
553 {
554  #ifdef KMP_STUB
555  __kmps_get_schedule( kind, modifier );
556  #else
557  /* TO DO */
558  /* For the per-task implementation of the internal controls */
559  __kmp_get_schedule( __kmp_entry_gtid(), kind, modifier );
560  #endif
561 }
562 
563 void FTN_STDCALL
564 xexpand(FTN_SET_MAX_ACTIVE_LEVELS)( int KMP_DEREF arg )
565 {
566  #ifdef KMP_STUB
567  // Nothing.
568  #else
569  /* TO DO */
570  /* We want per-task implementation of this internal control */
571  __kmp_set_max_active_levels( __kmp_entry_gtid(), KMP_DEREF arg );
572  #endif
573 }
574 
575 int FTN_STDCALL
576 xexpand(FTN_GET_MAX_ACTIVE_LEVELS)( void )
577 {
578  #ifdef KMP_STUB
579  return 0;
580  #else
581  /* TO DO */
582  /* We want per-task implementation of this internal control */
583  return __kmp_get_max_active_levels( __kmp_entry_gtid() );
584  #endif
585 }
586 
587 int FTN_STDCALL
588 xexpand(FTN_GET_ACTIVE_LEVEL)( void )
589 {
590  #ifdef KMP_STUB
591  return 0; // returns 0 if it is called from the sequential part of the program
592  #else
593  /* TO DO */
594  /* For the per-task implementation of the internal controls */
595  return __kmp_entry_thread() -> th.th_team -> t.t_active_level;
596  #endif
597 }
598 
599 int FTN_STDCALL
600 xexpand(FTN_GET_LEVEL)( void )
601 {
602  #ifdef KMP_STUB
603  return 0; // returns 0 if it is called from the sequential part of the program
604  #else
605  /* TO DO */
606  /* For the per-task implementation of the internal controls */
607  return __kmp_entry_thread() -> th.th_team -> t.t_level;
608  #endif
609 }
610 
611 int FTN_STDCALL
612 xexpand(FTN_GET_ANCESTOR_THREAD_NUM)( int KMP_DEREF level )
613 {
614  #ifdef KMP_STUB
615  return ( KMP_DEREF level ) ? ( -1 ) : ( 0 );
616  #else
617  return __kmp_get_ancestor_thread_num( __kmp_entry_gtid(), KMP_DEREF level );
618  #endif
619 }
620 
621 int FTN_STDCALL
622 xexpand(FTN_GET_TEAM_SIZE)( int KMP_DEREF level )
623 {
624  #ifdef KMP_STUB
625  return ( KMP_DEREF level ) ? ( -1 ) : ( 1 );
626  #else
627  return __kmp_get_team_size( __kmp_entry_gtid(), KMP_DEREF level );
628  #endif
629 }
630 
631 int FTN_STDCALL
632 xexpand(FTN_GET_THREAD_LIMIT)( void )
633 {
634  #ifdef KMP_STUB
635  return 1; // TO DO: clarify whether it returns 1 or 0?
636  #else
637  if ( ! __kmp_init_serial ) {
638  __kmp_serial_initialize();
639  };
640  /* global ICV */
641  return __kmp_max_nth;
642  #endif
643 }
644 
645 int FTN_STDCALL
646 xexpand(FTN_IN_FINAL)( void )
647 {
648  #ifdef KMP_STUB
649  return 0; // TO DO: clarify whether it returns 1 or 0?
650  #else
651  if ( ! TCR_4(__kmp_init_parallel) ) {
652  return 0;
653  }
654  return __kmp_entry_thread() -> th.th_current_task -> td_flags.final;
655  #endif
656 }
657 
658 #if OMP_40_ENABLED
659 
660 
661 kmp_proc_bind_t FTN_STDCALL
662 xexpand(FTN_GET_PROC_BIND)( void )
663 {
664  #ifdef KMP_STUB
665  return __kmps_get_proc_bind();
666  #else
667  return get__proc_bind( __kmp_entry_thread() );
668  #endif
669 }
670 
671 int FTN_STDCALL
672 xexpand(FTN_GET_NUM_TEAMS)( void )
673 {
674  #ifdef KMP_STUB
675  return 1;
676  #else
677  kmp_info_t *thr = __kmp_entry_thread();
678  if ( thr->th.th_teams_microtask ) {
679  kmp_team_t *team = thr->th.th_team;
680  int tlevel = thr->th.th_teams_level;
681  int ii = team->t.t_level; // the level of the teams construct
682  int dd = team -> t.t_serialized;
683  int level = tlevel + 1;
684  KMP_DEBUG_ASSERT( ii >= tlevel );
685  while( ii > level )
686  {
687  for( dd = team -> t.t_serialized; ( dd > 0 ) && ( ii > level ); dd--, ii-- )
688  {
689  }
690  if( team -> t.t_serialized && ( !dd ) ) {
691  team = team->t.t_parent;
692  continue;
693  }
694  if( ii > level ) {
695  team = team->t.t_parent;
696  ii--;
697  }
698  }
699  if ( dd > 1 ) {
700  return 1; // teams region is serialized ( 1 team of 1 thread ).
701  } else {
702  return team->t.t_parent->t.t_nproc;
703  }
704  } else {
705  return 1;
706  }
707  #endif
708 }
709 
710 int FTN_STDCALL
711 xexpand(FTN_GET_TEAM_NUM)( void )
712 {
713  #ifdef KMP_STUB
714  return 0;
715  #else
716  kmp_info_t *thr = __kmp_entry_thread();
717  if ( thr->th.th_teams_microtask ) {
718  kmp_team_t *team = thr->th.th_team;
719  int tlevel = thr->th.th_teams_level; // the level of the teams construct
720  int ii = team->t.t_level;
721  int dd = team -> t.t_serialized;
722  int level = tlevel + 1;
723  KMP_DEBUG_ASSERT( ii >= tlevel );
724  while( ii > level )
725  {
726  for( dd = team -> t.t_serialized; ( dd > 0 ) && ( ii > level ); dd--, ii-- )
727  {
728  }
729  if( team -> t.t_serialized && ( !dd ) ) {
730  team = team->t.t_parent;
731  continue;
732  }
733  if( ii > level ) {
734  team = team->t.t_parent;
735  ii--;
736  }
737  }
738  if ( dd > 1 ) {
739  return 0; // teams region is serialized ( 1 team of 1 thread ).
740  } else {
741  return team->t.t_master_tid;
742  }
743  } else {
744  return 0;
745  }
746  #endif
747 }
748 
749 #if KMP_MIC || KMP_OS_DARWIN
750 
751 static int __kmp_default_device = 0;
752 
753 int FTN_STDCALL
754 FTN_GET_DEFAULT_DEVICE( void )
755 {
756  return __kmp_default_device;
757 }
758 
759 void FTN_STDCALL
760 FTN_SET_DEFAULT_DEVICE( int KMP_DEREF arg )
761 {
762  __kmp_default_device = KMP_DEREF arg;
763 }
764 
765 int FTN_STDCALL
766 FTN_GET_NUM_DEVICES( void )
767 {
768  return 0;
769 }
770 
771 #endif // KMP_MIC || KMP_OS_DARWIN
772 
773 #if ! KMP_OS_LINUX
774 
775 int FTN_STDCALL
776 xexpand(FTN_IS_INITIAL_DEVICE)( void )
777 {
778  return 1;
779 }
780 
781 #else
782 
783 // This internal function is used when the entry from the offload library
784 // is not found.
785 int _Offload_get_device_number( void ) __attribute__((weak));
786 
787 int FTN_STDCALL
788 xexpand(FTN_IS_INITIAL_DEVICE)( void )
789 {
790  if( _Offload_get_device_number ) {
791  return _Offload_get_device_number() == -1;
792  } else {
793  return 1;
794  }
795 }
796 
797 #endif // ! KMP_OS_LINUX
798 
799 #endif // OMP_40_ENABLED
800 
801 #ifdef KMP_STUB
802 typedef enum { UNINIT = -1, UNLOCKED, LOCKED } kmp_stub_lock_t;
803 #endif /* KMP_STUB */
804 
805 #if KMP_USE_DYNAMIC_LOCK
806 void FTN_STDCALL
807 FTN_INIT_LOCK_HINTED( void **user_lock, int KMP_DEREF hint )
808 {
809  #ifdef KMP_STUB
810  *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
811  #else
812  __kmp_init_lock_hinted( user_lock, KMP_DEREF hint );
813  #endif
814 }
815 
816 void FTN_STDCALL
817 FTN_INIT_NEST_LOCK_HINTED( void **user_lock, int KMP_DEREF hint )
818 {
819  #ifdef KMP_STUB
820  *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
821  #else
822  __kmp_init_nest_lock_hinted( user_lock, KMP_DEREF hint );
823  #endif
824 }
825 #endif
826 
827 /* initialize the lock */
828 void FTN_STDCALL
829 xexpand(FTN_INIT_LOCK)( void **user_lock )
830 {
831  #ifdef KMP_STUB
832  *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
833  #else
834  __kmpc_init_lock( NULL, __kmp_entry_gtid(), user_lock );
835  #endif
836 }
837 
838 /* initialize the lock */
839 void FTN_STDCALL
840 xexpand(FTN_INIT_NEST_LOCK)( void **user_lock )
841 {
842  #ifdef KMP_STUB
843  *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
844  #else
845  __kmpc_init_nest_lock( NULL, __kmp_entry_gtid(), user_lock );
846  #endif
847 }
848 
849 void FTN_STDCALL
850 xexpand(FTN_DESTROY_LOCK)( void **user_lock )
851 {
852  #ifdef KMP_STUB
853  *((kmp_stub_lock_t *)user_lock) = UNINIT;
854  #else
855  __kmpc_destroy_lock( NULL, __kmp_entry_gtid(), user_lock );
856  #endif
857 }
858 
859 void FTN_STDCALL
860 xexpand(FTN_DESTROY_NEST_LOCK)( void **user_lock )
861 {
862  #ifdef KMP_STUB
863  *((kmp_stub_lock_t *)user_lock) = UNINIT;
864  #else
865  __kmpc_destroy_nest_lock( NULL, __kmp_entry_gtid(), user_lock );
866  #endif
867 }
868 
869 void FTN_STDCALL
870 xexpand(FTN_SET_LOCK)( void **user_lock )
871 {
872  #ifdef KMP_STUB
873  if ( *((kmp_stub_lock_t *)user_lock) == UNINIT ) {
874  // TODO: Issue an error.
875  }; // if
876  if ( *((kmp_stub_lock_t *)user_lock) != UNLOCKED ) {
877  // TODO: Issue an error.
878  }; // if
879  *((kmp_stub_lock_t *)user_lock) = LOCKED;
880  #else
881  __kmpc_set_lock( NULL, __kmp_entry_gtid(), user_lock );
882  #endif
883 }
884 
885 void FTN_STDCALL
886 xexpand(FTN_SET_NEST_LOCK)( void **user_lock )
887 {
888  #ifdef KMP_STUB
889  if ( *((kmp_stub_lock_t *)user_lock) == UNINIT ) {
890  // TODO: Issue an error.
891  }; // if
892  (*((int *)user_lock))++;
893  #else
894  __kmpc_set_nest_lock( NULL, __kmp_entry_gtid(), user_lock );
895  #endif
896 }
897 
898 void FTN_STDCALL
899 xexpand(FTN_UNSET_LOCK)( void **user_lock )
900 {
901  #ifdef KMP_STUB
902  if ( *((kmp_stub_lock_t *)user_lock) == UNINIT ) {
903  // TODO: Issue an error.
904  }; // if
905  if ( *((kmp_stub_lock_t *)user_lock) == UNLOCKED ) {
906  // TODO: Issue an error.
907  }; // if
908  *((kmp_stub_lock_t *)user_lock) = UNLOCKED;
909  #else
910  __kmpc_unset_lock( NULL, __kmp_entry_gtid(), user_lock );
911  #endif
912 }
913 
914 void FTN_STDCALL
915 xexpand(FTN_UNSET_NEST_LOCK)( void **user_lock )
916 {
917  #ifdef KMP_STUB
918  if ( *((kmp_stub_lock_t *)user_lock) == UNINIT ) {
919  // TODO: Issue an error.
920  }; // if
921  if ( *((kmp_stub_lock_t *)user_lock) == UNLOCKED ) {
922  // TODO: Issue an error.
923  }; // if
924  (*((int *)user_lock))--;
925  #else
926  __kmpc_unset_nest_lock( NULL, __kmp_entry_gtid(), user_lock );
927  #endif
928 }
929 
930 int FTN_STDCALL
931 xexpand(FTN_TEST_LOCK)( void **user_lock )
932 {
933  #ifdef KMP_STUB
934  if ( *((kmp_stub_lock_t *)user_lock) == UNINIT ) {
935  // TODO: Issue an error.
936  }; // if
937  if ( *((kmp_stub_lock_t *)user_lock) == LOCKED ) {
938  return 0;
939  }; // if
940  *((kmp_stub_lock_t *)user_lock) = LOCKED;
941  return 1;
942  #else
943  return __kmpc_test_lock( NULL, __kmp_entry_gtid(), user_lock );
944  #endif
945 }
946 
947 int FTN_STDCALL
948 xexpand(FTN_TEST_NEST_LOCK)( void **user_lock )
949 {
950  #ifdef KMP_STUB
951  if ( *((kmp_stub_lock_t *)user_lock) == UNINIT ) {
952  // TODO: Issue an error.
953  }; // if
954  return ++(*((int *)user_lock));
955  #else
956  return __kmpc_test_nest_lock( NULL, __kmp_entry_gtid(), user_lock );
957  #endif
958 }
959 
960 double FTN_STDCALL
961 xexpand(FTN_GET_WTIME)( void )
962 {
963  #ifdef KMP_STUB
964  return __kmps_get_wtime();
965  #else
966  double data;
967  #if ! KMP_OS_LINUX
968  // We don't need library initialization to get the time on Linux* OS.
969  // The routine can be used to measure library initialization time on Linux* OS now.
970  if ( ! __kmp_init_serial ) {
971  __kmp_serial_initialize();
972  };
973  #endif
974  __kmp_elapsed( & data );
975  return data;
976  #endif
977 }
978 
979 double FTN_STDCALL
980 xexpand(FTN_GET_WTICK)( void )
981 {
982  #ifdef KMP_STUB
983  return __kmps_get_wtick();
984  #else
985  double data;
986  if ( ! __kmp_init_serial ) {
987  __kmp_serial_initialize();
988  };
989  __kmp_elapsed_tick( & data );
990  return data;
991  #endif
992 }
993 
994 /* ------------------------------------------------------------------------ */
995 
996 void * FTN_STDCALL
997 FTN_MALLOC( size_t KMP_DEREF size )
998 {
999  // kmpc_malloc initializes the library if needed
1000  return kmpc_malloc( KMP_DEREF size );
1001 }
1002 
1003 void * FTN_STDCALL
1004 FTN_CALLOC( size_t KMP_DEREF nelem, size_t KMP_DEREF elsize )
1005 {
1006  // kmpc_calloc initializes the library if needed
1007  return kmpc_calloc( KMP_DEREF nelem, KMP_DEREF elsize );
1008 }
1009 
1010 void * FTN_STDCALL
1011 FTN_REALLOC( void * KMP_DEREF ptr, size_t KMP_DEREF size )
1012 {
1013  // kmpc_realloc initializes the library if needed
1014  return kmpc_realloc( KMP_DEREF ptr, KMP_DEREF size );
1015 }
1016 
1017 void FTN_STDCALL
1018 FTN_FREE( void * KMP_DEREF ptr )
1019 {
1020  // does nothing if the library is not initialized
1021  kmpc_free( KMP_DEREF ptr );
1022 }
1023 
1024 void FTN_STDCALL
1025 FTN_SET_WARNINGS_ON( void )
1026 {
1027  #ifndef KMP_STUB
1028  __kmp_generate_warnings = kmp_warnings_explicit;
1029  #endif
1030 }
1031 
1032 void FTN_STDCALL
1033 FTN_SET_WARNINGS_OFF( void )
1034 {
1035  #ifndef KMP_STUB
1036  __kmp_generate_warnings = FALSE;
1037  #endif
1038 }
1039 
1040 void FTN_STDCALL
1041 FTN_SET_DEFAULTS( char const * str
1042  #ifndef PASS_ARGS_BY_VALUE
1043  , int len
1044  #endif
1045 )
1046 {
1047  #ifndef KMP_STUB
1048  #ifdef PASS_ARGS_BY_VALUE
1049  int len = (int)KMP_STRLEN( str );
1050  #endif
1051  __kmp_aux_set_defaults( str, len );
1052  #endif
1053 }
1054 
1055 /* ------------------------------------------------------------------------ */
1056 
1057 
1058 #if OMP_40_ENABLED
1059 /* returns the status of cancellation */
1060 int FTN_STDCALL
1061 xexpand(FTN_GET_CANCELLATION)(void) {
1062 #ifdef KMP_STUB
1063  return 0 /* false */;
1064 #else
1065  // initialize the library if needed
1066  if ( ! __kmp_init_serial ) {
1067  __kmp_serial_initialize();
1068  }
1069  return __kmp_omp_cancellation;
1070 #endif
1071 }
1072 
1073 int FTN_STDCALL
1074 FTN_GET_CANCELLATION_STATUS(int cancel_kind) {
1075 #ifdef KMP_STUB
1076  return 0 /* false */;
1077 #else
1078  return __kmp_get_cancellation_status(cancel_kind);
1079 #endif
1080 }
1081 
1082 #endif // OMP_40_ENABLED
1083 
1084 // GCC compatibility (versioned symbols)
1085 #ifdef KMP_USE_VERSION_SYMBOLS
1086 
1087 /*
1088  These following sections create function aliases (dummy symbols) for the omp_* routines.
1089  These aliases will then be versioned according to how libgomp ``versions'' its
1090  symbols (OMP_1.0, OMP_2.0, OMP_3.0, ...) while also retaining the
1091  default version which libomp uses: VERSION (defined in exports_so.txt)
1092  If you want to see the versioned symbols for libgomp.so.1 then just type:
1093 
1094  objdump -T /path/to/libgomp.so.1 | grep omp_
1095 
1096  Example:
1097  Step 1) Create __kmp_api_omp_set_num_threads_10_alias
1098  which is alias of __kmp_api_omp_set_num_threads
1099  Step 2) Set __kmp_api_omp_set_num_threads_10_alias to version: omp_set_num_threads@OMP_1.0
1100  Step 2B) Set __kmp_api_omp_set_num_threads to default version : omp_set_num_threads@@VERSION
1101 */
1102 
1103 // OMP_1.0 aliases
1104 xaliasify(FTN_SET_NUM_THREADS, 10);
1105 xaliasify(FTN_GET_NUM_THREADS, 10);
1106 xaliasify(FTN_GET_MAX_THREADS, 10);
1107 xaliasify(FTN_GET_THREAD_NUM, 10);
1108 xaliasify(FTN_GET_NUM_PROCS, 10);
1109 xaliasify(FTN_IN_PARALLEL, 10);
1110 xaliasify(FTN_SET_DYNAMIC, 10);
1111 xaliasify(FTN_GET_DYNAMIC, 10);
1112 xaliasify(FTN_SET_NESTED, 10);
1113 xaliasify(FTN_GET_NESTED, 10);
1114 xaliasify(FTN_INIT_LOCK, 10);
1115 xaliasify(FTN_INIT_NEST_LOCK, 10);
1116 xaliasify(FTN_DESTROY_LOCK, 10);
1117 xaliasify(FTN_DESTROY_NEST_LOCK, 10);
1118 xaliasify(FTN_SET_LOCK, 10);
1119 xaliasify(FTN_SET_NEST_LOCK, 10);
1120 xaliasify(FTN_UNSET_LOCK, 10);
1121 xaliasify(FTN_UNSET_NEST_LOCK, 10);
1122 xaliasify(FTN_TEST_LOCK, 10);
1123 xaliasify(FTN_TEST_NEST_LOCK, 10);
1124 
1125 // OMP_2.0 aliases
1126 xaliasify(FTN_GET_WTICK, 20);
1127 xaliasify(FTN_GET_WTIME, 20);
1128 
1129 // OMP_3.0 aliases
1130 xaliasify(FTN_SET_SCHEDULE, 30);
1131 xaliasify(FTN_GET_SCHEDULE, 30);
1132 xaliasify(FTN_GET_THREAD_LIMIT, 30);
1133 xaliasify(FTN_SET_MAX_ACTIVE_LEVELS, 30);
1134 xaliasify(FTN_GET_MAX_ACTIVE_LEVELS, 30);
1135 xaliasify(FTN_GET_LEVEL, 30);
1136 xaliasify(FTN_GET_ANCESTOR_THREAD_NUM, 30);
1137 xaliasify(FTN_GET_TEAM_SIZE, 30);
1138 xaliasify(FTN_GET_ACTIVE_LEVEL, 30);
1139 xaliasify(FTN_INIT_LOCK, 30);
1140 xaliasify(FTN_INIT_NEST_LOCK, 30);
1141 xaliasify(FTN_DESTROY_LOCK, 30);
1142 xaliasify(FTN_DESTROY_NEST_LOCK, 30);
1143 xaliasify(FTN_SET_LOCK, 30);
1144 xaliasify(FTN_SET_NEST_LOCK, 30);
1145 xaliasify(FTN_UNSET_LOCK, 30);
1146 xaliasify(FTN_UNSET_NEST_LOCK, 30);
1147 xaliasify(FTN_TEST_LOCK, 30);
1148 xaliasify(FTN_TEST_NEST_LOCK, 30);
1149 
1150 // OMP_3.1 aliases
1151 xaliasify(FTN_IN_FINAL, 31);
1152 
1153 #if OMP_40_ENABLED
1154 // OMP_4.0 aliases
1155 xaliasify(FTN_GET_PROC_BIND, 40);
1156 xaliasify(FTN_GET_NUM_TEAMS, 40);
1157 xaliasify(FTN_GET_TEAM_NUM, 40);
1158 xaliasify(FTN_GET_CANCELLATION, 40);
1159 xaliasify(FTN_IS_INITIAL_DEVICE, 40);
1160 #endif /* OMP_40_ENABLED */
1161 
1162 #if OMP_41_ENABLED
1163 // OMP_4.1 aliases
1164 #endif
1165 
1166 #if OMP_50_ENABLED
1167 // OMP_5.0 aliases
1168 #endif
1169 
1170 // OMP_1.0 versioned symbols
1171 xversionify(FTN_SET_NUM_THREADS, 10, "OMP_1.0");
1172 xversionify(FTN_GET_NUM_THREADS, 10, "OMP_1.0");
1173 xversionify(FTN_GET_MAX_THREADS, 10, "OMP_1.0");
1174 xversionify(FTN_GET_THREAD_NUM, 10, "OMP_1.0");
1175 xversionify(FTN_GET_NUM_PROCS, 10, "OMP_1.0");
1176 xversionify(FTN_IN_PARALLEL, 10, "OMP_1.0");
1177 xversionify(FTN_SET_DYNAMIC, 10, "OMP_1.0");
1178 xversionify(FTN_GET_DYNAMIC, 10, "OMP_1.0");
1179 xversionify(FTN_SET_NESTED, 10, "OMP_1.0");
1180 xversionify(FTN_GET_NESTED, 10, "OMP_1.0");
1181 xversionify(FTN_INIT_LOCK, 10, "OMP_1.0");
1182 xversionify(FTN_INIT_NEST_LOCK, 10, "OMP_1.0");
1183 xversionify(FTN_DESTROY_LOCK, 10, "OMP_1.0");
1184 xversionify(FTN_DESTROY_NEST_LOCK, 10, "OMP_1.0");
1185 xversionify(FTN_SET_LOCK, 10, "OMP_1.0");
1186 xversionify(FTN_SET_NEST_LOCK, 10, "OMP_1.0");
1187 xversionify(FTN_UNSET_LOCK, 10, "OMP_1.0");
1188 xversionify(FTN_UNSET_NEST_LOCK, 10, "OMP_1.0");
1189 xversionify(FTN_TEST_LOCK, 10, "OMP_1.0");
1190 xversionify(FTN_TEST_NEST_LOCK, 10, "OMP_1.0");
1191 
1192 // OMP_2.0 versioned symbols
1193 xversionify(FTN_GET_WTICK, 20, "OMP_2.0");
1194 xversionify(FTN_GET_WTIME, 20, "OMP_2.0");
1195 
1196 // OMP_3.0 versioned symbols
1197 xversionify(FTN_SET_SCHEDULE, 30, "OMP_3.0");
1198 xversionify(FTN_GET_SCHEDULE, 30, "OMP_3.0");
1199 xversionify(FTN_GET_THREAD_LIMIT, 30, "OMP_3.0");
1200 xversionify(FTN_SET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1201 xversionify(FTN_GET_MAX_ACTIVE_LEVELS, 30, "OMP_3.0");
1202 xversionify(FTN_GET_ANCESTOR_THREAD_NUM, 30, "OMP_3.0");
1203 xversionify(FTN_GET_LEVEL, 30, "OMP_3.0");
1204 xversionify(FTN_GET_TEAM_SIZE, 30, "OMP_3.0");
1205 xversionify(FTN_GET_ACTIVE_LEVEL, 30, "OMP_3.0");
1206 
1207 // the lock routines have a 1.0 and 3.0 version
1208 xversionify(FTN_INIT_LOCK, 30, "OMP_3.0");
1209 xversionify(FTN_INIT_NEST_LOCK, 30, "OMP_3.0");
1210 xversionify(FTN_DESTROY_LOCK, 30, "OMP_3.0");
1211 xversionify(FTN_DESTROY_NEST_LOCK, 30, "OMP_3.0");
1212 xversionify(FTN_SET_LOCK, 30, "OMP_3.0");
1213 xversionify(FTN_SET_NEST_LOCK, 30, "OMP_3.0");
1214 xversionify(FTN_UNSET_LOCK, 30, "OMP_3.0");
1215 xversionify(FTN_UNSET_NEST_LOCK, 30, "OMP_3.0");
1216 xversionify(FTN_TEST_LOCK, 30, "OMP_3.0");
1217 xversionify(FTN_TEST_NEST_LOCK, 30, "OMP_3.0");
1218 
1219 // OMP_3.1 versioned symbol
1220 xversionify(FTN_IN_FINAL, 31, "OMP_3.1");
1221 
1222 #if OMP_40_ENABLED
1223 // OMP_4.0 versioned symbols
1224 xversionify(FTN_GET_PROC_BIND, 40, "OMP_4.0");
1225 xversionify(FTN_GET_NUM_TEAMS, 40, "OMP_4.0");
1226 xversionify(FTN_GET_TEAM_NUM, 40, "OMP_4.0");
1227 xversionify(FTN_GET_CANCELLATION, 40, "OMP_4.0");
1228 xversionify(FTN_IS_INITIAL_DEVICE, 40, "OMP_4.0");
1229 #endif /* OMP_40_ENABLED */
1230 
1231 #if OMP_41_ENABLED
1232 // OMP_4.1 versioned symbols
1233 #endif
1234 
1235 #if OMP_50_ENABLED
1236 // OMP_5.0 versioned symbols
1237 #endif
1238 
1239 #endif // KMP_USE_VERSION_SYMBOLS
1240 
1241 #ifdef __cplusplus
1242  } //extern "C"
1243 #endif // __cplusplus
1244 
1245 // end of file //
KMP_EXPORT kmp_int32 __kmpc_bound_num_threads(ident_t *)
Definition: kmp_csupport.c:147