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