libgomp/fortran.c

   1 /* Copyright (C) 2005-2020 Free Software Foundation, Inc.
   2    Contributed by Jakub Jelinek <jakub@redhat.com>.
   3
   4    This file is part of the GNU Offloading and Multi Processing Library
   5    (libgomp).
   6
   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.
  11
  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.
  16
  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.
  20
  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/>.  */
  25
  26 /* This file contains Fortran wrapper routines.  */
  27
  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>
  34
  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_set_nested)
  51 ialias_redirect (omp_set_num_threads)
  52 ialias_redirect (omp_get_dynamic)
  53 ialias_redirect (omp_get_nested)
  54 ialias_redirect (omp_in_parallel)
  55 ialias_redirect (omp_get_max_threads)
  56 ialias_redirect (omp_get_num_procs)
  57 ialias_redirect (omp_get_num_threads)
  58 ialias_redirect (omp_get_thread_num)
  59 ialias_redirect (omp_get_wtick)
  60 ialias_redirect (omp_get_wtime)
  61 ialias_redirect (omp_set_schedule)
  62 ialias_redirect (omp_get_schedule)
  63 ialias_redirect (omp_get_thread_limit)
  64 ialias_redirect (omp_set_max_active_levels)
  65 ialias_redirect (omp_get_max_active_levels)
  66 ialias_redirect (omp_get_supported_active_levels)
  67 ialias_redirect (omp_get_level)
  68 ialias_redirect (omp_get_ancestor_thread_num)
  69 ialias_redirect (omp_get_team_size)
  70 ialias_redirect (omp_get_active_level)
  71 ialias_redirect (omp_in_final)
  72 ialias_redirect (omp_get_cancellation)
  73 ialias_redirect (omp_get_proc_bind)
  74 ialias_redirect (omp_get_num_places)
  75 ialias_redirect (omp_get_place_num_procs)
  76 ialias_redirect (omp_get_place_proc_ids)
  77 ialias_redirect (omp_get_place_num)
  78 ialias_redirect (omp_get_partition_num_places)
  79 ialias_redirect (omp_get_partition_place_nums)
  80 ialias_redirect (omp_set_default_device)
  81 ialias_redirect (omp_get_default_device)
  82 ialias_redirect (omp_get_num_devices)
  83 ialias_redirect (omp_get_num_teams)
  84 ialias_redirect (omp_get_team_num)
  85 ialias_redirect (omp_is_initial_device)
  86 ialias_redirect (omp_get_initial_device)
  87 ialias_redirect (omp_get_max_task_priority)
  88 ialias_redirect (omp_pause_resource)
  89 ialias_redirect (omp_pause_resource_all)
  90 ialias_redirect (omp_init_allocator)
  91 ialias_redirect (omp_destroy_allocator)
  92 ialias_redirect (omp_set_default_allocator)
  93 ialias_redirect (omp_get_default_allocator)
  94 #endif
  95
  96 #ifndef LIBGOMP_GNU_SYMBOL_VERSIONING
  97 # define gomp_init_lock__30 omp_init_lock_
  98 # define gomp_destroy_lock__30 omp_destroy_lock_
  99 # define gomp_set_lock__30 omp_set_lock_
 100 # define gomp_unset_lock__30 omp_unset_lock_
 101 # define gomp_test_lock__30 omp_test_lock_
 102 # define gomp_init_nest_lock__30 omp_init_nest_lock_
 103 # define gomp_destroy_nest_lock__30 omp_destroy_nest_lock_
 104 # define gomp_set_nest_lock__30 omp_set_nest_lock_
 105 # define gomp_unset_nest_lock__30 omp_unset_nest_lock_
 106 # define gomp_test_nest_lock__30 omp_test_nest_lock_
 107 #endif
 108
 109 void
 110 gomp_init_lock__30 (omp_lock_arg_t lock)
 111 {
 112 #ifndef OMP_LOCK_DIRECT
 113   omp_lock_arg (lock) = malloc (sizeof (omp_lock_t));
 114 #endif
 115   gomp_init_lock_30 (omp_lock_arg (lock));
 116 }
 117
 118 void
 119 gomp_init_nest_lock__30 (omp_nest_lock_arg_t lock)
 120 {
 121 #ifndef OMP_NEST_LOCK_DIRECT
 122   omp_nest_lock_arg (lock) = malloc (sizeof (omp_nest_lock_t));
 123 #endif
 124   gomp_init_nest_lock_30 (omp_nest_lock_arg (lock));
 125 }
 126
 127 void
 128 gomp_destroy_lock__30 (omp_lock_arg_t lock)
 129 {
 130   gomp_destroy_lock_30 (omp_lock_arg (lock));
 131 #ifndef OMP_LOCK_DIRECT
 132   free (omp_lock_arg (lock));
 133   omp_lock_arg (lock) = NULL;
 134 #endif
 135 }
 136
 137 void
 138 gomp_destroy_nest_lock__30 (omp_nest_lock_arg_t lock)
 139 {
 140   gomp_destroy_nest_lock_30 (omp_nest_lock_arg (lock));
 141 #ifndef OMP_NEST_LOCK_DIRECT
 142   free (omp_nest_lock_arg (lock));
 143   omp_nest_lock_arg (lock) = NULL;
 144 #endif
 145 }
 146
 147 void
 148 gomp_set_lock__30 (omp_lock_arg_t lock)
 149 {
 150   gomp_set_lock_30 (omp_lock_arg (lock));
 151 }
 152
 153 void
 154 gomp_set_nest_lock__30 (omp_nest_lock_arg_t lock)
 155 {
 156   gomp_set_nest_lock_30 (omp_nest_lock_arg (lock));
 157 }
 158
 159 void
 160 gomp_unset_lock__30 (omp_lock_arg_t lock)
 161 {
 162   gomp_unset_lock_30 (omp_lock_arg (lock));
 163 }
 164
 165 void
 166 gomp_unset_nest_lock__30 (omp_nest_lock_arg_t lock)
 167 {
 168   gomp_unset_nest_lock_30 (omp_nest_lock_arg (lock));
 169 }
 170
 171 int32_t
 172 gomp_test_lock__30 (omp_lock_arg_t lock)
 173 {
 174   return gomp_test_lock_30 (omp_lock_arg (lock));
 175 }
 176
 177 int32_t
 178 gomp_test_nest_lock__30 (omp_nest_lock_arg_t lock)
 179 {
 180   return gomp_test_nest_lock_30 (omp_nest_lock_arg (lock));
 181 }
 182
 183 #ifdef LIBGOMP_GNU_SYMBOL_VERSIONING
 184 void
 185 gomp_init_lock__25 (omp_lock_25_arg_t lock)
 186 {
 187 #ifndef OMP_LOCK_25_DIRECT
 188   omp_lock_25_arg (lock) = malloc (sizeof (omp_lock_25_t));
 189 #endif
 190   gomp_init_lock_25 (omp_lock_25_arg (lock));
 191 }
 192
 193 void
 194 gomp_init_nest_lock__25 (omp_nest_lock_25_arg_t lock)
 195 {
 196 #ifndef OMP_NEST_LOCK_25_DIRECT
 197   omp_nest_lock_25_arg (lock) = malloc (sizeof (omp_nest_lock_25_t));
 198 #endif
 199   gomp_init_nest_lock_25 (omp_nest_lock_25_arg (lock));
 200 }
 201
 202 void
 203 gomp_destroy_lock__25 (omp_lock_25_arg_t lock)
 204 {
 205   gomp_destroy_lock_25 (omp_lock_25_arg (lock));
 206 #ifndef OMP_LOCK_25_DIRECT
 207   free (omp_lock_25_arg (lock));
 208   omp_lock_25_arg (lock) = NULL;
 209 #endif
 210 }
 211
 212 void
 213 gomp_destroy_nest_lock__25 (omp_nest_lock_25_arg_t lock)
 214 {
 215   gomp_destroy_nest_lock_25 (omp_nest_lock_25_arg (lock));
 216 #ifndef OMP_NEST_LOCK_25_DIRECT
 217   free (omp_nest_lock_25_arg (lock));
 218   omp_nest_lock_25_arg (lock) = NULL;
 219 #endif
 220 }
 221
 222 void
 223 gomp_set_lock__25 (omp_lock_25_arg_t lock)
 224 {
 225   gomp_set_lock_25 (omp_lock_25_arg (lock));
 226 }
 227
 228 void
 229 gomp_set_nest_lock__25 (omp_nest_lock_25_arg_t lock)
 230 {
 231   gomp_set_nest_lock_25 (omp_nest_lock_25_arg (lock));
 232 }
 233
 234 void
 235 gomp_unset_lock__25 (omp_lock_25_arg_t lock)
 236 {
 237   gomp_unset_lock_25 (omp_lock_25_arg (lock));
 238 }
 239
 240 void
 241 gomp_unset_nest_lock__25 (omp_nest_lock_25_arg_t lock)
 242 {
 243   gomp_unset_nest_lock_25 (omp_nest_lock_25_arg (lock));
 244 }
 245
 246 int32_t
 247 gomp_test_lock__25 (omp_lock_25_arg_t lock)
 248 {
 249   return gomp_test_lock_25 (omp_lock_25_arg (lock));
 250 }
 251
 252 int32_t
 253 gomp_test_nest_lock__25 (omp_nest_lock_25_arg_t lock)
 254 {
 255   return gomp_test_nest_lock_25 (omp_nest_lock_25_arg (lock));
 256 }
 257
 258 omp_lock_symver (omp_init_lock_)
 259 omp_lock_symver (omp_destroy_lock_)
 260 omp_lock_symver (omp_set_lock_)
 261 omp_lock_symver (omp_unset_lock_)
 262 omp_lock_symver (omp_test_lock_)
 263 omp_lock_symver (omp_init_nest_lock_)
 264 omp_lock_symver (omp_destroy_nest_lock_)
 265 omp_lock_symver (omp_set_nest_lock_)
 266 omp_lock_symver (omp_unset_nest_lock_)
 267 omp_lock_symver (omp_test_nest_lock_)
 268 #endif
 269
 270 #define TO_INT(x) ((x) > INT_MIN ? (x) < INT_MAX ? (x) : INT_MAX : INT_MIN)
 271
 272 void
 273 omp_set_dynamic_ (const int32_t *set)
 274 {
 275   omp_set_dynamic (*set);
 276 }
 277
 278 void
 279 omp_set_dynamic_8_ (const int64_t *set)
 280 {
 281   omp_set_dynamic (!!*set);
 282 }
 283
 284 void
 285 omp_set_nested_ (const int32_t *set)
 286 {
 287   omp_set_nested (*set);
 288 }
 289
 290 void
 291 omp_set_nested_8_ (const int64_t *set)
 292 {
 293   omp_set_nested (!!*set);
 294 }
 295
 296 void
 297 omp_set_num_threads_ (const int32_t *set)
 298 {
 299   omp_set_num_threads (*set);
 300 }
 301
 302 void
 303 omp_set_num_threads_8_ (const int64_t *set)
 304 {
 305   omp_set_num_threads (TO_INT (*set));
 306 }
 307
 308 int32_t
 309 omp_get_dynamic_ (void)
 310 {
 311   return omp_get_dynamic ();
 312 }
 313
 314 int32_t
 315 omp_get_nested_ (void)
 316 {
 317   return omp_get_nested ();
 318 }
 319
 320 int32_t
 321 omp_in_parallel_ (void)
 322 {
 323   return omp_in_parallel ();
 324 }
 325
 326 int32_t
 327 omp_get_max_threads_ (void)
 328 {
 329   return omp_get_max_threads ();
 330 }
 331
 332 int32_t
 333 omp_get_num_procs_ (void)
 334 {
 335   return omp_get_num_procs ();
 336 }
 337
 338 int32_t
 339 omp_get_num_threads_ (void)
 340 {
 341   return omp_get_num_threads ();
 342 }
 343
 344 int32_t
 345 omp_get_thread_num_ (void)
 346 {
 347   return omp_get_thread_num ();
 348 }
 349
 350 double
 351 omp_get_wtick_ (void)
 352 {
 353   return omp_get_wtick ();
 354 }
 355
 356 double
 357 omp_get_wtime_ (void)
 358 {
 359   return omp_get_wtime ();
 360 }
 361
 362 void
 363 omp_set_schedule_ (const int32_t *kind, const int32_t *chunk_size)
 364 {
 365   omp_set_schedule (*kind, *chunk_size);
 366 }
 367
 368 void
 369 omp_set_schedule_8_ (const int32_t *kind, const int64_t *chunk_size)
 370 {
 371   omp_set_schedule (*kind, TO_INT (*chunk_size));
 372 }
 373
 374 void
 375 omp_get_schedule_ (int32_t *kind, int32_t *chunk_size)
 376 {
 377   omp_sched_t k;
 378   int cs;
 379   omp_get_schedule (&k, &cs);
 380   /* For now mask off GFS_MONOTONIC, because OpenMP 4.5 code will not
 381      expect to see it.  */
 382   *kind = k & ~GFS_MONOTONIC;
 383   *chunk_size = cs;
 384 }
 385
 386 void
 387 omp_get_schedule_8_ (int32_t *kind, int64_t *chunk_size)
 388 {
 389   omp_sched_t k;
 390   int cs;
 391   omp_get_schedule (&k, &cs);
 392   /* See above.  */
 393   *kind = k & ~GFS_MONOTONIC;
 394   *chunk_size = cs;
 395 }
 396
 397 int32_t
 398 omp_get_thread_limit_ (void)
 399 {
 400   return omp_get_thread_limit ();
 401 }
 402
 403 void
 404 omp_set_max_active_levels_ (const int32_t *levels)
 405 {
 406   omp_set_max_active_levels (*levels);
 407 }
 408
 409 void
 410 omp_set_max_active_levels_8_ (const int64_t *levels)
 411 {
 412   omp_set_max_active_levels (TO_INT (*levels));
 413 }
 414
 415 int32_t
 416 omp_get_max_active_levels_ (void)
 417 {
 418   return omp_get_max_active_levels ();
 419 }
 420
 421 int32_t
 422 omp_get_supported_active_levels_ (void)
 423 {
 424   return omp_get_supported_active_levels ();
 425 }
 426
 427 int32_t
 428 omp_get_level_ (void)
 429 {
 430   return omp_get_level ();
 431 }
 432
 433 int32_t
 434 omp_get_ancestor_thread_num_ (const int32_t *level)
 435 {
 436   return omp_get_ancestor_thread_num (*level);
 437 }
 438
 439 int32_t
 440 omp_get_ancestor_thread_num_8_ (const int64_t *level)
 441 {
 442   return omp_get_ancestor_thread_num (TO_INT (*level));
 443 }
 444
 445 int32_t
 446 omp_get_team_size_ (const int32_t *level)
 447 {
 448   return omp_get_team_size (*level);
 449 }
 450
 451 int32_t
 452 omp_get_team_size_8_ (const int64_t *level)
 453 {
 454   return omp_get_team_size (TO_INT (*level));
 455 }
 456
 457 int32_t
 458 omp_get_active_level_ (void)
 459 {
 460   return omp_get_active_level ();
 461 }
 462
 463 int32_t
 464 omp_in_final_ (void)
 465 {
 466   return omp_in_final ();
 467 }
 468
 469 int32_t
 470 omp_get_cancellation_ (void)
 471 {
 472   return omp_get_cancellation ();
 473 }
 474
 475 int32_t
 476 omp_get_proc_bind_ (void)
 477 {
 478   return omp_get_proc_bind ();
 479 }
 480
 481 int32_t
 482 omp_get_num_places_ (void)
 483 {
 484   return omp_get_num_places ();
 485 }
 486
 487 int32_t
 488 omp_get_place_num_procs_ (const int32_t *place_num)
 489 {
 490   return omp_get_place_num_procs (*place_num);
 491 }
 492
 493 int32_t
 494 omp_get_place_num_procs_8_ (const int64_t *place_num)
 495 {
 496   return omp_get_place_num_procs (TO_INT (*place_num));
 497 }
 498
 499 void
 500 omp_get_place_proc_ids_ (const int32_t *place_num, int32_t *ids)
 501 {
 502   omp_get_place_proc_ids (*place_num, (int *) ids);
 503 }
 504
 505 void
 506 omp_get_place_proc_ids_8_ (const int64_t *place_num, int64_t *ids)
 507 {
 508   gomp_get_place_proc_ids_8 (TO_INT (*place_num), ids);
 509 }
 510
 511 int32_t
 512 omp_get_place_num_ (void)
 513 {
 514   return omp_get_place_num ();
 515 }
 516
 517 int32_t
 518 omp_get_partition_num_places_ (void)
 519 {
 520   return omp_get_partition_num_places ();
 521 }
 522
 523 void
 524 omp_get_partition_place_nums_ (int32_t *place_nums)
 525 {
 526   omp_get_partition_place_nums ((int *) place_nums);
 527 }
 528
 529 void
 530 omp_get_partition_place_nums_8_ (int64_t *place_nums)
 531 {
 532   if (gomp_places_list == NULL)
 533     return;
 534
 535   struct gomp_thread *thr = gomp_thread ();
 536   if (thr->place == 0)
 537     gomp_init_affinity ();
 538
 539   unsigned int i;
 540   for (i = 0; i < thr->ts.place_partition_len; i++)
 541     *place_nums++ = (int64_t) thr->ts.place_partition_off + i;
 542 }
 543
 544 void
 545 omp_set_default_device_ (const int32_t *device_num)
 546 {
 547   return omp_set_default_device (*device_num);
 548 }
 549
 550 void
 551 omp_set_default_device_8_ (const int64_t *device_num)
 552 {
 553   return omp_set_default_device (TO_INT (*device_num));
 554 }
 555
 556 int32_t
 557 omp_get_default_device_ (void)
 558 {
 559   return omp_get_default_device ();
 560 }
 561
 562 int32_t
 563 omp_get_num_devices_ (void)
 564 {
 565   return omp_get_num_devices ();
 566 }
 567
 568 int32_t
 569 omp_get_num_teams_ (void)
 570 {
 571   return omp_get_num_teams ();
 572 }
 573
 574 int32_t
 575 omp_get_team_num_ (void)
 576 {
 577   return omp_get_team_num ();
 578 }
 579
 580 int32_t
 581 omp_is_initial_device_ (void)
 582 {
 583   return omp_is_initial_device ();
 584 }
 585
 586 int32_t
 587 omp_get_initial_device_ (void)
 588 {
 589   return omp_get_initial_device ();
 590 }
 591
 592 int32_t
 593 omp_get_max_task_priority_ (void)
 594 {
 595   return omp_get_max_task_priority ();
 596 }
 597
 598 void
 599 omp_set_affinity_format_ (const char *format, size_t format_len)
 600 {
 601   gomp_set_affinity_format (format, format_len);
 602 }
 603
 604 int32_t
 605 omp_get_affinity_format_ (char *buffer, size_t buffer_len)
 606 {
 607   size_t len = strlen (gomp_affinity_format_var);
 608   if (buffer_len)
 609     {
 610       if (len < buffer_len)
 611         {
 612           memcpy (buffer, gomp_affinity_format_var, len);
 613           memset (buffer + len, ' ', buffer_len - len);
 614         }
 615       else
 616         memcpy (buffer, gomp_affinity_format_var, buffer_len);
 617     }
 618   return len;
 619 }
 620
 621 void
 622 omp_display_affinity_ (const char *format, size_t format_len)
 623 {
 624   char *fmt = NULL, fmt_buf[256];
 625   char buf[512];
 626   if (format_len)
 627     {
 628       fmt = format_len < 256 ? fmt_buf : gomp_malloc (format_len + 1);
 629       memcpy (fmt, format, format_len);
 630       fmt[format_len] = '\0';
 631     }
 632   struct gomp_thread *thr = gomp_thread ();
 633   size_t ret
 634     = gomp_display_affinity (buf, sizeof buf,
 635                              format_len ? fmt : gomp_affinity_format_var,
 636                              gomp_thread_self (), &thr->ts, thr->place);
 637   if (ret < sizeof buf)
 638     {
 639       buf[ret] = '\n';
 640       gomp_print_string (buf, ret + 1);
 641     }
 642   else
 643     {
 644       char *b = gomp_malloc (ret + 1);
 645       gomp_display_affinity (buf, sizeof buf,
 646                              format_len ? fmt : gomp_affinity_format_var,
 647                              gomp_thread_self (), &thr->ts, thr->place);
 648       b[ret] = '\n';
 649       gomp_print_string (b, ret + 1);
 650       free (b);
 651     }
 652   if (fmt && fmt != fmt_buf)
 653     free (fmt);
 654 }
 655
 656 int32_t
 657 omp_capture_affinity_ (char *buffer, const char *format,
 658                        size_t buffer_len, size_t format_len)
 659 {
 660   char *fmt = NULL, fmt_buf[256];
 661   if (format_len)
 662     {
 663       fmt = format_len < 256 ? fmt_buf : gomp_malloc (format_len + 1);
 664       memcpy (fmt, format, format_len);
 665       fmt[format_len] = '\0';
 666     }
 667   struct gomp_thread *thr = gomp_thread ();
 668   size_t ret
 669     = gomp_display_affinity (buffer, buffer_len,
 670                              format_len ? fmt : gomp_affinity_format_var,
 671                              gomp_thread_self (), &thr->ts, thr->place);
 672   if (fmt && fmt != fmt_buf)
 673     free (fmt);
 674   if (ret < buffer_len)
 675     memset (buffer + ret, ' ', buffer_len - ret);
 676   return ret;
 677 }
 678
 679 int32_t
 680 omp_pause_resource_ (const int32_t *kind, const int32_t *device_num)
 681 {
 682   return omp_pause_resource (*kind, *device_num);
 683 }
 684
 685 int32_t
 686 omp_pause_resource_all_ (const int32_t *kind)
 687 {
 688   return omp_pause_resource_all (*kind);
 689 }
 690
 691 intptr_t
 692 omp_init_allocator_ (const intptr_t *memspace, const int32_t *ntraits,
 693                     const omp_alloctrait_t *traits)
 694 {
 695   return (intptr_t) omp_init_allocator ((omp_memspace_handle_t) *memspace,
 696                                         (int) *ntraits, traits);
 697 }
 698
 699 intptr_t
 700 omp_init_allocator_8_ (const intptr_t *memspace, const int64_t *ntraits,
 701                     const omp_alloctrait_t *traits)
 702 {
 703   return (intptr_t) omp_init_allocator ((omp_memspace_handle_t) *memspace,
 704                                         (int) *ntraits, traits);
 705 }
 706
 707 void
 708 omp_destroy_allocator_ (const intptr_t *allocator)
 709 {
 710   omp_destroy_allocator ((omp_allocator_handle_t) *allocator);
 711 }
 712
 713 void
 714 omp_set_default_allocator_ (const intptr_t *allocator)
 715 {
 716   omp_set_default_allocator ((omp_allocator_handle_t) *allocator);
 717 }
 718
 719 intptr_t
 720 omp_get_default_allocator_ ()
 721 {
 722   return (intptr_t) omp_get_default_allocator ();
 723 }