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