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