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