Move PREFERRED_DEBUGGING_TYPE define in pa64-hpux.h to pa.h
[official-gcc.git] / libgomp / fortran.c
blob14b5c8d51dd65b0905ec82621086add96f97fa00
1 /* Copyright (C) 2005-2021 Free Software Foundation, Inc.
2 Contributed by Jakub Jelinek <jakub@redhat.com>.
4 This file is part of the GNU Offloading and Multi Processing Library
5 (libgomp).
7 Libgomp is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
10 any later version.
12 Libgomp is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14 FOR A PARTICULAR PURPOSE. See the GNU General Public License for
15 more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 /* This file contains Fortran wrapper routines. */
28 #include "libgomp.h"
29 #include "libgomp_f.h"
30 #include <stdlib.h>
31 #include <stdio.h>
32 #include <string.h>
33 #include <limits.h>
35 #ifdef HAVE_ATTRIBUTE_ALIAS
36 /* Use internal aliases if possible. */
37 # ifndef LIBGOMP_GNU_SYMBOL_VERSIONING
38 ialias_redirect (omp_init_lock)
39 ialias_redirect (omp_init_nest_lock)
40 ialias_redirect (omp_destroy_lock)
41 ialias_redirect (omp_destroy_nest_lock)
42 ialias_redirect (omp_set_lock)
43 ialias_redirect (omp_set_nest_lock)
44 ialias_redirect (omp_unset_lock)
45 ialias_redirect (omp_unset_nest_lock)
46 ialias_redirect (omp_test_lock)
47 ialias_redirect (omp_test_nest_lock)
48 # endif
49 ialias_redirect (omp_set_dynamic)
50 ialias_redirect (omp_get_dynamic)
51 #pragma GCC diagnostic push
52 #pragma GCC diagnostic ignored "-Wdeprecated-declarations"
53 ialias_redirect (omp_set_nested)
54 ialias_redirect (omp_get_nested)
55 #pragma GCC diagnostic pop
56 ialias_redirect (omp_set_num_threads)
57 ialias_redirect (omp_in_parallel)
58 ialias_redirect (omp_get_max_threads)
59 ialias_redirect (omp_get_num_procs)
60 ialias_redirect (omp_get_num_threads)
61 ialias_redirect (omp_get_thread_num)
62 ialias_redirect (omp_get_wtick)
63 ialias_redirect (omp_get_wtime)
64 ialias_redirect (omp_set_schedule)
65 ialias_redirect (omp_get_schedule)
66 ialias_redirect (omp_get_thread_limit)
67 ialias_redirect (omp_set_max_active_levels)
68 ialias_redirect (omp_get_max_active_levels)
69 ialias_redirect (omp_get_supported_active_levels)
70 ialias_redirect (omp_set_num_teams)
71 ialias_redirect (omp_get_max_teams)
72 ialias_redirect (omp_set_teams_thread_limit)
73 ialias_redirect (omp_get_teams_thread_limit)
74 ialias_redirect (omp_get_level)
75 ialias_redirect (omp_get_ancestor_thread_num)
76 ialias_redirect (omp_get_team_size)
77 ialias_redirect (omp_get_active_level)
78 ialias_redirect (omp_in_final)
79 ialias_redirect (omp_get_cancellation)
80 ialias_redirect (omp_get_proc_bind)
81 ialias_redirect (omp_get_num_places)
82 ialias_redirect (omp_get_place_num_procs)
83 ialias_redirect (omp_get_place_proc_ids)
84 ialias_redirect (omp_get_place_num)
85 ialias_redirect (omp_get_partition_num_places)
86 ialias_redirect (omp_get_partition_place_nums)
87 ialias_redirect (omp_set_default_device)
88 ialias_redirect (omp_get_default_device)
89 ialias_redirect (omp_get_num_devices)
90 ialias_redirect (omp_get_device_num)
91 ialias_redirect (omp_get_num_teams)
92 ialias_redirect (omp_get_team_num)
93 ialias_redirect (omp_is_initial_device)
94 ialias_redirect (omp_get_initial_device)
95 ialias_redirect (omp_get_max_task_priority)
96 ialias_redirect (omp_pause_resource)
97 ialias_redirect (omp_pause_resource_all)
98 ialias_redirect (omp_init_allocator)
99 ialias_redirect (omp_destroy_allocator)
100 ialias_redirect (omp_set_default_allocator)
101 ialias_redirect (omp_get_default_allocator)
102 ialias_redirect (omp_display_env)
103 ialias_redirect (omp_fulfill_event)
104 #endif
106 #ifndef LIBGOMP_GNU_SYMBOL_VERSIONING
107 # define gomp_init_lock__30 omp_init_lock_
108 # define gomp_destroy_lock__30 omp_destroy_lock_
109 # define gomp_set_lock__30 omp_set_lock_
110 # define gomp_unset_lock__30 omp_unset_lock_
111 # define gomp_test_lock__30 omp_test_lock_
112 # define gomp_init_nest_lock__30 omp_init_nest_lock_
113 # define gomp_destroy_nest_lock__30 omp_destroy_nest_lock_
114 # define gomp_set_nest_lock__30 omp_set_nest_lock_
115 # define gomp_unset_nest_lock__30 omp_unset_nest_lock_
116 # define gomp_test_nest_lock__30 omp_test_nest_lock_
117 #endif
119 void
120 gomp_init_lock__30 (omp_lock_arg_t lock)
122 #ifndef OMP_LOCK_DIRECT
123 omp_lock_arg (lock) = malloc (sizeof (omp_lock_t));
124 #endif
125 gomp_init_lock_30 (omp_lock_arg (lock));
128 void
129 gomp_init_nest_lock__30 (omp_nest_lock_arg_t lock)
131 #ifndef OMP_NEST_LOCK_DIRECT
132 omp_nest_lock_arg (lock) = malloc (sizeof (omp_nest_lock_t));
133 #endif
134 gomp_init_nest_lock_30 (omp_nest_lock_arg (lock));
137 void
138 gomp_destroy_lock__30 (omp_lock_arg_t lock)
140 gomp_destroy_lock_30 (omp_lock_arg (lock));
141 #ifndef OMP_LOCK_DIRECT
142 free (omp_lock_arg (lock));
143 omp_lock_arg (lock) = NULL;
144 #endif
147 void
148 gomp_destroy_nest_lock__30 (omp_nest_lock_arg_t lock)
150 gomp_destroy_nest_lock_30 (omp_nest_lock_arg (lock));
151 #ifndef OMP_NEST_LOCK_DIRECT
152 free (omp_nest_lock_arg (lock));
153 omp_nest_lock_arg (lock) = NULL;
154 #endif
157 void
158 gomp_set_lock__30 (omp_lock_arg_t lock)
160 gomp_set_lock_30 (omp_lock_arg (lock));
163 void
164 gomp_set_nest_lock__30 (omp_nest_lock_arg_t lock)
166 gomp_set_nest_lock_30 (omp_nest_lock_arg (lock));
169 void
170 gomp_unset_lock__30 (omp_lock_arg_t lock)
172 gomp_unset_lock_30 (omp_lock_arg (lock));
175 void
176 gomp_unset_nest_lock__30 (omp_nest_lock_arg_t lock)
178 gomp_unset_nest_lock_30 (omp_nest_lock_arg (lock));
181 int32_t
182 gomp_test_lock__30 (omp_lock_arg_t lock)
184 return gomp_test_lock_30 (omp_lock_arg (lock));
187 int32_t
188 gomp_test_nest_lock__30 (omp_nest_lock_arg_t lock)
190 return gomp_test_nest_lock_30 (omp_nest_lock_arg (lock));
193 #ifdef LIBGOMP_GNU_SYMBOL_VERSIONING
194 void
195 gomp_init_lock__25 (omp_lock_25_arg_t lock)
197 #ifndef OMP_LOCK_25_DIRECT
198 omp_lock_25_arg (lock) = malloc (sizeof (omp_lock_25_t));
199 #endif
200 gomp_init_lock_25 (omp_lock_25_arg (lock));
203 void
204 gomp_init_nest_lock__25 (omp_nest_lock_25_arg_t lock)
206 #ifndef OMP_NEST_LOCK_25_DIRECT
207 omp_nest_lock_25_arg (lock) = malloc (sizeof (omp_nest_lock_25_t));
208 #endif
209 gomp_init_nest_lock_25 (omp_nest_lock_25_arg (lock));
212 void
213 gomp_destroy_lock__25 (omp_lock_25_arg_t lock)
215 gomp_destroy_lock_25 (omp_lock_25_arg (lock));
216 #ifndef OMP_LOCK_25_DIRECT
217 free (omp_lock_25_arg (lock));
218 omp_lock_25_arg (lock) = NULL;
219 #endif
222 void
223 gomp_destroy_nest_lock__25 (omp_nest_lock_25_arg_t lock)
225 gomp_destroy_nest_lock_25 (omp_nest_lock_25_arg (lock));
226 #ifndef OMP_NEST_LOCK_25_DIRECT
227 free (omp_nest_lock_25_arg (lock));
228 omp_nest_lock_25_arg (lock) = NULL;
229 #endif
232 void
233 gomp_set_lock__25 (omp_lock_25_arg_t lock)
235 gomp_set_lock_25 (omp_lock_25_arg (lock));
238 void
239 gomp_set_nest_lock__25 (omp_nest_lock_25_arg_t lock)
241 gomp_set_nest_lock_25 (omp_nest_lock_25_arg (lock));
244 void
245 gomp_unset_lock__25 (omp_lock_25_arg_t lock)
247 gomp_unset_lock_25 (omp_lock_25_arg (lock));
250 void
251 gomp_unset_nest_lock__25 (omp_nest_lock_25_arg_t lock)
253 gomp_unset_nest_lock_25 (omp_nest_lock_25_arg (lock));
256 int32_t
257 gomp_test_lock__25 (omp_lock_25_arg_t lock)
259 return gomp_test_lock_25 (omp_lock_25_arg (lock));
262 int32_t
263 gomp_test_nest_lock__25 (omp_nest_lock_25_arg_t lock)
265 return gomp_test_nest_lock_25 (omp_nest_lock_25_arg (lock));
268 omp_lock_symver (omp_init_lock_)
269 omp_lock_symver (omp_destroy_lock_)
270 omp_lock_symver (omp_set_lock_)
271 omp_lock_symver (omp_unset_lock_)
272 omp_lock_symver (omp_test_lock_)
273 omp_lock_symver (omp_init_nest_lock_)
274 omp_lock_symver (omp_destroy_nest_lock_)
275 omp_lock_symver (omp_set_nest_lock_)
276 omp_lock_symver (omp_unset_nest_lock_)
277 omp_lock_symver (omp_test_nest_lock_)
278 #endif
280 #define TO_INT(x) ((x) > INT_MIN ? (x) < INT_MAX ? (x) : INT_MAX : INT_MIN)
282 void
283 omp_set_dynamic_ (const int32_t *set)
285 omp_set_dynamic (*set);
288 void
289 omp_set_dynamic_8_ (const int64_t *set)
291 omp_set_dynamic (!!*set);
294 #pragma GCC diagnostic push
295 #pragma GCC diagnostic ignored "-Wdeprecated-declarations"
296 void
297 omp_set_nested_ (const int32_t *set)
299 omp_set_nested (*set);
302 void
303 omp_set_nested_8_ (const int64_t *set)
305 omp_set_nested (!!*set);
307 #pragma GCC diagnostic pop
309 void
310 omp_set_num_threads_ (const int32_t *set)
312 omp_set_num_threads (*set);
315 void
316 omp_set_num_threads_8_ (const int64_t *set)
318 omp_set_num_threads (TO_INT (*set));
321 int32_t
322 omp_get_dynamic_ (void)
324 return omp_get_dynamic ();
327 #pragma GCC diagnostic push
328 #pragma GCC diagnostic ignored "-Wdeprecated-declarations"
329 int32_t
330 omp_get_nested_ (void)
332 return omp_get_nested ();
334 #pragma GCC diagnostic pop
336 int32_t
337 omp_in_parallel_ (void)
339 return omp_in_parallel ();
342 int32_t
343 omp_get_max_threads_ (void)
345 return omp_get_max_threads ();
348 int32_t
349 omp_get_num_procs_ (void)
351 return omp_get_num_procs ();
354 int32_t
355 omp_get_num_threads_ (void)
357 return omp_get_num_threads ();
360 int32_t
361 omp_get_thread_num_ (void)
363 return omp_get_thread_num ();
366 double
367 omp_get_wtick_ (void)
369 return omp_get_wtick ();
372 double
373 omp_get_wtime_ (void)
375 return omp_get_wtime ();
378 void
379 omp_set_schedule_ (const int32_t *kind, const int32_t *chunk_size)
381 omp_set_schedule (*kind, *chunk_size);
384 void
385 omp_set_schedule_8_ (const int32_t *kind, const int64_t *chunk_size)
387 omp_set_schedule (*kind, TO_INT (*chunk_size));
390 void
391 omp_get_schedule_ (int32_t *kind, int32_t *chunk_size)
393 omp_sched_t k;
394 int cs;
395 omp_get_schedule (&k, &cs);
396 /* For now mask off GFS_MONOTONIC, because OpenMP 4.5 code will not
397 expect to see it. */
398 *kind = k & ~GFS_MONOTONIC;
399 *chunk_size = cs;
402 void
403 omp_get_schedule_8_ (int32_t *kind, int64_t *chunk_size)
405 omp_sched_t k;
406 int cs;
407 omp_get_schedule (&k, &cs);
408 /* See above. */
409 *kind = k & ~GFS_MONOTONIC;
410 *chunk_size = cs;
413 int32_t
414 omp_get_thread_limit_ (void)
416 return omp_get_thread_limit ();
419 void
420 omp_set_max_active_levels_ (const int32_t *levels)
422 omp_set_max_active_levels (*levels);
425 void
426 omp_set_max_active_levels_8_ (const int64_t *levels)
428 omp_set_max_active_levels (TO_INT (*levels));
431 int32_t
432 omp_get_max_active_levels_ (void)
434 return omp_get_max_active_levels ();
437 int32_t
438 omp_get_supported_active_levels_ (void)
440 return omp_get_supported_active_levels ();
443 int32_t
444 omp_get_level_ (void)
446 return omp_get_level ();
449 int32_t
450 omp_get_ancestor_thread_num_ (const int32_t *level)
452 return omp_get_ancestor_thread_num (*level);
455 int32_t
456 omp_get_ancestor_thread_num_8_ (const int64_t *level)
458 return omp_get_ancestor_thread_num (TO_INT (*level));
461 int32_t
462 omp_get_team_size_ (const int32_t *level)
464 return omp_get_team_size (*level);
467 int32_t
468 omp_get_team_size_8_ (const int64_t *level)
470 return omp_get_team_size (TO_INT (*level));
473 int32_t
474 omp_get_active_level_ (void)
476 return omp_get_active_level ();
479 int32_t
480 omp_in_final_ (void)
482 return omp_in_final ();
485 void
486 omp_set_num_teams_ (const int32_t *num_teams)
488 omp_set_num_teams (*num_teams);
491 void
492 omp_set_num_teams_8_ (const int64_t *num_teams)
494 omp_set_max_active_levels (TO_INT (*num_teams));
497 int32_t
498 omp_get_max_teams_ (void)
500 return omp_get_max_teams ();
503 void
504 omp_set_teams_thread_limit_ (const int32_t *thread_limit)
506 omp_set_teams_thread_limit (*thread_limit);
509 void
510 omp_set_teams_thread_limit_8_ (const int64_t *thread_limit)
512 omp_set_teams_thread_limit (TO_INT (*thread_limit));
515 int32_t
516 omp_get_teams_thread_limit_ (void)
518 return omp_get_teams_thread_limit ();
521 int32_t
522 omp_get_cancellation_ (void)
524 return omp_get_cancellation ();
527 int32_t
528 omp_get_proc_bind_ (void)
530 return omp_get_proc_bind ();
533 int32_t
534 omp_get_num_places_ (void)
536 return omp_get_num_places ();
539 int32_t
540 omp_get_place_num_procs_ (const int32_t *place_num)
542 return omp_get_place_num_procs (*place_num);
545 int32_t
546 omp_get_place_num_procs_8_ (const int64_t *place_num)
548 return omp_get_place_num_procs (TO_INT (*place_num));
551 void
552 omp_get_place_proc_ids_ (const int32_t *place_num, int32_t *ids)
554 omp_get_place_proc_ids (*place_num, (int *) ids);
557 void
558 omp_get_place_proc_ids_8_ (const int64_t *place_num, int64_t *ids)
560 gomp_get_place_proc_ids_8 (TO_INT (*place_num), ids);
563 int32_t
564 omp_get_place_num_ (void)
566 return omp_get_place_num ();
569 int32_t
570 omp_get_partition_num_places_ (void)
572 return omp_get_partition_num_places ();
575 void
576 omp_get_partition_place_nums_ (int32_t *place_nums)
578 omp_get_partition_place_nums ((int *) place_nums);
581 void
582 omp_get_partition_place_nums_8_ (int64_t *place_nums)
584 if (gomp_places_list == NULL)
585 return;
587 struct gomp_thread *thr = gomp_thread ();
588 if (thr->place == 0)
589 gomp_init_affinity ();
591 unsigned int i;
592 for (i = 0; i < thr->ts.place_partition_len; i++)
593 *place_nums++ = (int64_t) thr->ts.place_partition_off + i;
596 void
597 omp_set_default_device_ (const int32_t *device_num)
599 return omp_set_default_device (*device_num);
602 void
603 omp_set_default_device_8_ (const int64_t *device_num)
605 return omp_set_default_device (TO_INT (*device_num));
608 int32_t
609 omp_get_default_device_ (void)
611 return omp_get_default_device ();
614 int32_t
615 omp_get_num_devices_ (void)
617 return omp_get_num_devices ();
620 int32_t
621 omp_get_num_teams_ (void)
623 return omp_get_num_teams ();
626 int32_t
627 omp_get_team_num_ (void)
629 return omp_get_team_num ();
632 int32_t
633 omp_is_initial_device_ (void)
635 return omp_is_initial_device ();
638 int32_t
639 omp_get_initial_device_ (void)
641 return omp_get_initial_device ();
644 int32_t
645 omp_get_device_num_ (void)
647 return omp_get_device_num ();
650 int32_t
651 omp_get_max_task_priority_ (void)
653 return omp_get_max_task_priority ();
656 void
657 omp_fulfill_event_ (intptr_t event)
659 omp_fulfill_event ((omp_event_handle_t) event);
662 void
663 omp_set_affinity_format_ (const char *format, size_t format_len)
665 gomp_set_affinity_format (format, format_len);
668 int32_t
669 omp_get_affinity_format_ (char *buffer, size_t buffer_len)
671 size_t len = strlen (gomp_affinity_format_var);
672 if (buffer_len)
674 if (len < buffer_len)
676 memcpy (buffer, gomp_affinity_format_var, len);
677 memset (buffer + len, ' ', buffer_len - len);
679 else
680 memcpy (buffer, gomp_affinity_format_var, buffer_len);
682 return len;
685 void
686 omp_display_affinity_ (const char *format, size_t format_len)
688 char *fmt = NULL, fmt_buf[256];
689 char buf[512];
690 if (format_len)
692 fmt = format_len < 256 ? fmt_buf : gomp_malloc (format_len + 1);
693 memcpy (fmt, format, format_len);
694 fmt[format_len] = '\0';
696 struct gomp_thread *thr = gomp_thread ();
697 size_t ret
698 = gomp_display_affinity (buf, sizeof buf,
699 format_len ? fmt : gomp_affinity_format_var,
700 gomp_thread_self (), &thr->ts, thr->place);
701 if (ret < sizeof buf)
703 buf[ret] = '\n';
704 gomp_print_string (buf, ret + 1);
706 else
708 char *b = gomp_malloc (ret + 1);
709 gomp_display_affinity (buf, sizeof buf,
710 format_len ? fmt : gomp_affinity_format_var,
711 gomp_thread_self (), &thr->ts, thr->place);
712 b[ret] = '\n';
713 gomp_print_string (b, ret + 1);
714 free (b);
716 if (fmt && fmt != fmt_buf)
717 free (fmt);
720 int32_t
721 omp_capture_affinity_ (char *buffer, const char *format,
722 size_t buffer_len, size_t format_len)
724 char *fmt = NULL, fmt_buf[256];
725 if (format_len)
727 fmt = format_len < 256 ? fmt_buf : gomp_malloc (format_len + 1);
728 memcpy (fmt, format, format_len);
729 fmt[format_len] = '\0';
731 struct gomp_thread *thr = gomp_thread ();
732 size_t ret
733 = gomp_display_affinity (buffer, buffer_len,
734 format_len ? fmt : gomp_affinity_format_var,
735 gomp_thread_self (), &thr->ts, thr->place);
736 if (fmt && fmt != fmt_buf)
737 free (fmt);
738 if (ret < buffer_len)
739 memset (buffer + ret, ' ', buffer_len - ret);
740 return ret;
743 int32_t
744 omp_pause_resource_ (const int32_t *kind, const int32_t *device_num)
746 return omp_pause_resource (*kind, *device_num);
749 int32_t
750 omp_pause_resource_all_ (const int32_t *kind)
752 return omp_pause_resource_all (*kind);
755 intptr_t
756 omp_init_allocator_ (const intptr_t *memspace, const int32_t *ntraits,
757 const omp_alloctrait_t *traits)
759 return (intptr_t) omp_init_allocator ((omp_memspace_handle_t) *memspace,
760 (int) *ntraits, traits);
763 intptr_t
764 omp_init_allocator_8_ (const intptr_t *memspace, const int64_t *ntraits,
765 const omp_alloctrait_t *traits)
767 return (intptr_t) omp_init_allocator ((omp_memspace_handle_t) *memspace,
768 (int) *ntraits, traits);
771 void
772 omp_destroy_allocator_ (const intptr_t *allocator)
774 omp_destroy_allocator ((omp_allocator_handle_t) *allocator);
777 void
778 omp_set_default_allocator_ (const intptr_t *allocator)
780 omp_set_default_allocator ((omp_allocator_handle_t) *allocator);
783 intptr_t
784 omp_get_default_allocator_ ()
786 return (intptr_t) omp_get_default_allocator ();
789 #ifndef LIBGOMP_OFFLOADED_ONLY
791 void
792 omp_display_env_ (const int32_t *verbose)
794 omp_display_env (*verbose);
797 void
798 omp_display_env_8_ (const int64_t *verbose)
800 omp_display_env (!!*verbose);
803 #endif /* LIBGOMP_OFFLOADED_ONLY */