libgomp/fortran.c

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