1/* OpenMP directive matching and resolving. 2 Copyright (C) 2005-2020 Free Software Foundation, Inc. 3 Contributed by Jakub Jelinek 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "gfortran.h" 25#include "arith.h" 26#include "match.h" 27#include "parse.h" 28#include "diagnostic.h" 29#include "gomp-constants.h" 30 31/* Match an end of OpenMP directive. End of OpenMP directive is optional 32 whitespace, followed by '\n' or comment '!'. */ 33 34static match 35gfc_match_omp_eos (void) 36{ 37 locus old_loc; 38 char c; 39 40 old_loc = gfc_current_locus; 41 gfc_gobble_whitespace (); 42 43 c = gfc_next_ascii_char (); 44 switch (c) 45 { 46 case '!': 47 do 48 c = gfc_next_ascii_char (); 49 while (c != '\n'); 50 /* Fall through */ 51 52 case '\n': 53 return MATCH_YES; 54 } 55 56 gfc_current_locus = old_loc; 57 return MATCH_NO; 58} 59 60match 61gfc_match_omp_eos_error (void) 62{ 63 if (gfc_match_omp_eos() == MATCH_YES) 64 return MATCH_YES; 65 66 gfc_error ("Unexpected junk at %C"); 67 return MATCH_ERROR; 68} 69 70 71/* Free an omp_clauses structure. */ 72 73void 74gfc_free_omp_clauses (gfc_omp_clauses *c) 75{ 76 int i; 77 if (c == NULL) 78 return; 79 80 gfc_free_expr (c->if_expr); 81 gfc_free_expr (c->final_expr); 82 gfc_free_expr (c->num_threads); 83 gfc_free_expr (c->chunk_size); 84 gfc_free_expr (c->safelen_expr); 85 gfc_free_expr (c->simdlen_expr); 86 gfc_free_expr (c->num_teams); 87 gfc_free_expr (c->device); 88 gfc_free_expr (c->thread_limit); 89 gfc_free_expr (c->dist_chunk_size); 90 gfc_free_expr (c->grainsize); 91 gfc_free_expr (c->hint); 92 gfc_free_expr (c->num_tasks); 93 gfc_free_expr (c->priority); 94 for (i = 0; i < OMP_IF_LAST; i++) 95 gfc_free_expr (c->if_exprs[i]); 96 gfc_free_expr (c->async_expr); 97 gfc_free_expr (c->gang_num_expr); 98 gfc_free_expr (c->gang_static_expr); 99 gfc_free_expr (c->worker_expr); 100 gfc_free_expr (c->vector_expr); 101 gfc_free_expr (c->num_gangs_expr); 102 gfc_free_expr (c->num_workers_expr); 103 gfc_free_expr (c->vector_length_expr); 104 for (i = 0; i < OMP_LIST_NUM; i++) 105 gfc_free_omp_namelist (c->lists[i]); 106 gfc_free_expr_list (c->wait_list); 107 gfc_free_expr_list (c->tile_list); 108 free (CONST_CAST (char *, c->critical_name)); 109 free (c); 110} 111 112/* Free oacc_declare structures. */ 113 114void 115gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc) 116{ 117 struct gfc_oacc_declare *decl = oc; 118 119 do 120 { 121 struct gfc_oacc_declare *next; 122 123 next = decl->next; 124 gfc_free_omp_clauses (decl->clauses); 125 free (decl); 126 decl = next; 127 } 128 while (decl); 129} 130 131/* Free expression list. */ 132void 133gfc_free_expr_list (gfc_expr_list *list) 134{ 135 gfc_expr_list *n; 136 137 for (; list; list = n) 138 { 139 n = list->next; 140 free (list); 141 } 142} 143 144/* Free an !$omp declare simd construct list. */ 145 146void 147gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods) 148{ 149 if (ods) 150 { 151 gfc_free_omp_clauses (ods->clauses); 152 free (ods); 153 } 154} 155 156void 157gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list) 158{ 159 while (list) 160 { 161 gfc_omp_declare_simd *current = list; 162 list = list->next; 163 gfc_free_omp_declare_simd (current); 164 } 165} 166 167/* Free an !$omp declare reduction. */ 168 169void 170gfc_free_omp_udr (gfc_omp_udr *omp_udr) 171{ 172 if (omp_udr) 173 { 174 gfc_free_omp_udr (omp_udr->next); 175 gfc_free_namespace (omp_udr->combiner_ns); 176 if (omp_udr->initializer_ns) 177 gfc_free_namespace (omp_udr->initializer_ns); 178 free (omp_udr); 179 } 180} 181 182 183static gfc_omp_udr * 184gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) 185{ 186 gfc_symtree *st; 187 188 if (ns == NULL) 189 ns = gfc_current_ns; 190 do 191 { 192 gfc_omp_udr *omp_udr; 193 194 st = gfc_find_symtree (ns->omp_udr_root, name); 195 if (st != NULL) 196 { 197 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) 198 if (ts == NULL) 199 return omp_udr; 200 else if (gfc_compare_types (&omp_udr->ts, ts)) 201 { 202 if (ts->type == BT_CHARACTER) 203 { 204 if (omp_udr->ts.u.cl->length == NULL) 205 return omp_udr; 206 if (ts->u.cl->length == NULL) 207 continue; 208 if (gfc_compare_expr (omp_udr->ts.u.cl->length, 209 ts->u.cl->length, 210 INTRINSIC_EQ) != 0) 211 continue; 212 } 213 return omp_udr; 214 } 215 } 216 217 /* Don't escape an interface block. */ 218 if (ns && !ns->has_import_set 219 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) 220 break; 221 222 ns = ns->parent; 223 } 224 while (ns != NULL); 225 226 return NULL; 227} 228 229 230/* Match a variable/common block list and construct a namelist from it. */ 231 232static match 233gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, 234 bool allow_common, bool *end_colon = NULL, 235 gfc_omp_namelist ***headp = NULL, 236 bool allow_sections = false, 237 bool allow_derived = false) 238{ 239 gfc_omp_namelist *head, *tail, *p; 240 locus old_loc, cur_loc; 241 char n[GFC_MAX_SYMBOL_LEN+1]; 242 gfc_symbol *sym; 243 match m; 244 gfc_symtree *st; 245 246 head = tail = NULL; 247 248 old_loc = gfc_current_locus; 249 250 m = gfc_match (str); 251 if (m != MATCH_YES) 252 return m; 253 254 for (;;) 255 { 256 cur_loc = gfc_current_locus; 257 m = gfc_match_symbol (&sym, 1); 258 switch (m) 259 { 260 case MATCH_YES: 261 gfc_expr *expr; 262 expr = NULL; 263 gfc_gobble_whitespace (); 264 if ((allow_sections && gfc_peek_ascii_char () == '(') 265 || (allow_derived && gfc_peek_ascii_char () == '%')) 266 { 267 gfc_current_locus = cur_loc; 268 m = gfc_match_variable (&expr, 0); 269 switch (m) 270 { 271 case MATCH_ERROR: 272 goto cleanup; 273 case MATCH_NO: 274 goto syntax; 275 default: 276 break; 277 } 278 if (gfc_is_coindexed (expr)) 279 { 280 gfc_error ("List item shall not be coindexed at %C"); 281 goto cleanup; 282 } 283 } 284 gfc_set_sym_referenced (sym); 285 p = gfc_get_omp_namelist (); 286 if (head == NULL) 287 head = tail = p; 288 else 289 { 290 tail->next = p; 291 tail = tail->next; 292 } 293 tail->sym = sym; 294 tail->expr = expr; 295 tail->where = cur_loc; 296 goto next_item; 297 case MATCH_NO: 298 break; 299 case MATCH_ERROR: 300 goto cleanup; 301 } 302 303 if (!allow_common) 304 goto syntax; 305 306 m = gfc_match (" / %n /", n); 307 if (m == MATCH_ERROR) 308 goto cleanup; 309 if (m == MATCH_NO) 310 goto syntax; 311 312 st = gfc_find_symtree (gfc_current_ns->common_root, n); 313 if (st == NULL) 314 { 315 gfc_error ("COMMON block /%s/ not found at %C", n); 316 goto cleanup; 317 } 318 for (sym = st->n.common->head; sym; sym = sym->common_next) 319 { 320 gfc_set_sym_referenced (sym); 321 p = gfc_get_omp_namelist (); 322 if (head == NULL) 323 head = tail = p; 324 else 325 { 326 tail->next = p; 327 tail = tail->next; 328 } 329 tail->sym = sym; 330 tail->where = cur_loc; 331 } 332 333 next_item: 334 if (end_colon && gfc_match_char (':') == MATCH_YES) 335 { 336 *end_colon = true; 337 break; 338 } 339 if (gfc_match_char (')') == MATCH_YES) 340 break; 341 if (gfc_match_char (',') != MATCH_YES) 342 goto syntax; 343 } 344 345 while (*list) 346 list = &(*list)->next; 347 348 *list = head; 349 if (headp) 350 *headp = list; 351 return MATCH_YES; 352 353syntax: 354 gfc_error ("Syntax error in OpenMP variable list at %C"); 355 356cleanup: 357 gfc_free_omp_namelist (head); 358 gfc_current_locus = old_loc; 359 return MATCH_ERROR; 360} 361 362/* Match a variable/procedure/common block list and construct a namelist 363 from it. */ 364 365static match 366gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list) 367{ 368 gfc_omp_namelist *head, *tail, *p; 369 locus old_loc, cur_loc; 370 char n[GFC_MAX_SYMBOL_LEN+1]; 371 gfc_symbol *sym; 372 match m; 373 gfc_symtree *st; 374 375 head = tail = NULL; 376 377 old_loc = gfc_current_locus; 378 379 m = gfc_match (str); 380 if (m != MATCH_YES) 381 return m; 382 383 for (;;) 384 { 385 cur_loc = gfc_current_locus; 386 m = gfc_match_symbol (&sym, 1); 387 switch (m) 388 { 389 case MATCH_YES: 390 p = gfc_get_omp_namelist (); 391 if (head == NULL) 392 head = tail = p; 393 else 394 { 395 tail->next = p; 396 tail = tail->next; 397 } 398 tail->sym = sym; 399 tail->where = cur_loc; 400 goto next_item; 401 case MATCH_NO: 402 break; 403 case MATCH_ERROR: 404 goto cleanup; 405 } 406 407 m = gfc_match (" / %n /", n); 408 if (m == MATCH_ERROR) 409 goto cleanup; 410 if (m == MATCH_NO) 411 goto syntax; 412 413 st = gfc_find_symtree (gfc_current_ns->common_root, n); 414 if (st == NULL) 415 { 416 gfc_error ("COMMON block /%s/ not found at %C", n); 417 goto cleanup; 418 } 419 p = gfc_get_omp_namelist (); 420 if (head == NULL) 421 head = tail = p; 422 else 423 { 424 tail->next = p; 425 tail = tail->next; 426 } 427 tail->u.common = st->n.common; 428 tail->where = cur_loc; 429 430 next_item: 431 if (gfc_match_char (')') == MATCH_YES) 432 break; 433 if (gfc_match_char (',') != MATCH_YES) 434 goto syntax; 435 } 436 437 while (*list) 438 list = &(*list)->next; 439 440 *list = head; 441 return MATCH_YES; 442 443syntax: 444 gfc_error ("Syntax error in OpenMP variable list at %C"); 445 446cleanup: 447 gfc_free_omp_namelist (head); 448 gfc_current_locus = old_loc; 449 return MATCH_ERROR; 450} 451 452/* Match depend(sink : ...) construct a namelist from it. */ 453 454static match 455gfc_match_omp_depend_sink (gfc_omp_namelist **list) 456{ 457 gfc_omp_namelist *head, *tail, *p; 458 locus old_loc, cur_loc; 459 gfc_symbol *sym; 460 461 head = tail = NULL; 462 463 old_loc = gfc_current_locus; 464 465 for (;;) 466 { 467 cur_loc = gfc_current_locus; 468 switch (gfc_match_symbol (&sym, 1)) 469 { 470 case MATCH_YES: 471 gfc_set_sym_referenced (sym); 472 p = gfc_get_omp_namelist (); 473 if (head == NULL) 474 { 475 head = tail = p; 476 head->u.depend_op = OMP_DEPEND_SINK_FIRST; 477 } 478 else 479 { 480 tail->next = p; 481 tail = tail->next; 482 tail->u.depend_op = OMP_DEPEND_SINK; 483 } 484 tail->sym = sym; 485 tail->expr = NULL; 486 tail->where = cur_loc; 487 if (gfc_match_char ('+') == MATCH_YES) 488 { 489 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) 490 goto syntax; 491 } 492 else if (gfc_match_char ('-') == MATCH_YES) 493 { 494 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) 495 goto syntax; 496 tail->expr = gfc_uminus (tail->expr); 497 } 498 break; 499 case MATCH_NO: 500 goto syntax; 501 case MATCH_ERROR: 502 goto cleanup; 503 } 504 505 if (gfc_match_char (')') == MATCH_YES) 506 break; 507 if (gfc_match_char (',') != MATCH_YES) 508 goto syntax; 509 } 510 511 while (*list) 512 list = &(*list)->next; 513 514 *list = head; 515 return MATCH_YES; 516 517syntax: 518 gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C"); 519 520cleanup: 521 gfc_free_omp_namelist (head); 522 gfc_current_locus = old_loc; 523 return MATCH_ERROR; 524} 525 526static match 527match_oacc_expr_list (const char *str, gfc_expr_list **list, 528 bool allow_asterisk) 529{ 530 gfc_expr_list *head, *tail, *p; 531 locus old_loc; 532 gfc_expr *expr; 533 match m; 534 535 head = tail = NULL; 536 537 old_loc = gfc_current_locus; 538 539 m = gfc_match (str); 540 if (m != MATCH_YES) 541 return m; 542 543 for (;;) 544 { 545 m = gfc_match_expr (&expr); 546 if (m == MATCH_YES || allow_asterisk) 547 { 548 p = gfc_get_expr_list (); 549 if (head == NULL) 550 head = tail = p; 551 else 552 { 553 tail->next = p; 554 tail = tail->next; 555 } 556 if (m == MATCH_YES) 557 tail->expr = expr; 558 else if (gfc_match (" *") != MATCH_YES) 559 goto syntax; 560 goto next_item; 561 } 562 if (m == MATCH_ERROR) 563 goto cleanup; 564 goto syntax; 565 566 next_item: 567 if (gfc_match_char (')') == MATCH_YES) 568 break; 569 if (gfc_match_char (',') != MATCH_YES) 570 goto syntax; 571 } 572 573 while (*list) 574 list = &(*list)->next; 575 576 *list = head; 577 return MATCH_YES; 578 579syntax: 580 gfc_error ("Syntax error in OpenACC expression list at %C"); 581 582cleanup: 583 gfc_free_expr_list (head); 584 gfc_current_locus = old_loc; 585 return MATCH_ERROR; 586} 587 588static match 589match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv) 590{ 591 match ret = MATCH_YES; 592 593 if (gfc_match (" ( ") != MATCH_YES) 594 return MATCH_NO; 595 596 if (gwv == GOMP_DIM_GANG) 597 { 598 /* The gang clause accepts two optional arguments, num and static. 599 The num argument may either be explicit (num: <val>) or 600 implicit without (<val> without num:). */ 601 602 while (ret == MATCH_YES) 603 { 604 if (gfc_match (" static :") == MATCH_YES) 605 { 606 if (cp->gang_static) 607 return MATCH_ERROR; 608 else 609 cp->gang_static = true; 610 if (gfc_match_char ('*') == MATCH_YES) 611 cp->gang_static_expr = NULL; 612 else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES) 613 return MATCH_ERROR; 614 } 615 else 616 { 617 if (cp->gang_num_expr) 618 return MATCH_ERROR; 619 620 /* The 'num' argument is optional. */ 621 gfc_match (" num :"); 622 623 if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES) 624 return MATCH_ERROR; 625 } 626 627 ret = gfc_match (" , "); 628 } 629 } 630 else if (gwv == GOMP_DIM_WORKER) 631 { 632 /* The 'num' argument is optional. */ 633 gfc_match (" num :"); 634 635 if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES) 636 return MATCH_ERROR; 637 } 638 else if (gwv == GOMP_DIM_VECTOR) 639 { 640 /* The 'length' argument is optional. */ 641 gfc_match (" length :"); 642 643 if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES) 644 return MATCH_ERROR; 645 } 646 else 647 gfc_fatal_error ("Unexpected OpenACC parallelism."); 648 649 return gfc_match (" )"); 650} 651 652static match 653gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list) 654{ 655 gfc_omp_namelist *head = NULL; 656 gfc_omp_namelist *tail, *p; 657 locus old_loc; 658 char n[GFC_MAX_SYMBOL_LEN+1]; 659 gfc_symbol *sym; 660 match m; 661 gfc_symtree *st; 662 663 old_loc = gfc_current_locus; 664 665 m = gfc_match (str); 666 if (m != MATCH_YES) 667 return m; 668 669 m = gfc_match (" ("); 670 671 for (;;) 672 { 673 m = gfc_match_symbol (&sym, 0); 674 switch (m) 675 { 676 case MATCH_YES: 677 if (sym->attr.in_common) 678 { 679 gfc_error_now ("Variable at %C is an element of a COMMON block"); 680 goto cleanup; 681 } 682 gfc_set_sym_referenced (sym); 683 p = gfc_get_omp_namelist (); 684 if (head == NULL) 685 head = tail = p; 686 else 687 { 688 tail->next = p; 689 tail = tail->next; 690 } 691 tail->sym = sym; 692 tail->expr = NULL; 693 tail->where = gfc_current_locus; 694 goto next_item; 695 case MATCH_NO: 696 break; 697 698 case MATCH_ERROR: 699 goto cleanup; 700 } 701 702 m = gfc_match (" / %n /", n); 703 if (m == MATCH_ERROR) 704 goto cleanup; 705 if (m == MATCH_NO || n[0] == '\0') 706 goto syntax; 707 708 st = gfc_find_symtree (gfc_current_ns->common_root, n); 709 if (st == NULL) 710 { 711 gfc_error ("COMMON block /%s/ not found at %C", n); 712 goto cleanup; 713 } 714 715 for (sym = st->n.common->head; sym; sym = sym->common_next) 716 { 717 gfc_set_sym_referenced (sym); 718 p = gfc_get_omp_namelist (); 719 if (head == NULL) 720 head = tail = p; 721 else 722 { 723 tail->next = p; 724 tail = tail->next; 725 } 726 tail->sym = sym; 727 tail->where = gfc_current_locus; 728 } 729 730 next_item: 731 if (gfc_match_char (')') == MATCH_YES) 732 break; 733 if (gfc_match_char (',') != MATCH_YES) 734 goto syntax; 735 } 736 737 if (gfc_match_omp_eos () != MATCH_YES) 738 { 739 gfc_error ("Unexpected junk after !$ACC DECLARE at %C"); 740 goto cleanup; 741 } 742 743 while (*list) 744 list = &(*list)->next; 745 *list = head; 746 return MATCH_YES; 747 748syntax: 749 gfc_error ("Syntax error in !$ACC DECLARE list at %C"); 750 751cleanup: 752 gfc_current_locus = old_loc; 753 return MATCH_ERROR; 754} 755 756/* OpenMP 4.5 clauses. */ 757enum omp_mask1 758{ 759 OMP_CLAUSE_PRIVATE, 760 OMP_CLAUSE_FIRSTPRIVATE, 761 OMP_CLAUSE_LASTPRIVATE, 762 OMP_CLAUSE_COPYPRIVATE, 763 OMP_CLAUSE_SHARED, 764 OMP_CLAUSE_COPYIN, 765 OMP_CLAUSE_REDUCTION, 766 OMP_CLAUSE_IF, 767 OMP_CLAUSE_NUM_THREADS, 768 OMP_CLAUSE_SCHEDULE, 769 OMP_CLAUSE_DEFAULT, 770 OMP_CLAUSE_ORDERED, 771 OMP_CLAUSE_COLLAPSE, 772 OMP_CLAUSE_UNTIED, 773 OMP_CLAUSE_FINAL, 774 OMP_CLAUSE_MERGEABLE, 775 OMP_CLAUSE_ALIGNED, 776 OMP_CLAUSE_DEPEND, 777 OMP_CLAUSE_INBRANCH, 778 OMP_CLAUSE_LINEAR, 779 OMP_CLAUSE_NOTINBRANCH, 780 OMP_CLAUSE_PROC_BIND, 781 OMP_CLAUSE_SAFELEN, 782 OMP_CLAUSE_SIMDLEN, 783 OMP_CLAUSE_UNIFORM, 784 OMP_CLAUSE_DEVICE, 785 OMP_CLAUSE_MAP, 786 OMP_CLAUSE_TO, 787 OMP_CLAUSE_FROM, 788 OMP_CLAUSE_NUM_TEAMS, 789 OMP_CLAUSE_THREAD_LIMIT, 790 OMP_CLAUSE_DIST_SCHEDULE, 791 OMP_CLAUSE_DEFAULTMAP, 792 OMP_CLAUSE_GRAINSIZE, 793 OMP_CLAUSE_HINT, 794 OMP_CLAUSE_IS_DEVICE_PTR, 795 OMP_CLAUSE_LINK, 796 OMP_CLAUSE_NOGROUP, 797 OMP_CLAUSE_NUM_TASKS, 798 OMP_CLAUSE_PRIORITY, 799 OMP_CLAUSE_SIMD, 800 OMP_CLAUSE_THREADS, 801 OMP_CLAUSE_USE_DEVICE_PTR, 802 OMP_CLAUSE_USE_DEVICE_ADDR, /* Actually, OpenMP 5.0. */ 803 OMP_CLAUSE_NOWAIT, 804 /* This must come last. */ 805 OMP_MASK1_LAST 806}; 807 808/* OpenACC 2.0+ specific clauses. */ 809enum omp_mask2 810{ 811 OMP_CLAUSE_ASYNC, 812 OMP_CLAUSE_NUM_GANGS, 813 OMP_CLAUSE_NUM_WORKERS, 814 OMP_CLAUSE_VECTOR_LENGTH, 815 OMP_CLAUSE_COPY, 816 OMP_CLAUSE_COPYOUT, 817 OMP_CLAUSE_CREATE, 818 OMP_CLAUSE_NO_CREATE, 819 OMP_CLAUSE_PRESENT, 820 OMP_CLAUSE_DEVICEPTR, 821 OMP_CLAUSE_GANG, 822 OMP_CLAUSE_WORKER, 823 OMP_CLAUSE_VECTOR, 824 OMP_CLAUSE_SEQ, 825 OMP_CLAUSE_INDEPENDENT, 826 OMP_CLAUSE_USE_DEVICE, 827 OMP_CLAUSE_DEVICE_RESIDENT, 828 OMP_CLAUSE_HOST_SELF, 829 OMP_CLAUSE_WAIT, 830 OMP_CLAUSE_DELETE, 831 OMP_CLAUSE_AUTO, 832 OMP_CLAUSE_TILE, 833 OMP_CLAUSE_IF_PRESENT, 834 OMP_CLAUSE_FINALIZE, 835 OMP_CLAUSE_ATTACH, 836 OMP_CLAUSE_DETACH, 837 /* This must come last. */ 838 OMP_MASK2_LAST 839}; 840 841struct omp_inv_mask; 842 843/* Customized bitset for up to 128-bits. 844 The two enums above provide bit numbers to use, and which of the 845 two enums it is determines which of the two mask fields is used. 846 Supported operations are defining a mask, like: 847 #define XXX_CLAUSES \ 848 (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ) 849 oring such bitsets together or removing selected bits: 850 (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV)) 851 and testing individual bits: 852 if (mask & OMP_CLAUSE_UUU) */ 853 854struct omp_mask { 855 const uint64_t mask1; 856 const uint64_t mask2; 857 inline omp_mask (); 858 inline omp_mask (omp_mask1); 859 inline omp_mask (omp_mask2); 860 inline omp_mask (uint64_t, uint64_t); 861 inline omp_mask operator| (omp_mask1) const; 862 inline omp_mask operator| (omp_mask2) const; 863 inline omp_mask operator| (omp_mask) const; 864 inline omp_mask operator& (const omp_inv_mask &) const; 865 inline bool operator& (omp_mask1) const; 866 inline bool operator& (omp_mask2) const; 867 inline omp_inv_mask operator~ () const; 868}; 869 870struct omp_inv_mask : public omp_mask { 871 inline omp_inv_mask (const omp_mask &); 872}; 873 874omp_mask::omp_mask () : mask1 (0), mask2 (0) 875{ 876} 877 878omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0) 879{ 880} 881 882omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m) 883{ 884} 885 886omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2) 887{ 888} 889 890omp_mask 891omp_mask::operator| (omp_mask1 m) const 892{ 893 return omp_mask (mask1 | (((uint64_t) 1) << m), mask2); 894} 895 896omp_mask 897omp_mask::operator| (omp_mask2 m) const 898{ 899 return omp_mask (mask1, mask2 | (((uint64_t) 1) << m)); 900} 901 902omp_mask 903omp_mask::operator| (omp_mask m) const 904{ 905 return omp_mask (mask1 | m.mask1, mask2 | m.mask2); 906} 907 908omp_mask 909omp_mask::operator& (const omp_inv_mask &m) const 910{ 911 return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2); 912} 913 914bool 915omp_mask::operator& (omp_mask1 m) const 916{ 917 return (mask1 & (((uint64_t) 1) << m)) != 0; 918} 919 920bool 921omp_mask::operator& (omp_mask2 m) const 922{ 923 return (mask2 & (((uint64_t) 1) << m)) != 0; 924} 925 926omp_inv_mask 927omp_mask::operator~ () const 928{ 929 return omp_inv_mask (*this); 930} 931 932omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) 933{ 934} 935 936/* Helper function for OpenACC and OpenMP clauses involving memory 937 mapping. */ 938 939static bool 940gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, 941 bool allow_common, bool allow_derived) 942{ 943 gfc_omp_namelist **head = NULL; 944 if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true, 945 allow_derived) 946 == MATCH_YES) 947 { 948 gfc_omp_namelist *n; 949 for (n = *head; n; n = n->next) 950 n->u.map_op = map_op; 951 return true; 952 } 953 954 return false; 955} 956 957/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of 958 clauses that are allowed for a particular directive. */ 959 960static match 961gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, 962 bool first = true, bool needs_space = true, 963 bool openacc = false) 964{ 965 gfc_omp_clauses *c = gfc_get_omp_clauses (); 966 locus old_loc; 967 /* Determine whether we're dealing with an OpenACC directive that permits 968 derived type member accesses. This in particular disallows 969 "!$acc declare" from using such accesses, because it's not clear if/how 970 that should work. */ 971 bool allow_derived = (openacc 972 && ((mask & OMP_CLAUSE_ATTACH) 973 || (mask & OMP_CLAUSE_DETACH) 974 || (mask & OMP_CLAUSE_HOST_SELF))); 975 976 gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); 977 *cp = NULL; 978 while (1) 979 { 980 if ((first || gfc_match_char (',') != MATCH_YES) 981 && (needs_space && gfc_match_space () != MATCH_YES)) 982 break; 983 needs_space = false; 984 first = false; 985 gfc_gobble_whitespace (); 986 bool end_colon; 987 gfc_omp_namelist **head; 988 old_loc = gfc_current_locus; 989 char pc = gfc_peek_ascii_char (); 990 switch (pc) 991 { 992 case 'a': 993 end_colon = false; 994 head = NULL; 995 if ((mask & OMP_CLAUSE_ALIGNED) 996 && gfc_match_omp_variable_list ("aligned (", 997 &c->lists[OMP_LIST_ALIGNED], 998 false, &end_colon, 999 &head) == MATCH_YES) 1000 { 1001 gfc_expr *alignment = NULL; 1002 gfc_omp_namelist *n; 1003 1004 if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) 1005 { 1006 gfc_free_omp_namelist (*head); 1007 gfc_current_locus = old_loc; 1008 *head = NULL; 1009 break; 1010 } 1011 for (n = *head; n; n = n->next) 1012 if (n->next && alignment) 1013 n->expr = gfc_copy_expr (alignment); 1014 else 1015 n->expr = alignment; 1016 continue; 1017 } 1018 if ((mask & OMP_CLAUSE_ASYNC) 1019 && !c->async 1020 && gfc_match ("async") == MATCH_YES) 1021 { 1022 c->async = true; 1023 match m = gfc_match (" ( %e )", &c->async_expr); 1024 if (m == MATCH_ERROR) 1025 { 1026 gfc_current_locus = old_loc; 1027 break; 1028 } 1029 else if (m == MATCH_NO) 1030 { 1031 c->async_expr 1032 = gfc_get_constant_expr (BT_INTEGER, 1033 gfc_default_integer_kind, 1034 &gfc_current_locus); 1035 mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL); 1036 needs_space = true; 1037 } 1038 continue; 1039 } 1040 if ((mask & OMP_CLAUSE_AUTO) 1041 && !c->par_auto 1042 && gfc_match ("auto") == MATCH_YES) 1043 { 1044 c->par_auto = true; 1045 needs_space = true; 1046 continue; 1047 } 1048 if ((mask & OMP_CLAUSE_ATTACH) 1049 && gfc_match ("attach ( ") == MATCH_YES 1050 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1051 OMP_MAP_ATTACH, false, 1052 allow_derived)) 1053 continue; 1054 break; 1055 case 'c': 1056 if ((mask & OMP_CLAUSE_COLLAPSE) 1057 && !c->collapse) 1058 { 1059 gfc_expr *cexpr = NULL; 1060 match m = gfc_match ("collapse ( %e )", &cexpr); 1061 1062 if (m == MATCH_YES) 1063 { 1064 int collapse; 1065 if (gfc_extract_int (cexpr, &collapse, -1)) 1066 collapse = 1; 1067 else if (collapse <= 0) 1068 { 1069 gfc_error_now ("COLLAPSE clause argument not" 1070 " constant positive integer at %C"); 1071 collapse = 1; 1072 } 1073 c->collapse = collapse; 1074 gfc_free_expr (cexpr); 1075 continue; 1076 } 1077 } 1078 if ((mask & OMP_CLAUSE_COPY) 1079 && gfc_match ("copy ( ") == MATCH_YES 1080 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1081 OMP_MAP_TOFROM, true, 1082 allow_derived)) 1083 continue; 1084 if (mask & OMP_CLAUSE_COPYIN) 1085 { 1086 if (openacc) 1087 { 1088 if (gfc_match ("copyin ( ") == MATCH_YES 1089 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1090 OMP_MAP_TO, true, 1091 allow_derived)) 1092 continue; 1093 } 1094 else if (gfc_match_omp_variable_list ("copyin (", 1095 &c->lists[OMP_LIST_COPYIN], 1096 true) == MATCH_YES) 1097 continue; 1098 } 1099 if ((mask & OMP_CLAUSE_COPYOUT) 1100 && gfc_match ("copyout ( ") == MATCH_YES 1101 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1102 OMP_MAP_FROM, true, allow_derived)) 1103 continue; 1104 if ((mask & OMP_CLAUSE_COPYPRIVATE) 1105 && gfc_match_omp_variable_list ("copyprivate (", 1106 &c->lists[OMP_LIST_COPYPRIVATE], 1107 true) == MATCH_YES) 1108 continue; 1109 if ((mask & OMP_CLAUSE_CREATE) 1110 && gfc_match ("create ( ") == MATCH_YES 1111 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1112 OMP_MAP_ALLOC, true, allow_derived)) 1113 continue; 1114 break; 1115 case 'd': 1116 if ((mask & OMP_CLAUSE_DEFAULT) 1117 && c->default_sharing == OMP_DEFAULT_UNKNOWN) 1118 { 1119 if (gfc_match ("default ( none )") == MATCH_YES) 1120 c->default_sharing = OMP_DEFAULT_NONE; 1121 else if (openacc) 1122 { 1123 if (gfc_match ("default ( present )") == MATCH_YES) 1124 c->default_sharing = OMP_DEFAULT_PRESENT; 1125 } 1126 else 1127 { 1128 if (gfc_match ("default ( firstprivate )") == MATCH_YES) 1129 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; 1130 else if (gfc_match ("default ( private )") == MATCH_YES) 1131 c->default_sharing = OMP_DEFAULT_PRIVATE; 1132 else if (gfc_match ("default ( shared )") == MATCH_YES) 1133 c->default_sharing = OMP_DEFAULT_SHARED; 1134 } 1135 if (c->default_sharing != OMP_DEFAULT_UNKNOWN) 1136 continue; 1137 } 1138 if ((mask & OMP_CLAUSE_DEFAULTMAP) 1139 && !c->defaultmap 1140 && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES) 1141 { 1142 c->defaultmap = true; 1143 continue; 1144 } 1145 if ((mask & OMP_CLAUSE_DELETE) 1146 && gfc_match ("delete ( ") == MATCH_YES 1147 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1148 OMP_MAP_RELEASE, true, 1149 allow_derived)) 1150 continue; 1151 if ((mask & OMP_CLAUSE_DEPEND) 1152 && gfc_match ("depend ( ") == MATCH_YES) 1153 { 1154 match m = MATCH_YES; 1155 gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; 1156 if (gfc_match ("inout") == MATCH_YES) 1157 depend_op = OMP_DEPEND_INOUT; 1158 else if (gfc_match ("in") == MATCH_YES) 1159 depend_op = OMP_DEPEND_IN; 1160 else if (gfc_match ("out") == MATCH_YES) 1161 depend_op = OMP_DEPEND_OUT; 1162 else if (!c->depend_source 1163 && gfc_match ("source )") == MATCH_YES) 1164 { 1165 c->depend_source = true; 1166 continue; 1167 } 1168 else if (gfc_match ("sink : ") == MATCH_YES) 1169 { 1170 if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND]) 1171 == MATCH_YES) 1172 continue; 1173 m = MATCH_NO; 1174 } 1175 else 1176 m = MATCH_NO; 1177 head = NULL; 1178 if (m == MATCH_YES 1179 && gfc_match_omp_variable_list (" : ", 1180 &c->lists[OMP_LIST_DEPEND], 1181 false, NULL, &head, 1182 true) == MATCH_YES) 1183 { 1184 gfc_omp_namelist *n; 1185 for (n = *head; n; n = n->next) 1186 n->u.depend_op = depend_op; 1187 continue; 1188 } 1189 else 1190 gfc_current_locus = old_loc; 1191 } 1192 if ((mask & OMP_CLAUSE_DETACH) 1193 && gfc_match ("detach ( ") == MATCH_YES 1194 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1195 OMP_MAP_DETACH, false, 1196 allow_derived)) 1197 continue; 1198 if ((mask & OMP_CLAUSE_DEVICE) 1199 && !openacc 1200 && c->device == NULL 1201 && gfc_match ("device ( %e )", &c->device) == MATCH_YES) 1202 continue; 1203 if ((mask & OMP_CLAUSE_DEVICE) 1204 && openacc 1205 && gfc_match ("device ( ") == MATCH_YES 1206 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1207 OMP_MAP_FORCE_TO, true, 1208 allow_derived)) 1209 continue; 1210 if ((mask & OMP_CLAUSE_DEVICEPTR) 1211 && gfc_match ("deviceptr ( ") == MATCH_YES 1212 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1213 OMP_MAP_FORCE_DEVICEPTR, false, 1214 allow_derived)) 1215 continue; 1216 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) 1217 && gfc_match_omp_variable_list 1218 ("device_resident (", 1219 &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES) 1220 continue; 1221 if ((mask & OMP_CLAUSE_DIST_SCHEDULE) 1222 && c->dist_sched_kind == OMP_SCHED_NONE 1223 && gfc_match ("dist_schedule ( static") == MATCH_YES) 1224 { 1225 match m = MATCH_NO; 1226 c->dist_sched_kind = OMP_SCHED_STATIC; 1227 m = gfc_match (" , %e )", &c->dist_chunk_size); 1228 if (m != MATCH_YES) 1229 m = gfc_match_char (')'); 1230 if (m != MATCH_YES) 1231 { 1232 c->dist_sched_kind = OMP_SCHED_NONE; 1233 gfc_current_locus = old_loc; 1234 } 1235 else 1236 continue; 1237 } 1238 break; 1239 case 'f': 1240 if ((mask & OMP_CLAUSE_FINAL) 1241 && c->final_expr == NULL 1242 && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES) 1243 continue; 1244 if ((mask & OMP_CLAUSE_FINALIZE) 1245 && !c->finalize 1246 && gfc_match ("finalize") == MATCH_YES) 1247 { 1248 c->finalize = true; 1249 needs_space = true; 1250 continue; 1251 } 1252 if ((mask & OMP_CLAUSE_FIRSTPRIVATE) 1253 && gfc_match_omp_variable_list ("firstprivate (", 1254 &c->lists[OMP_LIST_FIRSTPRIVATE], 1255 true) == MATCH_YES) 1256 continue; 1257 if ((mask & OMP_CLAUSE_FROM) 1258 && gfc_match_omp_variable_list ("from (", 1259 &c->lists[OMP_LIST_FROM], false, 1260 NULL, &head, true) == MATCH_YES) 1261 continue; 1262 break; 1263 case 'g': 1264 if ((mask & OMP_CLAUSE_GANG) 1265 && !c->gang 1266 && gfc_match ("gang") == MATCH_YES) 1267 { 1268 c->gang = true; 1269 match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG); 1270 if (m == MATCH_ERROR) 1271 { 1272 gfc_current_locus = old_loc; 1273 break; 1274 } 1275 else if (m == MATCH_NO) 1276 needs_space = true; 1277 continue; 1278 } 1279 if ((mask & OMP_CLAUSE_GRAINSIZE) 1280 && c->grainsize == NULL 1281 && gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES) 1282 continue; 1283 break; 1284 case 'h': 1285 if ((mask & OMP_CLAUSE_HINT) 1286 && c->hint == NULL 1287 && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES) 1288 continue; 1289 if ((mask & OMP_CLAUSE_HOST_SELF) 1290 && gfc_match ("host ( ") == MATCH_YES 1291 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1292 OMP_MAP_FORCE_FROM, true, 1293 allow_derived)) 1294 continue; 1295 break; 1296 case 'i': 1297 if ((mask & OMP_CLAUSE_IF) 1298 && c->if_expr == NULL 1299 && gfc_match ("if ( ") == MATCH_YES) 1300 { 1301 if (gfc_match ("%e )", &c->if_expr) == MATCH_YES) 1302 continue; 1303 if (!openacc) 1304 { 1305 /* This should match the enum gfc_omp_if_kind order. */ 1306 static const char *ifs[OMP_IF_LAST] = { 1307 " parallel : %e )", 1308 " task : %e )", 1309 " taskloop : %e )", 1310 " target : %e )", 1311 " target data : %e )", 1312 " target update : %e )", 1313 " target enter data : %e )", 1314 " target exit data : %e )" }; 1315 int i; 1316 for (i = 0; i < OMP_IF_LAST; i++) 1317 if (c->if_exprs[i] == NULL 1318 && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES) 1319 break; 1320 if (i < OMP_IF_LAST) 1321 continue; 1322 } 1323 gfc_current_locus = old_loc; 1324 } 1325 if ((mask & OMP_CLAUSE_IF_PRESENT) 1326 && !c->if_present 1327 && gfc_match ("if_present") == MATCH_YES) 1328 { 1329 c->if_present = true; 1330 needs_space = true; 1331 continue; 1332 } 1333 if ((mask & OMP_CLAUSE_INBRANCH) 1334 && !c->inbranch 1335 && !c->notinbranch 1336 && gfc_match ("inbranch") == MATCH_YES) 1337 { 1338 c->inbranch = needs_space = true; 1339 continue; 1340 } 1341 if ((mask & OMP_CLAUSE_INDEPENDENT) 1342 && !c->independent 1343 && gfc_match ("independent") == MATCH_YES) 1344 { 1345 c->independent = true; 1346 needs_space = true; 1347 continue; 1348 } 1349 if ((mask & OMP_CLAUSE_IS_DEVICE_PTR) 1350 && gfc_match_omp_variable_list 1351 ("is_device_ptr (", 1352 &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES) 1353 continue; 1354 break; 1355 case 'l': 1356 if ((mask & OMP_CLAUSE_LASTPRIVATE) 1357 && gfc_match_omp_variable_list ("lastprivate (", 1358 &c->lists[OMP_LIST_LASTPRIVATE], 1359 true) == MATCH_YES) 1360 continue; 1361 end_colon = false; 1362 head = NULL; 1363 if ((mask & OMP_CLAUSE_LINEAR) 1364 && gfc_match ("linear (") == MATCH_YES) 1365 { 1366 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; 1367 gfc_expr *step = NULL; 1368 1369 if (gfc_match_omp_variable_list (" ref (", 1370 &c->lists[OMP_LIST_LINEAR], 1371 false, NULL, &head) 1372 == MATCH_YES) 1373 linear_op = OMP_LINEAR_REF; 1374 else if (gfc_match_omp_variable_list (" val (", 1375 &c->lists[OMP_LIST_LINEAR], 1376 false, NULL, &head) 1377 == MATCH_YES) 1378 linear_op = OMP_LINEAR_VAL; 1379 else if (gfc_match_omp_variable_list (" uval (", 1380 &c->lists[OMP_LIST_LINEAR], 1381 false, NULL, &head) 1382 == MATCH_YES) 1383 linear_op = OMP_LINEAR_UVAL; 1384 else if (gfc_match_omp_variable_list ("", 1385 &c->lists[OMP_LIST_LINEAR], 1386 false, &end_colon, &head) 1387 == MATCH_YES) 1388 linear_op = OMP_LINEAR_DEFAULT; 1389 else 1390 { 1391 gfc_current_locus = old_loc; 1392 break; 1393 } 1394 if (linear_op != OMP_LINEAR_DEFAULT) 1395 { 1396 if (gfc_match (" :") == MATCH_YES) 1397 end_colon = true; 1398 else if (gfc_match (" )") != MATCH_YES) 1399 { 1400 gfc_free_omp_namelist (*head); 1401 gfc_current_locus = old_loc; 1402 *head = NULL; 1403 break; 1404 } 1405 } 1406 if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) 1407 { 1408 gfc_free_omp_namelist (*head); 1409 gfc_current_locus = old_loc; 1410 *head = NULL; 1411 break; 1412 } 1413 else if (!end_colon) 1414 { 1415 step = gfc_get_constant_expr (BT_INTEGER, 1416 gfc_default_integer_kind, 1417 &old_loc); 1418 mpz_set_si (step->value.integer, 1); 1419 } 1420 (*head)->expr = step; 1421 if (linear_op != OMP_LINEAR_DEFAULT) 1422 for (gfc_omp_namelist *n = *head; n; n = n->next) 1423 n->u.linear_op = linear_op; 1424 continue; 1425 } 1426 if ((mask & OMP_CLAUSE_LINK) 1427 && openacc 1428 && (gfc_match_oacc_clause_link ("link (", 1429 &c->lists[OMP_LIST_LINK]) 1430 == MATCH_YES)) 1431 continue; 1432 else if ((mask & OMP_CLAUSE_LINK) 1433 && !openacc 1434 && (gfc_match_omp_to_link ("link (", 1435 &c->lists[OMP_LIST_LINK]) 1436 == MATCH_YES)) 1437 continue; 1438 break; 1439 case 'm': 1440 if ((mask & OMP_CLAUSE_MAP) 1441 && gfc_match ("map ( ") == MATCH_YES) 1442 { 1443 locus old_loc2 = gfc_current_locus; 1444 bool always = false; 1445 gfc_omp_map_op map_op = OMP_MAP_TOFROM; 1446 if (gfc_match ("always , ") == MATCH_YES) 1447 always = true; 1448 if (gfc_match ("alloc : ") == MATCH_YES) 1449 map_op = OMP_MAP_ALLOC; 1450 else if (gfc_match ("tofrom : ") == MATCH_YES) 1451 map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; 1452 else if (gfc_match ("to : ") == MATCH_YES) 1453 map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; 1454 else if (gfc_match ("from : ") == MATCH_YES) 1455 map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; 1456 else if (gfc_match ("release : ") == MATCH_YES) 1457 map_op = OMP_MAP_RELEASE; 1458 else if (gfc_match ("delete : ") == MATCH_YES) 1459 map_op = OMP_MAP_DELETE; 1460 else if (always) 1461 { 1462 gfc_current_locus = old_loc2; 1463 always = false; 1464 } 1465 head = NULL; 1466 if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], 1467 false, NULL, &head, 1468 true) == MATCH_YES) 1469 { 1470 gfc_omp_namelist *n; 1471 for (n = *head; n; n = n->next) 1472 n->u.map_op = map_op; 1473 continue; 1474 } 1475 else 1476 gfc_current_locus = old_loc; 1477 } 1478 if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable 1479 && gfc_match ("mergeable") == MATCH_YES) 1480 { 1481 c->mergeable = needs_space = true; 1482 continue; 1483 } 1484 break; 1485 case 'n': 1486 if ((mask & OMP_CLAUSE_NO_CREATE) 1487 && gfc_match ("no_create ( ") == MATCH_YES 1488 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1489 OMP_MAP_IF_PRESENT, true, 1490 allow_derived)) 1491 continue; 1492 if ((mask & OMP_CLAUSE_NOGROUP) 1493 && !c->nogroup 1494 && gfc_match ("nogroup") == MATCH_YES) 1495 { 1496 c->nogroup = needs_space = true; 1497 continue; 1498 } 1499 if ((mask & OMP_CLAUSE_NOTINBRANCH) 1500 && !c->notinbranch 1501 && !c->inbranch 1502 && gfc_match ("notinbranch") == MATCH_YES) 1503 { 1504 c->notinbranch = needs_space = true; 1505 continue; 1506 } 1507 if ((mask & OMP_CLAUSE_NOWAIT) 1508 && !c->nowait 1509 && gfc_match ("nowait") == MATCH_YES) 1510 { 1511 c->nowait = needs_space = true; 1512 continue; 1513 } 1514 if ((mask & OMP_CLAUSE_NUM_GANGS) 1515 && c->num_gangs_expr == NULL 1516 && gfc_match ("num_gangs ( %e )", 1517 &c->num_gangs_expr) == MATCH_YES) 1518 continue; 1519 if ((mask & OMP_CLAUSE_NUM_TASKS) 1520 && c->num_tasks == NULL 1521 && gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES) 1522 continue; 1523 if ((mask & OMP_CLAUSE_NUM_TEAMS) 1524 && c->num_teams == NULL 1525 && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES) 1526 continue; 1527 if ((mask & OMP_CLAUSE_NUM_THREADS) 1528 && c->num_threads == NULL 1529 && (gfc_match ("num_threads ( %e )", &c->num_threads) 1530 == MATCH_YES)) 1531 continue; 1532 if ((mask & OMP_CLAUSE_NUM_WORKERS) 1533 && c->num_workers_expr == NULL 1534 && gfc_match ("num_workers ( %e )", 1535 &c->num_workers_expr) == MATCH_YES) 1536 continue; 1537 break; 1538 case 'o': 1539 if ((mask & OMP_CLAUSE_ORDERED) 1540 && !c->ordered 1541 && gfc_match ("ordered") == MATCH_YES) 1542 { 1543 gfc_expr *cexpr = NULL; 1544 match m = gfc_match (" ( %e )", &cexpr); 1545 1546 c->ordered = true; 1547 if (m == MATCH_YES) 1548 { 1549 int ordered = 0; 1550 if (gfc_extract_int (cexpr, &ordered, -1)) 1551 ordered = 0; 1552 else if (ordered <= 0) 1553 { 1554 gfc_error_now ("ORDERED clause argument not" 1555 " constant positive integer at %C"); 1556 ordered = 0; 1557 } 1558 c->orderedc = ordered; 1559 gfc_free_expr (cexpr); 1560 continue; 1561 } 1562 1563 needs_space = true; 1564 continue; 1565 } 1566 break; 1567 case 'p': 1568 if ((mask & OMP_CLAUSE_COPY) 1569 && gfc_match ("pcopy ( ") == MATCH_YES 1570 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1571 OMP_MAP_TOFROM, true, allow_derived)) 1572 continue; 1573 if ((mask & OMP_CLAUSE_COPYIN) 1574 && gfc_match ("pcopyin ( ") == MATCH_YES 1575 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1576 OMP_MAP_TO, true, allow_derived)) 1577 continue; 1578 if ((mask & OMP_CLAUSE_COPYOUT) 1579 && gfc_match ("pcopyout ( ") == MATCH_YES 1580 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1581 OMP_MAP_FROM, true, allow_derived)) 1582 continue; 1583 if ((mask & OMP_CLAUSE_CREATE) 1584 && gfc_match ("pcreate ( ") == MATCH_YES 1585 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1586 OMP_MAP_ALLOC, true, allow_derived)) 1587 continue; 1588 if ((mask & OMP_CLAUSE_PRESENT) 1589 && gfc_match ("present ( ") == MATCH_YES 1590 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1591 OMP_MAP_FORCE_PRESENT, false, 1592 allow_derived)) 1593 continue; 1594 if ((mask & OMP_CLAUSE_COPY) 1595 && gfc_match ("present_or_copy ( ") == MATCH_YES 1596 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1597 OMP_MAP_TOFROM, true, 1598 allow_derived)) 1599 continue; 1600 if ((mask & OMP_CLAUSE_COPYIN) 1601 && gfc_match ("present_or_copyin ( ") == MATCH_YES 1602 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1603 OMP_MAP_TO, true, allow_derived)) 1604 continue; 1605 if ((mask & OMP_CLAUSE_COPYOUT) 1606 && gfc_match ("present_or_copyout ( ") == MATCH_YES 1607 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1608 OMP_MAP_FROM, true, allow_derived)) 1609 continue; 1610 if ((mask & OMP_CLAUSE_CREATE) 1611 && gfc_match ("present_or_create ( ") == MATCH_YES 1612 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1613 OMP_MAP_ALLOC, true, allow_derived)) 1614 continue; 1615 if ((mask & OMP_CLAUSE_PRIORITY) 1616 && c->priority == NULL 1617 && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES) 1618 continue; 1619 if ((mask & OMP_CLAUSE_PRIVATE) 1620 && gfc_match_omp_variable_list ("private (", 1621 &c->lists[OMP_LIST_PRIVATE], 1622 true) == MATCH_YES) 1623 continue; 1624 if ((mask & OMP_CLAUSE_PROC_BIND) 1625 && c->proc_bind == OMP_PROC_BIND_UNKNOWN) 1626 { 1627 if (gfc_match ("proc_bind ( master )") == MATCH_YES) 1628 c->proc_bind = OMP_PROC_BIND_MASTER; 1629 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES) 1630 c->proc_bind = OMP_PROC_BIND_SPREAD; 1631 else if (gfc_match ("proc_bind ( close )") == MATCH_YES) 1632 c->proc_bind = OMP_PROC_BIND_CLOSE; 1633 if (c->proc_bind != OMP_PROC_BIND_UNKNOWN) 1634 continue; 1635 } 1636 break; 1637 case 'r': 1638 if ((mask & OMP_CLAUSE_REDUCTION) 1639 && gfc_match ("reduction ( ") == MATCH_YES) 1640 { 1641 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; 1642 char buffer[GFC_MAX_SYMBOL_LEN + 3]; 1643 if (gfc_match_char ('+') == MATCH_YES) 1644 rop = OMP_REDUCTION_PLUS; 1645 else if (gfc_match_char ('*') == MATCH_YES) 1646 rop = OMP_REDUCTION_TIMES; 1647 else if (gfc_match_char ('-') == MATCH_YES) 1648 rop = OMP_REDUCTION_MINUS; 1649 else if (gfc_match (".and.") == MATCH_YES) 1650 rop = OMP_REDUCTION_AND; 1651 else if (gfc_match (".or.") == MATCH_YES) 1652 rop = OMP_REDUCTION_OR; 1653 else if (gfc_match (".eqv.") == MATCH_YES) 1654 rop = OMP_REDUCTION_EQV; 1655 else if (gfc_match (".neqv.") == MATCH_YES) 1656 rop = OMP_REDUCTION_NEQV; 1657 if (rop != OMP_REDUCTION_NONE) 1658 snprintf (buffer, sizeof buffer, "operator %s", 1659 gfc_op2string ((gfc_intrinsic_op) rop)); 1660 else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES) 1661 { 1662 buffer[0] = '.'; 1663 strcat (buffer, "."); 1664 } 1665 else if (gfc_match_name (buffer) == MATCH_YES) 1666 { 1667 gfc_symbol *sym; 1668 const char *n = buffer; 1669 1670 gfc_find_symbol (buffer, NULL, 1, &sym); 1671 if (sym != NULL) 1672 { 1673 if (sym->attr.intrinsic) 1674 n = sym->name; 1675 else if ((sym->attr.flavor != FL_UNKNOWN 1676 && sym->attr.flavor != FL_PROCEDURE) 1677 || sym->attr.external 1678 || sym->attr.generic 1679 || sym->attr.entry 1680 || sym->attr.result 1681 || sym->attr.dummy 1682 || sym->attr.subroutine 1683 || sym->attr.pointer 1684 || sym->attr.target 1685 || sym->attr.cray_pointer 1686 || sym->attr.cray_pointee 1687 || (sym->attr.proc != PROC_UNKNOWN 1688 && sym->attr.proc != PROC_INTRINSIC) 1689 || sym->attr.if_source != IFSRC_UNKNOWN 1690 || sym == sym->ns->proc_name) 1691 { 1692 sym = NULL; 1693 n = NULL; 1694 } 1695 else 1696 n = sym->name; 1697 } 1698 if (n == NULL) 1699 rop = OMP_REDUCTION_NONE; 1700 else if (strcmp (n, "max") == 0) 1701 rop = OMP_REDUCTION_MAX; 1702 else if (strcmp (n, "min") == 0) 1703 rop = OMP_REDUCTION_MIN; 1704 else if (strcmp (n, "iand") == 0) 1705 rop = OMP_REDUCTION_IAND; 1706 else if (strcmp (n, "ior") == 0) 1707 rop = OMP_REDUCTION_IOR; 1708 else if (strcmp (n, "ieor") == 0) 1709 rop = OMP_REDUCTION_IEOR; 1710 if (rop != OMP_REDUCTION_NONE 1711 && sym != NULL 1712 && ! sym->attr.intrinsic 1713 && ! sym->attr.use_assoc 1714 && ((sym->attr.flavor == FL_UNKNOWN 1715 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, 1716 sym->name, NULL)) 1717 || !gfc_add_intrinsic (&sym->attr, NULL))) 1718 rop = OMP_REDUCTION_NONE; 1719 } 1720 else 1721 buffer[0] = '\0'; 1722 gfc_omp_udr *udr 1723 = (buffer[0] 1724 ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL); 1725 gfc_omp_namelist **head = NULL; 1726 if (rop == OMP_REDUCTION_NONE && udr) 1727 rop = OMP_REDUCTION_USER; 1728 1729 if (gfc_match_omp_variable_list (" :", 1730 &c->lists[OMP_LIST_REDUCTION], 1731 false, NULL, &head, openacc, 1732 allow_derived) == MATCH_YES) 1733 { 1734 gfc_omp_namelist *n; 1735 if (rop == OMP_REDUCTION_NONE) 1736 { 1737 n = *head; 1738 *head = NULL; 1739 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found " 1740 "at %L", buffer, &old_loc); 1741 gfc_free_omp_namelist (n); 1742 } 1743 else 1744 for (n = *head; n; n = n->next) 1745 { 1746 n->u.reduction_op = rop; 1747 if (udr) 1748 { 1749 n->udr = gfc_get_omp_namelist_udr (); 1750 n->udr->udr = udr; 1751 } 1752 } 1753 continue; 1754 } 1755 else 1756 gfc_current_locus = old_loc; 1757 } 1758 break; 1759 case 's': 1760 if ((mask & OMP_CLAUSE_SAFELEN) 1761 && c->safelen_expr == NULL 1762 && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES) 1763 continue; 1764 if ((mask & OMP_CLAUSE_SCHEDULE) 1765 && c->sched_kind == OMP_SCHED_NONE 1766 && gfc_match ("schedule ( ") == MATCH_YES) 1767 { 1768 int nmodifiers = 0; 1769 locus old_loc2 = gfc_current_locus; 1770 do 1771 { 1772 if (gfc_match ("simd") == MATCH_YES) 1773 { 1774 c->sched_simd = true; 1775 nmodifiers++; 1776 } 1777 else if (gfc_match ("monotonic") == MATCH_YES) 1778 { 1779 c->sched_monotonic = true; 1780 nmodifiers++; 1781 } 1782 else if (gfc_match ("nonmonotonic") == MATCH_YES) 1783 { 1784 c->sched_nonmonotonic = true; 1785 nmodifiers++; 1786 } 1787 else 1788 { 1789 if (nmodifiers) 1790 gfc_current_locus = old_loc2; 1791 break; 1792 } 1793 if (nmodifiers == 1 1794 && gfc_match (" , ") == MATCH_YES) 1795 continue; 1796 else if (gfc_match (" : ") == MATCH_YES) 1797 break; 1798 gfc_current_locus = old_loc2; 1799 break; 1800 } 1801 while (1); 1802 if (gfc_match ("static") == MATCH_YES) 1803 c->sched_kind = OMP_SCHED_STATIC; 1804 else if (gfc_match ("dynamic") == MATCH_YES) 1805 c->sched_kind = OMP_SCHED_DYNAMIC; 1806 else if (gfc_match ("guided") == MATCH_YES) 1807 c->sched_kind = OMP_SCHED_GUIDED; 1808 else if (gfc_match ("runtime") == MATCH_YES) 1809 c->sched_kind = OMP_SCHED_RUNTIME; 1810 else if (gfc_match ("auto") == MATCH_YES) 1811 c->sched_kind = OMP_SCHED_AUTO; 1812 if (c->sched_kind != OMP_SCHED_NONE) 1813 { 1814 match m = MATCH_NO; 1815 if (c->sched_kind != OMP_SCHED_RUNTIME 1816 && c->sched_kind != OMP_SCHED_AUTO) 1817 m = gfc_match (" , %e )", &c->chunk_size); 1818 if (m != MATCH_YES) 1819 m = gfc_match_char (')'); 1820 if (m != MATCH_YES) 1821 c->sched_kind = OMP_SCHED_NONE; 1822 } 1823 if (c->sched_kind != OMP_SCHED_NONE) 1824 continue; 1825 else 1826 gfc_current_locus = old_loc; 1827 } 1828 if ((mask & OMP_CLAUSE_HOST_SELF) 1829 && gfc_match ("self ( ") == MATCH_YES 1830 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1831 OMP_MAP_FORCE_FROM, true, 1832 allow_derived)) 1833 continue; 1834 if ((mask & OMP_CLAUSE_SEQ) 1835 && !c->seq 1836 && gfc_match ("seq") == MATCH_YES) 1837 { 1838 c->seq = true; 1839 needs_space = true; 1840 continue; 1841 } 1842 if ((mask & OMP_CLAUSE_SHARED) 1843 && gfc_match_omp_variable_list ("shared (", 1844 &c->lists[OMP_LIST_SHARED], 1845 true) == MATCH_YES) 1846 continue; 1847 if ((mask & OMP_CLAUSE_SIMDLEN) 1848 && c->simdlen_expr == NULL 1849 && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES) 1850 continue; 1851 if ((mask & OMP_CLAUSE_SIMD) 1852 && !c->simd 1853 && gfc_match ("simd") == MATCH_YES) 1854 { 1855 c->simd = needs_space = true; 1856 continue; 1857 } 1858 break; 1859 case 't': 1860 if ((mask & OMP_CLAUSE_THREAD_LIMIT) 1861 && c->thread_limit == NULL 1862 && gfc_match ("thread_limit ( %e )", 1863 &c->thread_limit) == MATCH_YES) 1864 continue; 1865 if ((mask & OMP_CLAUSE_THREADS) 1866 && !c->threads 1867 && gfc_match ("threads") == MATCH_YES) 1868 { 1869 c->threads = needs_space = true; 1870 continue; 1871 } 1872 if ((mask & OMP_CLAUSE_TILE) 1873 && !c->tile_list 1874 && match_oacc_expr_list ("tile (", &c->tile_list, 1875 true) == MATCH_YES) 1876 continue; 1877 if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK)) 1878 { 1879 if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]) 1880 == MATCH_YES) 1881 continue; 1882 } 1883 else if ((mask & OMP_CLAUSE_TO) 1884 && gfc_match_omp_variable_list ("to (", 1885 &c->lists[OMP_LIST_TO], false, 1886 NULL, &head, true) == MATCH_YES) 1887 continue; 1888 break; 1889 case 'u': 1890 if ((mask & OMP_CLAUSE_UNIFORM) 1891 && gfc_match_omp_variable_list ("uniform (", 1892 &c->lists[OMP_LIST_UNIFORM], 1893 false) == MATCH_YES) 1894 continue; 1895 if ((mask & OMP_CLAUSE_UNTIED) 1896 && !c->untied 1897 && gfc_match ("untied") == MATCH_YES) 1898 { 1899 c->untied = needs_space = true; 1900 continue; 1901 } 1902 if ((mask & OMP_CLAUSE_USE_DEVICE) 1903 && gfc_match_omp_variable_list ("use_device (", 1904 &c->lists[OMP_LIST_USE_DEVICE], 1905 true) == MATCH_YES) 1906 continue; 1907 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR) 1908 && gfc_match_omp_variable_list 1909 ("use_device_ptr (", 1910 &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES) 1911 continue; 1912 if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR) 1913 && gfc_match_omp_variable_list 1914 ("use_device_addr (", 1915 &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES) 1916 continue; 1917 break; 1918 case 'v': 1919 /* VECTOR_LENGTH must be matched before VECTOR, because the latter 1920 doesn't unconditionally match '('. */ 1921 if ((mask & OMP_CLAUSE_VECTOR_LENGTH) 1922 && c->vector_length_expr == NULL 1923 && (gfc_match ("vector_length ( %e )", &c->vector_length_expr) 1924 == MATCH_YES)) 1925 continue; 1926 if ((mask & OMP_CLAUSE_VECTOR) 1927 && !c->vector 1928 && gfc_match ("vector") == MATCH_YES) 1929 { 1930 c->vector = true; 1931 match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR); 1932 if (m == MATCH_ERROR) 1933 { 1934 gfc_current_locus = old_loc; 1935 break; 1936 } 1937 if (m == MATCH_NO) 1938 needs_space = true; 1939 continue; 1940 } 1941 break; 1942 case 'w': 1943 if ((mask & OMP_CLAUSE_WAIT) 1944 && gfc_match ("wait") == MATCH_YES) 1945 { 1946 match m = match_oacc_expr_list (" (", &c->wait_list, false); 1947 if (m == MATCH_ERROR) 1948 { 1949 gfc_current_locus = old_loc; 1950 break; 1951 } 1952 else if (m == MATCH_NO) 1953 { 1954 gfc_expr *expr 1955 = gfc_get_constant_expr (BT_INTEGER, 1956 gfc_default_integer_kind, 1957 &gfc_current_locus); 1958 mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL); 1959 gfc_expr_list **expr_list = &c->wait_list; 1960 while (*expr_list) 1961 expr_list = &(*expr_list)->next; 1962 *expr_list = gfc_get_expr_list (); 1963 (*expr_list)->expr = expr; 1964 needs_space = true; 1965 } 1966 continue; 1967 } 1968 if ((mask & OMP_CLAUSE_WORKER) 1969 && !c->worker 1970 && gfc_match ("worker") == MATCH_YES) 1971 { 1972 c->worker = true; 1973 match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER); 1974 if (m == MATCH_ERROR) 1975 { 1976 gfc_current_locus = old_loc; 1977 break; 1978 } 1979 else if (m == MATCH_NO) 1980 needs_space = true; 1981 continue; 1982 } 1983 break; 1984 } 1985 break; 1986 } 1987 1988 if (gfc_match_omp_eos () != MATCH_YES) 1989 { 1990 if (!gfc_error_flag_test ()) 1991 gfc_error ("Failed to match clause at %C"); 1992 gfc_free_omp_clauses (c); 1993 return MATCH_ERROR; 1994 } 1995 1996 *cp = c; 1997 return MATCH_YES; 1998} 1999 2000 2001#define OACC_PARALLEL_CLAUSES \ 2002 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ 2003 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \ 2004 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2005 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ 2006 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ 2007 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) 2008#define OACC_KERNELS_CLAUSES \ 2009 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ 2010 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ 2011 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2012 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ 2013 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) 2014#define OACC_SERIAL_CLAUSES \ 2015 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \ 2016 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2017 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ 2018 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ 2019 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) 2020#define OACC_DATA_CLAUSES \ 2021 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ 2022 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ 2023 | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH) 2024#define OACC_LOOP_CLAUSES \ 2025 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ 2026 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ 2027 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ 2028 | OMP_CLAUSE_TILE) 2029#define OACC_PARALLEL_LOOP_CLAUSES \ 2030 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) 2031#define OACC_KERNELS_LOOP_CLAUSES \ 2032 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) 2033#define OACC_SERIAL_LOOP_CLAUSES \ 2034 (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES) 2035#define OACC_HOST_DATA_CLAUSES \ 2036 (omp_mask (OMP_CLAUSE_USE_DEVICE) \ 2037 | OMP_CLAUSE_IF \ 2038 | OMP_CLAUSE_IF_PRESENT) 2039#define OACC_DECLARE_CLAUSES \ 2040 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2041 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ 2042 | OMP_CLAUSE_PRESENT \ 2043 | OMP_CLAUSE_LINK) 2044#define OACC_UPDATE_CLAUSES \ 2045 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ 2046 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) 2047#define OACC_ENTER_DATA_CLAUSES \ 2048 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ 2049 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH) 2050#define OACC_EXIT_DATA_CLAUSES \ 2051 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ 2052 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ 2053 | OMP_CLAUSE_DETACH) 2054#define OACC_WAIT_CLAUSES \ 2055 omp_mask (OMP_CLAUSE_ASYNC) 2056#define OACC_ROUTINE_CLAUSES \ 2057 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ 2058 | OMP_CLAUSE_SEQ) 2059 2060 2061static match 2062match_acc (gfc_exec_op op, const omp_mask mask) 2063{ 2064 gfc_omp_clauses *c; 2065 if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES) 2066 return MATCH_ERROR; 2067 new_st.op = op; 2068 new_st.ext.omp_clauses = c; 2069 return MATCH_YES; 2070} 2071 2072match 2073gfc_match_oacc_parallel_loop (void) 2074{ 2075 return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES); 2076} 2077 2078 2079match 2080gfc_match_oacc_parallel (void) 2081{ 2082 return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES); 2083} 2084 2085 2086match 2087gfc_match_oacc_kernels_loop (void) 2088{ 2089 return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES); 2090} 2091 2092 2093match 2094gfc_match_oacc_kernels (void) 2095{ 2096 return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES); 2097} 2098 2099 2100match 2101gfc_match_oacc_serial_loop (void) 2102{ 2103 return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES); 2104} 2105 2106 2107match 2108gfc_match_oacc_serial (void) 2109{ 2110 return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES); 2111} 2112 2113 2114match 2115gfc_match_oacc_data (void) 2116{ 2117 return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES); 2118} 2119 2120 2121match 2122gfc_match_oacc_host_data (void) 2123{ 2124 return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES); 2125} 2126 2127 2128match 2129gfc_match_oacc_loop (void) 2130{ 2131 return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES); 2132} 2133 2134 2135match 2136gfc_match_oacc_declare (void) 2137{ 2138 gfc_omp_clauses *c; 2139 gfc_omp_namelist *n; 2140 gfc_namespace *ns = gfc_current_ns; 2141 gfc_oacc_declare *new_oc; 2142 bool module_var = false; 2143 locus where = gfc_current_locus; 2144 2145 if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true) 2146 != MATCH_YES) 2147 return MATCH_ERROR; 2148 2149 for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next) 2150 n->sym->attr.oacc_declare_device_resident = 1; 2151 2152 for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next) 2153 n->sym->attr.oacc_declare_link = 1; 2154 2155 for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next) 2156 { 2157 gfc_symbol *s = n->sym; 2158 2159 if (gfc_current_ns->proc_name 2160 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) 2161 { 2162 if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO) 2163 { 2164 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L", 2165 &where); 2166 return MATCH_ERROR; 2167 } 2168 2169 module_var = true; 2170 } 2171 2172 if (s->attr.use_assoc) 2173 { 2174 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L", 2175 &where); 2176 return MATCH_ERROR; 2177 } 2178 2179 if ((s->result == s && s->ns->contained != gfc_current_ns) 2180 || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE) 2181 && s->ns != gfc_current_ns)) 2182 { 2183 gfc_error ("Variable %qs shall be declared in the same scoping unit " 2184 "as !$ACC DECLARE at %L", s->name, &where); 2185 return MATCH_ERROR; 2186 } 2187 2188 if ((s->attr.dimension || s->attr.codimension) 2189 && s->attr.dummy && s->as->type != AS_EXPLICIT) 2190 { 2191 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L", 2192 &where); 2193 return MATCH_ERROR; 2194 } 2195 2196 switch (n->u.map_op) 2197 { 2198 case OMP_MAP_FORCE_ALLOC: 2199 case OMP_MAP_ALLOC: 2200 s->attr.oacc_declare_create = 1; 2201 break; 2202 2203 case OMP_MAP_FORCE_TO: 2204 case OMP_MAP_TO: 2205 s->attr.oacc_declare_copyin = 1; 2206 break; 2207 2208 case OMP_MAP_FORCE_DEVICEPTR: 2209 s->attr.oacc_declare_deviceptr = 1; 2210 break; 2211 2212 default: 2213 break; 2214 } 2215 } 2216 2217 new_oc = gfc_get_oacc_declare (); 2218 new_oc->next = ns->oacc_declare; 2219 new_oc->module_var = module_var; 2220 new_oc->clauses = c; 2221 new_oc->loc = gfc_current_locus; 2222 ns->oacc_declare = new_oc; 2223 2224 return MATCH_YES; 2225} 2226 2227 2228match 2229gfc_match_oacc_update (void) 2230{ 2231 gfc_omp_clauses *c; 2232 locus here = gfc_current_locus; 2233 2234 if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) 2235 != MATCH_YES) 2236 return MATCH_ERROR; 2237 2238 if (!c->lists[OMP_LIST_MAP]) 2239 { 2240 gfc_error ("%<acc update%> must contain at least one " 2241 "%<device%> or %<host%> or %<self%> clause at %L", &here); 2242 return MATCH_ERROR; 2243 } 2244 2245 new_st.op = EXEC_OACC_UPDATE; 2246 new_st.ext.omp_clauses = c; 2247 return MATCH_YES; 2248} 2249 2250 2251match 2252gfc_match_oacc_enter_data (void) 2253{ 2254 return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES); 2255} 2256 2257 2258match 2259gfc_match_oacc_exit_data (void) 2260{ 2261 return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES); 2262} 2263 2264 2265match 2266gfc_match_oacc_wait (void) 2267{ 2268 gfc_omp_clauses *c = gfc_get_omp_clauses (); 2269 gfc_expr_list *wait_list = NULL, *el; 2270 bool space = true; 2271 match m; 2272 2273 m = match_oacc_expr_list (" (", &wait_list, true); 2274 if (m == MATCH_ERROR) 2275 return m; 2276 else if (m == MATCH_YES) 2277 space = false; 2278 2279 if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true) 2280 == MATCH_ERROR) 2281 return MATCH_ERROR; 2282 2283 if (wait_list) 2284 for (el = wait_list; el; el = el->next) 2285 { 2286 if (el->expr == NULL) 2287 { 2288 gfc_error ("Invalid argument to !$ACC WAIT at %C"); 2289 return MATCH_ERROR; 2290 } 2291 2292 if (!gfc_resolve_expr (el->expr) 2293 || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0) 2294 { 2295 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression", 2296 &el->expr->where); 2297 2298 return MATCH_ERROR; 2299 } 2300 } 2301 c->wait_list = wait_list; 2302 new_st.op = EXEC_OACC_WAIT; 2303 new_st.ext.omp_clauses = c; 2304 return MATCH_YES; 2305} 2306 2307 2308match 2309gfc_match_oacc_cache (void) 2310{ 2311 gfc_omp_clauses *c = gfc_get_omp_clauses (); 2312 /* The OpenACC cache directive explicitly only allows "array elements or 2313 subarrays", which we're currently not checking here. Either check this 2314 after the call of gfc_match_omp_variable_list, or add something like a 2315 only_sections variant next to its allow_sections parameter. */ 2316 match m = gfc_match_omp_variable_list (" (", 2317 &c->lists[OMP_LIST_CACHE], true, 2318 NULL, NULL, true); 2319 if (m != MATCH_YES) 2320 { 2321 gfc_free_omp_clauses(c); 2322 return m; 2323 } 2324 2325 if (gfc_current_state() != COMP_DO 2326 && gfc_current_state() != COMP_DO_CONCURRENT) 2327 { 2328 gfc_error ("ACC CACHE directive must be inside of loop %C"); 2329 gfc_free_omp_clauses(c); 2330 return MATCH_ERROR; 2331 } 2332 2333 new_st.op = EXEC_OACC_CACHE; 2334 new_st.ext.omp_clauses = c; 2335 return MATCH_YES; 2336} 2337 2338/* Determine the OpenACC 'routine' directive's level of parallelism. */ 2339 2340static oacc_routine_lop 2341gfc_oacc_routine_lop (gfc_omp_clauses *clauses) 2342{ 2343 oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ; 2344 2345 if (clauses) 2346 { 2347 unsigned n_lop_clauses = 0; 2348 2349 if (clauses->gang) 2350 { 2351 ++n_lop_clauses; 2352 ret = OACC_ROUTINE_LOP_GANG; 2353 } 2354 if (clauses->worker) 2355 { 2356 ++n_lop_clauses; 2357 ret = OACC_ROUTINE_LOP_WORKER; 2358 } 2359 if (clauses->vector) 2360 { 2361 ++n_lop_clauses; 2362 ret = OACC_ROUTINE_LOP_VECTOR; 2363 } 2364 if (clauses->seq) 2365 { 2366 ++n_lop_clauses; 2367 ret = OACC_ROUTINE_LOP_SEQ; 2368 } 2369 2370 if (n_lop_clauses > 1) 2371 ret = OACC_ROUTINE_LOP_ERROR; 2372 } 2373 2374 return ret; 2375} 2376 2377match 2378gfc_match_oacc_routine (void) 2379{ 2380 locus old_loc; 2381 match m; 2382 gfc_intrinsic_sym *isym = NULL; 2383 gfc_symbol *sym = NULL; 2384 gfc_omp_clauses *c = NULL; 2385 gfc_oacc_routine_name *n = NULL; 2386 oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; 2387 2388 old_loc = gfc_current_locus; 2389 2390 m = gfc_match (" ("); 2391 2392 if (gfc_current_ns->proc_name 2393 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY 2394 && m == MATCH_YES) 2395 { 2396 gfc_error ("Only the !$ACC ROUTINE form without " 2397 "list is allowed in interface block at %C"); 2398 goto cleanup; 2399 } 2400 2401 if (m == MATCH_YES) 2402 { 2403 char buffer[GFC_MAX_SYMBOL_LEN + 1]; 2404 2405 m = gfc_match_name (buffer); 2406 if (m == MATCH_YES) 2407 { 2408 gfc_symtree *st = NULL; 2409 2410 /* First look for an intrinsic symbol. */ 2411 isym = gfc_find_function (buffer); 2412 if (!isym) 2413 isym = gfc_find_subroutine (buffer); 2414 /* If no intrinsic symbol found, search the current namespace. */ 2415 if (!isym) 2416 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); 2417 if (st) 2418 { 2419 sym = st->n.sym; 2420 /* If the name in a 'routine' directive refers to the containing 2421 subroutine or function, then make sure that we'll later handle 2422 this accordingly. */ 2423 if (gfc_current_ns->proc_name != NULL 2424 && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) 2425 sym = NULL; 2426 } 2427 2428 if (isym == NULL && st == NULL) 2429 { 2430 gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C", 2431 buffer); 2432 gfc_current_locus = old_loc; 2433 return MATCH_ERROR; 2434 } 2435 } 2436 else 2437 { 2438 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); 2439 gfc_current_locus = old_loc; 2440 return MATCH_ERROR; 2441 } 2442 2443 if (gfc_match_char (')') != MATCH_YES) 2444 { 2445 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" 2446 " ')' after NAME"); 2447 gfc_current_locus = old_loc; 2448 return MATCH_ERROR; 2449 } 2450 } 2451 2452 if (gfc_match_omp_eos () != MATCH_YES 2453 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true) 2454 != MATCH_YES)) 2455 return MATCH_ERROR; 2456 2457 lop = gfc_oacc_routine_lop (c); 2458 if (lop == OACC_ROUTINE_LOP_ERROR) 2459 { 2460 gfc_error ("Multiple loop axes specified for routine at %C"); 2461 goto cleanup; 2462 } 2463 2464 if (isym != NULL) 2465 { 2466 /* Diagnose any OpenACC 'routine' directive that doesn't match the 2467 (implicit) one with a 'seq' clause. */ 2468 if (c && (c->gang || c->worker || c->vector)) 2469 { 2470 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" 2471 " at %C marked with incompatible GANG, WORKER, or VECTOR" 2472 " clause"); 2473 goto cleanup; 2474 } 2475 } 2476 else if (sym != NULL) 2477 { 2478 bool add = true; 2479 2480 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't 2481 match the first one. */ 2482 for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names; 2483 n_p; 2484 n_p = n_p->next) 2485 if (n_p->sym == sym) 2486 { 2487 add = false; 2488 if (lop != gfc_oacc_routine_lop (n_p->clauses)) 2489 { 2490 gfc_error ("!$ACC ROUTINE already applied at %C"); 2491 goto cleanup; 2492 } 2493 } 2494 2495 if (add) 2496 { 2497 sym->attr.oacc_routine_lop = lop; 2498 2499 n = gfc_get_oacc_routine_name (); 2500 n->sym = sym; 2501 n->clauses = c; 2502 n->next = gfc_current_ns->oacc_routine_names; 2503 n->loc = old_loc; 2504 gfc_current_ns->oacc_routine_names = n; 2505 } 2506 } 2507 else if (gfc_current_ns->proc_name) 2508 { 2509 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't 2510 match the first one. */ 2511 oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; 2512 if (lop_p != OACC_ROUTINE_LOP_NONE 2513 && lop != lop_p) 2514 { 2515 gfc_error ("!$ACC ROUTINE already applied at %C"); 2516 goto cleanup; 2517 } 2518 2519 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, 2520 gfc_current_ns->proc_name->name, 2521 &old_loc)) 2522 goto cleanup; 2523 gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; 2524 } 2525 else 2526 /* Something has gone wrong, possibly a syntax error. */ 2527 goto cleanup; 2528 2529 if (n) 2530 n->clauses = c; 2531 else if (gfc_current_ns->oacc_routine) 2532 gfc_current_ns->oacc_routine_clauses = c; 2533 2534 new_st.op = EXEC_OACC_ROUTINE; 2535 new_st.ext.omp_clauses = c; 2536 return MATCH_YES; 2537 2538cleanup: 2539 gfc_current_locus = old_loc; 2540 return MATCH_ERROR; 2541} 2542 2543 2544#define OMP_PARALLEL_CLAUSES \ 2545 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2546 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \ 2547 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \ 2548 | OMP_CLAUSE_PROC_BIND) 2549#define OMP_DECLARE_SIMD_CLAUSES \ 2550 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \ 2551 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \ 2552 | OMP_CLAUSE_NOTINBRANCH) 2553#define OMP_DO_CLAUSES \ 2554 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2555 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ 2556 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ 2557 | OMP_CLAUSE_LINEAR) 2558#define OMP_SECTIONS_CLAUSES \ 2559 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2560 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) 2561#define OMP_SIMD_CLAUSES \ 2562 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \ 2563 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \ 2564 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN) 2565#define OMP_TASK_CLAUSES \ 2566 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2567 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ 2568 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ 2569 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY) 2570#define OMP_TASKLOOP_CLAUSES \ 2571 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2572 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ 2573 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ 2574 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ 2575 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP) 2576#define OMP_TARGET_CLAUSES \ 2577 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2578 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ 2579 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ 2580 | OMP_CLAUSE_IS_DEVICE_PTR) 2581#define OMP_TARGET_DATA_CLAUSES \ 2582 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2583 | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) 2584#define OMP_TARGET_ENTER_DATA_CLAUSES \ 2585 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2586 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) 2587#define OMP_TARGET_EXIT_DATA_CLAUSES \ 2588 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2589 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) 2590#define OMP_TARGET_UPDATE_CLAUSES \ 2591 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \ 2592 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) 2593#define OMP_TEAMS_CLAUSES \ 2594 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ 2595 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ 2596 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION) 2597#define OMP_DISTRIBUTE_CLAUSES \ 2598 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2599 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE) 2600#define OMP_SINGLE_CLAUSES \ 2601 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE) 2602#define OMP_ORDERED_CLAUSES \ 2603 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) 2604#define OMP_DECLARE_TARGET_CLAUSES \ 2605 (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK) 2606 2607 2608static match 2609match_omp (gfc_exec_op op, const omp_mask mask) 2610{ 2611 gfc_omp_clauses *c; 2612 if (gfc_match_omp_clauses (&c, mask) != MATCH_YES) 2613 return MATCH_ERROR; 2614 new_st.op = op; 2615 new_st.ext.omp_clauses = c; 2616 return MATCH_YES; 2617} 2618 2619 2620match 2621gfc_match_omp_critical (void) 2622{ 2623 char n[GFC_MAX_SYMBOL_LEN+1]; 2624 gfc_omp_clauses *c = NULL; 2625 2626 if (gfc_match (" ( %n )", n) != MATCH_YES) 2627 { 2628 n[0] = '\0'; 2629 if (gfc_match_omp_eos () != MATCH_YES) 2630 { 2631 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); 2632 return MATCH_ERROR; 2633 } 2634 } 2635 else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES) 2636 return MATCH_ERROR; 2637 2638 new_st.op = EXEC_OMP_CRITICAL; 2639 new_st.ext.omp_clauses = c; 2640 if (n[0]) 2641 c->critical_name = xstrdup (n); 2642 return MATCH_YES; 2643} 2644 2645 2646match 2647gfc_match_omp_end_critical (void) 2648{ 2649 char n[GFC_MAX_SYMBOL_LEN+1]; 2650 2651 if (gfc_match (" ( %n )", n) != MATCH_YES) 2652 n[0] = '\0'; 2653 if (gfc_match_omp_eos () != MATCH_YES) 2654 { 2655 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); 2656 return MATCH_ERROR; 2657 } 2658 2659 new_st.op = EXEC_OMP_END_CRITICAL; 2660 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; 2661 return MATCH_YES; 2662} 2663 2664 2665match 2666gfc_match_omp_distribute (void) 2667{ 2668 return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES); 2669} 2670 2671 2672match 2673gfc_match_omp_distribute_parallel_do (void) 2674{ 2675 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO, 2676 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES 2677 | OMP_DO_CLAUSES) 2678 & ~(omp_mask (OMP_CLAUSE_ORDERED)) 2679 & ~(omp_mask (OMP_CLAUSE_LINEAR))); 2680} 2681 2682 2683match 2684gfc_match_omp_distribute_parallel_do_simd (void) 2685{ 2686 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD, 2687 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES 2688 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) 2689 & ~(omp_mask (OMP_CLAUSE_ORDERED))); 2690} 2691 2692 2693match 2694gfc_match_omp_distribute_simd (void) 2695{ 2696 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD, 2697 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); 2698} 2699 2700 2701match 2702gfc_match_omp_do (void) 2703{ 2704 return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES); 2705} 2706 2707 2708match 2709gfc_match_omp_do_simd (void) 2710{ 2711 return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); 2712} 2713 2714 2715match 2716gfc_match_omp_flush (void) 2717{ 2718 gfc_omp_namelist *list = NULL; 2719 gfc_match_omp_variable_list (" (", &list, true); 2720 if (gfc_match_omp_eos () != MATCH_YES) 2721 { 2722 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); 2723 gfc_free_omp_namelist (list); 2724 return MATCH_ERROR; 2725 } 2726 new_st.op = EXEC_OMP_FLUSH; 2727 new_st.ext.omp_namelist = list; 2728 return MATCH_YES; 2729} 2730 2731 2732match 2733gfc_match_omp_declare_simd (void) 2734{ 2735 locus where = gfc_current_locus; 2736 gfc_symbol *proc_name; 2737 gfc_omp_clauses *c; 2738 gfc_omp_declare_simd *ods; 2739 bool needs_space = false; 2740 2741 switch (gfc_match (" ( %s ) ", &proc_name)) 2742 { 2743 case MATCH_YES: break; 2744 case MATCH_NO: proc_name = NULL; needs_space = true; break; 2745 case MATCH_ERROR: return MATCH_ERROR; 2746 } 2747 2748 if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true, 2749 needs_space) != MATCH_YES) 2750 return MATCH_ERROR; 2751 2752 if (gfc_current_ns->is_block_data) 2753 { 2754 gfc_free_omp_clauses (c); 2755 return MATCH_YES; 2756 } 2757 2758 ods = gfc_get_omp_declare_simd (); 2759 ods->where = where; 2760 ods->proc_name = proc_name; 2761 ods->clauses = c; 2762 ods->next = gfc_current_ns->omp_declare_simd; 2763 gfc_current_ns->omp_declare_simd = ods; 2764 return MATCH_YES; 2765} 2766 2767 2768static bool 2769match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) 2770{ 2771 match m; 2772 locus old_loc = gfc_current_locus; 2773 char sname[GFC_MAX_SYMBOL_LEN + 1]; 2774 gfc_symbol *sym; 2775 gfc_namespace *ns = gfc_current_ns; 2776 gfc_expr *lvalue = NULL, *rvalue = NULL; 2777 gfc_symtree *st; 2778 gfc_actual_arglist *arglist; 2779 2780 m = gfc_match (" %v =", &lvalue); 2781 if (m != MATCH_YES) 2782 gfc_current_locus = old_loc; 2783 else 2784 { 2785 m = gfc_match (" %e )", &rvalue); 2786 if (m == MATCH_YES) 2787 { 2788 ns->code = gfc_get_code (EXEC_ASSIGN); 2789 ns->code->expr1 = lvalue; 2790 ns->code->expr2 = rvalue; 2791 ns->code->loc = old_loc; 2792 return true; 2793 } 2794 2795 gfc_current_locus = old_loc; 2796 gfc_free_expr (lvalue); 2797 } 2798 2799 m = gfc_match (" %n", sname); 2800 if (m != MATCH_YES) 2801 return false; 2802 2803 if (strcmp (sname, omp_sym1->name) == 0 2804 || strcmp (sname, omp_sym2->name) == 0) 2805 return false; 2806 2807 gfc_current_ns = ns->parent; 2808 if (gfc_get_ha_sym_tree (sname, &st)) 2809 return false; 2810 2811 sym = st->n.sym; 2812 if (sym->attr.flavor != FL_PROCEDURE 2813 && sym->attr.flavor != FL_UNKNOWN) 2814 return false; 2815 2816 if (!sym->attr.generic 2817 && !sym->attr.subroutine 2818 && !sym->attr.function) 2819 { 2820 if (!(sym->attr.external && !sym->attr.referenced)) 2821 { 2822 /* ...create a symbol in this scope... */ 2823 if (sym->ns != gfc_current_ns 2824 && gfc_get_sym_tree (sname, NULL, &st, false) == 1) 2825 return false; 2826 2827 if (sym != st->n.sym) 2828 sym = st->n.sym; 2829 } 2830 2831 /* ...and then to try to make the symbol into a subroutine. */ 2832 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) 2833 return false; 2834 } 2835 2836 gfc_set_sym_referenced (sym); 2837 gfc_gobble_whitespace (); 2838 if (gfc_peek_ascii_char () != '(') 2839 return false; 2840 2841 gfc_current_ns = ns; 2842 m = gfc_match_actual_arglist (1, &arglist); 2843 if (m != MATCH_YES) 2844 return false; 2845 2846 if (gfc_match_char (')') != MATCH_YES) 2847 return false; 2848 2849 ns->code = gfc_get_code (EXEC_CALL); 2850 ns->code->symtree = st; 2851 ns->code->ext.actual = arglist; 2852 ns->code->loc = old_loc; 2853 return true; 2854} 2855 2856static bool 2857gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name, 2858 gfc_typespec *ts, const char **n) 2859{ 2860 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL) 2861 return false; 2862 2863 switch (rop) 2864 { 2865 case OMP_REDUCTION_PLUS: 2866 case OMP_REDUCTION_MINUS: 2867 case OMP_REDUCTION_TIMES: 2868 return ts->type != BT_LOGICAL; 2869 case OMP_REDUCTION_AND: 2870 case OMP_REDUCTION_OR: 2871 case OMP_REDUCTION_EQV: 2872 case OMP_REDUCTION_NEQV: 2873 return ts->type == BT_LOGICAL; 2874 case OMP_REDUCTION_USER: 2875 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL)) 2876 { 2877 gfc_symbol *sym; 2878 2879 gfc_find_symbol (name, NULL, 1, &sym); 2880 if (sym != NULL) 2881 { 2882 if (sym->attr.intrinsic) 2883 *n = sym->name; 2884 else if ((sym->attr.flavor != FL_UNKNOWN 2885 && sym->attr.flavor != FL_PROCEDURE) 2886 || sym->attr.external 2887 || sym->attr.generic 2888 || sym->attr.entry 2889 || sym->attr.result 2890 || sym->attr.dummy 2891 || sym->attr.subroutine 2892 || sym->attr.pointer 2893 || sym->attr.target 2894 || sym->attr.cray_pointer 2895 || sym->attr.cray_pointee 2896 || (sym->attr.proc != PROC_UNKNOWN 2897 && sym->attr.proc != PROC_INTRINSIC) 2898 || sym->attr.if_source != IFSRC_UNKNOWN 2899 || sym == sym->ns->proc_name) 2900 *n = NULL; 2901 else 2902 *n = sym->name; 2903 } 2904 else 2905 *n = name; 2906 if (*n 2907 && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0)) 2908 return true; 2909 else if (*n 2910 && ts->type == BT_INTEGER 2911 && (strcmp (*n, "iand") == 0 2912 || strcmp (*n, "ior") == 0 2913 || strcmp (*n, "ieor") == 0)) 2914 return true; 2915 } 2916 break; 2917 default: 2918 break; 2919 } 2920 return false; 2921} 2922 2923gfc_omp_udr * 2924gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts) 2925{ 2926 gfc_omp_udr *omp_udr; 2927 2928 if (st == NULL) 2929 return NULL; 2930 2931 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) 2932 if (omp_udr->ts.type == ts->type 2933 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) 2934 && (ts->type == BT_DERIVED || ts->type == BT_CLASS))) 2935 { 2936 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) 2937 { 2938 if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0) 2939 return omp_udr; 2940 } 2941 else if (omp_udr->ts.kind == ts->kind) 2942 { 2943 if (omp_udr->ts.type == BT_CHARACTER) 2944 { 2945 if (omp_udr->ts.u.cl->length == NULL 2946 || ts->u.cl->length == NULL) 2947 return omp_udr; 2948 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) 2949 return omp_udr; 2950 if (ts->u.cl->length->expr_type != EXPR_CONSTANT) 2951 return omp_udr; 2952 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER) 2953 return omp_udr; 2954 if (ts->u.cl->length->ts.type != BT_INTEGER) 2955 return omp_udr; 2956 if (gfc_compare_expr (omp_udr->ts.u.cl->length, 2957 ts->u.cl->length, INTRINSIC_EQ) != 0) 2958 continue; 2959 } 2960 return omp_udr; 2961 } 2962 } 2963 return NULL; 2964} 2965 2966match 2967gfc_match_omp_declare_reduction (void) 2968{ 2969 match m; 2970 gfc_intrinsic_op op; 2971 char name[GFC_MAX_SYMBOL_LEN + 3]; 2972 auto_vec<gfc_typespec, 5> tss; 2973 gfc_typespec ts; 2974 unsigned int i; 2975 gfc_symtree *st; 2976 locus where = gfc_current_locus; 2977 locus end_loc = gfc_current_locus; 2978 bool end_loc_set = false; 2979 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; 2980 2981 if (gfc_match_char ('(') != MATCH_YES) 2982 return MATCH_ERROR; 2983 2984 m = gfc_match (" %o : ", &op); 2985 if (m == MATCH_ERROR) 2986 return MATCH_ERROR; 2987 if (m == MATCH_YES) 2988 { 2989 snprintf (name, sizeof name, "operator %s", gfc_op2string (op)); 2990 rop = (gfc_omp_reduction_op) op; 2991 } 2992 else 2993 { 2994 m = gfc_match_defined_op_name (name + 1, 1); 2995 if (m == MATCH_ERROR) 2996 return MATCH_ERROR; 2997 if (m == MATCH_YES) 2998 { 2999 name[0] = '.'; 3000 strcat (name, "."); 3001 if (gfc_match (" : ") != MATCH_YES) 3002 return MATCH_ERROR; 3003 } 3004 else 3005 { 3006 if (gfc_match (" %n : ", name) != MATCH_YES) 3007 return MATCH_ERROR; 3008 } 3009 rop = OMP_REDUCTION_USER; 3010 } 3011 3012 m = gfc_match_type_spec (&ts); 3013 if (m != MATCH_YES) 3014 return MATCH_ERROR; 3015 /* Treat len=: the same as len=*. */ 3016 if (ts.type == BT_CHARACTER) 3017 ts.deferred = false; 3018 tss.safe_push (ts); 3019 3020 while (gfc_match_char (',') == MATCH_YES) 3021 { 3022 m = gfc_match_type_spec (&ts); 3023 if (m != MATCH_YES) 3024 return MATCH_ERROR; 3025 tss.safe_push (ts); 3026 } 3027 if (gfc_match_char (':') != MATCH_YES) 3028 return MATCH_ERROR; 3029 3030 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); 3031 for (i = 0; i < tss.length (); i++) 3032 { 3033 gfc_symtree *omp_out, *omp_in; 3034 gfc_symtree *omp_priv = NULL, *omp_orig = NULL; 3035 gfc_namespace *combiner_ns, *initializer_ns = NULL; 3036 gfc_omp_udr *prev_udr, *omp_udr; 3037 const char *predef_name = NULL; 3038 3039 omp_udr = gfc_get_omp_udr (); 3040 omp_udr->name = gfc_get_string ("%s", name); 3041 omp_udr->rop = rop; 3042 omp_udr->ts = tss[i]; 3043 omp_udr->where = where; 3044 3045 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1); 3046 combiner_ns->proc_name = combiner_ns->parent->proc_name; 3047 3048 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false); 3049 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false); 3050 combiner_ns->omp_udr_ns = 1; 3051 omp_out->n.sym->ts = tss[i]; 3052 omp_in->n.sym->ts = tss[i]; 3053 omp_out->n.sym->attr.omp_udr_artificial_var = 1; 3054 omp_in->n.sym->attr.omp_udr_artificial_var = 1; 3055 omp_out->n.sym->attr.flavor = FL_VARIABLE; 3056 omp_in->n.sym->attr.flavor = FL_VARIABLE; 3057 gfc_commit_symbols (); 3058 omp_udr->combiner_ns = combiner_ns; 3059 omp_udr->omp_out = omp_out->n.sym; 3060 omp_udr->omp_in = omp_in->n.sym; 3061 3062 locus old_loc = gfc_current_locus; 3063 3064 if (!match_udr_expr (omp_out, omp_in)) 3065 { 3066 syntax: 3067 gfc_current_locus = old_loc; 3068 gfc_current_ns = combiner_ns->parent; 3069 gfc_undo_symbols (); 3070 gfc_free_omp_udr (omp_udr); 3071 return MATCH_ERROR; 3072 } 3073 3074 if (gfc_match (" initializer ( ") == MATCH_YES) 3075 { 3076 gfc_current_ns = combiner_ns->parent; 3077 initializer_ns = gfc_get_namespace (gfc_current_ns, 1); 3078 gfc_current_ns = initializer_ns; 3079 initializer_ns->proc_name = initializer_ns->parent->proc_name; 3080 3081 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false); 3082 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false); 3083 initializer_ns->omp_udr_ns = 1; 3084 omp_priv->n.sym->ts = tss[i]; 3085 omp_orig->n.sym->ts = tss[i]; 3086 omp_priv->n.sym->attr.omp_udr_artificial_var = 1; 3087 omp_orig->n.sym->attr.omp_udr_artificial_var = 1; 3088 omp_priv->n.sym->attr.flavor = FL_VARIABLE; 3089 omp_orig->n.sym->attr.flavor = FL_VARIABLE; 3090 gfc_commit_symbols (); 3091 omp_udr->initializer_ns = initializer_ns; 3092 omp_udr->omp_priv = omp_priv->n.sym; 3093 omp_udr->omp_orig = omp_orig->n.sym; 3094 3095 if (!match_udr_expr (omp_priv, omp_orig)) 3096 goto syntax; 3097 } 3098 3099 gfc_current_ns = combiner_ns->parent; 3100 if (!end_loc_set) 3101 { 3102 end_loc_set = true; 3103 end_loc = gfc_current_locus; 3104 } 3105 gfc_current_locus = old_loc; 3106 3107 prev_udr = gfc_omp_udr_find (st, &tss[i]); 3108 if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name) 3109 /* Don't error on !$omp declare reduction (min : integer : ...) 3110 just yet, there could be integer :: min afterwards, 3111 making it valid. When the UDR is resolved, we'll get 3112 to it again. */ 3113 && (rop != OMP_REDUCTION_USER || name[0] == '.')) 3114 { 3115 if (predef_name) 3116 gfc_error_now ("Redefinition of predefined %s " 3117 "!$OMP DECLARE REDUCTION at %L", 3118 predef_name, &where); 3119 else 3120 gfc_error_now ("Redefinition of predefined " 3121 "!$OMP DECLARE REDUCTION at %L", &where); 3122 } 3123 else if (prev_udr) 3124 { 3125 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L", 3126 &where); 3127 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L", 3128 &prev_udr->where); 3129 } 3130 else if (st) 3131 { 3132 omp_udr->next = st->n.omp_udr; 3133 st->n.omp_udr = omp_udr; 3134 } 3135 else 3136 { 3137 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); 3138 st->n.omp_udr = omp_udr; 3139 } 3140 } 3141 3142 if (end_loc_set) 3143 { 3144 gfc_current_locus = end_loc; 3145 if (gfc_match_omp_eos () != MATCH_YES) 3146 { 3147 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C"); 3148 gfc_current_locus = where; 3149 return MATCH_ERROR; 3150 } 3151 3152 return MATCH_YES; 3153 } 3154 gfc_clear_error (); 3155 return MATCH_ERROR; 3156} 3157 3158 3159match 3160gfc_match_omp_declare_target (void) 3161{ 3162 locus old_loc; 3163 match m; 3164 gfc_omp_clauses *c = NULL; 3165 int list; 3166 gfc_omp_namelist *n; 3167 gfc_symbol *s; 3168 3169 old_loc = gfc_current_locus; 3170 3171 if (gfc_current_ns->proc_name 3172 && gfc_match_omp_eos () == MATCH_YES) 3173 { 3174 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, 3175 gfc_current_ns->proc_name->name, 3176 &old_loc)) 3177 goto cleanup; 3178 return MATCH_YES; 3179 } 3180 3181 if (gfc_current_ns->proc_name 3182 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) 3183 { 3184 gfc_error ("Only the !$OMP DECLARE TARGET form without " 3185 "clauses is allowed in interface block at %C"); 3186 goto cleanup; 3187 } 3188 3189 m = gfc_match (" ("); 3190 if (m == MATCH_YES) 3191 { 3192 c = gfc_get_omp_clauses (); 3193 gfc_current_locus = old_loc; 3194 m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]); 3195 if (m != MATCH_YES) 3196 goto syntax; 3197 if (gfc_match_omp_eos () != MATCH_YES) 3198 { 3199 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C"); 3200 goto cleanup; 3201 } 3202 } 3203 else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES) 3204 return MATCH_ERROR; 3205 3206 gfc_buffer_error (false); 3207 3208 for (list = OMP_LIST_TO; list != OMP_LIST_NUM; 3209 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) 3210 for (n = c->lists[list]; n; n = n->next) 3211 if (n->sym) 3212 n->sym->mark = 0; 3213 else if (n->u.common->head) 3214 n->u.common->head->mark = 0; 3215 3216 for (list = OMP_LIST_TO; list != OMP_LIST_NUM; 3217 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) 3218 for (n = c->lists[list]; n; n = n->next) 3219 if (n->sym) 3220 { 3221 if (n->sym->attr.in_common) 3222 gfc_error_now ("OMP DECLARE TARGET variable at %L is an " 3223 "element of a COMMON block", &n->where); 3224 else if (n->sym->attr.omp_declare_target 3225 && n->sym->attr.omp_declare_target_link 3226 && list != OMP_LIST_LINK) 3227 gfc_error_now ("OMP DECLARE TARGET variable at %L previously " 3228 "mentioned in LINK clause and later in TO clause", 3229 &n->where); 3230 else if (n->sym->attr.omp_declare_target 3231 && !n->sym->attr.omp_declare_target_link 3232 && list == OMP_LIST_LINK) 3233 gfc_error_now ("OMP DECLARE TARGET variable at %L previously " 3234 "mentioned in TO clause and later in LINK clause", 3235 &n->where); 3236 else if (n->sym->mark) 3237 gfc_error_now ("Variable at %L mentioned multiple times in " 3238 "clauses of the same OMP DECLARE TARGET directive", 3239 &n->where); 3240 else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, 3241 &n->sym->declared_at)) 3242 { 3243 if (list == OMP_LIST_LINK) 3244 gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, 3245 &n->sym->declared_at); 3246 } 3247 n->sym->mark = 1; 3248 } 3249 else if (n->u.common->omp_declare_target 3250 && n->u.common->omp_declare_target_link 3251 && list != OMP_LIST_LINK) 3252 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " 3253 "mentioned in LINK clause and later in TO clause", 3254 &n->where); 3255 else if (n->u.common->omp_declare_target 3256 && !n->u.common->omp_declare_target_link 3257 && list == OMP_LIST_LINK) 3258 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " 3259 "mentioned in TO clause and later in LINK clause", 3260 &n->where); 3261 else if (n->u.common->head && n->u.common->head->mark) 3262 gfc_error_now ("COMMON at %L mentioned multiple times in " 3263 "clauses of the same OMP DECLARE TARGET directive", 3264 &n->where); 3265 else 3266 { 3267 n->u.common->omp_declare_target = 1; 3268 n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); 3269 for (s = n->u.common->head; s; s = s->common_next) 3270 { 3271 s->mark = 1; 3272 if (gfc_add_omp_declare_target (&s->attr, s->name, 3273 &s->declared_at)) 3274 { 3275 if (list == OMP_LIST_LINK) 3276 gfc_add_omp_declare_target_link (&s->attr, s->name, 3277 &s->declared_at); 3278 } 3279 } 3280 } 3281 3282 gfc_buffer_error (true); 3283 3284 if (c) 3285 gfc_free_omp_clauses (c); 3286 return MATCH_YES; 3287 3288syntax: 3289 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C"); 3290 3291cleanup: 3292 gfc_current_locus = old_loc; 3293 if (c) 3294 gfc_free_omp_clauses (c); 3295 return MATCH_ERROR; 3296} 3297 3298 3299match 3300gfc_match_omp_threadprivate (void) 3301{ 3302 locus old_loc; 3303 char n[GFC_MAX_SYMBOL_LEN+1]; 3304 gfc_symbol *sym; 3305 match m; 3306 gfc_symtree *st; 3307 3308 old_loc = gfc_current_locus; 3309 3310 m = gfc_match (" ("); 3311 if (m != MATCH_YES) 3312 return m; 3313 3314 for (;;) 3315 { 3316 m = gfc_match_symbol (&sym, 0); 3317 switch (m) 3318 { 3319 case MATCH_YES: 3320 if (sym->attr.in_common) 3321 gfc_error_now ("Threadprivate variable at %C is an element of " 3322 "a COMMON block"); 3323 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) 3324 goto cleanup; 3325 goto next_item; 3326 case MATCH_NO: 3327 break; 3328 case MATCH_ERROR: 3329 goto cleanup; 3330 } 3331 3332 m = gfc_match (" / %n /", n); 3333 if (m == MATCH_ERROR) 3334 goto cleanup; 3335 if (m == MATCH_NO || n[0] == '\0') 3336 goto syntax; 3337 3338 st = gfc_find_symtree (gfc_current_ns->common_root, n); 3339 if (st == NULL) 3340 { 3341 gfc_error ("COMMON block /%s/ not found at %C", n); 3342 goto cleanup; 3343 } 3344 st->n.common->threadprivate = 1; 3345 for (sym = st->n.common->head; sym; sym = sym->common_next) 3346 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) 3347 goto cleanup; 3348 3349 next_item: 3350 if (gfc_match_char (')') == MATCH_YES) 3351 break; 3352 if (gfc_match_char (',') != MATCH_YES) 3353 goto syntax; 3354 } 3355 3356 if (gfc_match_omp_eos () != MATCH_YES) 3357 { 3358 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); 3359 goto cleanup; 3360 } 3361 3362 return MATCH_YES; 3363 3364syntax: 3365 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); 3366 3367cleanup: 3368 gfc_current_locus = old_loc; 3369 return MATCH_ERROR; 3370} 3371 3372 3373match 3374gfc_match_omp_parallel (void) 3375{ 3376 return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); 3377} 3378 3379 3380match 3381gfc_match_omp_parallel_do (void) 3382{ 3383 return match_omp (EXEC_OMP_PARALLEL_DO, 3384 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES); 3385} 3386 3387 3388match 3389gfc_match_omp_parallel_do_simd (void) 3390{ 3391 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD, 3392 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); 3393} 3394 3395 3396match 3397gfc_match_omp_parallel_sections (void) 3398{ 3399 return match_omp (EXEC_OMP_PARALLEL_SECTIONS, 3400 OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES); 3401} 3402 3403 3404match 3405gfc_match_omp_parallel_workshare (void) 3406{ 3407 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES); 3408} 3409 3410 3411match 3412gfc_match_omp_sections (void) 3413{ 3414 return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES); 3415} 3416 3417 3418match 3419gfc_match_omp_simd (void) 3420{ 3421 return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES); 3422} 3423 3424 3425match 3426gfc_match_omp_single (void) 3427{ 3428 return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES); 3429} 3430 3431 3432match 3433gfc_match_omp_target (void) 3434{ 3435 return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES); 3436} 3437 3438 3439match 3440gfc_match_omp_target_data (void) 3441{ 3442 return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES); 3443} 3444 3445 3446match 3447gfc_match_omp_target_enter_data (void) 3448{ 3449 return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES); 3450} 3451 3452 3453match 3454gfc_match_omp_target_exit_data (void) 3455{ 3456 return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES); 3457} 3458 3459 3460match 3461gfc_match_omp_target_parallel (void) 3462{ 3463 return match_omp (EXEC_OMP_TARGET_PARALLEL, 3464 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES) 3465 & ~(omp_mask (OMP_CLAUSE_COPYIN))); 3466} 3467 3468 3469match 3470gfc_match_omp_target_parallel_do (void) 3471{ 3472 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO, 3473 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES 3474 | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); 3475} 3476 3477 3478match 3479gfc_match_omp_target_parallel_do_simd (void) 3480{ 3481 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD, 3482 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES 3483 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); 3484} 3485 3486 3487match 3488gfc_match_omp_target_simd (void) 3489{ 3490 return match_omp (EXEC_OMP_TARGET_SIMD, 3491 OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES); 3492} 3493 3494 3495match 3496gfc_match_omp_target_teams (void) 3497{ 3498 return match_omp (EXEC_OMP_TARGET_TEAMS, 3499 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES); 3500} 3501 3502 3503match 3504gfc_match_omp_target_teams_distribute (void) 3505{ 3506 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE, 3507 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES 3508 | OMP_DISTRIBUTE_CLAUSES); 3509} 3510 3511 3512match 3513gfc_match_omp_target_teams_distribute_parallel_do (void) 3514{ 3515 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, 3516 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES 3517 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES 3518 | OMP_DO_CLAUSES) 3519 & ~(omp_mask (OMP_CLAUSE_ORDERED)) 3520 & ~(omp_mask (OMP_CLAUSE_LINEAR))); 3521} 3522 3523 3524match 3525gfc_match_omp_target_teams_distribute_parallel_do_simd (void) 3526{ 3527 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, 3528 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES 3529 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES 3530 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) 3531 & ~(omp_mask (OMP_CLAUSE_ORDERED))); 3532} 3533 3534 3535match 3536gfc_match_omp_target_teams_distribute_simd (void) 3537{ 3538 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD, 3539 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES 3540 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); 3541} 3542 3543 3544match 3545gfc_match_omp_target_update (void) 3546{ 3547 return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES); 3548} 3549 3550 3551match 3552gfc_match_omp_task (void) 3553{ 3554 return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES); 3555} 3556 3557 3558match 3559gfc_match_omp_taskloop (void) 3560{ 3561 return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES); 3562} 3563 3564 3565match 3566gfc_match_omp_taskloop_simd (void) 3567{ 3568 return match_omp (EXEC_OMP_TASKLOOP_SIMD, 3569 (OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) 3570 & ~(omp_mask (OMP_CLAUSE_REDUCTION))); 3571} 3572 3573 3574match 3575gfc_match_omp_taskwait (void) 3576{ 3577 if (gfc_match_omp_eos () != MATCH_YES) 3578 { 3579 gfc_error ("Unexpected junk after TASKWAIT clause at %C"); 3580 return MATCH_ERROR; 3581 } 3582 new_st.op = EXEC_OMP_TASKWAIT; 3583 new_st.ext.omp_clauses = NULL; 3584 return MATCH_YES; 3585} 3586 3587 3588match 3589gfc_match_omp_taskyield (void) 3590{ 3591 if (gfc_match_omp_eos () != MATCH_YES) 3592 { 3593 gfc_error ("Unexpected junk after TASKYIELD clause at %C"); 3594 return MATCH_ERROR; 3595 } 3596 new_st.op = EXEC_OMP_TASKYIELD; 3597 new_st.ext.omp_clauses = NULL; 3598 return MATCH_YES; 3599} 3600 3601 3602match 3603gfc_match_omp_teams (void) 3604{ 3605 return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES); 3606} 3607 3608 3609match 3610gfc_match_omp_teams_distribute (void) 3611{ 3612 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE, 3613 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES); 3614} 3615 3616 3617match 3618gfc_match_omp_teams_distribute_parallel_do (void) 3619{ 3620 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO, 3621 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES 3622 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) 3623 & ~(omp_mask (OMP_CLAUSE_ORDERED)) 3624 & ~(omp_mask (OMP_CLAUSE_LINEAR))); 3625} 3626 3627 3628match 3629gfc_match_omp_teams_distribute_parallel_do_simd (void) 3630{ 3631 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, 3632 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES 3633 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES 3634 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED))); 3635} 3636 3637 3638match 3639gfc_match_omp_teams_distribute_simd (void) 3640{ 3641 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD, 3642 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES 3643 | OMP_SIMD_CLAUSES); 3644} 3645 3646 3647match 3648gfc_match_omp_workshare (void) 3649{ 3650 if (gfc_match_omp_eos () != MATCH_YES) 3651 { 3652 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C"); 3653 return MATCH_ERROR; 3654 } 3655 new_st.op = EXEC_OMP_WORKSHARE; 3656 new_st.ext.omp_clauses = gfc_get_omp_clauses (); 3657 return MATCH_YES; 3658} 3659 3660 3661match 3662gfc_match_omp_master (void) 3663{ 3664 if (gfc_match_omp_eos () != MATCH_YES) 3665 { 3666 gfc_error ("Unexpected junk after $OMP MASTER statement at %C"); 3667 return MATCH_ERROR; 3668 } 3669 new_st.op = EXEC_OMP_MASTER; 3670 new_st.ext.omp_clauses = NULL; 3671 return MATCH_YES; 3672} 3673 3674 3675match 3676gfc_match_omp_ordered (void) 3677{ 3678 return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES); 3679} 3680 3681 3682match 3683gfc_match_omp_ordered_depend (void) 3684{ 3685 return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND)); 3686} 3687 3688 3689static match 3690gfc_match_omp_oacc_atomic (bool omp_p) 3691{ 3692 gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE; 3693 int seq_cst = 0; 3694 if (gfc_match ("% seq_cst") == MATCH_YES) 3695 seq_cst = 1; 3696 locus old_loc = gfc_current_locus; 3697 if (seq_cst && gfc_match_char (',') == MATCH_YES) 3698 seq_cst = 2; 3699 if (seq_cst == 2 3700 || gfc_match_space () == MATCH_YES) 3701 { 3702 gfc_gobble_whitespace (); 3703 if (gfc_match ("update") == MATCH_YES) 3704 op = GFC_OMP_ATOMIC_UPDATE; 3705 else if (gfc_match ("read") == MATCH_YES) 3706 op = GFC_OMP_ATOMIC_READ; 3707 else if (gfc_match ("write") == MATCH_YES) 3708 op = GFC_OMP_ATOMIC_WRITE; 3709 else if (gfc_match ("capture") == MATCH_YES) 3710 op = GFC_OMP_ATOMIC_CAPTURE; 3711 else 3712 { 3713 if (seq_cst == 2) 3714 gfc_current_locus = old_loc; 3715 goto finish; 3716 } 3717 if (!seq_cst 3718 && (gfc_match (", seq_cst") == MATCH_YES 3719 || gfc_match ("% seq_cst") == MATCH_YES)) 3720 seq_cst = 1; 3721 } 3722 finish: 3723 if (gfc_match_omp_eos () != MATCH_YES) 3724 { 3725 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C"); 3726 return MATCH_ERROR; 3727 } 3728 new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC); 3729 if (seq_cst) 3730 op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST); 3731 new_st.ext.omp_atomic = op; 3732 return MATCH_YES; 3733} 3734 3735match 3736gfc_match_oacc_atomic (void) 3737{ 3738 return gfc_match_omp_oacc_atomic (false); 3739} 3740 3741match 3742gfc_match_omp_atomic (void) 3743{ 3744 return gfc_match_omp_oacc_atomic (true); 3745} 3746 3747match 3748gfc_match_omp_barrier (void) 3749{ 3750 if (gfc_match_omp_eos () != MATCH_YES) 3751 { 3752 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C"); 3753 return MATCH_ERROR; 3754 } 3755 new_st.op = EXEC_OMP_BARRIER; 3756 new_st.ext.omp_clauses = NULL; 3757 return MATCH_YES; 3758} 3759 3760 3761match 3762gfc_match_omp_taskgroup (void) 3763{ 3764 if (gfc_match_omp_eos () != MATCH_YES) 3765 { 3766 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C"); 3767 return MATCH_ERROR; 3768 } 3769 new_st.op = EXEC_OMP_TASKGROUP; 3770 return MATCH_YES; 3771} 3772 3773 3774static enum gfc_omp_cancel_kind 3775gfc_match_omp_cancel_kind (void) 3776{ 3777 if (gfc_match_space () != MATCH_YES) 3778 return OMP_CANCEL_UNKNOWN; 3779 if (gfc_match ("parallel") == MATCH_YES) 3780 return OMP_CANCEL_PARALLEL; 3781 if (gfc_match ("sections") == MATCH_YES) 3782 return OMP_CANCEL_SECTIONS; 3783 if (gfc_match ("do") == MATCH_YES) 3784 return OMP_CANCEL_DO; 3785 if (gfc_match ("taskgroup") == MATCH_YES) 3786 return OMP_CANCEL_TASKGROUP; 3787 return OMP_CANCEL_UNKNOWN; 3788} 3789 3790 3791match 3792gfc_match_omp_cancel (void) 3793{ 3794 gfc_omp_clauses *c; 3795 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); 3796 if (kind == OMP_CANCEL_UNKNOWN) 3797 return MATCH_ERROR; 3798 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES) 3799 return MATCH_ERROR; 3800 c->cancel = kind; 3801 new_st.op = EXEC_OMP_CANCEL; 3802 new_st.ext.omp_clauses = c; 3803 return MATCH_YES; 3804} 3805 3806 3807match 3808gfc_match_omp_cancellation_point (void) 3809{ 3810 gfc_omp_clauses *c; 3811 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); 3812 if (kind == OMP_CANCEL_UNKNOWN) 3813 return MATCH_ERROR; 3814 if (gfc_match_omp_eos () != MATCH_YES) 3815 { 3816 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement " 3817 "at %C"); 3818 return MATCH_ERROR; 3819 } 3820 c = gfc_get_omp_clauses (); 3821 c->cancel = kind; 3822 new_st.op = EXEC_OMP_CANCELLATION_POINT; 3823 new_st.ext.omp_clauses = c; 3824 return MATCH_YES; 3825} 3826 3827 3828match 3829gfc_match_omp_end_nowait (void) 3830{ 3831 bool nowait = false; 3832 if (gfc_match ("% nowait") == MATCH_YES) 3833 nowait = true; 3834 if (gfc_match_omp_eos () != MATCH_YES) 3835 { 3836 gfc_error ("Unexpected junk after NOWAIT clause at %C"); 3837 return MATCH_ERROR; 3838 } 3839 new_st.op = EXEC_OMP_END_NOWAIT; 3840 new_st.ext.omp_bool = nowait; 3841 return MATCH_YES; 3842} 3843 3844 3845match 3846gfc_match_omp_end_single (void) 3847{ 3848 gfc_omp_clauses *c; 3849 if (gfc_match ("% nowait") == MATCH_YES) 3850 { 3851 new_st.op = EXEC_OMP_END_NOWAIT; 3852 new_st.ext.omp_bool = true; 3853 return MATCH_YES; 3854 } 3855 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)) 3856 != MATCH_YES) 3857 return MATCH_ERROR; 3858 new_st.op = EXEC_OMP_END_SINGLE; 3859 new_st.ext.omp_clauses = c; 3860 return MATCH_YES; 3861} 3862 3863 3864static bool 3865oacc_is_loop (gfc_code *code) 3866{ 3867 return code->op == EXEC_OACC_PARALLEL_LOOP 3868 || code->op == EXEC_OACC_KERNELS_LOOP 3869 || code->op == EXEC_OACC_SERIAL_LOOP 3870 || code->op == EXEC_OACC_LOOP; 3871} 3872 3873static void 3874resolve_scalar_int_expr (gfc_expr *expr, const char *clause) 3875{ 3876 if (!gfc_resolve_expr (expr) 3877 || expr->ts.type != BT_INTEGER 3878 || expr->rank != 0) 3879 gfc_error ("%s clause at %L requires a scalar INTEGER expression", 3880 clause, &expr->where); 3881} 3882 3883static void 3884resolve_positive_int_expr (gfc_expr *expr, const char *clause) 3885{ 3886 resolve_scalar_int_expr (expr, clause); 3887 if (expr->expr_type == EXPR_CONSTANT 3888 && expr->ts.type == BT_INTEGER 3889 && mpz_sgn (expr->value.integer) <= 0) 3890 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive", 3891 clause, &expr->where); 3892} 3893 3894static void 3895resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause) 3896{ 3897 resolve_scalar_int_expr (expr, clause); 3898 if (expr->expr_type == EXPR_CONSTANT 3899 && expr->ts.type == BT_INTEGER 3900 && mpz_sgn (expr->value.integer) < 0) 3901 gfc_warning (0, "INTEGER expression of %s clause at %L must be " 3902 "non-negative", clause, &expr->where); 3903} 3904 3905/* Emits error when symbol is pointer, cray pointer or cray pointee 3906 of derived of polymorphic type. */ 3907 3908static void 3909check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) 3910{ 3911 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) 3912 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L", 3913 sym->name, name, &loc); 3914 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee) 3915 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L", 3916 sym->name, name, &loc); 3917 3918 if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer) 3919 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3920 && CLASS_DATA (sym)->attr.pointer)) 3921 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L", 3922 sym->name, name, &loc); 3923 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer) 3924 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3925 && CLASS_DATA (sym)->attr.cray_pointer)) 3926 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L", 3927 sym->name, name, &loc); 3928 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee) 3929 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3930 && CLASS_DATA (sym)->attr.cray_pointee)) 3931 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L", 3932 sym->name, name, &loc); 3933} 3934 3935/* Emits error when symbol represents assumed size/rank array. */ 3936 3937static void 3938check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) 3939{ 3940 if (sym->as && sym->as->type == AS_ASSUMED_SIZE) 3941 gfc_error ("Assumed size array %qs in %s clause at %L", 3942 sym->name, name, &loc); 3943 if (sym->as && sym->as->type == AS_ASSUMED_RANK) 3944 gfc_error ("Assumed rank array %qs in %s clause at %L", 3945 sym->name, name, &loc); 3946} 3947 3948static void 3949resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) 3950{ 3951 check_array_not_assumed (sym, loc, name); 3952} 3953 3954static void 3955resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name) 3956{ 3957 if (sym->attr.pointer 3958 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3959 && CLASS_DATA (sym)->attr.class_pointer)) 3960 gfc_error ("POINTER object %qs in %s clause at %L", 3961 sym->name, name, &loc); 3962 if (sym->attr.cray_pointer 3963 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3964 && CLASS_DATA (sym)->attr.cray_pointer)) 3965 gfc_error ("Cray pointer object %qs in %s clause at %L", 3966 sym->name, name, &loc); 3967 if (sym->attr.cray_pointee 3968 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3969 && CLASS_DATA (sym)->attr.cray_pointee)) 3970 gfc_error ("Cray pointee object %qs in %s clause at %L", 3971 sym->name, name, &loc); 3972 if (sym->attr.allocatable 3973 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3974 && CLASS_DATA (sym)->attr.allocatable)) 3975 gfc_error ("ALLOCATABLE object %qs in %s clause at %L", 3976 sym->name, name, &loc); 3977 if (sym->attr.value) 3978 gfc_error ("VALUE object %qs in %s clause at %L", 3979 sym->name, name, &loc); 3980 check_array_not_assumed (sym, loc, name); 3981} 3982 3983 3984struct resolve_omp_udr_callback_data 3985{ 3986 gfc_symbol *sym1, *sym2; 3987}; 3988 3989 3990static int 3991resolve_omp_udr_callback (gfc_expr **e, int *, void *data) 3992{ 3993 struct resolve_omp_udr_callback_data *rcd 3994 = (struct resolve_omp_udr_callback_data *) data; 3995 if ((*e)->expr_type == EXPR_VARIABLE 3996 && ((*e)->symtree->n.sym == rcd->sym1 3997 || (*e)->symtree->n.sym == rcd->sym2)) 3998 { 3999 gfc_ref *ref = gfc_get_ref (); 4000 ref->type = REF_ARRAY; 4001 ref->u.ar.where = (*e)->where; 4002 ref->u.ar.as = (*e)->symtree->n.sym->as; 4003 ref->u.ar.type = AR_FULL; 4004 ref->u.ar.dimen = 0; 4005 ref->next = (*e)->ref; 4006 (*e)->ref = ref; 4007 } 4008 return 0; 4009} 4010 4011 4012static int 4013resolve_omp_udr_callback2 (gfc_expr **e, int *, void *) 4014{ 4015 if ((*e)->expr_type == EXPR_FUNCTION 4016 && (*e)->value.function.isym == NULL) 4017 { 4018 gfc_symbol *sym = (*e)->symtree->n.sym; 4019 if (!sym->attr.intrinsic 4020 && sym->attr.if_source == IFSRC_UNKNOWN) 4021 gfc_error ("Implicitly declared function %s used in " 4022 "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where); 4023 } 4024 return 0; 4025} 4026 4027 4028static gfc_code * 4029resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, 4030 gfc_symbol *sym1, gfc_symbol *sym2) 4031{ 4032 gfc_code *copy; 4033 gfc_symbol sym1_copy, sym2_copy; 4034 4035 if (ns->code->op == EXEC_ASSIGN) 4036 { 4037 copy = gfc_get_code (EXEC_ASSIGN); 4038 copy->expr1 = gfc_copy_expr (ns->code->expr1); 4039 copy->expr2 = gfc_copy_expr (ns->code->expr2); 4040 } 4041 else 4042 { 4043 copy = gfc_get_code (EXEC_CALL); 4044 copy->symtree = ns->code->symtree; 4045 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual); 4046 } 4047 copy->loc = ns->code->loc; 4048 sym1_copy = *sym1; 4049 sym2_copy = *sym2; 4050 *sym1 = *n->sym; 4051 *sym2 = *n->sym; 4052 sym1->name = sym1_copy.name; 4053 sym2->name = sym2_copy.name; 4054 ns->proc_name = ns->parent->proc_name; 4055 if (n->sym->attr.dimension) 4056 { 4057 struct resolve_omp_udr_callback_data rcd; 4058 rcd.sym1 = sym1; 4059 rcd.sym2 = sym2; 4060 gfc_code_walker (©, gfc_dummy_code_callback, 4061 resolve_omp_udr_callback, &rcd); 4062 } 4063 gfc_resolve_code (copy, gfc_current_ns); 4064 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL) 4065 { 4066 gfc_symbol *sym = copy->resolved_sym; 4067 if (sym 4068 && !sym->attr.intrinsic 4069 && sym->attr.if_source == IFSRC_UNKNOWN) 4070 gfc_error ("Implicitly declared subroutine %s used in " 4071 "!$OMP DECLARE REDUCTION at %L", sym->name, 4072 ©->loc); 4073 } 4074 gfc_code_walker (©, gfc_dummy_code_callback, 4075 resolve_omp_udr_callback2, NULL); 4076 *sym1 = sym1_copy; 4077 *sym2 = sym2_copy; 4078 return copy; 4079} 4080 4081/* OpenMP directive resolving routines. */ 4082 4083static void 4084resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, 4085 gfc_namespace *ns, bool openacc = false) 4086{ 4087 gfc_omp_namelist *n; 4088 gfc_expr_list *el; 4089 int list; 4090 int ifc; 4091 bool if_without_mod = false; 4092 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; 4093 static const char *clause_names[] 4094 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", 4095 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", 4096 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", 4097 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR" }; 4098 4099 if (omp_clauses == NULL) 4100 return; 4101 4102 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) 4103 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L", 4104 &code->loc); 4105 4106 if (omp_clauses->if_expr) 4107 { 4108 gfc_expr *expr = omp_clauses->if_expr; 4109 if (!gfc_resolve_expr (expr) 4110 || expr->ts.type != BT_LOGICAL || expr->rank != 0) 4111 gfc_error ("IF clause at %L requires a scalar LOGICAL expression", 4112 &expr->where); 4113 if_without_mod = true; 4114 } 4115 for (ifc = 0; ifc < OMP_IF_LAST; ifc++) 4116 if (omp_clauses->if_exprs[ifc]) 4117 { 4118 gfc_expr *expr = omp_clauses->if_exprs[ifc]; 4119 bool ok = true; 4120 if (!gfc_resolve_expr (expr) 4121 || expr->ts.type != BT_LOGICAL || expr->rank != 0) 4122 gfc_error ("IF clause at %L requires a scalar LOGICAL expression", 4123 &expr->where); 4124 else if (if_without_mod) 4125 { 4126 gfc_error ("IF clause without modifier at %L used together with " 4127 "IF clauses with modifiers", 4128 &omp_clauses->if_expr->where); 4129 if_without_mod = false; 4130 } 4131 else 4132 switch (code->op) 4133 { 4134 case EXEC_OMP_PARALLEL: 4135 case EXEC_OMP_PARALLEL_DO: 4136 case EXEC_OMP_PARALLEL_SECTIONS: 4137 case EXEC_OMP_PARALLEL_WORKSHARE: 4138 case EXEC_OMP_PARALLEL_DO_SIMD: 4139 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 4140 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 4141 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 4142 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4143 ok = ifc == OMP_IF_PARALLEL; 4144 break; 4145 4146 case EXEC_OMP_TASK: 4147 ok = ifc == OMP_IF_TASK; 4148 break; 4149 4150 case EXEC_OMP_TASKLOOP: 4151 case EXEC_OMP_TASKLOOP_SIMD: 4152 ok = ifc == OMP_IF_TASKLOOP; 4153 break; 4154 4155 case EXEC_OMP_TARGET: 4156 case EXEC_OMP_TARGET_TEAMS: 4157 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 4158 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 4159 case EXEC_OMP_TARGET_SIMD: 4160 ok = ifc == OMP_IF_TARGET; 4161 break; 4162 4163 case EXEC_OMP_TARGET_DATA: 4164 ok = ifc == OMP_IF_TARGET_DATA; 4165 break; 4166 4167 case EXEC_OMP_TARGET_UPDATE: 4168 ok = ifc == OMP_IF_TARGET_UPDATE; 4169 break; 4170 4171 case EXEC_OMP_TARGET_ENTER_DATA: 4172 ok = ifc == OMP_IF_TARGET_ENTER_DATA; 4173 break; 4174 4175 case EXEC_OMP_TARGET_EXIT_DATA: 4176 ok = ifc == OMP_IF_TARGET_EXIT_DATA; 4177 break; 4178 4179 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 4180 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4181 case EXEC_OMP_TARGET_PARALLEL: 4182 case EXEC_OMP_TARGET_PARALLEL_DO: 4183 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 4184 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL; 4185 break; 4186 4187 default: 4188 ok = false; 4189 break; 4190 } 4191 if (!ok) 4192 { 4193 static const char *ifs[] = { 4194 "PARALLEL", 4195 "TASK", 4196 "TASKLOOP", 4197 "TARGET", 4198 "TARGET DATA", 4199 "TARGET UPDATE", 4200 "TARGET ENTER DATA", 4201 "TARGET EXIT DATA" 4202 }; 4203 gfc_error ("IF clause modifier %s at %L not appropriate for " 4204 "the current OpenMP construct", ifs[ifc], &expr->where); 4205 } 4206 } 4207 4208 if (omp_clauses->final_expr) 4209 { 4210 gfc_expr *expr = omp_clauses->final_expr; 4211 if (!gfc_resolve_expr (expr) 4212 || expr->ts.type != BT_LOGICAL || expr->rank != 0) 4213 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression", 4214 &expr->where); 4215 } 4216 if (omp_clauses->num_threads) 4217 resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); 4218 if (omp_clauses->chunk_size) 4219 { 4220 gfc_expr *expr = omp_clauses->chunk_size; 4221 if (!gfc_resolve_expr (expr) 4222 || expr->ts.type != BT_INTEGER || expr->rank != 0) 4223 gfc_error ("SCHEDULE clause's chunk_size at %L requires " 4224 "a scalar INTEGER expression", &expr->where); 4225 else if (expr->expr_type == EXPR_CONSTANT 4226 && expr->ts.type == BT_INTEGER 4227 && mpz_sgn (expr->value.integer) <= 0) 4228 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size " 4229 "at %L must be positive", &expr->where); 4230 } 4231 if (omp_clauses->sched_kind != OMP_SCHED_NONE 4232 && omp_clauses->sched_nonmonotonic) 4233 { 4234 if (omp_clauses->sched_kind != OMP_SCHED_DYNAMIC 4235 && omp_clauses->sched_kind != OMP_SCHED_GUIDED) 4236 { 4237 const char *p; 4238 switch (omp_clauses->sched_kind) 4239 { 4240 case OMP_SCHED_STATIC: p = "STATIC"; break; 4241 case OMP_SCHED_RUNTIME: p = "RUNTIME"; break; 4242 case OMP_SCHED_AUTO: p = "AUTO"; break; 4243 default: gcc_unreachable (); 4244 } 4245 gfc_error ("NONMONOTONIC modifier specified for %s schedule kind " 4246 "at %L", p, &code->loc); 4247 } 4248 else if (omp_clauses->sched_monotonic) 4249 gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers " 4250 "specified at %L", &code->loc); 4251 else if (omp_clauses->ordered) 4252 gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED " 4253 "clause at %L", &code->loc); 4254 } 4255 4256 /* Check that no symbol appears on multiple clauses, except that 4257 a symbol can appear on both firstprivate and lastprivate. */ 4258 for (list = 0; list < OMP_LIST_NUM; list++) 4259 for (n = omp_clauses->lists[list]; n; n = n->next) 4260 { 4261 n->sym->mark = 0; 4262 n->sym->comp_mark = 0; 4263 if (n->sym->attr.flavor == FL_VARIABLE 4264 || n->sym->attr.proc_pointer 4265 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) 4266 { 4267 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) 4268 gfc_error ("Variable %qs is not a dummy argument at %L", 4269 n->sym->name, &n->where); 4270 continue; 4271 } 4272 if (n->sym->attr.flavor == FL_PROCEDURE 4273 && n->sym->result == n->sym 4274 && n->sym->attr.function) 4275 { 4276 if (gfc_current_ns->proc_name == n->sym 4277 || (gfc_current_ns->parent 4278 && gfc_current_ns->parent->proc_name == n->sym)) 4279 continue; 4280 if (gfc_current_ns->proc_name->attr.entry_master) 4281 { 4282 gfc_entry_list *el = gfc_current_ns->entries; 4283 for (; el; el = el->next) 4284 if (el->sym == n->sym) 4285 break; 4286 if (el) 4287 continue; 4288 } 4289 if (gfc_current_ns->parent 4290 && gfc_current_ns->parent->proc_name->attr.entry_master) 4291 { 4292 gfc_entry_list *el = gfc_current_ns->parent->entries; 4293 for (; el; el = el->next) 4294 if (el->sym == n->sym) 4295 break; 4296 if (el) 4297 continue; 4298 } 4299 } 4300 if (list == OMP_LIST_MAP 4301 && n->sym->attr.flavor == FL_PARAMETER) 4302 { 4303 if (openacc) 4304 gfc_error ("Object %qs is not a variable at %L; parameters" 4305 " cannot be and need not be copied", n->sym->name, 4306 &n->where); 4307 else 4308 gfc_error ("Object %qs is not a variable at %L; parameters" 4309 " cannot be and need not be mapped", n->sym->name, 4310 &n->where); 4311 } 4312 else 4313 gfc_error ("Object %qs is not a variable at %L", n->sym->name, 4314 &n->where); 4315 } 4316 4317 for (list = 0; list < OMP_LIST_NUM; list++) 4318 if (list != OMP_LIST_FIRSTPRIVATE 4319 && list != OMP_LIST_LASTPRIVATE 4320 && list != OMP_LIST_ALIGNED 4321 && list != OMP_LIST_DEPEND 4322 && (list != OMP_LIST_MAP || openacc) 4323 && list != OMP_LIST_FROM 4324 && list != OMP_LIST_TO 4325 && (list != OMP_LIST_REDUCTION || !openacc)) 4326 for (n = omp_clauses->lists[list]; n; n = n->next) 4327 { 4328 bool component_ref_p = false; 4329 4330 /* Allow multiple components of the same (e.g. derived-type) 4331 variable here. Duplicate components are detected elsewhere. */ 4332 if (n->expr && n->expr->expr_type == EXPR_VARIABLE) 4333 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) 4334 if (ref->type == REF_COMPONENT) 4335 component_ref_p = true; 4336 if ((!component_ref_p && n->sym->comp_mark) 4337 || (component_ref_p && n->sym->mark)) 4338 gfc_error ("Symbol %qs has mixed component and non-component " 4339 "accesses at %L", n->sym->name, &n->where); 4340 else if (n->sym->mark) 4341 gfc_error ("Symbol %qs present on multiple clauses at %L", 4342 n->sym->name, &n->where); 4343 else 4344 { 4345 if (component_ref_p) 4346 n->sym->comp_mark = 1; 4347 else 4348 n->sym->mark = 1; 4349 } 4350 } 4351 4352 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); 4353 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) 4354 for (n = omp_clauses->lists[list]; n; n = n->next) 4355 if (n->sym->mark) 4356 { 4357 gfc_error ("Symbol %qs present on multiple clauses at %L", 4358 n->sym->name, &n->where); 4359 n->sym->mark = 0; 4360 } 4361 4362 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) 4363 { 4364 if (n->sym->mark) 4365 gfc_error ("Symbol %qs present on multiple clauses at %L", 4366 n->sym->name, &n->where); 4367 else 4368 n->sym->mark = 1; 4369 } 4370 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) 4371 n->sym->mark = 0; 4372 4373 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) 4374 { 4375 if (n->sym->mark) 4376 gfc_error ("Symbol %qs present on multiple clauses at %L", 4377 n->sym->name, &n->where); 4378 else 4379 n->sym->mark = 1; 4380 } 4381 4382 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) 4383 n->sym->mark = 0; 4384 4385 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) 4386 { 4387 if (n->sym->mark) 4388 gfc_error ("Symbol %qs present on multiple clauses at %L", 4389 n->sym->name, &n->where); 4390 else 4391 n->sym->mark = 1; 4392 } 4393 4394 /* OpenACC reductions. */ 4395 if (openacc) 4396 { 4397 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) 4398 n->sym->mark = 0; 4399 4400 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) 4401 { 4402 if (n->sym->mark) 4403 gfc_error ("Symbol %qs present on multiple clauses at %L", 4404 n->sym->name, &n->where); 4405 else 4406 n->sym->mark = 1; 4407 4408 /* OpenACC does not support reductions on arrays. */ 4409 if (n->sym->as) 4410 gfc_error ("Array %qs is not permitted in reduction at %L", 4411 n->sym->name, &n->where); 4412 } 4413 } 4414 4415 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) 4416 n->sym->mark = 0; 4417 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next) 4418 if (n->expr == NULL) 4419 n->sym->mark = 1; 4420 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) 4421 { 4422 if (n->expr == NULL && n->sym->mark) 4423 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L", 4424 n->sym->name, &n->where); 4425 else 4426 n->sym->mark = 1; 4427 } 4428 4429 for (list = 0; list < OMP_LIST_NUM; list++) 4430 if ((n = omp_clauses->lists[list]) != NULL) 4431 { 4432 const char *name; 4433 4434 if (list < OMP_LIST_NUM) 4435 name = clause_names[list]; 4436 else 4437 gcc_unreachable (); 4438 4439 switch (list) 4440 { 4441 case OMP_LIST_COPYIN: 4442 for (; n != NULL; n = n->next) 4443 { 4444 if (!n->sym->attr.threadprivate) 4445 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause" 4446 " at %L", n->sym->name, &n->where); 4447 } 4448 break; 4449 case OMP_LIST_COPYPRIVATE: 4450 for (; n != NULL; n = n->next) 4451 { 4452 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) 4453 gfc_error ("Assumed size array %qs in COPYPRIVATE clause " 4454 "at %L", n->sym->name, &n->where); 4455 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) 4456 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause " 4457 "at %L", n->sym->name, &n->where); 4458 } 4459 break; 4460 case OMP_LIST_SHARED: 4461 for (; n != NULL; n = n->next) 4462 { 4463 if (n->sym->attr.threadprivate) 4464 gfc_error ("THREADPRIVATE object %qs in SHARED clause at " 4465 "%L", n->sym->name, &n->where); 4466 if (n->sym->attr.cray_pointee) 4467 gfc_error ("Cray pointee %qs in SHARED clause at %L", 4468 n->sym->name, &n->where); 4469 if (n->sym->attr.associate_var) 4470 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L", 4471 n->sym->name, &n->where); 4472 } 4473 break; 4474 case OMP_LIST_ALIGNED: 4475 for (; n != NULL; n = n->next) 4476 { 4477 if (!n->sym->attr.pointer 4478 && !n->sym->attr.allocatable 4479 && !n->sym->attr.cray_pointer 4480 && (n->sym->ts.type != BT_DERIVED 4481 || (n->sym->ts.u.derived->from_intmod 4482 != INTMOD_ISO_C_BINDING) 4483 || (n->sym->ts.u.derived->intmod_sym_id 4484 != ISOCBINDING_PTR))) 4485 gfc_error ("%qs in ALIGNED clause must be POINTER, " 4486 "ALLOCATABLE, Cray pointer or C_PTR at %L", 4487 n->sym->name, &n->where); 4488 else if (n->expr) 4489 { 4490 gfc_expr *expr = n->expr; 4491 int alignment = 0; 4492 if (!gfc_resolve_expr (expr) 4493 || expr->ts.type != BT_INTEGER 4494 || expr->rank != 0 4495 || gfc_extract_int (expr, &alignment) 4496 || alignment <= 0) 4497 gfc_error ("%qs in ALIGNED clause at %L requires a scalar " 4498 "positive constant integer alignment " 4499 "expression", n->sym->name, &n->where); 4500 } 4501 } 4502 break; 4503 case OMP_LIST_DEPEND: 4504 case OMP_LIST_MAP: 4505 case OMP_LIST_TO: 4506 case OMP_LIST_FROM: 4507 case OMP_LIST_CACHE: 4508 for (; n != NULL; n = n->next) 4509 { 4510 if (list == OMP_LIST_DEPEND) 4511 { 4512 if (n->u.depend_op == OMP_DEPEND_SINK_FIRST 4513 || n->u.depend_op == OMP_DEPEND_SINK) 4514 { 4515 if (code->op != EXEC_OMP_ORDERED) 4516 gfc_error ("SINK dependence type only allowed " 4517 "on ORDERED directive at %L", &n->where); 4518 else if (omp_clauses->depend_source) 4519 { 4520 gfc_error ("DEPEND SINK used together with " 4521 "DEPEND SOURCE on the same construct " 4522 "at %L", &n->where); 4523 omp_clauses->depend_source = false; 4524 } 4525 else if (n->expr) 4526 { 4527 if (!gfc_resolve_expr (n->expr) 4528 || n->expr->ts.type != BT_INTEGER 4529 || n->expr->rank != 0) 4530 gfc_error ("SINK addend not a constant integer " 4531 "at %L", &n->where); 4532 } 4533 continue; 4534 } 4535 else if (code->op == EXEC_OMP_ORDERED) 4536 gfc_error ("Only SOURCE or SINK dependence types " 4537 "are allowed on ORDERED directive at %L", 4538 &n->where); 4539 } 4540 gfc_ref *array_ref = NULL; 4541 bool resolved = false; 4542 if (n->expr) 4543 { 4544 array_ref = n->expr->ref; 4545 resolved = gfc_resolve_expr (n->expr); 4546 4547 /* Look through component refs to find last array 4548 reference. */ 4549 if (openacc && resolved) 4550 { 4551 /* The "!$acc cache" directive allows rectangular 4552 subarrays to be specified, with some restrictions 4553 on the form of bounds (not implemented). 4554 Only raise an error here if we're really sure the 4555 array isn't contiguous. An expression such as 4556 arr(-n:n,-n:n) could be contiguous even if it looks 4557 like it may not be. */ 4558 if (list != OMP_LIST_CACHE 4559 && !gfc_is_simply_contiguous (n->expr, false, true) 4560 && gfc_is_not_contiguous (n->expr)) 4561 gfc_error ("Array is not contiguous at %L", 4562 &n->where); 4563 4564 while (array_ref 4565 && (array_ref->type == REF_COMPONENT 4566 || (array_ref->type == REF_ARRAY 4567 && array_ref->next 4568 && (array_ref->next->type 4569 == REF_COMPONENT)))) 4570 array_ref = array_ref->next; 4571 } 4572 } 4573 if (array_ref 4574 || (n->expr 4575 && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) 4576 { 4577 if (!resolved 4578 || n->expr->expr_type != EXPR_VARIABLE 4579 || array_ref->next 4580 || array_ref->type != REF_ARRAY) 4581 gfc_error ("%qs in %s clause at %L is not a proper " 4582 "array section", n->sym->name, name, 4583 &n->where); 4584 else 4585 { 4586 int i; 4587 gfc_array_ref *ar = &array_ref->u.ar; 4588 for (i = 0; i < ar->dimen; i++) 4589 if (ar->stride[i]) 4590 { 4591 gfc_error ("Stride should not be specified for " 4592 "array section in %s clause at %L", 4593 name, &n->where); 4594 break; 4595 } 4596 else if (ar->dimen_type[i] != DIMEN_ELEMENT 4597 && ar->dimen_type[i] != DIMEN_RANGE) 4598 { 4599 gfc_error ("%qs in %s clause at %L is not a " 4600 "proper array section", 4601 n->sym->name, name, &n->where); 4602 break; 4603 } 4604 else if (list == OMP_LIST_DEPEND 4605 && ar->start[i] 4606 && ar->start[i]->expr_type == EXPR_CONSTANT 4607 && ar->end[i] 4608 && ar->end[i]->expr_type == EXPR_CONSTANT 4609 && mpz_cmp (ar->start[i]->value.integer, 4610 ar->end[i]->value.integer) > 0) 4611 { 4612 gfc_error ("%qs in DEPEND clause at %L is a " 4613 "zero size array section", 4614 n->sym->name, &n->where); 4615 break; 4616 } 4617 } 4618 } 4619 else if (openacc) 4620 { 4621 if (list == OMP_LIST_MAP 4622 && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR) 4623 resolve_oacc_deviceptr_clause (n->sym, n->where, name); 4624 else 4625 resolve_oacc_data_clauses (n->sym, n->where, name); 4626 } 4627 else if (list != OMP_LIST_DEPEND 4628 && n->sym->as 4629 && n->sym->as->type == AS_ASSUMED_SIZE) 4630 gfc_error ("Assumed size array %qs in %s clause at %L", 4631 n->sym->name, name, &n->where); 4632 if (list == OMP_LIST_MAP && !openacc) 4633 switch (code->op) 4634 { 4635 case EXEC_OMP_TARGET: 4636 case EXEC_OMP_TARGET_DATA: 4637 switch (n->u.map_op) 4638 { 4639 case OMP_MAP_TO: 4640 case OMP_MAP_ALWAYS_TO: 4641 case OMP_MAP_FROM: 4642 case OMP_MAP_ALWAYS_FROM: 4643 case OMP_MAP_TOFROM: 4644 case OMP_MAP_ALWAYS_TOFROM: 4645 case OMP_MAP_ALLOC: 4646 break; 4647 default: 4648 gfc_error ("TARGET%s with map-type other than TO, " 4649 "FROM, TOFROM, or ALLOC on MAP clause " 4650 "at %L", 4651 code->op == EXEC_OMP_TARGET 4652 ? "" : " DATA", &n->where); 4653 break; 4654 } 4655 break; 4656 case EXEC_OMP_TARGET_ENTER_DATA: 4657 switch (n->u.map_op) 4658 { 4659 case OMP_MAP_TO: 4660 case OMP_MAP_ALWAYS_TO: 4661 case OMP_MAP_ALLOC: 4662 break; 4663 default: 4664 gfc_error ("TARGET ENTER DATA with map-type other " 4665 "than TO, or ALLOC on MAP clause at %L", 4666 &n->where); 4667 break; 4668 } 4669 break; 4670 case EXEC_OMP_TARGET_EXIT_DATA: 4671 switch (n->u.map_op) 4672 { 4673 case OMP_MAP_FROM: 4674 case OMP_MAP_ALWAYS_FROM: 4675 case OMP_MAP_RELEASE: 4676 case OMP_MAP_DELETE: 4677 break; 4678 default: 4679 gfc_error ("TARGET EXIT DATA with map-type other " 4680 "than FROM, RELEASE, or DELETE on MAP " 4681 "clause at %L", &n->where); 4682 break; 4683 } 4684 break; 4685 default: 4686 break; 4687 } 4688 } 4689 4690 if (list != OMP_LIST_DEPEND) 4691 for (n = omp_clauses->lists[list]; n != NULL; n = n->next) 4692 { 4693 n->sym->attr.referenced = 1; 4694 if (n->sym->attr.threadprivate) 4695 gfc_error ("THREADPRIVATE object %qs in %s clause at %L", 4696 n->sym->name, name, &n->where); 4697 if (n->sym->attr.cray_pointee) 4698 gfc_error ("Cray pointee %qs in %s clause at %L", 4699 n->sym->name, name, &n->where); 4700 } 4701 break; 4702 case OMP_LIST_IS_DEVICE_PTR: 4703 if (!n->sym->attr.dummy) 4704 gfc_error ("Non-dummy object %qs in %s clause at %L", 4705 n->sym->name, name, &n->where); 4706 if (n->sym->attr.allocatable 4707 || (n->sym->ts.type == BT_CLASS 4708 && CLASS_DATA (n->sym)->attr.allocatable)) 4709 gfc_error ("ALLOCATABLE object %qs in %s clause at %L", 4710 n->sym->name, name, &n->where); 4711 if (n->sym->attr.pointer 4712 || (n->sym->ts.type == BT_CLASS 4713 && CLASS_DATA (n->sym)->attr.pointer)) 4714 gfc_error ("POINTER object %qs in %s clause at %L", 4715 n->sym->name, name, &n->where); 4716 if (n->sym->attr.value) 4717 gfc_error ("VALUE object %qs in %s clause at %L", 4718 n->sym->name, name, &n->where); 4719 break; 4720 case OMP_LIST_USE_DEVICE_PTR: 4721 case OMP_LIST_USE_DEVICE_ADDR: 4722 /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */ 4723 break; 4724 default: 4725 for (; n != NULL; n = n->next) 4726 { 4727 bool bad = false; 4728 if (n->sym->attr.threadprivate) 4729 gfc_error ("THREADPRIVATE object %qs in %s clause at %L", 4730 n->sym->name, name, &n->where); 4731 if (n->sym->attr.cray_pointee) 4732 gfc_error ("Cray pointee %qs in %s clause at %L", 4733 n->sym->name, name, &n->where); 4734 if (n->sym->attr.associate_var) 4735 gfc_error ("ASSOCIATE name %qs in %s clause at %L", 4736 n->sym->name, name, &n->where); 4737 if (list != OMP_LIST_PRIVATE) 4738 { 4739 if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION) 4740 gfc_error ("Procedure pointer %qs in %s clause at %L", 4741 n->sym->name, name, &n->where); 4742 if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION) 4743 gfc_error ("POINTER object %qs in %s clause at %L", 4744 n->sym->name, name, &n->where); 4745 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION) 4746 gfc_error ("Cray pointer %qs in %s clause at %L", 4747 n->sym->name, name, &n->where); 4748 } 4749 if (code 4750 && (oacc_is_loop (code) 4751 || code->op == EXEC_OACC_PARALLEL 4752 || code->op == EXEC_OACC_SERIAL)) 4753 check_array_not_assumed (n->sym, n->where, name); 4754 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) 4755 gfc_error ("Assumed size array %qs in %s clause at %L", 4756 n->sym->name, name, &n->where); 4757 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION) 4758 gfc_error ("Variable %qs in %s clause is used in " 4759 "NAMELIST statement at %L", 4760 n->sym->name, name, &n->where); 4761 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) 4762 switch (list) 4763 { 4764 case OMP_LIST_PRIVATE: 4765 case OMP_LIST_LASTPRIVATE: 4766 case OMP_LIST_LINEAR: 4767 /* case OMP_LIST_REDUCTION: */ 4768 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L", 4769 n->sym->name, name, &n->where); 4770 break; 4771 default: 4772 break; 4773 } 4774 4775 switch (list) 4776 { 4777 case OMP_LIST_REDUCTION: 4778 switch (n->u.reduction_op) 4779 { 4780 case OMP_REDUCTION_PLUS: 4781 case OMP_REDUCTION_TIMES: 4782 case OMP_REDUCTION_MINUS: 4783 if (!gfc_numeric_ts (&n->sym->ts)) 4784 bad = true; 4785 break; 4786 case OMP_REDUCTION_AND: 4787 case OMP_REDUCTION_OR: 4788 case OMP_REDUCTION_EQV: 4789 case OMP_REDUCTION_NEQV: 4790 if (n->sym->ts.type != BT_LOGICAL) 4791 bad = true; 4792 break; 4793 case OMP_REDUCTION_MAX: 4794 case OMP_REDUCTION_MIN: 4795 if (n->sym->ts.type != BT_INTEGER 4796 && n->sym->ts.type != BT_REAL) 4797 bad = true; 4798 break; 4799 case OMP_REDUCTION_IAND: 4800 case OMP_REDUCTION_IOR: 4801 case OMP_REDUCTION_IEOR: 4802 if (n->sym->ts.type != BT_INTEGER) 4803 bad = true; 4804 break; 4805 case OMP_REDUCTION_USER: 4806 bad = true; 4807 break; 4808 default: 4809 break; 4810 } 4811 if (!bad) 4812 n->udr = NULL; 4813 else 4814 { 4815 const char *udr_name = NULL; 4816 if (n->udr) 4817 { 4818 udr_name = n->udr->udr->name; 4819 n->udr->udr 4820 = gfc_find_omp_udr (NULL, udr_name, 4821 &n->sym->ts); 4822 if (n->udr->udr == NULL) 4823 { 4824 free (n->udr); 4825 n->udr = NULL; 4826 } 4827 } 4828 if (n->udr == NULL) 4829 { 4830 if (udr_name == NULL) 4831 switch (n->u.reduction_op) 4832 { 4833 case OMP_REDUCTION_PLUS: 4834 case OMP_REDUCTION_TIMES: 4835 case OMP_REDUCTION_MINUS: 4836 case OMP_REDUCTION_AND: 4837 case OMP_REDUCTION_OR: 4838 case OMP_REDUCTION_EQV: 4839 case OMP_REDUCTION_NEQV: 4840 udr_name = gfc_op2string ((gfc_intrinsic_op) 4841 n->u.reduction_op); 4842 break; 4843 case OMP_REDUCTION_MAX: 4844 udr_name = "max"; 4845 break; 4846 case OMP_REDUCTION_MIN: 4847 udr_name = "min"; 4848 break; 4849 case OMP_REDUCTION_IAND: 4850 udr_name = "iand"; 4851 break; 4852 case OMP_REDUCTION_IOR: 4853 udr_name = "ior"; 4854 break; 4855 case OMP_REDUCTION_IEOR: 4856 udr_name = "ieor"; 4857 break; 4858 default: 4859 gcc_unreachable (); 4860 } 4861 gfc_error ("!$OMP DECLARE REDUCTION %s not found " 4862 "for type %s at %L", udr_name, 4863 gfc_typename (&n->sym->ts), &n->where); 4864 } 4865 else 4866 { 4867 gfc_omp_udr *udr = n->udr->udr; 4868 n->u.reduction_op = OMP_REDUCTION_USER; 4869 n->udr->combiner 4870 = resolve_omp_udr_clause (n, udr->combiner_ns, 4871 udr->omp_out, 4872 udr->omp_in); 4873 if (udr->initializer_ns) 4874 n->udr->initializer 4875 = resolve_omp_udr_clause (n, 4876 udr->initializer_ns, 4877 udr->omp_priv, 4878 udr->omp_orig); 4879 } 4880 } 4881 break; 4882 case OMP_LIST_LINEAR: 4883 if (code 4884 && n->u.linear_op != OMP_LINEAR_DEFAULT 4885 && n->u.linear_op != linear_op) 4886 { 4887 gfc_error ("LINEAR clause modifier used on DO or SIMD" 4888 " construct at %L", &n->where); 4889 linear_op = n->u.linear_op; 4890 } 4891 else if (omp_clauses->orderedc) 4892 gfc_error ("LINEAR clause specified together with " 4893 "ORDERED clause with argument at %L", 4894 &n->where); 4895 else if (n->u.linear_op != OMP_LINEAR_REF 4896 && n->sym->ts.type != BT_INTEGER) 4897 gfc_error ("LINEAR variable %qs must be INTEGER " 4898 "at %L", n->sym->name, &n->where); 4899 else if ((n->u.linear_op == OMP_LINEAR_REF 4900 || n->u.linear_op == OMP_LINEAR_UVAL) 4901 && n->sym->attr.value) 4902 gfc_error ("LINEAR dummy argument %qs with VALUE " 4903 "attribute with %s modifier at %L", 4904 n->sym->name, 4905 n->u.linear_op == OMP_LINEAR_REF 4906 ? "REF" : "UVAL", &n->where); 4907 else if (n->expr) 4908 { 4909 gfc_expr *expr = n->expr; 4910 if (!gfc_resolve_expr (expr) 4911 || expr->ts.type != BT_INTEGER 4912 || expr->rank != 0) 4913 gfc_error ("%qs in LINEAR clause at %L requires " 4914 "a scalar integer linear-step expression", 4915 n->sym->name, &n->where); 4916 else if (!code && expr->expr_type != EXPR_CONSTANT) 4917 { 4918 if (expr->expr_type == EXPR_VARIABLE 4919 && expr->symtree->n.sym->attr.dummy 4920 && expr->symtree->n.sym->ns == ns) 4921 { 4922 gfc_omp_namelist *n2; 4923 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM]; 4924 n2; n2 = n2->next) 4925 if (n2->sym == expr->symtree->n.sym) 4926 break; 4927 if (n2) 4928 break; 4929 } 4930 gfc_error ("%qs in LINEAR clause at %L requires " 4931 "a constant integer linear-step " 4932 "expression or dummy argument " 4933 "specified in UNIFORM clause", 4934 n->sym->name, &n->where); 4935 } 4936 } 4937 break; 4938 /* Workaround for PR middle-end/26316, nothing really needs 4939 to be done here for OMP_LIST_PRIVATE. */ 4940 case OMP_LIST_PRIVATE: 4941 gcc_assert (code && code->op != EXEC_NOP); 4942 break; 4943 case OMP_LIST_USE_DEVICE: 4944 if (n->sym->attr.allocatable 4945 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym) 4946 && CLASS_DATA (n->sym)->attr.allocatable)) 4947 gfc_error ("ALLOCATABLE object %qs in %s clause at %L", 4948 n->sym->name, name, &n->where); 4949 if (n->sym->ts.type == BT_CLASS 4950 && CLASS_DATA (n->sym) 4951 && CLASS_DATA (n->sym)->attr.class_pointer) 4952 gfc_error ("POINTER object %qs of polymorphic type in " 4953 "%s clause at %L", n->sym->name, name, 4954 &n->where); 4955 if (n->sym->attr.cray_pointer) 4956 gfc_error ("Cray pointer object %qs in %s clause at %L", 4957 n->sym->name, name, &n->where); 4958 else if (n->sym->attr.cray_pointee) 4959 gfc_error ("Cray pointee object %qs in %s clause at %L", 4960 n->sym->name, name, &n->where); 4961 else if (n->sym->attr.flavor == FL_VARIABLE 4962 && !n->sym->as 4963 && !n->sym->attr.pointer) 4964 gfc_error ("%s clause variable %qs at %L is neither " 4965 "a POINTER nor an array", name, 4966 n->sym->name, &n->where); 4967 /* FALLTHRU */ 4968 case OMP_LIST_DEVICE_RESIDENT: 4969 check_symbol_not_pointer (n->sym, n->where, name); 4970 check_array_not_assumed (n->sym, n->where, name); 4971 break; 4972 default: 4973 break; 4974 } 4975 } 4976 break; 4977 } 4978 } 4979 if (omp_clauses->safelen_expr) 4980 resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN"); 4981 if (omp_clauses->simdlen_expr) 4982 resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN"); 4983 if (omp_clauses->num_teams) 4984 resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS"); 4985 if (omp_clauses->device) 4986 resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); 4987 if (omp_clauses->hint) 4988 resolve_scalar_int_expr (omp_clauses->hint, "HINT"); 4989 if (omp_clauses->priority) 4990 resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY"); 4991 if (omp_clauses->dist_chunk_size) 4992 { 4993 gfc_expr *expr = omp_clauses->dist_chunk_size; 4994 if (!gfc_resolve_expr (expr) 4995 || expr->ts.type != BT_INTEGER || expr->rank != 0) 4996 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires " 4997 "a scalar INTEGER expression", &expr->where); 4998 } 4999 if (omp_clauses->thread_limit) 5000 resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT"); 5001 if (omp_clauses->grainsize) 5002 resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE"); 5003 if (omp_clauses->num_tasks) 5004 resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS"); 5005 if (omp_clauses->async) 5006 if (omp_clauses->async_expr) 5007 resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC"); 5008 if (omp_clauses->num_gangs_expr) 5009 resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS"); 5010 if (omp_clauses->num_workers_expr) 5011 resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS"); 5012 if (omp_clauses->vector_length_expr) 5013 resolve_positive_int_expr (omp_clauses->vector_length_expr, 5014 "VECTOR_LENGTH"); 5015 if (omp_clauses->gang_num_expr) 5016 resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG"); 5017 if (omp_clauses->gang_static_expr) 5018 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG"); 5019 if (omp_clauses->worker_expr) 5020 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER"); 5021 if (omp_clauses->vector_expr) 5022 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR"); 5023 for (el = omp_clauses->wait_list; el; el = el->next) 5024 resolve_scalar_int_expr (el->expr, "WAIT"); 5025 if (omp_clauses->collapse && omp_clauses->tile_list) 5026 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc); 5027 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) 5028 gfc_error ("SOURCE dependence type only allowed " 5029 "on ORDERED directive at %L", &code->loc); 5030 if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL) 5031 { 5032 const char *p = NULL; 5033 switch (code->op) 5034 { 5035 case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break; 5036 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break; 5037 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break; 5038 default: break; 5039 } 5040 if (p) 5041 gfc_error ("%s must contain at least one MAP clause at %L", 5042 p, &code->loc); 5043 } 5044} 5045 5046 5047/* Return true if SYM is ever referenced in EXPR except in the SE node. */ 5048 5049static bool 5050expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) 5051{ 5052 gfc_actual_arglist *arg; 5053 if (e == NULL || e == se) 5054 return false; 5055 switch (e->expr_type) 5056 { 5057 case EXPR_CONSTANT: 5058 case EXPR_NULL: 5059 case EXPR_VARIABLE: 5060 case EXPR_STRUCTURE: 5061 case EXPR_ARRAY: 5062 if (e->symtree != NULL 5063 && e->symtree->n.sym == s) 5064 return true; 5065 return false; 5066 case EXPR_SUBSTRING: 5067 if (e->ref != NULL 5068 && (expr_references_sym (e->ref->u.ss.start, s, se) 5069 || expr_references_sym (e->ref->u.ss.end, s, se))) 5070 return true; 5071 return false; 5072 case EXPR_OP: 5073 if (expr_references_sym (e->value.op.op2, s, se)) 5074 return true; 5075 return expr_references_sym (e->value.op.op1, s, se); 5076 case EXPR_FUNCTION: 5077 for (arg = e->value.function.actual; arg; arg = arg->next) 5078 if (expr_references_sym (arg->expr, s, se)) 5079 return true; 5080 return false; 5081 default: 5082 gcc_unreachable (); 5083 } 5084} 5085 5086 5087/* If EXPR is a conversion function that widens the type 5088 if WIDENING is true or narrows the type if WIDENING is false, 5089 return the inner expression, otherwise return NULL. */ 5090 5091static gfc_expr * 5092is_conversion (gfc_expr *expr, bool widening) 5093{ 5094 gfc_typespec *ts1, *ts2; 5095 5096 if (expr->expr_type != EXPR_FUNCTION 5097 || expr->value.function.isym == NULL 5098 || expr->value.function.esym != NULL 5099 || expr->value.function.isym->id != GFC_ISYM_CONVERSION) 5100 return NULL; 5101 5102 if (widening) 5103 { 5104 ts1 = &expr->ts; 5105 ts2 = &expr->value.function.actual->expr->ts; 5106 } 5107 else 5108 { 5109 ts1 = &expr->value.function.actual->expr->ts; 5110 ts2 = &expr->ts; 5111 } 5112 5113 if (ts1->type > ts2->type 5114 || (ts1->type == ts2->type && ts1->kind > ts2->kind)) 5115 return expr->value.function.actual->expr; 5116 5117 return NULL; 5118} 5119 5120 5121static void 5122resolve_omp_atomic (gfc_code *code) 5123{ 5124 gfc_code *atomic_code = code; 5125 gfc_symbol *var; 5126 gfc_expr *expr2, *expr2_tmp; 5127 gfc_omp_atomic_op aop 5128 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK); 5129 5130 code = code->block->next; 5131 /* resolve_blocks asserts this is initially EXEC_ASSIGN. 5132 If it changed to EXEC_NOP, assume an error has been emitted already. */ 5133 if (code->op == EXEC_NOP) 5134 return; 5135 if (code->op != EXEC_ASSIGN) 5136 { 5137 unexpected: 5138 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc); 5139 return; 5140 } 5141 if (aop != GFC_OMP_ATOMIC_CAPTURE) 5142 { 5143 if (code->next != NULL) 5144 goto unexpected; 5145 } 5146 else 5147 { 5148 if (code->next == NULL) 5149 goto unexpected; 5150 if (code->next->op == EXEC_NOP) 5151 return; 5152 if (code->next->op != EXEC_ASSIGN || code->next->next) 5153 { 5154 code = code->next; 5155 goto unexpected; 5156 } 5157 } 5158 5159 if (code->expr1->expr_type != EXPR_VARIABLE 5160 || code->expr1->symtree == NULL 5161 || code->expr1->rank != 0 5162 || (code->expr1->ts.type != BT_INTEGER 5163 && code->expr1->ts.type != BT_REAL 5164 && code->expr1->ts.type != BT_COMPLEX 5165 && code->expr1->ts.type != BT_LOGICAL)) 5166 { 5167 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " 5168 "intrinsic type at %L", &code->loc); 5169 return; 5170 } 5171 5172 var = code->expr1->symtree->n.sym; 5173 expr2 = is_conversion (code->expr2, false); 5174 if (expr2 == NULL) 5175 { 5176 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE) 5177 expr2 = is_conversion (code->expr2, true); 5178 if (expr2 == NULL) 5179 expr2 = code->expr2; 5180 } 5181 5182 switch (aop) 5183 { 5184 case GFC_OMP_ATOMIC_READ: 5185 if (expr2->expr_type != EXPR_VARIABLE 5186 || expr2->symtree == NULL 5187 || expr2->rank != 0 5188 || (expr2->ts.type != BT_INTEGER 5189 && expr2->ts.type != BT_REAL 5190 && expr2->ts.type != BT_COMPLEX 5191 && expr2->ts.type != BT_LOGICAL)) 5192 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar " 5193 "variable of intrinsic type at %L", &expr2->where); 5194 return; 5195 case GFC_OMP_ATOMIC_WRITE: 5196 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL)) 5197 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr " 5198 "must be scalar and cannot reference var at %L", 5199 &expr2->where); 5200 return; 5201 case GFC_OMP_ATOMIC_CAPTURE: 5202 expr2_tmp = expr2; 5203 if (expr2 == code->expr2) 5204 { 5205 expr2_tmp = is_conversion (code->expr2, true); 5206 if (expr2_tmp == NULL) 5207 expr2_tmp = expr2; 5208 } 5209 if (expr2_tmp->expr_type == EXPR_VARIABLE) 5210 { 5211 if (expr2_tmp->symtree == NULL 5212 || expr2_tmp->rank != 0 5213 || (expr2_tmp->ts.type != BT_INTEGER 5214 && expr2_tmp->ts.type != BT_REAL 5215 && expr2_tmp->ts.type != BT_COMPLEX 5216 && expr2_tmp->ts.type != BT_LOGICAL) 5217 || expr2_tmp->symtree->n.sym == var) 5218 { 5219 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from " 5220 "a scalar variable of intrinsic type at %L", 5221 &expr2_tmp->where); 5222 return; 5223 } 5224 var = expr2_tmp->symtree->n.sym; 5225 code = code->next; 5226 if (code->expr1->expr_type != EXPR_VARIABLE 5227 || code->expr1->symtree == NULL 5228 || code->expr1->rank != 0 5229 || (code->expr1->ts.type != BT_INTEGER 5230 && code->expr1->ts.type != BT_REAL 5231 && code->expr1->ts.type != BT_COMPLEX 5232 && code->expr1->ts.type != BT_LOGICAL)) 5233 { 5234 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set " 5235 "a scalar variable of intrinsic type at %L", 5236 &code->expr1->where); 5237 return; 5238 } 5239 if (code->expr1->symtree->n.sym != var) 5240 { 5241 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " 5242 "different variable than update statement writes " 5243 "into at %L", &code->expr1->where); 5244 return; 5245 } 5246 expr2 = is_conversion (code->expr2, false); 5247 if (expr2 == NULL) 5248 expr2 = code->expr2; 5249 } 5250 break; 5251 default: 5252 break; 5253 } 5254 5255 if (gfc_expr_attr (code->expr1).allocatable) 5256 { 5257 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L", 5258 &code->loc); 5259 return; 5260 } 5261 5262 if (aop == GFC_OMP_ATOMIC_CAPTURE 5263 && code->next == NULL 5264 && code->expr2->rank == 0 5265 && !expr_references_sym (code->expr2, var, NULL)) 5266 atomic_code->ext.omp_atomic 5267 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic 5268 | GFC_OMP_ATOMIC_SWAP); 5269 else if (expr2->expr_type == EXPR_OP) 5270 { 5271 gfc_expr *v = NULL, *e, *c; 5272 gfc_intrinsic_op op = expr2->value.op.op; 5273 gfc_intrinsic_op alt_op = INTRINSIC_NONE; 5274 5275 switch (op) 5276 { 5277 case INTRINSIC_PLUS: 5278 alt_op = INTRINSIC_MINUS; 5279 break; 5280 case INTRINSIC_TIMES: 5281 alt_op = INTRINSIC_DIVIDE; 5282 break; 5283 case INTRINSIC_MINUS: 5284 alt_op = INTRINSIC_PLUS; 5285 break; 5286 case INTRINSIC_DIVIDE: 5287 alt_op = INTRINSIC_TIMES; 5288 break; 5289 case INTRINSIC_AND: 5290 case INTRINSIC_OR: 5291 break; 5292 case INTRINSIC_EQV: 5293 alt_op = INTRINSIC_NEQV; 5294 break; 5295 case INTRINSIC_NEQV: 5296 alt_op = INTRINSIC_EQV; 5297 break; 5298 default: 5299 gfc_error ("!$OMP ATOMIC assignment operator must be binary " 5300 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", 5301 &expr2->where); 5302 return; 5303 } 5304 5305 /* Check for var = var op expr resp. var = expr op var where 5306 expr doesn't reference var and var op expr is mathematically 5307 equivalent to var op (expr) resp. expr op var equivalent to 5308 (expr) op var. We rely here on the fact that the matcher 5309 for x op1 y op2 z where op1 and op2 have equal precedence 5310 returns (x op1 y) op2 z. */ 5311 e = expr2->value.op.op2; 5312 if (e->expr_type == EXPR_VARIABLE 5313 && e->symtree != NULL 5314 && e->symtree->n.sym == var) 5315 v = e; 5316 else if ((c = is_conversion (e, true)) != NULL 5317 && c->expr_type == EXPR_VARIABLE 5318 && c->symtree != NULL 5319 && c->symtree->n.sym == var) 5320 v = c; 5321 else 5322 { 5323 gfc_expr **p = NULL, **q; 5324 for (q = &expr2->value.op.op1; (e = *q) != NULL; ) 5325 if (e->expr_type == EXPR_VARIABLE 5326 && e->symtree != NULL 5327 && e->symtree->n.sym == var) 5328 { 5329 v = e; 5330 break; 5331 } 5332 else if ((c = is_conversion (e, true)) != NULL) 5333 q = &e->value.function.actual->expr; 5334 else if (e->expr_type != EXPR_OP 5335 || (e->value.op.op != op 5336 && e->value.op.op != alt_op) 5337 || e->rank != 0) 5338 break; 5339 else 5340 { 5341 p = q; 5342 q = &e->value.op.op1; 5343 } 5344 5345 if (v == NULL) 5346 { 5347 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " 5348 "or var = expr op var at %L", &expr2->where); 5349 return; 5350 } 5351 5352 if (p != NULL) 5353 { 5354 e = *p; 5355 switch (e->value.op.op) 5356 { 5357 case INTRINSIC_MINUS: 5358 case INTRINSIC_DIVIDE: 5359 case INTRINSIC_EQV: 5360 case INTRINSIC_NEQV: 5361 gfc_error ("!$OMP ATOMIC var = var op expr not " 5362 "mathematically equivalent to var = var op " 5363 "(expr) at %L", &expr2->where); 5364 break; 5365 default: 5366 break; 5367 } 5368 5369 /* Canonicalize into var = var op (expr). */ 5370 *p = e->value.op.op2; 5371 e->value.op.op2 = expr2; 5372 e->ts = expr2->ts; 5373 if (code->expr2 == expr2) 5374 code->expr2 = expr2 = e; 5375 else 5376 code->expr2->value.function.actual->expr = expr2 = e; 5377 5378 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts)) 5379 { 5380 for (p = &expr2->value.op.op1; *p != v; 5381 p = &(*p)->value.function.actual->expr) 5382 ; 5383 *p = NULL; 5384 gfc_free_expr (expr2->value.op.op1); 5385 expr2->value.op.op1 = v; 5386 gfc_convert_type (v, &expr2->ts, 2); 5387 } 5388 } 5389 } 5390 5391 if (e->rank != 0 || expr_references_sym (code->expr2, var, v)) 5392 { 5393 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " 5394 "must be scalar and cannot reference var at %L", 5395 &expr2->where); 5396 return; 5397 } 5398 } 5399 else if (expr2->expr_type == EXPR_FUNCTION 5400 && expr2->value.function.isym != NULL 5401 && expr2->value.function.esym == NULL 5402 && expr2->value.function.actual != NULL 5403 && expr2->value.function.actual->next != NULL) 5404 { 5405 gfc_actual_arglist *arg, *var_arg; 5406 5407 switch (expr2->value.function.isym->id) 5408 { 5409 case GFC_ISYM_MIN: 5410 case GFC_ISYM_MAX: 5411 break; 5412 case GFC_ISYM_IAND: 5413 case GFC_ISYM_IOR: 5414 case GFC_ISYM_IEOR: 5415 if (expr2->value.function.actual->next->next != NULL) 5416 { 5417 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " 5418 "or IEOR must have two arguments at %L", 5419 &expr2->where); 5420 return; 5421 } 5422 break; 5423 default: 5424 gfc_error ("!$OMP ATOMIC assignment intrinsic must be " 5425 "MIN, MAX, IAND, IOR or IEOR at %L", 5426 &expr2->where); 5427 return; 5428 } 5429 5430 var_arg = NULL; 5431 for (arg = expr2->value.function.actual; arg; arg = arg->next) 5432 { 5433 if ((arg == expr2->value.function.actual 5434 || (var_arg == NULL && arg->next == NULL)) 5435 && arg->expr->expr_type == EXPR_VARIABLE 5436 && arg->expr->symtree != NULL 5437 && arg->expr->symtree->n.sym == var) 5438 var_arg = arg; 5439 else if (expr_references_sym (arg->expr, var, NULL)) 5440 { 5441 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " 5442 "not reference %qs at %L", 5443 var->name, &arg->expr->where); 5444 return; 5445 } 5446 if (arg->expr->rank != 0) 5447 { 5448 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar " 5449 "at %L", &arg->expr->where); 5450 return; 5451 } 5452 } 5453 5454 if (var_arg == NULL) 5455 { 5456 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " 5457 "be %qs at %L", var->name, &expr2->where); 5458 return; 5459 } 5460 5461 if (var_arg != expr2->value.function.actual) 5462 { 5463 /* Canonicalize, so that var comes first. */ 5464 gcc_assert (var_arg->next == NULL); 5465 for (arg = expr2->value.function.actual; 5466 arg->next != var_arg; arg = arg->next) 5467 ; 5468 var_arg->next = expr2->value.function.actual; 5469 expr2->value.function.actual = var_arg; 5470 arg->next = NULL; 5471 } 5472 } 5473 else 5474 gfc_error ("!$OMP ATOMIC assignment must have an operator or " 5475 "intrinsic on right hand side at %L", &expr2->where); 5476 5477 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next) 5478 { 5479 code = code->next; 5480 if (code->expr1->expr_type != EXPR_VARIABLE 5481 || code->expr1->symtree == NULL 5482 || code->expr1->rank != 0 5483 || (code->expr1->ts.type != BT_INTEGER 5484 && code->expr1->ts.type != BT_REAL 5485 && code->expr1->ts.type != BT_COMPLEX 5486 && code->expr1->ts.type != BT_LOGICAL)) 5487 { 5488 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set " 5489 "a scalar variable of intrinsic type at %L", 5490 &code->expr1->where); 5491 return; 5492 } 5493 5494 expr2 = is_conversion (code->expr2, false); 5495 if (expr2 == NULL) 5496 { 5497 expr2 = is_conversion (code->expr2, true); 5498 if (expr2 == NULL) 5499 expr2 = code->expr2; 5500 } 5501 5502 if (expr2->expr_type != EXPR_VARIABLE 5503 || expr2->symtree == NULL 5504 || expr2->rank != 0 5505 || (expr2->ts.type != BT_INTEGER 5506 && expr2->ts.type != BT_REAL 5507 && expr2->ts.type != BT_COMPLEX 5508 && expr2->ts.type != BT_LOGICAL)) 5509 { 5510 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read " 5511 "from a scalar variable of intrinsic type at %L", 5512 &expr2->where); 5513 return; 5514 } 5515 if (expr2->symtree->n.sym != var) 5516 { 5517 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " 5518 "different variable than update statement writes " 5519 "into at %L", &expr2->where); 5520 return; 5521 } 5522 } 5523} 5524 5525 5526static struct fortran_omp_context 5527{ 5528 gfc_code *code; 5529 hash_set<gfc_symbol *> *sharing_clauses; 5530 hash_set<gfc_symbol *> *private_iterators; 5531 struct fortran_omp_context *previous; 5532 bool is_openmp; 5533} *omp_current_ctx; 5534static gfc_code *omp_current_do_code; 5535static int omp_current_do_collapse; 5536 5537void 5538gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) 5539{ 5540 if (code->block->next && code->block->next->op == EXEC_DO) 5541 { 5542 int i; 5543 gfc_code *c; 5544 5545 omp_current_do_code = code->block->next; 5546 if (code->ext.omp_clauses->orderedc) 5547 omp_current_do_collapse = code->ext.omp_clauses->orderedc; 5548 else 5549 omp_current_do_collapse = code->ext.omp_clauses->collapse; 5550 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++) 5551 { 5552 c = c->block; 5553 if (c->op != EXEC_DO || c->next == NULL) 5554 break; 5555 c = c->next; 5556 if (c->op != EXEC_DO) 5557 break; 5558 } 5559 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0) 5560 omp_current_do_collapse = 1; 5561 } 5562 gfc_resolve_blocks (code->block, ns); 5563 omp_current_do_collapse = 0; 5564 omp_current_do_code = NULL; 5565} 5566 5567 5568void 5569gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) 5570{ 5571 struct fortran_omp_context ctx; 5572 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; 5573 gfc_omp_namelist *n; 5574 int list; 5575 5576 ctx.code = code; 5577 ctx.sharing_clauses = new hash_set<gfc_symbol *>; 5578 ctx.private_iterators = new hash_set<gfc_symbol *>; 5579 ctx.previous = omp_current_ctx; 5580 ctx.is_openmp = true; 5581 omp_current_ctx = &ctx; 5582 5583 for (list = 0; list < OMP_LIST_NUM; list++) 5584 switch (list) 5585 { 5586 case OMP_LIST_SHARED: 5587 case OMP_LIST_PRIVATE: 5588 case OMP_LIST_FIRSTPRIVATE: 5589 case OMP_LIST_LASTPRIVATE: 5590 case OMP_LIST_REDUCTION: 5591 case OMP_LIST_LINEAR: 5592 for (n = omp_clauses->lists[list]; n; n = n->next) 5593 ctx.sharing_clauses->add (n->sym); 5594 break; 5595 default: 5596 break; 5597 } 5598 5599 switch (code->op) 5600 { 5601 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 5602 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5603 case EXEC_OMP_PARALLEL_DO: 5604 case EXEC_OMP_PARALLEL_DO_SIMD: 5605 case EXEC_OMP_TARGET_PARALLEL_DO: 5606 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 5607 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 5608 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5609 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5610 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5611 case EXEC_OMP_TASKLOOP: 5612 case EXEC_OMP_TASKLOOP_SIMD: 5613 case EXEC_OMP_TEAMS_DISTRIBUTE: 5614 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5615 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5616 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 5617 gfc_resolve_omp_do_blocks (code, ns); 5618 break; 5619 default: 5620 gfc_resolve_blocks (code->block, ns); 5621 } 5622 5623 omp_current_ctx = ctx.previous; 5624 delete ctx.sharing_clauses; 5625 delete ctx.private_iterators; 5626} 5627 5628 5629/* Save and clear openmp.c private state. */ 5630 5631void 5632gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state) 5633{ 5634 state->ptrs[0] = omp_current_ctx; 5635 state->ptrs[1] = omp_current_do_code; 5636 state->ints[0] = omp_current_do_collapse; 5637 omp_current_ctx = NULL; 5638 omp_current_do_code = NULL; 5639 omp_current_do_collapse = 0; 5640} 5641 5642 5643/* Restore openmp.c private state from the saved state. */ 5644 5645void 5646gfc_omp_restore_state (struct gfc_omp_saved_state *state) 5647{ 5648 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0]; 5649 omp_current_do_code = (gfc_code *) state->ptrs[1]; 5650 omp_current_do_collapse = state->ints[0]; 5651} 5652 5653 5654/* Note a DO iterator variable. This is special in !$omp parallel 5655 construct, where they are predetermined private. */ 5656 5657void 5658gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) 5659{ 5660 if (omp_current_ctx == NULL) 5661 return; 5662 5663 int i = omp_current_do_collapse; 5664 gfc_code *c = omp_current_do_code; 5665 5666 if (sym->attr.threadprivate) 5667 return; 5668 5669 /* !$omp do and !$omp parallel do iteration variable is predetermined 5670 private just in the !$omp do resp. !$omp parallel do construct, 5671 with no implications for the outer parallel constructs. */ 5672 5673 while (i-- >= 1) 5674 { 5675 if (code == c) 5676 return; 5677 5678 c = c->block->next; 5679 } 5680 5681 /* An openacc context may represent a data clause. Abort if so. */ 5682 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code)) 5683 return; 5684 5685 if (omp_current_ctx->sharing_clauses->contains (sym)) 5686 return; 5687 5688 if (! omp_current_ctx->private_iterators->add (sym) && add_clause) 5689 { 5690 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; 5691 gfc_omp_namelist *p; 5692 5693 p = gfc_get_omp_namelist (); 5694 p->sym = sym; 5695 p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; 5696 omp_clauses->lists[OMP_LIST_PRIVATE] = p; 5697 } 5698} 5699 5700static void 5701handle_local_var (gfc_symbol *sym) 5702{ 5703 if (sym->attr.flavor != FL_VARIABLE 5704 || sym->as != NULL 5705 || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL)) 5706 return; 5707 gfc_resolve_do_iterator (sym->ns->code, sym, false); 5708} 5709 5710void 5711gfc_resolve_omp_local_vars (gfc_namespace *ns) 5712{ 5713 if (omp_current_ctx) 5714 gfc_traverse_ns (ns, handle_local_var); 5715} 5716 5717static void 5718resolve_omp_do (gfc_code *code) 5719{ 5720 gfc_code *do_code, *c; 5721 int list, i, collapse; 5722 gfc_omp_namelist *n; 5723 gfc_symbol *dovar; 5724 const char *name; 5725 bool is_simd = false; 5726 5727 switch (code->op) 5728 { 5729 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break; 5730 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 5731 name = "!$OMP DISTRIBUTE PARALLEL DO"; 5732 break; 5733 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5734 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; 5735 is_simd = true; 5736 break; 5737 case EXEC_OMP_DISTRIBUTE_SIMD: 5738 name = "!$OMP DISTRIBUTE SIMD"; 5739 is_simd = true; 5740 break; 5741 case EXEC_OMP_DO: name = "!$OMP DO"; break; 5742 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break; 5743 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break; 5744 case EXEC_OMP_PARALLEL_DO_SIMD: 5745 name = "!$OMP PARALLEL DO SIMD"; 5746 is_simd = true; 5747 break; 5748 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break; 5749 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break; 5750 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 5751 name = "!$OMP TARGET PARALLEL DO SIMD"; 5752 is_simd = true; 5753 break; 5754 case EXEC_OMP_TARGET_SIMD: 5755 name = "!$OMP TARGET SIMD"; 5756 is_simd = true; 5757 break; 5758 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 5759 name = "!$OMP TARGET TEAMS DISTRIBUTE"; 5760 break; 5761 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5762 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; 5763 break; 5764 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5765 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; 5766 is_simd = true; 5767 break; 5768 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5769 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; 5770 is_simd = true; 5771 break; 5772 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break; 5773 case EXEC_OMP_TASKLOOP_SIMD: 5774 name = "!$OMP TASKLOOP SIMD"; 5775 is_simd = true; 5776 break; 5777 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break; 5778 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5779 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; 5780 break; 5781 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5782 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; 5783 is_simd = true; 5784 break; 5785 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 5786 name = "!$OMP TEAMS DISTRIBUTE SIMD"; 5787 is_simd = true; 5788 break; 5789 default: gcc_unreachable (); 5790 } 5791 5792 if (code->ext.omp_clauses) 5793 resolve_omp_clauses (code, code->ext.omp_clauses, NULL); 5794 5795 do_code = code->block->next; 5796 if (code->ext.omp_clauses->orderedc) 5797 collapse = code->ext.omp_clauses->orderedc; 5798 else 5799 { 5800 collapse = code->ext.omp_clauses->collapse; 5801 if (collapse <= 0) 5802 collapse = 1; 5803 } 5804 for (i = 1; i <= collapse; i++) 5805 { 5806 if (do_code->op == EXEC_DO_WHILE) 5807 { 5808 gfc_error ("%s cannot be a DO WHILE or DO without loop control " 5809 "at %L", name, &do_code->loc); 5810 break; 5811 } 5812 if (do_code->op == EXEC_DO_CONCURRENT) 5813 { 5814 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name, 5815 &do_code->loc); 5816 break; 5817 } 5818 gcc_assert (do_code->op == EXEC_DO); 5819 if (do_code->ext.iterator->var->ts.type != BT_INTEGER) 5820 gfc_error ("%s iteration variable must be of type integer at %L", 5821 name, &do_code->loc); 5822 dovar = do_code->ext.iterator->var->symtree->n.sym; 5823 if (dovar->attr.threadprivate) 5824 gfc_error ("%s iteration variable must not be THREADPRIVATE " 5825 "at %L", name, &do_code->loc); 5826 if (code->ext.omp_clauses) 5827 for (list = 0; list < OMP_LIST_NUM; list++) 5828 if (!is_simd 5829 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE) 5830 : code->ext.omp_clauses->collapse > 1 5831 ? (list != OMP_LIST_LASTPRIVATE) 5832 : (list != OMP_LIST_LINEAR)) 5833 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) 5834 if (dovar == n->sym) 5835 { 5836 if (!is_simd) 5837 gfc_error ("%s iteration variable present on clause " 5838 "other than PRIVATE or LASTPRIVATE at %L", 5839 name, &do_code->loc); 5840 else if (code->ext.omp_clauses->collapse > 1) 5841 gfc_error ("%s iteration variable present on clause " 5842 "other than LASTPRIVATE at %L", 5843 name, &do_code->loc); 5844 else 5845 gfc_error ("%s iteration variable present on clause " 5846 "other than LINEAR at %L", 5847 name, &do_code->loc); 5848 break; 5849 } 5850 if (i > 1) 5851 { 5852 gfc_code *do_code2 = code->block->next; 5853 int j; 5854 5855 for (j = 1; j < i; j++) 5856 { 5857 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; 5858 if (dovar == ivar 5859 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) 5860 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) 5861 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) 5862 { 5863 gfc_error ("%s collapsed loops don't form rectangular " 5864 "iteration space at %L", name, &do_code->loc); 5865 break; 5866 } 5867 do_code2 = do_code2->block->next; 5868 } 5869 } 5870 if (i == collapse) 5871 break; 5872 for (c = do_code->next; c; c = c->next) 5873 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) 5874 { 5875 gfc_error ("collapsed %s loops not perfectly nested at %L", 5876 name, &c->loc); 5877 break; 5878 } 5879 if (c) 5880 break; 5881 do_code = do_code->block; 5882 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) 5883 { 5884 gfc_error ("not enough DO loops for collapsed %s at %L", 5885 name, &code->loc); 5886 break; 5887 } 5888 do_code = do_code->next; 5889 if (do_code == NULL 5890 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)) 5891 { 5892 gfc_error ("not enough DO loops for collapsed %s at %L", 5893 name, &code->loc); 5894 break; 5895 } 5896 } 5897} 5898 5899 5900static gfc_statement 5901omp_code_to_statement (gfc_code *code) 5902{ 5903 switch (code->op) 5904 { 5905 case EXEC_OMP_PARALLEL: 5906 return ST_OMP_PARALLEL; 5907 case EXEC_OMP_PARALLEL_SECTIONS: 5908 return ST_OMP_PARALLEL_SECTIONS; 5909 case EXEC_OMP_SECTIONS: 5910 return ST_OMP_SECTIONS; 5911 case EXEC_OMP_ORDERED: 5912 return ST_OMP_ORDERED; 5913 case EXEC_OMP_CRITICAL: 5914 return ST_OMP_CRITICAL; 5915 case EXEC_OMP_MASTER: 5916 return ST_OMP_MASTER; 5917 case EXEC_OMP_SINGLE: 5918 return ST_OMP_SINGLE; 5919 case EXEC_OMP_TASK: 5920 return ST_OMP_TASK; 5921 case EXEC_OMP_WORKSHARE: 5922 return ST_OMP_WORKSHARE; 5923 case EXEC_OMP_PARALLEL_WORKSHARE: 5924 return ST_OMP_PARALLEL_WORKSHARE; 5925 case EXEC_OMP_DO: 5926 return ST_OMP_DO; 5927 case EXEC_OMP_ATOMIC: 5928 return ST_OMP_ATOMIC; 5929 case EXEC_OMP_BARRIER: 5930 return ST_OMP_BARRIER; 5931 case EXEC_OMP_CANCEL: 5932 return ST_OMP_CANCEL; 5933 case EXEC_OMP_CANCELLATION_POINT: 5934 return ST_OMP_CANCELLATION_POINT; 5935 case EXEC_OMP_FLUSH: 5936 return ST_OMP_FLUSH; 5937 case EXEC_OMP_DISTRIBUTE: 5938 return ST_OMP_DISTRIBUTE; 5939 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 5940 return ST_OMP_DISTRIBUTE_PARALLEL_DO; 5941 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5942 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD; 5943 case EXEC_OMP_DISTRIBUTE_SIMD: 5944 return ST_OMP_DISTRIBUTE_SIMD; 5945 case EXEC_OMP_DO_SIMD: 5946 return ST_OMP_DO_SIMD; 5947 case EXEC_OMP_SIMD: 5948 return ST_OMP_SIMD; 5949 case EXEC_OMP_TARGET: 5950 return ST_OMP_TARGET; 5951 case EXEC_OMP_TARGET_DATA: 5952 return ST_OMP_TARGET_DATA; 5953 case EXEC_OMP_TARGET_ENTER_DATA: 5954 return ST_OMP_TARGET_ENTER_DATA; 5955 case EXEC_OMP_TARGET_EXIT_DATA: 5956 return ST_OMP_TARGET_EXIT_DATA; 5957 case EXEC_OMP_TARGET_PARALLEL: 5958 return ST_OMP_TARGET_PARALLEL; 5959 case EXEC_OMP_TARGET_PARALLEL_DO: 5960 return ST_OMP_TARGET_PARALLEL_DO; 5961 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 5962 return ST_OMP_TARGET_PARALLEL_DO_SIMD; 5963 case EXEC_OMP_TARGET_SIMD: 5964 return ST_OMP_TARGET_SIMD; 5965 case EXEC_OMP_TARGET_TEAMS: 5966 return ST_OMP_TARGET_TEAMS; 5967 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 5968 return ST_OMP_TARGET_TEAMS_DISTRIBUTE; 5969 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5970 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; 5971 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5972 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; 5973 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5974 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD; 5975 case EXEC_OMP_TARGET_UPDATE: 5976 return ST_OMP_TARGET_UPDATE; 5977 case EXEC_OMP_TASKGROUP: 5978 return ST_OMP_TASKGROUP; 5979 case EXEC_OMP_TASKLOOP: 5980 return ST_OMP_TASKLOOP; 5981 case EXEC_OMP_TASKLOOP_SIMD: 5982 return ST_OMP_TASKLOOP_SIMD; 5983 case EXEC_OMP_TASKWAIT: 5984 return ST_OMP_TASKWAIT; 5985 case EXEC_OMP_TASKYIELD: 5986 return ST_OMP_TASKYIELD; 5987 case EXEC_OMP_TEAMS: 5988 return ST_OMP_TEAMS; 5989 case EXEC_OMP_TEAMS_DISTRIBUTE: 5990 return ST_OMP_TEAMS_DISTRIBUTE; 5991 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5992 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO; 5993 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5994 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; 5995 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 5996 return ST_OMP_TEAMS_DISTRIBUTE_SIMD; 5997 case EXEC_OMP_PARALLEL_DO: 5998 return ST_OMP_PARALLEL_DO; 5999 case EXEC_OMP_PARALLEL_DO_SIMD: 6000 return ST_OMP_PARALLEL_DO_SIMD; 6001 6002 default: 6003 gcc_unreachable (); 6004 } 6005} 6006 6007static gfc_statement 6008oacc_code_to_statement (gfc_code *code) 6009{ 6010 switch (code->op) 6011 { 6012 case EXEC_OACC_PARALLEL: 6013 return ST_OACC_PARALLEL; 6014 case EXEC_OACC_KERNELS: 6015 return ST_OACC_KERNELS; 6016 case EXEC_OACC_SERIAL: 6017 return ST_OACC_SERIAL; 6018 case EXEC_OACC_DATA: 6019 return ST_OACC_DATA; 6020 case EXEC_OACC_HOST_DATA: 6021 return ST_OACC_HOST_DATA; 6022 case EXEC_OACC_PARALLEL_LOOP: 6023 return ST_OACC_PARALLEL_LOOP; 6024 case EXEC_OACC_KERNELS_LOOP: 6025 return ST_OACC_KERNELS_LOOP; 6026 case EXEC_OACC_SERIAL_LOOP: 6027 return ST_OACC_SERIAL_LOOP; 6028 case EXEC_OACC_LOOP: 6029 return ST_OACC_LOOP; 6030 case EXEC_OACC_ATOMIC: 6031 return ST_OACC_ATOMIC; 6032 case EXEC_OACC_ROUTINE: 6033 return ST_OACC_ROUTINE; 6034 case EXEC_OACC_UPDATE: 6035 return ST_OACC_UPDATE; 6036 case EXEC_OACC_WAIT: 6037 return ST_OACC_WAIT; 6038 case EXEC_OACC_CACHE: 6039 return ST_OACC_CACHE; 6040 case EXEC_OACC_ENTER_DATA: 6041 return ST_OACC_ENTER_DATA; 6042 case EXEC_OACC_EXIT_DATA: 6043 return ST_OACC_EXIT_DATA; 6044 case EXEC_OACC_DECLARE: 6045 return ST_OACC_DECLARE; 6046 default: 6047 gcc_unreachable (); 6048 } 6049} 6050 6051static void 6052resolve_oacc_directive_inside_omp_region (gfc_code *code) 6053{ 6054 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp) 6055 { 6056 gfc_statement st = omp_code_to_statement (omp_current_ctx->code); 6057 gfc_statement oacc_st = oacc_code_to_statement (code); 6058 gfc_error ("The %s directive cannot be specified within " 6059 "a %s region at %L", gfc_ascii_statement (oacc_st), 6060 gfc_ascii_statement (st), &code->loc); 6061 } 6062} 6063 6064static void 6065resolve_omp_directive_inside_oacc_region (gfc_code *code) 6066{ 6067 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp) 6068 { 6069 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code); 6070 gfc_statement omp_st = omp_code_to_statement (code); 6071 gfc_error ("The %s directive cannot be specified within " 6072 "a %s region at %L", gfc_ascii_statement (omp_st), 6073 gfc_ascii_statement (st), &code->loc); 6074 } 6075} 6076 6077 6078static void 6079resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse, 6080 const char *clause) 6081{ 6082 gfc_symbol *dovar; 6083 gfc_code *c; 6084 int i; 6085 6086 for (i = 1; i <= collapse; i++) 6087 { 6088 if (do_code->op == EXEC_DO_WHILE) 6089 { 6090 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control " 6091 "at %L", &do_code->loc); 6092 break; 6093 } 6094 if (do_code->op == EXEC_DO_CONCURRENT) 6095 { 6096 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L", 6097 &do_code->loc); 6098 break; 6099 } 6100 gcc_assert (do_code->op == EXEC_DO); 6101 if (do_code->ext.iterator->var->ts.type != BT_INTEGER) 6102 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L", 6103 &do_code->loc); 6104 dovar = do_code->ext.iterator->var->symtree->n.sym; 6105 if (i > 1) 6106 { 6107 gfc_code *do_code2 = code->block->next; 6108 int j; 6109 6110 for (j = 1; j < i; j++) 6111 { 6112 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; 6113 if (dovar == ivar 6114 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) 6115 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) 6116 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) 6117 { 6118 gfc_error ("!$ACC LOOP %s loops don't form rectangular " 6119 "iteration space at %L", clause, &do_code->loc); 6120 break; 6121 } 6122 do_code2 = do_code2->block->next; 6123 } 6124 } 6125 if (i == collapse) 6126 break; 6127 for (c = do_code->next; c; c = c->next) 6128 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) 6129 { 6130 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L", 6131 clause, &c->loc); 6132 break; 6133 } 6134 if (c) 6135 break; 6136 do_code = do_code->block; 6137 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE 6138 && do_code->op != EXEC_DO_CONCURRENT) 6139 { 6140 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", 6141 clause, &code->loc); 6142 break; 6143 } 6144 do_code = do_code->next; 6145 if (do_code == NULL 6146 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE 6147 && do_code->op != EXEC_DO_CONCURRENT)) 6148 { 6149 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", 6150 clause, &code->loc); 6151 break; 6152 } 6153 } 6154} 6155 6156 6157static void 6158resolve_oacc_loop_blocks (gfc_code *code) 6159{ 6160 if (!oacc_is_loop (code)) 6161 return; 6162 6163 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang 6164 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) 6165 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and " 6166 "vectors at the same time at %L", &code->loc); 6167 6168 if (code->ext.omp_clauses->tile_list) 6169 { 6170 gfc_expr_list *el; 6171 for (el = code->ext.omp_clauses->tile_list; el; el = el->next) 6172 { 6173 if (el->expr == NULL) 6174 { 6175 /* NULL expressions are used to represent '*' arguments. 6176 Convert those to a 0 expressions. */ 6177 el->expr = gfc_get_constant_expr (BT_INTEGER, 6178 gfc_default_integer_kind, 6179 &code->loc); 6180 mpz_set_si (el->expr->value.integer, 0); 6181 } 6182 else 6183 { 6184 resolve_positive_int_expr (el->expr, "TILE"); 6185 if (el->expr->expr_type != EXPR_CONSTANT) 6186 gfc_error ("TILE requires constant expression at %L", 6187 &code->loc); 6188 } 6189 } 6190 } 6191} 6192 6193 6194void 6195gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) 6196{ 6197 fortran_omp_context ctx; 6198 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; 6199 gfc_omp_namelist *n; 6200 int list; 6201 6202 resolve_oacc_loop_blocks (code); 6203 6204 ctx.code = code; 6205 ctx.sharing_clauses = new hash_set<gfc_symbol *>; 6206 ctx.private_iterators = new hash_set<gfc_symbol *>; 6207 ctx.previous = omp_current_ctx; 6208 ctx.is_openmp = false; 6209 omp_current_ctx = &ctx; 6210 6211 for (list = 0; list < OMP_LIST_NUM; list++) 6212 switch (list) 6213 { 6214 case OMP_LIST_PRIVATE: 6215 for (n = omp_clauses->lists[list]; n; n = n->next) 6216 ctx.sharing_clauses->add (n->sym); 6217 break; 6218 default: 6219 break; 6220 } 6221 6222 gfc_resolve_blocks (code->block, ns); 6223 6224 omp_current_ctx = ctx.previous; 6225 delete ctx.sharing_clauses; 6226 delete ctx.private_iterators; 6227} 6228 6229 6230static void 6231resolve_oacc_loop (gfc_code *code) 6232{ 6233 gfc_code *do_code; 6234 int collapse; 6235 6236 if (code->ext.omp_clauses) 6237 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); 6238 6239 do_code = code->block->next; 6240 collapse = code->ext.omp_clauses->collapse; 6241 6242 /* Both collapsed and tiled loops are lowered the same way, but are not 6243 compatible. In gfc_trans_omp_do, the tile is prioritized. */ 6244 if (code->ext.omp_clauses->tile_list) 6245 { 6246 int num = 0; 6247 gfc_expr_list *el; 6248 for (el = code->ext.omp_clauses->tile_list; el; el = el->next) 6249 ++num; 6250 resolve_oacc_nested_loops (code, code->block->next, num, "tiled"); 6251 return; 6252 } 6253 6254 if (collapse <= 0) 6255 collapse = 1; 6256 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed"); 6257} 6258 6259void 6260gfc_resolve_oacc_declare (gfc_namespace *ns) 6261{ 6262 int list; 6263 gfc_omp_namelist *n; 6264 gfc_oacc_declare *oc; 6265 6266 if (ns->oacc_declare == NULL) 6267 return; 6268 6269 for (oc = ns->oacc_declare; oc; oc = oc->next) 6270 { 6271 for (list = 0; list < OMP_LIST_NUM; list++) 6272 for (n = oc->clauses->lists[list]; n; n = n->next) 6273 { 6274 n->sym->mark = 0; 6275 if (n->sym->attr.flavor != FL_VARIABLE 6276 && (n->sym->attr.flavor != FL_PROCEDURE 6277 || n->sym->result != n->sym)) 6278 { 6279 gfc_error ("Object %qs is not a variable at %L", 6280 n->sym->name, &oc->loc); 6281 continue; 6282 } 6283 6284 if (n->expr && n->expr->ref->type == REF_ARRAY) 6285 { 6286 gfc_error ("Array sections: %qs not allowed in" 6287 " !$ACC DECLARE at %L", n->sym->name, &oc->loc); 6288 continue; 6289 } 6290 } 6291 6292 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next) 6293 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT"); 6294 } 6295 6296 for (oc = ns->oacc_declare; oc; oc = oc->next) 6297 { 6298 for (list = 0; list < OMP_LIST_NUM; list++) 6299 for (n = oc->clauses->lists[list]; n; n = n->next) 6300 { 6301 if (n->sym->mark) 6302 { 6303 gfc_error ("Symbol %qs present on multiple clauses at %L", 6304 n->sym->name, &oc->loc); 6305 continue; 6306 } 6307 else 6308 n->sym->mark = 1; 6309 } 6310 } 6311 6312 for (oc = ns->oacc_declare; oc; oc = oc->next) 6313 { 6314 for (list = 0; list < OMP_LIST_NUM; list++) 6315 for (n = oc->clauses->lists[list]; n; n = n->next) 6316 n->sym->mark = 0; 6317 } 6318} 6319 6320 6321void 6322gfc_resolve_oacc_routines (gfc_namespace *ns) 6323{ 6324 for (gfc_oacc_routine_name *orn = ns->oacc_routine_names; 6325 orn; 6326 orn = orn->next) 6327 { 6328 gfc_symbol *sym = orn->sym; 6329 if (!sym->attr.external 6330 && !sym->attr.function 6331 && !sym->attr.subroutine) 6332 { 6333 gfc_error ("NAME %qs does not refer to a subroutine or function" 6334 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); 6335 continue; 6336 } 6337 if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc)) 6338 { 6339 gfc_error ("NAME %qs invalid" 6340 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); 6341 continue; 6342 } 6343 } 6344} 6345 6346 6347void 6348gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) 6349{ 6350 resolve_oacc_directive_inside_omp_region (code); 6351 6352 switch (code->op) 6353 { 6354 case EXEC_OACC_PARALLEL: 6355 case EXEC_OACC_KERNELS: 6356 case EXEC_OACC_SERIAL: 6357 case EXEC_OACC_DATA: 6358 case EXEC_OACC_HOST_DATA: 6359 case EXEC_OACC_UPDATE: 6360 case EXEC_OACC_ENTER_DATA: 6361 case EXEC_OACC_EXIT_DATA: 6362 case EXEC_OACC_WAIT: 6363 case EXEC_OACC_CACHE: 6364 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); 6365 break; 6366 case EXEC_OACC_PARALLEL_LOOP: 6367 case EXEC_OACC_KERNELS_LOOP: 6368 case EXEC_OACC_SERIAL_LOOP: 6369 case EXEC_OACC_LOOP: 6370 resolve_oacc_loop (code); 6371 break; 6372 case EXEC_OACC_ATOMIC: 6373 resolve_omp_atomic (code); 6374 break; 6375 default: 6376 break; 6377 } 6378} 6379 6380 6381/* Resolve OpenMP directive clauses and check various requirements 6382 of each directive. */ 6383 6384void 6385gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) 6386{ 6387 resolve_omp_directive_inside_oacc_region (code); 6388 6389 if (code->op != EXEC_OMP_ATOMIC) 6390 gfc_maybe_initialize_eh (); 6391 6392 switch (code->op) 6393 { 6394 case EXEC_OMP_DISTRIBUTE: 6395 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 6396 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 6397 case EXEC_OMP_DISTRIBUTE_SIMD: 6398 case EXEC_OMP_DO: 6399 case EXEC_OMP_DO_SIMD: 6400 case EXEC_OMP_PARALLEL_DO: 6401 case EXEC_OMP_PARALLEL_DO_SIMD: 6402 case EXEC_OMP_SIMD: 6403 case EXEC_OMP_TARGET_PARALLEL_DO: 6404 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 6405 case EXEC_OMP_TARGET_SIMD: 6406 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 6407 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 6408 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 6409 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 6410 case EXEC_OMP_TASKLOOP: 6411 case EXEC_OMP_TASKLOOP_SIMD: 6412 case EXEC_OMP_TEAMS_DISTRIBUTE: 6413 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 6414 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 6415 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 6416 resolve_omp_do (code); 6417 break; 6418 case EXEC_OMP_CANCEL: 6419 case EXEC_OMP_PARALLEL_WORKSHARE: 6420 case EXEC_OMP_PARALLEL: 6421 case EXEC_OMP_PARALLEL_SECTIONS: 6422 case EXEC_OMP_SECTIONS: 6423 case EXEC_OMP_SINGLE: 6424 case EXEC_OMP_TARGET: 6425 case EXEC_OMP_TARGET_DATA: 6426 case EXEC_OMP_TARGET_ENTER_DATA: 6427 case EXEC_OMP_TARGET_EXIT_DATA: 6428 case EXEC_OMP_TARGET_PARALLEL: 6429 case EXEC_OMP_TARGET_TEAMS: 6430 case EXEC_OMP_TASK: 6431 case EXEC_OMP_TEAMS: 6432 case EXEC_OMP_WORKSHARE: 6433 if (code->ext.omp_clauses) 6434 resolve_omp_clauses (code, code->ext.omp_clauses, NULL); 6435 break; 6436 case EXEC_OMP_TARGET_UPDATE: 6437 if (code->ext.omp_clauses) 6438 resolve_omp_clauses (code, code->ext.omp_clauses, NULL); 6439 if (code->ext.omp_clauses == NULL 6440 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL 6441 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL)) 6442 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or " 6443 "FROM clause", &code->loc); 6444 break; 6445 case EXEC_OMP_ATOMIC: 6446 resolve_omp_atomic (code); 6447 break; 6448 default: 6449 break; 6450 } 6451} 6452 6453/* Resolve !$omp declare simd constructs in NS. */ 6454 6455void 6456gfc_resolve_omp_declare_simd (gfc_namespace *ns) 6457{ 6458 gfc_omp_declare_simd *ods; 6459 6460 for (ods = ns->omp_declare_simd; ods; ods = ods->next) 6461 { 6462 if (ods->proc_name != NULL 6463 && ods->proc_name != ns->proc_name) 6464 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " 6465 "%qs at %L", ns->proc_name->name, &ods->where); 6466 if (ods->clauses) 6467 resolve_omp_clauses (NULL, ods->clauses, ns); 6468 } 6469} 6470 6471struct omp_udr_callback_data 6472{ 6473 gfc_omp_udr *omp_udr; 6474 bool is_initializer; 6475}; 6476 6477static int 6478omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 6479 void *data) 6480{ 6481 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data; 6482 if ((*e)->expr_type == EXPR_VARIABLE) 6483 { 6484 if (cd->is_initializer) 6485 { 6486 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv 6487 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig) 6488 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in " 6489 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L", 6490 &(*e)->where); 6491 } 6492 else 6493 { 6494 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out 6495 && (*e)->symtree->n.sym != cd->omp_udr->omp_in) 6496 gfc_error ("Variable other than OMP_OUT or OMP_IN used in " 6497 "combiner of !$OMP DECLARE REDUCTION at %L", 6498 &(*e)->where); 6499 } 6500 } 6501 return 0; 6502} 6503 6504/* Resolve !$omp declare reduction constructs. */ 6505 6506static void 6507gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) 6508{ 6509 gfc_actual_arglist *a; 6510 const char *predef_name = NULL; 6511 6512 switch (omp_udr->rop) 6513 { 6514 case OMP_REDUCTION_PLUS: 6515 case OMP_REDUCTION_TIMES: 6516 case OMP_REDUCTION_MINUS: 6517 case OMP_REDUCTION_AND: 6518 case OMP_REDUCTION_OR: 6519 case OMP_REDUCTION_EQV: 6520 case OMP_REDUCTION_NEQV: 6521 case OMP_REDUCTION_MAX: 6522 case OMP_REDUCTION_USER: 6523 break; 6524 default: 6525 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L", 6526 omp_udr->name, &omp_udr->where); 6527 return; 6528 } 6529 6530 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name, 6531 &omp_udr->ts, &predef_name)) 6532 { 6533 if (predef_name) 6534 gfc_error_now ("Redefinition of predefined %s " 6535 "!$OMP DECLARE REDUCTION at %L", 6536 predef_name, &omp_udr->where); 6537 else 6538 gfc_error_now ("Redefinition of predefined " 6539 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where); 6540 return; 6541 } 6542 6543 if (omp_udr->ts.type == BT_CHARACTER 6544 && omp_udr->ts.u.cl->length 6545 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) 6546 { 6547 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not " 6548 "constant at %L", omp_udr->name, &omp_udr->where); 6549 return; 6550 } 6551 6552 struct omp_udr_callback_data cd; 6553 cd.omp_udr = omp_udr; 6554 cd.is_initializer = false; 6555 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback, 6556 omp_udr_callback, &cd); 6557 if (omp_udr->combiner_ns->code->op == EXEC_CALL) 6558 { 6559 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next) 6560 if (a->expr == NULL) 6561 break; 6562 if (a) 6563 gfc_error ("Subroutine call with alternate returns in combiner " 6564 "of !$OMP DECLARE REDUCTION at %L", 6565 &omp_udr->combiner_ns->code->loc); 6566 } 6567 if (omp_udr->initializer_ns) 6568 { 6569 cd.is_initializer = true; 6570 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback, 6571 omp_udr_callback, &cd); 6572 if (omp_udr->initializer_ns->code->op == EXEC_CALL) 6573 { 6574 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) 6575 if (a->expr == NULL) 6576 break; 6577 if (a) 6578 gfc_error ("Subroutine call with alternate returns in " 6579 "INITIALIZER clause of !$OMP DECLARE REDUCTION " 6580 "at %L", &omp_udr->initializer_ns->code->loc); 6581 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) 6582 if (a->expr 6583 && a->expr->expr_type == EXPR_VARIABLE 6584 && a->expr->symtree->n.sym == omp_udr->omp_priv 6585 && a->expr->ref == NULL) 6586 break; 6587 if (a == NULL) 6588 gfc_error ("One of actual subroutine arguments in INITIALIZER " 6589 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV " 6590 "at %L", &omp_udr->initializer_ns->code->loc); 6591 } 6592 } 6593 else if (omp_udr->ts.type == BT_DERIVED 6594 && !gfc_has_default_initializer (omp_udr->ts.u.derived)) 6595 { 6596 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION " 6597 "of derived type without default initializer at %L", 6598 &omp_udr->where); 6599 return; 6600 } 6601} 6602 6603void 6604gfc_resolve_omp_udrs (gfc_symtree *st) 6605{ 6606 gfc_omp_udr *omp_udr; 6607 6608 if (st == NULL) 6609 return; 6610 gfc_resolve_omp_udrs (st->left); 6611 gfc_resolve_omp_udrs (st->right); 6612 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) 6613 gfc_resolve_omp_udr (omp_udr); 6614} 6615