Daily bump.
[official-gcc.git] / libgomp / fortran.c
blobcfbea32b022b237b4a457fefee78d48517cb362a
1 /* Copyright (C) 2005-2024 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_in_explicit_task)
80 ialias_redirect (omp_get_cancellation)
81 ialias_redirect (omp_get_proc_bind)
82 ialias_redirect (omp_get_num_places)
83 ialias_redirect (omp_get_place_num_procs)
84 ialias_redirect (omp_get_place_proc_ids)
85 ialias_redirect (omp_get_place_num)
86 ialias_redirect (omp_get_partition_num_places)
87 ialias_redirect (omp_get_partition_place_nums)
88 ialias_redirect (omp_set_default_device)
89 ialias_redirect (omp_get_default_device)
90 ialias_redirect (omp_get_num_devices)
91 ialias_redirect (omp_get_device_num)
92 ialias_redirect (omp_get_num_teams)
93 ialias_redirect (omp_get_team_num)
94 ialias_redirect (omp_is_initial_device)
95 ialias_redirect (omp_get_initial_device)
96 ialias_redirect (omp_get_max_task_priority)
97 ialias_redirect (omp_pause_resource)
98 ialias_redirect (omp_pause_resource_all)
99 ialias_redirect (omp_init_allocator)
100 ialias_redirect (omp_destroy_allocator)
101 ialias_redirect (omp_set_default_allocator)
102 ialias_redirect (omp_get_default_allocator)
103 ialias_redirect (omp_display_env)
104 ialias_redirect (omp_fulfill_event)
105 #endif
107 #ifndef LIBGOMP_GNU_SYMBOL_VERSIONING
108 # define gomp_init_lock__30 omp_init_lock_
109 # define gomp_destroy_lock__30 omp_destroy_lock_
110 # define gomp_set_lock__30 omp_set_lock_
111 # define gomp_unset_lock__30 omp_unset_lock_
112 # define gomp_test_lock__30 omp_test_lock_
113 # define gomp_init_nest_lock__30 omp_init_nest_lock_
114 # define gomp_destroy_nest_lock__30 omp_destroy_nest_lock_
115 # define gomp_set_nest_lock__30 omp_set_nest_lock_
116 # define gomp_unset_nest_lock__30 omp_unset_nest_lock_
117 # define gomp_test_nest_lock__30 omp_test_nest_lock_
118 #endif
120 void
121 gomp_init_lock__30 (omp_lock_arg_t lock)
123 #ifndef OMP_LOCK_DIRECT
124 omp_lock_arg (lock) = malloc (sizeof (omp_lock_t));
125 #endif
126 gomp_init_lock_30 (omp_lock_arg (lock));
129 void
130 gomp_init_nest_lock__30 (omp_nest_lock_arg_t lock)
132 #ifndef OMP_NEST_LOCK_DIRECT
133 omp_nest_lock_arg (lock) = malloc (sizeof (omp_nest_lock_t));
134 #endif
135 gomp_init_nest_lock_30 (omp_nest_lock_arg (lock));
138 void
139 gomp_destroy_lock__30 (omp_lock_arg_t lock)
141 gomp_destroy_lock_30 (omp_lock_arg (lock));
142 #ifndef OMP_LOCK_DIRECT
143 free (omp_lock_arg (lock));
144 omp_lock_arg (lock) = NULL;
145 #endif
148 void
149 gomp_destroy_nest_lock__30 (omp_nest_lock_arg_t lock)
151 gomp_destroy_nest_lock_30 (omp_nest_lock_arg (lock));
152 #ifndef OMP_NEST_LOCK_DIRECT
153 free (omp_nest_lock_arg (lock));
154 omp_nest_lock_arg (lock) = NULL;
155 #endif
158 void
159 gomp_set_lock__30 (omp_lock_arg_t lock)
161 gomp_set_lock_30 (omp_lock_arg (lock));
164 void
165 gomp_set_nest_lock__30 (omp_nest_lock_arg_t lock)
167 gomp_set_nest_lock_30 (omp_nest_lock_arg (lock));
170 void
171 gomp_unset_lock__30 (omp_lock_arg_t lock)
173 gomp_unset_lock_30 (omp_lock_arg (lock));
176 void
177 gomp_unset_nest_lock__30 (omp_nest_lock_arg_t lock)
179 gomp_unset_nest_lock_30 (omp_nest_lock_arg (lock));
182 int32_t
183 gomp_test_lock__30 (omp_lock_arg_t lock)
185 return gomp_test_lock_30 (omp_lock_arg (lock));
188 int32_t
189 gomp_test_nest_lock__30 (omp_nest_lock_arg_t lock)
191 return gomp_test_nest_lock_30 (omp_nest_lock_arg (lock));
194 #ifdef LIBGOMP_GNU_SYMBOL_VERSIONING
195 void
196 gomp_init_lock__25 (omp_lock_25_arg_t lock)
198 #ifndef OMP_LOCK_25_DIRECT
199 omp_lock_25_arg (lock) = malloc (sizeof (omp_lock_25_t));
200 #endif
201 gomp_init_lock_25 (omp_lock_25_arg (lock));
204 void
205 gomp_init_nest_lock__25 (omp_nest_lock_25_arg_t lock)
207 #ifndef OMP_NEST_LOCK_25_DIRECT
208 omp_nest_lock_25_arg (lock) = malloc (sizeof (omp_nest_lock_25_t));
209 #endif
210 gomp_init_nest_lock_25 (omp_nest_lock_25_arg (lock));
213 void
214 gomp_destroy_lock__25 (omp_lock_25_arg_t lock)
216 gomp_destroy_lock_25 (omp_lock_25_arg (lock));
217 #ifndef OMP_LOCK_25_DIRECT
218 free (omp_lock_25_arg (lock));
219 omp_lock_25_arg (lock) = NULL;
220 #endif
223 void
224 gomp_destroy_nest_lock__25 (omp_nest_lock_25_arg_t lock)
226 gomp_destroy_nest_lock_25 (omp_nest_lock_25_arg (lock));
227 #ifndef OMP_NEST_LOCK_25_DIRECT
228 free (omp_nest_lock_25_arg (lock));
229 omp_nest_lock_25_arg (lock) = NULL;
230 #endif
233 void
234 gomp_set_lock__25 (omp_lock_25_arg_t lock)
236 gomp_set_lock_25 (omp_lock_25_arg (lock));
239 void
240 gomp_set_nest_lock__25 (omp_nest_lock_25_arg_t lock)
242 gomp_set_nest_lock_25 (omp_nest_lock_25_arg (lock));
245 void
246 gomp_unset_lock__25 (omp_lock_25_arg_t lock)
248 gomp_unset_lock_25 (omp_lock_25_arg (lock));
251 void
252 gomp_unset_nest_lock__25 (omp_nest_lock_25_arg_t lock)
254 gomp_unset_nest_lock_25 (omp_nest_lock_25_arg (lock));
257 int32_t
258 gomp_test_lock__25 (omp_lock_25_arg_t lock)
260 return gomp_test_lock_25 (omp_lock_25_arg (lock));
263 int32_t
264 gomp_test_nest_lock__25 (omp_nest_lock_25_arg_t lock)
266 return gomp_test_nest_lock_25 (omp_nest_lock_25_arg (lock));
269 omp_lock_symver (omp_init_lock_)
270 omp_lock_symver (omp_destroy_lock_)
271 omp_lock_symver (omp_set_lock_)
272 omp_lock_symver (omp_unset_lock_)
273 omp_lock_symver (omp_test_lock_)
274 omp_lock_symver (omp_init_nest_lock_)
275 omp_lock_symver (omp_destroy_nest_lock_)
276 omp_lock_symver (omp_set_nest_lock_)
277 omp_lock_symver (omp_unset_nest_lock_)
278 omp_lock_symver (omp_test_nest_lock_)
279 #endif
281 #define TO_INT(x) ((x) > INT_MIN ? (x) < INT_MAX ? (x) : INT_MAX : INT_MIN)
283 void
284 omp_set_dynamic_ (const int32_t *set)
286 omp_set_dynamic (*set);
289 void
290 omp_set_dynamic_8_ (const int64_t *set)
292 omp_set_dynamic (!!*set);
295 #pragma GCC diagnostic push
296 #pragma GCC diagnostic ignored "-Wdeprecated-declarations"
297 void
298 omp_set_nested_ (const int32_t *set)
300 omp_set_nested (*set);
303 void
304 omp_set_nested_8_ (const int64_t *set)
306 omp_set_nested (!!*set);
308 #pragma GCC diagnostic pop
310 void
311 omp_set_num_threads_ (const int32_t *set)
313 omp_set_num_threads (*set);
316 void
317 omp_set_num_threads_8_ (const int64_t *set)
319 omp_set_num_threads (TO_INT (*set));
322 int32_t
323 omp_get_dynamic_ (void)
325 return omp_get_dynamic ();
328 #pragma GCC diagnostic push
329 #pragma GCC diagnostic ignored "-Wdeprecated-declarations"
330 int32_t
331 omp_get_nested_ (void)
333 return omp_get_nested ();
335 #pragma GCC diagnostic pop
337 int32_t
338 omp_in_parallel_ (void)
340 return omp_in_parallel ();
343 int32_t
344 omp_get_max_threads_ (void)
346 return omp_get_max_threads ();
349 int32_t
350 omp_get_num_procs_ (void)
352 return omp_get_num_procs ();
355 int32_t
356 omp_get_num_threads_ (void)
358 return omp_get_num_threads ();
361 int32_t
362 omp_get_thread_num_ (void)
364 return omp_get_thread_num ();
367 double
368 omp_get_wtick_ (void)
370 return omp_get_wtick ();
373 double
374 omp_get_wtime_ (void)
376 return omp_get_wtime ();
379 void
380 omp_set_schedule_ (const int32_t *kind, const int32_t *chunk_size)
382 omp_set_schedule (*kind, *chunk_size);
385 void
386 omp_set_schedule_8_ (const int32_t *kind, const int64_t *chunk_size)
388 omp_set_schedule (*kind, TO_INT (*chunk_size));
391 void
392 omp_get_schedule_ (int32_t *kind, int32_t *chunk_size)
394 omp_sched_t k;
395 int cs;
396 omp_get_schedule (&k, &cs);
397 /* For now mask off GFS_MONOTONIC, because OpenMP 4.5 code will not
398 expect to see it. */
399 *kind = k & ~GFS_MONOTONIC;
400 *chunk_size = cs;
403 void
404 omp_get_schedule_8_ (int32_t *kind, int64_t *chunk_size)
406 omp_sched_t k;
407 int cs;
408 omp_get_schedule (&k, &cs);
409 /* See above. */
410 *kind = k & ~GFS_MONOTONIC;
411 *chunk_size = cs;
414 int32_t
415 omp_get_thread_limit_ (void)
417 return omp_get_thread_limit ();
420 void
421 omp_set_max_active_levels_ (const int32_t *levels)
423 omp_set_max_active_levels (*levels);
426 void
427 omp_set_max_active_levels_8_ (const int64_t *levels)
429 omp_set_max_active_levels (TO_INT (*levels));
432 int32_t
433 omp_get_max_active_levels_ (void)
435 return omp_get_max_active_levels ();
438 int32_t
439 omp_get_supported_active_levels_ (void)
441 return omp_get_supported_active_levels ();
444 int32_t
445 omp_get_level_ (void)
447 return omp_get_level ();
450 int32_t
451 omp_get_ancestor_thread_num_ (const int32_t *level)
453 return omp_get_ancestor_thread_num (*level);
456 int32_t
457 omp_get_ancestor_thread_num_8_ (const int64_t *level)
459 return omp_get_ancestor_thread_num (TO_INT (*level));
462 int32_t
463 omp_get_team_size_ (const int32_t *level)
465 return omp_get_team_size (*level);
468 int32_t
469 omp_get_team_size_8_ (const int64_t *level)
471 return omp_get_team_size (TO_INT (*level));
474 int32_t
475 omp_get_active_level_ (void)
477 return omp_get_active_level ();
480 int32_t
481 omp_in_final_ (void)
483 return omp_in_final ();
486 int32_t
487 omp_in_explicit_task_ (void)
489 return omp_in_explicit_task ();
492 void
493 omp_set_num_teams_ (const int32_t *num_teams)
495 omp_set_num_teams (*num_teams);
498 void
499 omp_set_num_teams_8_ (const int64_t *num_teams)
501 omp_set_num_teams (TO_INT (*num_teams));
504 int32_t
505 omp_get_max_teams_ (void)
507 return omp_get_max_teams ();
510 void
511 omp_set_teams_thread_limit_ (const int32_t *thread_limit)
513 omp_set_teams_thread_limit (*thread_limit);
516 void
517 omp_set_teams_thread_limit_8_ (const int64_t *thread_limit)
519 omp_set_teams_thread_limit (TO_INT (*thread_limit));
522 int32_t
523 omp_get_teams_thread_limit_ (void)
525 return omp_get_teams_thread_limit ();
528 int32_t
529 omp_get_cancellation_ (void)
531 return omp_get_cancellation ();
534 int32_t
535 omp_get_proc_bind_ (void)
537 return omp_get_proc_bind ();
540 int32_t
541 omp_get_num_places_ (void)
543 return omp_get_num_places ();
546 int32_t
547 omp_get_place_num_procs_ (const int32_t *place_num)
549 return omp_get_place_num_procs (*place_num);
552 int32_t
553 omp_get_place_num_procs_8_ (const int64_t *place_num)
555 return omp_get_place_num_procs (TO_INT (*place_num));
558 void
559 omp_get_place_proc_ids_ (const int32_t *place_num, int32_t *ids)
561 omp_get_place_proc_ids (*place_num, (int *) ids);
564 void
565 omp_get_place_proc_ids_8_ (const int64_t *place_num, int64_t *ids)
567 gomp_get_place_proc_ids_8 (TO_INT (*place_num), ids);
570 int32_t
571 omp_get_place_num_ (void)
573 return omp_get_place_num ();
576 int32_t
577 omp_get_partition_num_places_ (void)
579 return omp_get_partition_num_places ();
582 void
583 omp_get_partition_place_nums_ (int32_t *place_nums)
585 omp_get_partition_place_nums ((int *) place_nums);
588 void
589 omp_get_partition_place_nums_8_ (int64_t *place_nums)
591 if (gomp_places_list == NULL)
592 return;
594 struct gomp_thread *thr = gomp_thread ();
595 if (thr->place == 0)
596 gomp_init_affinity ();
598 unsigned int i;
599 for (i = 0; i < thr->ts.place_partition_len; i++)
600 *place_nums++ = (int64_t) thr->ts.place_partition_off + i;
603 void
604 omp_set_default_device_ (const int32_t *device_num)
606 return omp_set_default_device (*device_num);
609 void
610 omp_set_default_device_8_ (const int64_t *device_num)
612 return omp_set_default_device (TO_INT (*device_num));
615 int32_t
616 omp_get_default_device_ (void)
618 return omp_get_default_device ();
621 int32_t
622 omp_get_num_devices_ (void)
624 return omp_get_num_devices ();
627 int32_t
628 omp_get_num_teams_ (void)
630 return omp_get_num_teams ();
633 int32_t
634 omp_get_team_num_ (void)
636 return omp_get_team_num ();
639 int32_t
640 omp_is_initial_device_ (void)
642 return omp_is_initial_device ();
645 int32_t
646 omp_get_initial_device_ (void)
648 return omp_get_initial_device ();
651 int32_t
652 omp_get_device_num_ (void)
654 return omp_get_device_num ();
657 int32_t
658 omp_get_max_task_priority_ (void)
660 return omp_get_max_task_priority ();
663 void
664 omp_fulfill_event_ (intptr_t event)
666 omp_fulfill_event ((omp_event_handle_t) event);
669 void
670 omp_set_affinity_format_ (const char *format, size_t format_len)
672 gomp_set_affinity_format (format, format_len);
675 int32_t
676 omp_get_affinity_format_ (char *buffer, size_t buffer_len)
678 size_t len = strlen (gomp_affinity_format_var);
679 if (buffer_len)
681 if (len < buffer_len)
683 memcpy (buffer, gomp_affinity_format_var, len);
684 memset (buffer + len, ' ', buffer_len - len);
686 else
687 memcpy (buffer, gomp_affinity_format_var, buffer_len);
689 return len;
692 void
693 omp_display_affinity_ (const char *format, size_t format_len)
695 char *fmt = NULL, fmt_buf[256];
696 char buf[512];
697 if (format_len)
699 fmt = format_len < 256 ? fmt_buf : gomp_malloc (format_len + 1);
700 memcpy (fmt, format, format_len);
701 fmt[format_len] = '\0';
703 struct gomp_thread *thr = gomp_thread ();
704 size_t ret
705 = gomp_display_affinity (buf, sizeof buf,
706 format_len ? fmt : gomp_affinity_format_var,
707 gomp_thread_self (), &thr->ts, thr->place);
708 if (ret < sizeof buf)
710 buf[ret] = '\n';
711 gomp_print_string (buf, ret + 1);
713 else
715 char *b = gomp_malloc (ret + 1);
716 gomp_display_affinity (buf, sizeof buf,
717 format_len ? fmt : gomp_affinity_format_var,
718 gomp_thread_self (), &thr->ts, thr->place);
719 b[ret] = '\n';
720 gomp_print_string (b, ret + 1);
721 free (b);
723 if (fmt && fmt != fmt_buf)
724 free (fmt);
727 int32_t
728 omp_capture_affinity_ (char *buffer, const char *format,
729 size_t buffer_len, size_t format_len)
731 char *fmt = NULL, fmt_buf[256];
732 if (format_len)
734 fmt = format_len < 256 ? fmt_buf : gomp_malloc (format_len + 1);
735 memcpy (fmt, format, format_len);
736 fmt[format_len] = '\0';
738 struct gomp_thread *thr = gomp_thread ();
739 size_t ret
740 = gomp_display_affinity (buffer, buffer_len,
741 format_len ? fmt : gomp_affinity_format_var,
742 gomp_thread_self (), &thr->ts, thr->place);
743 if (fmt && fmt != fmt_buf)
744 free (fmt);
745 if (ret < buffer_len)
746 memset (buffer + ret, ' ', buffer_len - ret);
747 return ret;
750 int32_t
751 omp_pause_resource_ (const int32_t *kind, const int32_t *device_num)
753 return omp_pause_resource (*kind, *device_num);
756 int32_t
757 omp_pause_resource_all_ (const int32_t *kind)
759 return omp_pause_resource_all (*kind);
762 intptr_t
763 omp_init_allocator_ (const intptr_t *memspace, const int32_t *ntraits,
764 const omp_alloctrait_t *traits)
766 return (intptr_t) omp_init_allocator ((omp_memspace_handle_t) *memspace,
767 (int) *ntraits, traits);
770 intptr_t
771 omp_init_allocator_8_ (const intptr_t *memspace, const int64_t *ntraits,
772 const omp_alloctrait_t *traits)
774 return (intptr_t) omp_init_allocator ((omp_memspace_handle_t) *memspace,
775 (int) *ntraits, traits);
778 void
779 omp_destroy_allocator_ (const intptr_t *allocator)
781 omp_destroy_allocator ((omp_allocator_handle_t) *allocator);
784 void
785 omp_set_default_allocator_ (const intptr_t *allocator)
787 omp_set_default_allocator ((omp_allocator_handle_t) *allocator);
790 intptr_t
791 omp_get_default_allocator_ ()
793 return (intptr_t) omp_get_default_allocator ();
796 #ifndef LIBGOMP_OFFLOADED_ONLY
798 void
799 omp_display_env_ (const int32_t *verbose)
801 omp_display_env (*verbose);
804 void
805 omp_display_env_8_ (const int64_t *verbose)
807 omp_display_env (!!*verbose);
810 #endif /* LIBGOMP_OFFLOADED_ONLY */