1 /* OpenMP directive translation -- generate GCC trees from gfc_code. 2 Copyright (C) 2005-2024 Free Software Foundation, Inc. 3 Contributed by Jakub Jelinek <jakub (at) redhat.com> 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 22 #include "config.h" 23 #include "system.h" 24 #include "coretypes.h" 25 #include "options.h" 26 #include "tree.h" 27 #include "gfortran.h" 28 #include "gimple-expr.h" 29 #include "trans.h" 30 #include "stringpool.h" 31 #include "fold-const.h" 32 #include "gimplify.h" /* For create_tmp_var_raw. */ 33 #include "trans-stmt.h" 34 #include "trans-types.h" 35 #include "trans-array.h" 36 #include "trans-const.h" 37 #include "arith.h" 38 #include "constructor.h" 39 #include "gomp-constants.h" 40 #include "omp-general.h" 41 #include "omp-low.h" 42 #include "memmodel.h" /* For MEMMODEL_ enums. */ 43 #include "dependency.h" 44 45 #undef GCC_DIAG_STYLE 46 #define GCC_DIAG_STYLE __gcc_tdiag__ 47 #include "diagnostic-core.h" 48 #undef GCC_DIAG_STYLE 49 #define GCC_DIAG_STYLE __gcc_gfc__ 50 #include "attribs.h" 51 #include "function.h" 52 53 int ompws_flags; 54 55 /* True if OpenMP should regard this DECL as being a scalar which has Fortran's 56 allocatable or pointer attribute. */ 57 58 bool 59 gfc_omp_is_allocatable_or_ptr (const_tree decl) 60 { 61 return (DECL_P (decl) 62 && (GFC_DECL_GET_SCALAR_POINTER (decl) 63 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))); 64 } 65 66 /* True if the argument is an optional argument; except that false is also 67 returned for arguments with the value attribute (nonpointers) and for 68 assumed-shape variables (decl is a local variable containing arg->data). 69 Note that for 'procedure(), optional' the value false is used as that's 70 always a pointer and no additional indirection is used. 71 Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */ 72 73 static bool 74 gfc_omp_is_optional_argument (const_tree decl) 75 { 76 /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */ 77 return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl)) 78 && DECL_LANG_SPECIFIC (decl) 79 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE 80 && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) 81 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE 82 && GFC_DECL_OPTIONAL_ARGUMENT (decl)); 83 } 84 85 /* Check whether this DECL belongs to a Fortran optional argument. 86 With 'for_present_check' set to false, decls which are optional parameters 87 themselves are returned as tree - or a NULL_TREE otherwise. Those decls are 88 always pointers. With 'for_present_check' set to true, the decl for checking 89 whether an argument is present is returned; for arguments with value 90 attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is 91 unrelated to optional arguments, NULL_TREE is returned. */ 92 93 tree 94 gfc_omp_check_optional_argument (tree decl, bool for_present_check) 95 { 96 if (!for_present_check) 97 return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE; 98 99 if (!DECL_LANG_SPECIFIC (decl)) 100 return NULL_TREE; 101 102 tree orig_decl = decl; 103 104 /* For assumed-shape arrays, a local decl with arg->data is used. */ 105 if (TREE_CODE (decl) != PARM_DECL 106 && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) 107 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) 108 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 109 110 /* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */ 111 if (decl == NULL_TREE 112 || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL) 113 || !DECL_LANG_SPECIFIC (decl) 114 || !GFC_DECL_OPTIONAL_ARGUMENT (decl)) 115 return NULL_TREE; 116 117 /* Scalars with VALUE attribute which are passed by value use a hidden 118 argument to denote the present status. They are passed as nonpointer type 119 with one exception: 'type(c_ptr), value' as 'void*'. */ 120 /* Cf. trans-expr.cc's gfc_conv_expr_present. */ 121 if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE 122 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) 123 { 124 char name[GFC_MAX_SYMBOL_LEN + 2]; 125 tree tree_name; 126 127 name[0] = '.'; 128 strcpy (&name[1], IDENTIFIER_POINTER (DECL_NAME (decl))); 129 tree_name = get_identifier (name); 130 131 /* Walk function argument list to find the hidden arg. */ 132 decl = DECL_ARGUMENTS (DECL_CONTEXT (decl)); 133 for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl)) 134 if (DECL_NAME (decl) == tree_name 135 && DECL_ARTIFICIAL (decl)) 136 break; 137 138 gcc_assert (decl); 139 return decl; 140 } 141 142 return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 143 orig_decl, null_pointer_node); 144 } 145 146 147 /* Returns tree with NULL if it is not an array descriptor and with the tree to 148 access the 'data' component otherwise. With type_only = true, it returns the 149 TREE_TYPE without creating a new tree. */ 150 151 tree 152 gfc_omp_array_data (tree decl, bool type_only) 153 { 154 tree type = TREE_TYPE (decl); 155 156 if (POINTER_TYPE_P (type)) 157 type = TREE_TYPE (type); 158 159 if (!GFC_DESCRIPTOR_TYPE_P (type)) 160 return NULL_TREE; 161 162 if (type_only) 163 return GFC_TYPE_ARRAY_DATAPTR_TYPE (type); 164 165 if (POINTER_TYPE_P (TREE_TYPE (decl))) 166 decl = build_fold_indirect_ref (decl); 167 168 decl = gfc_conv_descriptor_data_get (decl); 169 STRIP_NOPS (decl); 170 return decl; 171 } 172 173 /* Return the byte-size of the passed array descriptor. */ 174 175 tree 176 gfc_omp_array_size (tree decl, gimple_seq *pre_p) 177 { 178 stmtblock_t block; 179 if (POINTER_TYPE_P (TREE_TYPE (decl))) 180 decl = build_fold_indirect_ref (decl); 181 tree type = TREE_TYPE (decl); 182 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 183 bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE 184 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER 185 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT); 186 gfc_init_block (&block); 187 tree size = gfc_full_array_size (&block, decl, 188 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl))); 189 size = fold_convert (size_type_node, size); 190 tree elemsz = gfc_get_element_type (TREE_TYPE (decl)); 191 if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz)) 192 elemsz = gfc_conv_descriptor_elem_len (decl); 193 else 194 elemsz = TYPE_SIZE_UNIT (elemsz); 195 size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz); 196 if (!allocatable) 197 gimplify_and_add (gfc_finish_block (&block), pre_p); 198 else 199 { 200 tree var = create_tmp_var (size_type_node); 201 gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size)); 202 tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 203 gfc_conv_descriptor_data_get (decl), 204 null_pointer_node); 205 tmp = build3_loc (input_location, COND_EXPR, void_type_node, tmp, 206 gfc_finish_block (&block), 207 build2 (MODIFY_EXPR, sizetype, var, size_zero_node)); 208 gimplify_and_add (tmp, pre_p); 209 size = var; 210 } 211 return size; 212 } 213 214 215 /* True if OpenMP should privatize what this DECL points to rather 216 than the DECL itself. */ 217 218 bool 219 gfc_omp_privatize_by_reference (const_tree decl) 220 { 221 tree type = TREE_TYPE (decl); 222 223 if (TREE_CODE (type) == REFERENCE_TYPE 224 && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL)) 225 return true; 226 227 if (TREE_CODE (type) == POINTER_TYPE 228 && gfc_omp_is_optional_argument (decl)) 229 return true; 230 231 if (TREE_CODE (type) == POINTER_TYPE) 232 { 233 while (TREE_CODE (decl) == COMPONENT_REF) 234 decl = TREE_OPERAND (decl, 1); 235 236 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables 237 that have POINTER_TYPE type and aren't scalar pointers, scalar 238 allocatables, Cray pointees or C pointers are supposed to be 239 privatized by reference. */ 240 if (GFC_DECL_GET_SCALAR_POINTER (decl) 241 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 242 || GFC_DECL_CRAY_POINTEE (decl) 243 || GFC_DECL_ASSOCIATE_VAR_P (decl) 244 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) 245 return false; 246 247 if (!DECL_ARTIFICIAL (decl) 248 && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) 249 return true; 250 251 /* Some arrays are expanded as DECL_ARTIFICIAL pointers 252 by the frontend. */ 253 if (DECL_LANG_SPECIFIC (decl) 254 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 255 return true; 256 } 257 258 return false; 259 } 260 261 /* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute 262 of DECL is predetermined. */ 263 264 enum omp_clause_default_kind 265 gfc_omp_predetermined_sharing (tree decl) 266 { 267 /* Associate names preserve the association established during ASSOCIATE. 268 As they are implemented either as pointers to the selector or array 269 descriptor and shouldn't really change in the ASSOCIATE region, 270 this decl can be either shared or firstprivate. If it is a pointer, 271 use firstprivate, as it is cheaper that way, otherwise make it shared. */ 272 if (GFC_DECL_ASSOCIATE_VAR_P (decl)) 273 { 274 if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) 275 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; 276 else 277 return OMP_CLAUSE_DEFAULT_SHARED; 278 } 279 280 if (DECL_ARTIFICIAL (decl) 281 && ! GFC_DECL_RESULT (decl) 282 && ! (DECL_LANG_SPECIFIC (decl) 283 && GFC_DECL_SAVED_DESCRIPTOR (decl))) 284 return OMP_CLAUSE_DEFAULT_SHARED; 285 286 /* Cray pointees shouldn't be listed in any clauses and should be 287 gimplified to dereference of the corresponding Cray pointer. 288 Make them all private, so that they are emitted in the debug 289 information. */ 290 if (GFC_DECL_CRAY_POINTEE (decl)) 291 return OMP_CLAUSE_DEFAULT_PRIVATE; 292 293 /* Assumed-size arrays are predetermined shared. */ 294 if (TREE_CODE (decl) == PARM_DECL 295 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) 296 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN 297 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), 298 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) 299 == NULL) 300 return OMP_CLAUSE_DEFAULT_SHARED; 301 302 /* Dummy procedures aren't considered variables by OpenMP, thus are 303 disallowed in OpenMP clauses. They are represented as PARM_DECLs 304 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here 305 to avoid complaining about their uses with default(none). */ 306 if (TREE_CODE (decl) == PARM_DECL 307 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE 308 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) 309 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; 310 311 /* COMMON and EQUIVALENCE decls are shared. They 312 are only referenced through DECL_VALUE_EXPR of the variables 313 contained in them. If those are privatized, they will not be 314 gimplified to the COMMON or EQUIVALENCE decls. */ 315 if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) 316 return OMP_CLAUSE_DEFAULT_SHARED; 317 318 if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) 319 return OMP_CLAUSE_DEFAULT_SHARED; 320 321 /* These are either array or derived parameters, or vtables. 322 In the former cases, the OpenMP standard doesn't consider them to be 323 variables at all (they can't be redefined), but they can nevertheless appear 324 in parallel/task regions and for default(none) purposes treat them as shared. 325 For vtables likely the same handling is desirable. */ 326 if (VAR_P (decl) && TREE_READONLY (decl) 327 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) 328 return OMP_CLAUSE_DEFAULT_SHARED; 329 330 return OMP_CLAUSE_DEFAULT_UNSPECIFIED; 331 } 332 333 334 /* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute 335 of DECL is predetermined. */ 336 337 enum omp_clause_defaultmap_kind 338 gfc_omp_predetermined_mapping (tree decl) 339 { 340 if (DECL_ARTIFICIAL (decl) 341 && ! GFC_DECL_RESULT (decl) 342 && ! (DECL_LANG_SPECIFIC (decl) 343 && GFC_DECL_SAVED_DESCRIPTOR (decl))) 344 return OMP_CLAUSE_DEFAULTMAP_TO; 345 346 /* Dummy procedures aren't considered variables by OpenMP, thus are 347 disallowed in OpenMP clauses. They are represented as PARM_DECLs 348 in the middle-end, so return OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE here 349 to avoid complaining about their uses with defaultmap(none). */ 350 if (TREE_CODE (decl) == PARM_DECL 351 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE 352 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) 353 return OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE; 354 355 /* These are either array or derived parameters, or vtables. */ 356 if (VAR_P (decl) && TREE_READONLY (decl) 357 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) 358 return OMP_CLAUSE_DEFAULTMAP_TO; 359 360 return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; 361 } 362 363 364 /* Return decl that should be used when reporting DEFAULT(NONE) 365 diagnostics. */ 366 367 tree 368 gfc_omp_report_decl (tree decl) 369 { 370 if (DECL_ARTIFICIAL (decl) 371 && DECL_LANG_SPECIFIC (decl) 372 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 373 return GFC_DECL_SAVED_DESCRIPTOR (decl); 374 375 return decl; 376 } 377 378 /* Return true if TYPE has any allocatable components. */ 379 380 static bool 381 gfc_has_alloc_comps (tree type, tree decl) 382 { 383 tree field, ftype; 384 385 if (POINTER_TYPE_P (type)) 386 { 387 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) 388 type = TREE_TYPE (type); 389 else if (GFC_DECL_GET_SCALAR_POINTER (decl)) 390 return false; 391 } 392 393 if (GFC_DESCRIPTOR_TYPE_P (type) 394 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER 395 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) 396 return false; 397 398 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) 399 type = gfc_get_element_type (type); 400 401 if (TREE_CODE (type) != RECORD_TYPE) 402 return false; 403 404 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) 405 { 406 ftype = TREE_TYPE (field); 407 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 408 return true; 409 if (GFC_DESCRIPTOR_TYPE_P (ftype) 410 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 411 return true; 412 if (gfc_has_alloc_comps (ftype, field)) 413 return true; 414 } 415 return false; 416 } 417 418 /* Return true if TYPE is a class container for a POINTER entity. */ 419 420 static bool 421 gfc_is_class_pointer_type (tree type) 422 { 423 tree name; 424 const char *s; 425 426 if (POINTER_TYPE_P (type)) 427 type = TREE_TYPE (type); 428 429 if (!GFC_CLASS_TYPE_P (type)) 430 return false; 431 432 name = TYPE_NAME (type); 433 if (name && TREE_CODE (name) == TYPE_DECL) 434 name = DECL_NAME (name); 435 if (!name) 436 return false; 437 438 s = IDENTIFIER_POINTER (name); 439 return startswith (s, "__class_") && s[strlen (s) - 1] == 'p'; 440 } 441 442 /* Return true if TYPE is polymorphic but not with pointer attribute. */ 443 444 static bool 445 gfc_is_polymorphic_nonptr (tree type) 446 { 447 if (POINTER_TYPE_P (type)) 448 type = TREE_TYPE (type); 449 return GFC_CLASS_TYPE_P (type); 450 } 451 452 /* Return true if TYPE is unlimited polymorphic but not with pointer attribute; 453 unlimited means also intrinsic types are handled and _len is used. */ 454 455 static bool 456 gfc_is_unlimited_polymorphic_nonptr (tree type) 457 { 458 if (POINTER_TYPE_P (type)) 459 type = TREE_TYPE (type); 460 if (!GFC_CLASS_TYPE_P (type)) 461 return false; 462 463 tree field = TYPE_FIELDS (type); /* _data */ 464 gcc_assert (field); 465 field = DECL_CHAIN (field); /* _vptr */ 466 gcc_assert (field); 467 field = DECL_CHAIN (field); 468 if (!field) 469 return false; 470 gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0); 471 return true; 472 } 473 474 /* Return true if the DECL is for an allocatable array or scalar. */ 475 476 bool 477 gfc_omp_allocatable_p (tree decl) 478 { 479 if (!DECL_P (decl)) 480 return false; 481 482 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) 483 return true; 484 485 tree type = TREE_TYPE (decl); 486 if (gfc_omp_privatize_by_reference (decl)) 487 type = TREE_TYPE (type); 488 489 if (GFC_DESCRIPTOR_TYPE_P (type) 490 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) 491 return true; 492 493 return false; 494 } 495 496 497 /* Return true if DECL in private clause needs 498 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ 499 bool 500 gfc_omp_private_outer_ref (tree decl) 501 { 502 tree type = TREE_TYPE (decl); 503 504 if (gfc_omp_privatize_by_reference (decl)) 505 type = TREE_TYPE (type); 506 507 if (GFC_DESCRIPTOR_TYPE_P (type) 508 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) 509 return true; 510 511 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) 512 return true; 513 514 if (gfc_has_alloc_comps (type, decl)) 515 return true; 516 517 return false; 518 } 519 520 /* Callback for gfc_omp_unshare_expr. */ 521 522 static tree 523 gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *) 524 { 525 tree t = *tp; 526 enum tree_code code = TREE_CODE (t); 527 528 /* Stop at types, decls, constants like copy_tree_r. */ 529 if (TREE_CODE_CLASS (code) == tcc_type 530 || TREE_CODE_CLASS (code) == tcc_declaration 531 || TREE_CODE_CLASS (code) == tcc_constant 532 || code == BLOCK) 533 *walk_subtrees = 0; 534 else if (handled_component_p (t) 535 || TREE_CODE (t) == MEM_REF) 536 { 537 *tp = unshare_expr (t); 538 *walk_subtrees = 0; 539 } 540 541 return NULL_TREE; 542 } 543 544 /* Unshare in expr anything that the FE which normally doesn't 545 care much about tree sharing (because during gimplification 546 everything is unshared) could cause problems with tree sharing 547 at omp-low.cc time. */ 548 549 static tree 550 gfc_omp_unshare_expr (tree expr) 551 { 552 walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL); 553 return expr; 554 } 555 556 enum walk_alloc_comps 557 { 558 WALK_ALLOC_COMPS_DTOR, 559 WALK_ALLOC_COMPS_DEFAULT_CTOR, 560 WALK_ALLOC_COMPS_COPY_CTOR 561 }; 562 563 /* Handle allocatable components in OpenMP clauses. */ 564 565 static tree 566 gfc_walk_alloc_comps (tree decl, tree dest, tree var, 567 enum walk_alloc_comps kind) 568 { 569 stmtblock_t block, tmpblock; 570 tree type = TREE_TYPE (decl), then_b, tem, field; 571 gfc_init_block (&block); 572 573 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) 574 { 575 if (GFC_DESCRIPTOR_TYPE_P (type)) 576 { 577 gfc_init_block (&tmpblock); 578 tem = gfc_full_array_size (&tmpblock, decl, 579 GFC_TYPE_ARRAY_RANK (type)); 580 then_b = gfc_finish_block (&tmpblock); 581 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b)); 582 tem = gfc_omp_unshare_expr (tem); 583 tem = fold_build2_loc (input_location, MINUS_EXPR, 584 gfc_array_index_type, tem, 585 gfc_index_one_node); 586 } 587 else 588 { 589 bool compute_nelts = false; 590 if (!TYPE_DOMAIN (type) 591 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE 592 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node 593 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) 594 compute_nelts = true; 595 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) 596 { 597 tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); 598 if (lookup_attribute ("omp dummy var", a)) 599 compute_nelts = true; 600 } 601 if (compute_nelts) 602 { 603 tem = fold_build2 (EXACT_DIV_EXPR, sizetype, 604 TYPE_SIZE_UNIT (type), 605 TYPE_SIZE_UNIT (TREE_TYPE (type))); 606 tem = size_binop (MINUS_EXPR, tem, size_one_node); 607 } 608 else 609 tem = array_type_nelts (type); 610 tem = fold_convert (gfc_array_index_type, tem); 611 } 612 613 tree nelems = gfc_evaluate_now (tem, &block); 614 tree index = gfc_create_var (gfc_array_index_type, "S"); 615 616 gfc_init_block (&tmpblock); 617 tem = gfc_conv_array_data (decl); 618 tree declvar = build_fold_indirect_ref_loc (input_location, tem); 619 tree declvref = gfc_build_array_ref (declvar, index, NULL); 620 tree destvar, destvref = NULL_TREE; 621 if (dest) 622 { 623 tem = gfc_conv_array_data (dest); 624 destvar = build_fold_indirect_ref_loc (input_location, tem); 625 destvref = gfc_build_array_ref (destvar, index, NULL); 626 } 627 gfc_add_expr_to_block (&tmpblock, 628 gfc_walk_alloc_comps (declvref, destvref, 629 var, kind)); 630 631 gfc_loopinfo loop; 632 gfc_init_loopinfo (&loop); 633 loop.dimen = 1; 634 loop.from[0] = gfc_index_zero_node; 635 loop.loopvar[0] = index; 636 loop.to[0] = nelems; 637 gfc_trans_scalarizing_loops (&loop, &tmpblock); 638 gfc_add_block_to_block (&block, &loop.pre); 639 return gfc_finish_block (&block); 640 } 641 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var)) 642 { 643 decl = build_fold_indirect_ref_loc (input_location, decl); 644 if (dest) 645 dest = build_fold_indirect_ref_loc (input_location, dest); 646 type = TREE_TYPE (decl); 647 } 648 649 gcc_assert (TREE_CODE (type) == RECORD_TYPE); 650 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) 651 { 652 tree ftype = TREE_TYPE (field); 653 tree declf, destf = NULL_TREE; 654 bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); 655 if ((!GFC_DESCRIPTOR_TYPE_P (ftype) 656 || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) 657 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) 658 && !has_alloc_comps) 659 continue; 660 declf = fold_build3_loc (input_location, COMPONENT_REF, ftype, 661 decl, field, NULL_TREE); 662 if (dest) 663 destf = fold_build3_loc (input_location, COMPONENT_REF, ftype, 664 dest, field, NULL_TREE); 665 666 tem = NULL_TREE; 667 switch (kind) 668 { 669 case WALK_ALLOC_COMPS_DTOR: 670 break; 671 case WALK_ALLOC_COMPS_DEFAULT_CTOR: 672 if (GFC_DESCRIPTOR_TYPE_P (ftype) 673 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 674 { 675 gfc_add_modify (&block, unshare_expr (destf), 676 unshare_expr (declf)); 677 tem = gfc_duplicate_allocatable_nocopy 678 (destf, declf, ftype, 679 GFC_TYPE_ARRAY_RANK (ftype)); 680 } 681 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 682 tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0); 683 break; 684 case WALK_ALLOC_COMPS_COPY_CTOR: 685 if (GFC_DESCRIPTOR_TYPE_P (ftype) 686 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 687 tem = gfc_duplicate_allocatable (destf, declf, ftype, 688 GFC_TYPE_ARRAY_RANK (ftype), 689 NULL_TREE); 690 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 691 tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, 692 NULL_TREE); 693 break; 694 } 695 if (tem) 696 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); 697 if (has_alloc_comps) 698 { 699 gfc_init_block (&tmpblock); 700 gfc_add_expr_to_block (&tmpblock, 701 gfc_walk_alloc_comps (declf, destf, 702 field, kind)); 703 then_b = gfc_finish_block (&tmpblock); 704 if (GFC_DESCRIPTOR_TYPE_P (ftype) 705 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 706 tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); 707 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 708 tem = unshare_expr (declf); 709 else 710 tem = NULL_TREE; 711 if (tem) 712 { 713 tem = fold_convert (pvoid_type_node, tem); 714 tem = fold_build2_loc (input_location, NE_EXPR, 715 logical_type_node, tem, 716 null_pointer_node); 717 then_b = build3_loc (input_location, COND_EXPR, void_type_node, 718 tem, then_b, 719 build_empty_stmt (input_location)); 720 } 721 gfc_add_expr_to_block (&block, then_b); 722 } 723 if (kind == WALK_ALLOC_COMPS_DTOR) 724 { 725 if (GFC_DESCRIPTOR_TYPE_P (ftype) 726 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 727 { 728 tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); 729 tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, 730 NULL_TREE, NULL_TREE, true, 731 NULL, 732 GFC_CAF_COARRAY_NOCOARRAY); 733 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); 734 } 735 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 736 { 737 tem = gfc_call_free (unshare_expr (declf)); 738 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); 739 } 740 } 741 } 742 743 return gfc_finish_block (&block); 744 } 745 746 /* Return code to initialize DECL with its default constructor, or 747 NULL if there's nothing to do. */ 748 749 tree 750 gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) 751 { 752 tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b; 753 stmtblock_t block, cond_block; 754 755 switch (OMP_CLAUSE_CODE (clause)) 756 { 757 case OMP_CLAUSE__LOOPTEMP_: 758 case OMP_CLAUSE__REDUCTEMP_: 759 case OMP_CLAUSE__CONDTEMP_: 760 case OMP_CLAUSE__SCANTEMP_: 761 return NULL; 762 case OMP_CLAUSE_PRIVATE: 763 case OMP_CLAUSE_LASTPRIVATE: 764 case OMP_CLAUSE_LINEAR: 765 case OMP_CLAUSE_REDUCTION: 766 case OMP_CLAUSE_IN_REDUCTION: 767 case OMP_CLAUSE_TASK_REDUCTION: 768 break; 769 default: 770 gcc_unreachable (); 771 } 772 773 if ((! GFC_DESCRIPTOR_TYPE_P (type) 774 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 775 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 776 || !POINTER_TYPE_P (type))) 777 { 778 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 779 { 780 gcc_assert (outer); 781 gfc_start_block (&block); 782 tree tem = gfc_walk_alloc_comps (outer, decl, 783 OMP_CLAUSE_DECL (clause), 784 WALK_ALLOC_COMPS_DEFAULT_CTOR); 785 gfc_add_expr_to_block (&block, tem); 786 return gfc_finish_block (&block); 787 } 788 return NULL_TREE; 789 } 790 791 gcc_assert (outer != NULL_TREE 792 || (!GFC_DESCRIPTOR_TYPE_P (type) 793 && !gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))); 794 795 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to 796 "not currently allocated" allocation status if outer 797 array is "not currently allocated", otherwise should be allocated. */ 798 gfc_start_block (&block); 799 800 gfc_init_block (&cond_block); 801 802 if (GFC_DESCRIPTOR_TYPE_P (type)) 803 { 804 gfc_add_modify (&cond_block, decl, outer); 805 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 806 size = gfc_conv_descriptor_ubound_get (decl, rank); 807 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 808 size, 809 gfc_conv_descriptor_lbound_get (decl, rank)); 810 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 811 size, gfc_index_one_node); 812 if (GFC_TYPE_ARRAY_RANK (type) > 1) 813 size = fold_build2_loc (input_location, MULT_EXPR, 814 gfc_array_index_type, size, 815 gfc_conv_descriptor_stride_get (decl, rank)); 816 tree esize = fold_convert (gfc_array_index_type, 817 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 818 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 819 size, esize); 820 size = unshare_expr (size); 821 size = gfc_evaluate_now (fold_convert (size_type_node, size), 822 &cond_block); 823 } 824 else 825 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 826 ptr = gfc_create_var (pvoid_type_node, NULL); 827 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); 828 if (GFC_DESCRIPTOR_TYPE_P (type)) 829 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr); 830 else 831 gfc_add_modify (&cond_block, unshare_expr (decl), 832 fold_convert (TREE_TYPE (decl), ptr)); 833 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 834 { 835 tree tem = gfc_walk_alloc_comps (outer, decl, 836 OMP_CLAUSE_DECL (clause), 837 WALK_ALLOC_COMPS_DEFAULT_CTOR); 838 gfc_add_expr_to_block (&cond_block, tem); 839 } 840 then_b = gfc_finish_block (&cond_block); 841 842 /* Reduction clause requires allocated ALLOCATABLE. */ 843 if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION 844 && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION 845 && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_REDUCTION) 846 { 847 gfc_init_block (&cond_block); 848 if (GFC_DESCRIPTOR_TYPE_P (type)) 849 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), 850 null_pointer_node); 851 else 852 gfc_add_modify (&cond_block, unshare_expr (decl), 853 build_zero_cst (TREE_TYPE (decl))); 854 else_b = gfc_finish_block (&cond_block); 855 856 tree tem = fold_convert (pvoid_type_node, 857 GFC_DESCRIPTOR_TYPE_P (type) 858 ? gfc_conv_descriptor_data_get (outer) : outer); 859 tem = unshare_expr (tem); 860 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 861 tem, null_pointer_node); 862 gfc_add_expr_to_block (&block, 863 build3_loc (input_location, COND_EXPR, 864 void_type_node, cond, then_b, 865 else_b)); 866 /* Avoid -W*uninitialized warnings. */ 867 if (DECL_P (decl)) 868 suppress_warning (decl, OPT_Wuninitialized); 869 } 870 else 871 gfc_add_expr_to_block (&block, then_b); 872 873 return gfc_finish_block (&block); 874 } 875 876 /* Build and return code for a copy constructor from SRC to DEST. */ 877 878 tree 879 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) 880 { 881 tree type = TREE_TYPE (dest), ptr, size, call; 882 tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); 883 tree orig_decl = OMP_CLAUSE_DECL (clause); 884 tree cond, then_b, else_b; 885 stmtblock_t block, cond_block; 886 887 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE 888 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); 889 890 if (DECL_ARTIFICIAL (orig_decl) 891 && DECL_LANG_SPECIFIC (orig_decl) 892 && GFC_DECL_SAVED_DESCRIPTOR (orig_decl)) 893 { 894 orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl); 895 decl_type = TREE_TYPE (orig_decl); 896 } 897 898 /* Privatize pointer association only; cf. gfc_omp_predetermined_sharing. 899 This includes scalar class pointers, whose tree type is still the class 900 record even though the Fortran entity has POINTER semantics. */ 901 if (DECL_P (orig_decl) 902 && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl) 903 || GFC_DECL_GET_SCALAR_POINTER (orig_decl) 904 || gfc_is_class_pointer_type (decl_type))) 905 return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src); 906 907 if (gfc_is_polymorphic_nonptr (decl_type)) 908 { 909 if (POINTER_TYPE_P (decl_type)) 910 decl_type = TREE_TYPE (decl_type); 911 decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); 912 if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) 913 fatal_error (input_location, 914 "Sorry, polymorphic arrays not yet supported for " 915 "firstprivate"); 916 tree src_len; 917 tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */ 918 tree src_data = gfc_class_data_get (unshare_expr (src)); 919 tree dest_data = gfc_class_data_get (unshare_expr (dest)); 920 bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type); 921 922 gfc_start_block (&block); 923 gfc_add_modify (&block, gfc_class_vptr_get (dest), 924 gfc_class_vptr_get (src)); 925 gfc_init_block (&cond_block); 926 927 if (unlimited) 928 { 929 src_len = gfc_class_len_get (src); 930 gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len); 931 } 932 933 /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */ 934 size = fold_convert (size_type_node, gfc_class_vtab_size_get (src)); 935 if (unlimited) 936 { 937 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 938 unshare_expr (src_len), 939 build_zero_cst (TREE_TYPE (src_len))); 940 cond = build3_loc (input_location, COND_EXPR, size_type_node, cond, 941 fold_convert (size_type_node, 942 unshare_expr (src_len)), 943 build_int_cst (size_type_node, 1)); 944 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 945 size, cond); 946 } 947 948 /* Malloc memory + call class->_vpt->_copy. */ 949 call = builtin_decl_explicit (BUILT_IN_MALLOC); 950 call = build_call_expr_loc (input_location, call, 1, size); 951 gfc_add_modify (&cond_block, dest_data, 952 fold_convert (TREE_TYPE (dest_data), call)); 953 gfc_add_expr_to_block (&cond_block, 954 gfc_copy_class_to_class (src, dest, nelems, 955 unlimited)); 956 957 gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF); 958 if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1))) 959 { 960 gfc_add_block_to_block (&block, &cond_block); 961 } 962 else 963 { 964 /* Create: if (class._data != 0) <cond_block> else class._data = NULL; */ 965 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 966 src_data, null_pointer_node); 967 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, 968 void_type_node, cond, 969 gfc_finish_block (&cond_block), 970 fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 971 unshare_expr (dest_data), null_pointer_node))); 972 } 973 return gfc_finish_block (&block); 974 } 975 976 if ((! GFC_DESCRIPTOR_TYPE_P (type) 977 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 978 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 979 || !POINTER_TYPE_P (type))) 980 { 981 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 982 { 983 gfc_start_block (&block); 984 gfc_add_modify (&block, dest, src); 985 tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), 986 WALK_ALLOC_COMPS_COPY_CTOR); 987 gfc_add_expr_to_block (&block, tem); 988 return gfc_finish_block (&block); 989 } 990 else 991 return build2_v (MODIFY_EXPR, dest, src); 992 } 993 994 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated 995 and copied from SRC. */ 996 gfc_start_block (&block); 997 998 gfc_init_block (&cond_block); 999 1000 gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src)); 1001 if (GFC_DESCRIPTOR_TYPE_P (type)) 1002 { 1003 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 1004 size = gfc_conv_descriptor_ubound_get (dest, rank); 1005 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 1006 size, 1007 gfc_conv_descriptor_lbound_get (dest, rank)); 1008 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1009 size, gfc_index_one_node); 1010 if (GFC_TYPE_ARRAY_RANK (type) > 1) 1011 size = fold_build2_loc (input_location, MULT_EXPR, 1012 gfc_array_index_type, size, 1013 gfc_conv_descriptor_stride_get (dest, rank)); 1014 tree esize = fold_convert (gfc_array_index_type, 1015 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 1016 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 1017 size, esize); 1018 size = unshare_expr (size); 1019 size = gfc_evaluate_now (fold_convert (size_type_node, size), 1020 &cond_block); 1021 } 1022 else 1023 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 1024 ptr = gfc_create_var (pvoid_type_node, NULL); 1025 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); 1026 if (GFC_DESCRIPTOR_TYPE_P (type)) 1027 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr); 1028 else 1029 gfc_add_modify (&cond_block, unshare_expr (dest), 1030 fold_convert (TREE_TYPE (dest), ptr)); 1031 1032 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) 1033 ? gfc_conv_descriptor_data_get (src) : src; 1034 srcptr = unshare_expr (srcptr); 1035 srcptr = fold_convert (pvoid_type_node, srcptr); 1036 call = build_call_expr_loc (input_location, 1037 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, 1038 srcptr, size); 1039 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); 1040 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1041 { 1042 tree tem = gfc_walk_alloc_comps (src, dest, 1043 OMP_CLAUSE_DECL (clause), 1044 WALK_ALLOC_COMPS_COPY_CTOR); 1045 gfc_add_expr_to_block (&cond_block, tem); 1046 } 1047 then_b = gfc_finish_block (&cond_block); 1048 1049 gfc_init_block (&cond_block); 1050 if (GFC_DESCRIPTOR_TYPE_P (type)) 1051 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), 1052 null_pointer_node); 1053 else 1054 gfc_add_modify (&cond_block, unshare_expr (dest), 1055 build_zero_cst (TREE_TYPE (dest))); 1056 else_b = gfc_finish_block (&cond_block); 1057 1058 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1059 unshare_expr (srcptr), null_pointer_node); 1060 gfc_add_expr_to_block (&block, 1061 build3_loc (input_location, COND_EXPR, 1062 void_type_node, cond, then_b, else_b)); 1063 /* Avoid -W*uninitialized warnings. */ 1064 if (DECL_P (dest)) 1065 suppress_warning (dest, OPT_Wuninitialized); 1066 1067 return gfc_finish_block (&block); 1068 } 1069 1070 /* Similarly, except use an intrinsic or pointer assignment operator 1071 instead. */ 1072 1073 tree 1074 gfc_omp_clause_assign_op (tree clause, tree dest, tree src) 1075 { 1076 tree type = TREE_TYPE (dest), ptr, size, call, nonalloc; 1077 tree cond, then_b, else_b; 1078 stmtblock_t block, cond_block, cond_block2, inner_block; 1079 1080 if ((! GFC_DESCRIPTOR_TYPE_P (type) 1081 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 1082 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 1083 || !POINTER_TYPE_P (type))) 1084 { 1085 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1086 { 1087 gfc_start_block (&block); 1088 /* First dealloc any allocatable components in DEST. */ 1089 tree tem = gfc_walk_alloc_comps (dest, NULL_TREE, 1090 OMP_CLAUSE_DECL (clause), 1091 WALK_ALLOC_COMPS_DTOR); 1092 gfc_add_expr_to_block (&block, tem); 1093 /* Then copy over toplevel data. */ 1094 gfc_add_modify (&block, dest, src); 1095 /* Finally allocate any allocatable components and copy. */ 1096 tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), 1097 WALK_ALLOC_COMPS_COPY_CTOR); 1098 gfc_add_expr_to_block (&block, tem); 1099 return gfc_finish_block (&block); 1100 } 1101 else 1102 return build2_v (MODIFY_EXPR, dest, src); 1103 } 1104 1105 gfc_start_block (&block); 1106 1107 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1108 { 1109 then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), 1110 WALK_ALLOC_COMPS_DTOR); 1111 tree tem = fold_convert (pvoid_type_node, 1112 GFC_DESCRIPTOR_TYPE_P (type) 1113 ? gfc_conv_descriptor_data_get (dest) : dest); 1114 tem = unshare_expr (tem); 1115 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1116 tem, null_pointer_node); 1117 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, 1118 then_b, build_empty_stmt (input_location)); 1119 gfc_add_expr_to_block (&block, tem); 1120 } 1121 1122 gfc_init_block (&cond_block); 1123 1124 if (GFC_DESCRIPTOR_TYPE_P (type)) 1125 { 1126 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 1127 size = gfc_conv_descriptor_ubound_get (src, rank); 1128 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 1129 size, 1130 gfc_conv_descriptor_lbound_get (src, rank)); 1131 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1132 size, gfc_index_one_node); 1133 if (GFC_TYPE_ARRAY_RANK (type) > 1) 1134 size = fold_build2_loc (input_location, MULT_EXPR, 1135 gfc_array_index_type, size, 1136 gfc_conv_descriptor_stride_get (src, rank)); 1137 tree esize = fold_convert (gfc_array_index_type, 1138 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 1139 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 1140 size, esize); 1141 size = unshare_expr (size); 1142 size = gfc_evaluate_now (fold_convert (size_type_node, size), 1143 &cond_block); 1144 } 1145 else 1146 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 1147 ptr = gfc_create_var (pvoid_type_node, NULL); 1148 1149 tree destptr = GFC_DESCRIPTOR_TYPE_P (type) 1150 ? gfc_conv_descriptor_data_get (dest) : dest; 1151 destptr = unshare_expr (destptr); 1152 destptr = fold_convert (pvoid_type_node, destptr); 1153 gfc_add_modify (&cond_block, ptr, destptr); 1154 1155 nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 1156 destptr, null_pointer_node); 1157 cond = nonalloc; 1158 if (GFC_DESCRIPTOR_TYPE_P (type)) 1159 { 1160 int i; 1161 for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++) 1162 { 1163 tree rank = gfc_rank_cst[i]; 1164 tree tem = gfc_conv_descriptor_ubound_get (src, rank); 1165 tem = fold_build2_loc (input_location, MINUS_EXPR, 1166 gfc_array_index_type, tem, 1167 gfc_conv_descriptor_lbound_get (src, rank)); 1168 tem = fold_build2_loc (input_location, PLUS_EXPR, 1169 gfc_array_index_type, tem, 1170 gfc_conv_descriptor_lbound_get (dest, rank)); 1171 tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1172 tem, gfc_conv_descriptor_ubound_get (dest, 1173 rank)); 1174 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, 1175 logical_type_node, cond, tem); 1176 } 1177 } 1178 1179 gfc_init_block (&cond_block2); 1180 1181 if (GFC_DESCRIPTOR_TYPE_P (type)) 1182 { 1183 gfc_init_block (&inner_block); 1184 gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE); 1185 then_b = gfc_finish_block (&inner_block); 1186 1187 gfc_init_block (&inner_block); 1188 gfc_add_modify (&inner_block, ptr, 1189 gfc_call_realloc (&inner_block, ptr, size)); 1190 else_b = gfc_finish_block (&inner_block); 1191 1192 gfc_add_expr_to_block (&cond_block2, 1193 build3_loc (input_location, COND_EXPR, 1194 void_type_node, 1195 unshare_expr (nonalloc), 1196 then_b, else_b)); 1197 gfc_add_modify (&cond_block2, dest, src); 1198 gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr); 1199 } 1200 else 1201 { 1202 gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE); 1203 gfc_add_modify (&cond_block2, unshare_expr (dest), 1204 fold_convert (type, ptr)); 1205 } 1206 then_b = gfc_finish_block (&cond_block2); 1207 else_b = build_empty_stmt (input_location); 1208 1209 gfc_add_expr_to_block (&cond_block, 1210 build3_loc (input_location, COND_EXPR, 1211 void_type_node, unshare_expr (cond), 1212 then_b, else_b)); 1213 1214 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) 1215 ? gfc_conv_descriptor_data_get (src) : src; 1216 srcptr = unshare_expr (srcptr); 1217 srcptr = fold_convert (pvoid_type_node, srcptr); 1218 call = build_call_expr_loc (input_location, 1219 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, 1220 srcptr, size); 1221 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); 1222 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1223 { 1224 tree tem = gfc_walk_alloc_comps (src, dest, 1225 OMP_CLAUSE_DECL (clause), 1226 WALK_ALLOC_COMPS_COPY_CTOR); 1227 gfc_add_expr_to_block (&cond_block, tem); 1228 } 1229 then_b = gfc_finish_block (&cond_block); 1230 1231 if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN) 1232 { 1233 gfc_init_block (&cond_block); 1234 if (GFC_DESCRIPTOR_TYPE_P (type)) 1235 { 1236 tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest)); 1237 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, 1238 NULL_TREE, NULL_TREE, true, NULL, 1239 GFC_CAF_COARRAY_NOCOARRAY); 1240 gfc_add_expr_to_block (&cond_block, tmp); 1241 } 1242 else 1243 { 1244 destptr = gfc_evaluate_now (destptr, &cond_block); 1245 gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr)); 1246 gfc_add_modify (&cond_block, unshare_expr (dest), 1247 build_zero_cst (TREE_TYPE (dest))); 1248 } 1249 else_b = gfc_finish_block (&cond_block); 1250 1251 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1252 unshare_expr (srcptr), null_pointer_node); 1253 gfc_add_expr_to_block (&block, 1254 build3_loc (input_location, COND_EXPR, 1255 void_type_node, cond, 1256 then_b, else_b)); 1257 } 1258 else 1259 gfc_add_expr_to_block (&block, then_b); 1260 1261 return gfc_finish_block (&block); 1262 } 1263 1264 static void 1265 gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src, 1266 tree add, tree nelems) 1267 { 1268 stmtblock_t tmpblock; 1269 tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S"); 1270 nelems = gfc_evaluate_now (nelems, block); 1271 1272 gfc_init_block (&tmpblock); 1273 if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE) 1274 { 1275 desta = gfc_build_array_ref (dest, index, NULL); 1276 srca = gfc_build_array_ref (src, index, NULL); 1277 } 1278 else 1279 { 1280 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest))); 1281 tree idx = fold_build2 (MULT_EXPR, sizetype, 1282 fold_convert (sizetype, index), 1283 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest)))); 1284 desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, 1285 TREE_TYPE (dest), dest, 1286 idx)); 1287 srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, 1288 TREE_TYPE (src), src, 1289 idx)); 1290 } 1291 gfc_add_modify (&tmpblock, desta, 1292 fold_build2 (PLUS_EXPR, TREE_TYPE (desta), 1293 srca, add)); 1294 1295 gfc_loopinfo loop; 1296 gfc_init_loopinfo (&loop); 1297 loop.dimen = 1; 1298 loop.from[0] = gfc_index_zero_node; 1299 loop.loopvar[0] = index; 1300 loop.to[0] = nelems; 1301 gfc_trans_scalarizing_loops (&loop, &tmpblock); 1302 gfc_add_block_to_block (block, &loop.pre); 1303 } 1304 1305 /* Build and return code for a constructor of DEST that initializes 1306 it to SRC plus ADD (ADD is scalar integer). */ 1307 1308 tree 1309 gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add) 1310 { 1311 tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE; 1312 stmtblock_t block; 1313 1314 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); 1315 1316 gfc_start_block (&block); 1317 add = gfc_evaluate_now (add, &block); 1318 1319 if ((! GFC_DESCRIPTOR_TYPE_P (type) 1320 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 1321 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 1322 || !POINTER_TYPE_P (type))) 1323 { 1324 bool compute_nelts = false; 1325 gcc_assert (TREE_CODE (type) == ARRAY_TYPE); 1326 if (!TYPE_DOMAIN (type) 1327 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE 1328 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node 1329 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) 1330 compute_nelts = true; 1331 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) 1332 { 1333 tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); 1334 if (lookup_attribute ("omp dummy var", a)) 1335 compute_nelts = true; 1336 } 1337 if (compute_nelts) 1338 { 1339 nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, 1340 TYPE_SIZE_UNIT (type), 1341 TYPE_SIZE_UNIT (TREE_TYPE (type))); 1342 nelems = size_binop (MINUS_EXPR, nelems, size_one_node); 1343 } 1344 else 1345 nelems = array_type_nelts (type); 1346 nelems = fold_convert (gfc_array_index_type, nelems); 1347 1348 gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems); 1349 return gfc_finish_block (&block); 1350 } 1351 1352 /* Allocatable arrays in LINEAR clauses need to be allocated 1353 and copied from SRC. */ 1354 gfc_add_modify (&block, dest, src); 1355 if (GFC_DESCRIPTOR_TYPE_P (type)) 1356 { 1357 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 1358 size = gfc_conv_descriptor_ubound_get (dest, rank); 1359 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 1360 size, 1361 gfc_conv_descriptor_lbound_get (dest, rank)); 1362 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1363 size, gfc_index_one_node); 1364 if (GFC_TYPE_ARRAY_RANK (type) > 1) 1365 size = fold_build2_loc (input_location, MULT_EXPR, 1366 gfc_array_index_type, size, 1367 gfc_conv_descriptor_stride_get (dest, rank)); 1368 tree esize = fold_convert (gfc_array_index_type, 1369 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 1370 nelems = gfc_evaluate_now (unshare_expr (size), &block); 1371 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 1372 nelems, unshare_expr (esize)); 1373 size = gfc_evaluate_now (fold_convert (size_type_node, size), 1374 &block); 1375 nelems = fold_build2_loc (input_location, MINUS_EXPR, 1376 gfc_array_index_type, nelems, 1377 gfc_index_one_node); 1378 } 1379 else 1380 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 1381 ptr = gfc_create_var (pvoid_type_node, NULL); 1382 gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); 1383 if (GFC_DESCRIPTOR_TYPE_P (type)) 1384 { 1385 gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr); 1386 tree etype = gfc_get_element_type (type); 1387 ptr = fold_convert (build_pointer_type (etype), ptr); 1388 tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src)); 1389 srcptr = fold_convert (build_pointer_type (etype), srcptr); 1390 gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems); 1391 } 1392 else 1393 { 1394 gfc_add_modify (&block, unshare_expr (dest), 1395 fold_convert (TREE_TYPE (dest), ptr)); 1396 ptr = fold_convert (TREE_TYPE (dest), ptr); 1397 tree dstm = build_fold_indirect_ref (ptr); 1398 tree srcm = build_fold_indirect_ref (unshare_expr (src)); 1399 gfc_add_modify (&block, dstm, 1400 fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add)); 1401 } 1402 return gfc_finish_block (&block); 1403 } 1404 1405 /* Build and return code destructing DECL. Return NULL if nothing 1406 to be done. */ 1407 1408 tree 1409 gfc_omp_clause_dtor (tree clause, tree decl) 1410 { 1411 tree type = TREE_TYPE (decl), tem; 1412 tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); 1413 tree orig_decl = OMP_CLAUSE_DECL (clause); 1414 1415 if (DECL_ARTIFICIAL (orig_decl) 1416 && DECL_LANG_SPECIFIC (orig_decl) 1417 && GFC_DECL_SAVED_DESCRIPTOR (orig_decl)) 1418 { 1419 orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl); 1420 decl_type = TREE_TYPE (orig_decl); 1421 } 1422 1423 /* Only pointer association was privatized; cf. gfc_omp_clause_copy_ctr. 1424 Scalar class pointers must not finalize or free their targets here. */ 1425 if (DECL_P (orig_decl) 1426 && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl) 1427 || GFC_DECL_GET_SCALAR_POINTER (orig_decl) 1428 || gfc_is_class_pointer_type (decl_type))) 1429 return NULL_TREE; 1430 1431 if (gfc_is_polymorphic_nonptr (decl_type)) 1432 { 1433 if (POINTER_TYPE_P (decl_type)) 1434 decl_type = TREE_TYPE (decl_type); 1435 decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); 1436 if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) 1437 fatal_error (input_location, 1438 "Sorry, polymorphic arrays not yet supported for " 1439 "firstprivate"); 1440 stmtblock_t block, cond_block; 1441 gfc_start_block (&block); 1442 gfc_init_block (&cond_block); 1443 tree final = gfc_class_vtab_final_get (decl); 1444 tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl)); 1445 gfc_se se; 1446 gfc_init_se (&se, NULL); 1447 symbol_attribute attr = {}; 1448 tree data = gfc_class_data_get (decl); 1449 tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr); 1450 1451 /* Call class->_vpt->_finalize + free. */ 1452 tree call = build_fold_indirect_ref (final); 1453 call = build_call_expr_loc (input_location, call, 3, 1454 gfc_build_addr_expr (NULL, desc), 1455 size, boolean_false_node); 1456 gfc_add_block_to_block (&cond_block, &se.pre); 1457 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); 1458 gfc_add_block_to_block (&cond_block, &se.post); 1459 /* Create: if (_vtab && _final) <cond_block> */ 1460 tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1461 gfc_class_vptr_get (decl), 1462 null_pointer_node); 1463 tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1464 final, null_pointer_node); 1465 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 1466 boolean_type_node, cond, cond2); 1467 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, 1468 void_type_node, cond, 1469 gfc_finish_block (&cond_block), NULL_TREE)); 1470 call = builtin_decl_explicit (BUILT_IN_FREE); 1471 call = build_call_expr_loc (input_location, call, 1, data); 1472 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); 1473 return gfc_finish_block (&block); 1474 } 1475 1476 if ((! GFC_DESCRIPTOR_TYPE_P (type) 1477 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 1478 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 1479 || !POINTER_TYPE_P (type))) 1480 { 1481 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1482 return gfc_walk_alloc_comps (decl, NULL_TREE, 1483 OMP_CLAUSE_DECL (clause), 1484 WALK_ALLOC_COMPS_DTOR); 1485 return NULL_TREE; 1486 } 1487 1488 if (GFC_DESCRIPTOR_TYPE_P (type)) 1489 { 1490 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need 1491 to be deallocated if they were allocated. */ 1492 tem = gfc_conv_descriptor_data_get (decl); 1493 tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE, 1494 NULL_TREE, true, NULL, 1495 GFC_CAF_COARRAY_NOCOARRAY); 1496 } 1497 else 1498 tem = gfc_call_free (decl); 1499 tem = gfc_omp_unshare_expr (tem); 1500 1501 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1502 { 1503 stmtblock_t block; 1504 tree then_b; 1505 1506 gfc_init_block (&block); 1507 gfc_add_expr_to_block (&block, 1508 gfc_walk_alloc_comps (decl, NULL_TREE, 1509 OMP_CLAUSE_DECL (clause), 1510 WALK_ALLOC_COMPS_DTOR)); 1511 gfc_add_expr_to_block (&block, tem); 1512 then_b = gfc_finish_block (&block); 1513 1514 tem = fold_convert (pvoid_type_node, 1515 GFC_DESCRIPTOR_TYPE_P (type) 1516 ? gfc_conv_descriptor_data_get (decl) : decl); 1517 tem = unshare_expr (tem); 1518 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1519 tem, null_pointer_node); 1520 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, 1521 then_b, build_empty_stmt (input_location)); 1522 } 1523 return tem; 1524 } 1525 1526 /* Build a conditional expression in BLOCK. If COND_VAL is not 1527 null, then the block THEN_B is executed, otherwise ELSE_VAL 1528 is assigned to VAL. */ 1529 1530 static void 1531 gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val, 1532 tree then_b, tree else_val) 1533 { 1534 stmtblock_t cond_block; 1535 tree else_b = NULL_TREE; 1536 tree val_ty = TREE_TYPE (val); 1537 1538 if (else_val) 1539 { 1540 gfc_init_block (&cond_block); 1541 gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val)); 1542 else_b = gfc_finish_block (&cond_block); 1543 } 1544 gfc_add_expr_to_block (block, 1545 build3_loc (input_location, COND_EXPR, void_type_node, 1546 cond_val, then_b, else_b)); 1547 } 1548 1549 /* Build a conditional expression in BLOCK, returning a temporary 1550 variable containing the result. If COND_VAL is not null, then 1551 THEN_VAL will be assigned to the variable, otherwise ELSE_VAL 1552 is assigned. 1553 */ 1554 1555 static tree 1556 gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val, 1557 tree then_val, tree else_val) 1558 { 1559 tree val; 1560 tree val_ty = TREE_TYPE (then_val); 1561 stmtblock_t cond_block; 1562 1563 val = create_tmp_var (val_ty); 1564 1565 gfc_init_block (&cond_block); 1566 gfc_add_modify (&cond_block, val, then_val); 1567 tree then_b = gfc_finish_block (&cond_block); 1568 1569 gfc_build_cond_assign (block, val, cond_val, then_b, else_val); 1570 1571 return val; 1572 } 1573 1574 void 1575 gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) 1576 { 1577 if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP) 1578 return; 1579 1580 tree decl = OMP_CLAUSE_DECL (c); 1581 1582 /* Assumed-size arrays can't be mapped implicitly, they have to be 1583 mapped explicitly using array sections. */ 1584 if (TREE_CODE (decl) == PARM_DECL 1585 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) 1586 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN 1587 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), 1588 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) 1589 == NULL) 1590 { 1591 error_at (OMP_CLAUSE_LOCATION (c), 1592 "implicit mapping of assumed size array %qD", decl); 1593 return; 1594 } 1595 1596 tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; 1597 tree present = gfc_omp_check_optional_argument (decl, true); 1598 if (POINTER_TYPE_P (TREE_TYPE (decl))) 1599 { 1600 if (!gfc_omp_privatize_by_reference (decl) 1601 && !GFC_DECL_GET_SCALAR_POINTER (decl) 1602 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 1603 && !GFC_DECL_CRAY_POINTEE (decl) 1604 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) 1605 return; 1606 tree orig_decl = decl; 1607 1608 c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); 1609 OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); 1610 OMP_CLAUSE_DECL (c4) = decl; 1611 OMP_CLAUSE_SIZE (c4) = size_int (0); 1612 decl = build_fold_indirect_ref (decl); 1613 if (present 1614 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) 1615 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) 1616 { 1617 c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 1618 OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); 1619 OMP_CLAUSE_DECL (c2) = decl; 1620 OMP_CLAUSE_SIZE (c2) = size_int (0); 1621 1622 stmtblock_t block; 1623 gfc_start_block (&block); 1624 tree ptr = decl; 1625 ptr = gfc_build_cond_assign_expr (&block, present, decl, 1626 null_pointer_node); 1627 gimplify_and_add (gfc_finish_block (&block), pre_p); 1628 ptr = build_fold_indirect_ref (ptr); 1629 OMP_CLAUSE_DECL (c) = ptr; 1630 OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); 1631 } 1632 else 1633 { 1634 OMP_CLAUSE_DECL (c) = decl; 1635 OMP_CLAUSE_SIZE (c) = NULL_TREE; 1636 } 1637 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE 1638 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) 1639 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) 1640 { 1641 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); 1642 OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); 1643 OMP_CLAUSE_DECL (c3) = unshare_expr (decl); 1644 OMP_CLAUSE_SIZE (c3) = size_int (0); 1645 decl = build_fold_indirect_ref (decl); 1646 OMP_CLAUSE_DECL (c) = decl; 1647 } 1648 } 1649 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 1650 { 1651 stmtblock_t block; 1652 gfc_start_block (&block); 1653 tree type = TREE_TYPE (decl); 1654 tree ptr = gfc_conv_descriptor_data_get (decl); 1655 1656 /* OpenMP: automatically map pointer targets with the pointer; 1657 hence, always update the descriptor/pointer itself. 1658 NOTE: This also remaps the pointer for allocatable arrays with 1659 'target' attribute which also don't have the 'restrict' qualifier. */ 1660 bool always_modifier = false; 1661 1662 if (!openacc 1663 && !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT)) 1664 always_modifier = true; 1665 1666 if (present) 1667 ptr = gfc_build_cond_assign_expr (&block, present, ptr, 1668 null_pointer_node); 1669 gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); 1670 ptr = build_fold_indirect_ref (ptr); 1671 OMP_CLAUSE_DECL (c) = ptr; 1672 c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 1673 OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); 1674 if (present) 1675 { 1676 ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0))); 1677 gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0)); 1678 1679 OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr); 1680 } 1681 else 1682 OMP_CLAUSE_DECL (c2) = decl; 1683 OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); 1684 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); 1685 OMP_CLAUSE_SET_MAP_KIND (c3, always_modifier ? GOMP_MAP_ALWAYS_POINTER 1686 : GOMP_MAP_POINTER); 1687 if (present) 1688 { 1689 ptr = gfc_conv_descriptor_data_get (decl); 1690 ptr = gfc_build_addr_expr (NULL, ptr); 1691 ptr = gfc_build_cond_assign_expr (&block, present, 1692 ptr, null_pointer_node); 1693 ptr = build_fold_indirect_ref (ptr); 1694 OMP_CLAUSE_DECL (c3) = ptr; 1695 } 1696 else 1697 OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); 1698 OMP_CLAUSE_SIZE (c3) = size_int (0); 1699 tree size = create_tmp_var (gfc_array_index_type); 1700 tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 1701 elemsz = fold_convert (gfc_array_index_type, elemsz); 1702 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE 1703 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER 1704 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) 1705 { 1706 stmtblock_t cond_block; 1707 tree tem, then_b, else_b, zero, cond; 1708 1709 gfc_init_block (&cond_block); 1710 tem = gfc_full_array_size (&cond_block, decl, 1711 GFC_TYPE_ARRAY_RANK (type)); 1712 gfc_add_modify (&cond_block, size, tem); 1713 gfc_add_modify (&cond_block, size, 1714 fold_build2 (MULT_EXPR, gfc_array_index_type, 1715 size, elemsz)); 1716 then_b = gfc_finish_block (&cond_block); 1717 gfc_init_block (&cond_block); 1718 zero = build_int_cst (gfc_array_index_type, 0); 1719 gfc_add_modify (&cond_block, size, zero); 1720 else_b = gfc_finish_block (&cond_block); 1721 tem = gfc_conv_descriptor_data_get (decl); 1722 tem = fold_convert (pvoid_type_node, tem); 1723 cond = fold_build2_loc (input_location, NE_EXPR, 1724 boolean_type_node, tem, null_pointer_node); 1725 if (present) 1726 { 1727 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 1728 boolean_type_node, present, cond); 1729 } 1730 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, 1731 void_type_node, cond, 1732 then_b, else_b)); 1733 } 1734 else if (present) 1735 { 1736 stmtblock_t cond_block; 1737 tree then_b; 1738 1739 gfc_init_block (&cond_block); 1740 gfc_add_modify (&cond_block, size, 1741 gfc_full_array_size (&cond_block, decl, 1742 GFC_TYPE_ARRAY_RANK (type))); 1743 gfc_add_modify (&cond_block, size, 1744 fold_build2 (MULT_EXPR, gfc_array_index_type, 1745 size, elemsz)); 1746 then_b = gfc_finish_block (&cond_block); 1747 1748 gfc_build_cond_assign (&block, size, present, then_b, 1749 build_int_cst (gfc_array_index_type, 0)); 1750 } 1751 else 1752 { 1753 gfc_add_modify (&block, size, 1754 gfc_full_array_size (&block, decl, 1755 GFC_TYPE_ARRAY_RANK (type))); 1756 gfc_add_modify (&block, size, 1757 fold_build2 (MULT_EXPR, gfc_array_index_type, 1758 size, elemsz)); 1759 } 1760 OMP_CLAUSE_SIZE (c) = size; 1761 tree stmt = gfc_finish_block (&block); 1762 gimplify_and_add (stmt, pre_p); 1763 } 1764 tree last = c; 1765 if (OMP_CLAUSE_SIZE (c) == NULL_TREE) 1766 { 1767 if (DECL_P (decl)) 1768 OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl); 1769 else 1770 { 1771 tree type = TREE_TYPE (decl); 1772 tree size = TYPE_SIZE_UNIT (type); 1773 /* For variable-length character types, TYPE_SIZE_UNIT is a 1774 SAVE_EXPR. Gimplifying the SAVE_EXPR (here or elsewhere) 1775 resolves it in place, embedding a gimple temporary that 1776 later causes an ICE in remap_type during inlining because 1777 the temporary is not in scope (PR101760, PR102314). 1778 Compute the size from the array domain and element size 1779 to decouple completely from the type's SAVE_EXPRs. */ 1780 if (size 1781 && TREE_CODE (type) == ARRAY_TYPE 1782 && TYPE_DOMAIN (type) 1783 && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) 1784 && !TREE_CONSTANT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) 1785 { 1786 tree len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 1787 tree lb = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); 1788 tree eltsz = TYPE_SIZE_UNIT (TREE_TYPE (type)); 1789 len = fold_build2 (MINUS_EXPR, TREE_TYPE (len), len, lb); 1790 len = fold_build2 (PLUS_EXPR, TREE_TYPE (len), len, 1791 build_one_cst (TREE_TYPE (len))); 1792 size = fold_build2 (MULT_EXPR, sizetype, 1793 fold_convert (sizetype, len), 1794 fold_convert (sizetype, eltsz)); 1795 } 1796 OMP_CLAUSE_SIZE (c) = size; 1797 } 1798 } 1799 if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, 1800 NULL, is_gimple_val, fb_rvalue) == GS_ERROR) 1801 OMP_CLAUSE_SIZE (c) = size_int (0); 1802 if (c2) 1803 { 1804 OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); 1805 OMP_CLAUSE_CHAIN (last) = c2; 1806 last = c2; 1807 } 1808 if (c3) 1809 { 1810 OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last); 1811 OMP_CLAUSE_CHAIN (last) = c3; 1812 last = c3; 1813 } 1814 if (c4) 1815 { 1816 OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); 1817 OMP_CLAUSE_CHAIN (last) = c4; 1818 } 1819 } 1820 1821 1822 /* Return true if DECL is a scalar variable (for the purpose of 1823 implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.' 1824 is true, allocatables and pointers are permitted. */ 1825 1826 bool 1827 gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok) 1828 { 1829 tree type = TREE_TYPE (decl); 1830 if (TREE_CODE (type) == REFERENCE_TYPE) 1831 type = TREE_TYPE (type); 1832 if (TREE_CODE (type) == POINTER_TYPE) 1833 { 1834 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 1835 || GFC_DECL_GET_SCALAR_POINTER (decl)) 1836 { 1837 if (!ptr_alloc_ok) 1838 return false; 1839 type = TREE_TYPE (type); 1840 } 1841 if (GFC_ARRAY_TYPE_P (type) 1842 || GFC_CLASS_TYPE_P (type)) 1843 return false; 1844 } 1845 if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE) 1846 && TYPE_STRING_FLAG (type)) 1847 return false; 1848 if (INTEGRAL_TYPE_P (type) 1849 || SCALAR_FLOAT_TYPE_P (type) 1850 || COMPLEX_FLOAT_TYPE_P (type)) 1851 return true; 1852 return false; 1853 } 1854 1855 1856 /* Return true if DECL is a scalar with target attribute but does not have the 1857 allocatable (or pointer) attribute (for the purpose of implicit mapping). */ 1858 1859 bool 1860 gfc_omp_scalar_target_p (tree decl) 1861 { 1862 return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl) 1863 && gfc_omp_scalar_p (decl, false)); 1864 } 1865 1866 1867 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be 1868 disregarded in OpenMP construct, because it is going to be 1869 remapped during OpenMP lowering. SHARED is true if DECL 1870 is going to be shared, false if it is going to be privatized. */ 1871 1872 bool 1873 gfc_omp_disregard_value_expr (tree decl, bool shared) 1874 { 1875 if (GFC_DECL_COMMON_OR_EQUIV (decl) 1876 && DECL_HAS_VALUE_EXPR_P (decl)) 1877 { 1878 tree value = DECL_VALUE_EXPR (decl); 1879 1880 if (TREE_CODE (value) == COMPONENT_REF 1881 && VAR_P (TREE_OPERAND (value, 0)) 1882 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) 1883 { 1884 /* If variable in COMMON or EQUIVALENCE is privatized, return 1885 true, as just that variable is supposed to be privatized, 1886 not the whole COMMON or whole EQUIVALENCE. 1887 For shared variables in COMMON or EQUIVALENCE, let them be 1888 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars 1889 from the same COMMON or EQUIVALENCE just one sharing of the 1890 whole COMMON or EQUIVALENCE is enough. */ 1891 return ! shared; 1892 } 1893 } 1894 1895 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl)) 1896 return ! shared; 1897 1898 return false; 1899 } 1900 1901 /* Return true if DECL that is shared iff SHARED is true should 1902 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG 1903 flag set. */ 1904 1905 bool 1906 gfc_omp_private_debug_clause (tree decl, bool shared) 1907 { 1908 if (GFC_DECL_CRAY_POINTEE (decl)) 1909 return true; 1910 1911 if (GFC_DECL_COMMON_OR_EQUIV (decl) 1912 && DECL_HAS_VALUE_EXPR_P (decl)) 1913 { 1914 tree value = DECL_VALUE_EXPR (decl); 1915 1916 if (TREE_CODE (value) == COMPONENT_REF 1917 && VAR_P (TREE_OPERAND (value, 0)) 1918 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) 1919 return shared; 1920 } 1921 1922 return false; 1923 } 1924 1925 /* Register language specific type size variables as potentially OpenMP 1926 firstprivate variables. */ 1927 1928 void 1929 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type) 1930 { 1931 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) 1932 { 1933 int r; 1934 1935 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL); 1936 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++) 1937 { 1938 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r)); 1939 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r)); 1940 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r)); 1941 } 1942 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type)); 1943 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type)); 1944 } 1945 } 1946 1947 1948 static inline tree 1949 gfc_trans_add_clause (tree node, tree tail) 1950 { 1951 OMP_CLAUSE_CHAIN (node) = tail; 1952 return node; 1953 } 1954 1955 static tree 1956 gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd) 1957 { 1958 if (declare_simd) 1959 { 1960 int cnt = 0; 1961 gfc_symbol *proc_sym; 1962 gfc_formal_arglist *f; 1963 1964 gcc_assert (sym->attr.dummy); 1965 proc_sym = sym->ns->proc_name; 1966 if (proc_sym->attr.entry_master) 1967 ++cnt; 1968 if (gfc_return_by_reference (proc_sym)) 1969 { 1970 ++cnt; 1971 if (proc_sym->ts.type == BT_CHARACTER) 1972 ++cnt; 1973 } 1974 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) 1975 if (f->sym == sym) 1976 break; 1977 else if (f->sym) 1978 ++cnt; 1979 gcc_assert (f); 1980 return build_int_cst (integer_type_node, cnt); 1981 } 1982 1983 tree t = gfc_get_symbol_decl (sym); 1984 tree parent_decl; 1985 int parent_flag; 1986 bool return_value; 1987 bool alternate_entry; 1988 bool entry_master; 1989 1990 return_value = sym->attr.function && sym->result == sym; 1991 alternate_entry = sym->attr.function && sym->attr.entry 1992 && sym->result == sym; 1993 entry_master = sym->attr.result 1994 && sym->ns->proc_name->attr.entry_master 1995 && !gfc_return_by_reference (sym->ns->proc_name); 1996 parent_decl = current_function_decl 1997 ? DECL_CONTEXT (current_function_decl) : NULL_TREE; 1998 1999 if ((t == parent_decl && return_value) 2000 || (sym->ns && sym->ns->proc_name 2001 && sym->ns->proc_name->backend_decl == parent_decl 2002 && (alternate_entry || entry_master))) 2003 parent_flag = 1; 2004 else 2005 parent_flag = 0; 2006 2007 /* Special case for assigning the return value of a function. 2008 Self recursive functions must have an explicit return value. */ 2009 if (return_value && (t == current_function_decl || parent_flag)) 2010 t = gfc_get_fake_result_decl (sym, parent_flag); 2011 2012 /* Similarly for alternate entry points. */ 2013 else if (alternate_entry 2014 && (sym->ns->proc_name->backend_decl == current_function_decl 2015 || parent_flag)) 2016 { 2017 gfc_entry_list *el = NULL; 2018 2019 for (el = sym->ns->entries; el; el = el->next) 2020 if (sym == el->sym) 2021 { 2022 t = gfc_get_fake_result_decl (sym, parent_flag); 2023 break; 2024 } 2025 } 2026 2027 else if (entry_master 2028 && (sym->ns->proc_name->backend_decl == current_function_decl 2029 || parent_flag)) 2030 t = gfc_get_fake_result_decl (sym, parent_flag); 2031 2032 return t; 2033 } 2034 2035 static tree 2036 gfc_trans_omp_variable_list (enum omp_clause_code code, 2037 gfc_omp_namelist *namelist, tree list, 2038 bool declare_simd) 2039 { 2040 for (; namelist != NULL; namelist = namelist->next) 2041 if (namelist->sym->attr.referenced || declare_simd) 2042 { 2043 tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); 2044 if (t != error_mark_node) 2045 { 2046 tree node; 2047 node = build_omp_clause (input_location, code); 2048 OMP_CLAUSE_DECL (node) = t; 2049 list = gfc_trans_add_clause (node, list); 2050 2051 if (code == OMP_CLAUSE_LASTPRIVATE 2052 && namelist->u.lastprivate_conditional) 2053 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1; 2054 } 2055 } 2056 return list; 2057 } 2058 2059 struct omp_udr_find_orig_data 2060 { 2061 gfc_omp_udr *omp_udr; 2062 bool omp_orig_seen; 2063 }; 2064 2065 static int 2066 omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 2067 void *data) 2068 { 2069 struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data; 2070 if ((*e)->expr_type == EXPR_VARIABLE 2071 && (*e)->symtree->n.sym == cd->omp_udr->omp_orig) 2072 cd->omp_orig_seen = true; 2073 2074 return 0; 2075 } 2076 2077 static void 2078 gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) 2079 { 2080 gfc_symbol *sym = n->sym; 2081 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; 2082 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; 2083 gfc_symbol init_val_sym, outer_sym, intrinsic_sym; 2084 gfc_symbol omp_var_copy[4]; 2085 gfc_expr *e1, *e2, *e3, *e4; 2086 gfc_ref *ref; 2087 tree decl, backend_decl, stmt, type, outer_decl; 2088 locus old_loc = gfc_current_locus; 2089 const char *iname; 2090 bool t; 2091 gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL; 2092 2093 decl = OMP_CLAUSE_DECL (c); 2094 gfc_current_locus = where; 2095 type = TREE_TYPE (decl); 2096 outer_decl = create_tmp_var_raw (type); 2097 if (TREE_CODE (decl) == PARM_DECL 2098 && TREE_CODE (type) == REFERENCE_TYPE 2099 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) 2100 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE) 2101 { 2102 decl = build_fold_indirect_ref (decl); 2103 type = TREE_TYPE (type); 2104 } 2105 2106 /* Create a fake symbol for init value. */ 2107 memset (&init_val_sym, 0, sizeof (init_val_sym)); 2108 init_val_sym.ns = sym->ns; 2109 init_val_sym.name = sym->name; 2110 init_val_sym.ts = sym->ts; 2111 init_val_sym.attr.referenced = 1; 2112 init_val_sym.declared_at = where; 2113 init_val_sym.attr.flavor = FL_VARIABLE; 2114 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) 2115 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); 2116 else if (udr->initializer_ns) 2117 backend_decl = NULL; 2118 else 2119 switch (sym->ts.type) 2120 { 2121 case BT_LOGICAL: 2122 case BT_INTEGER: 2123 case BT_REAL: 2124 case BT_COMPLEX: 2125 backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym)); 2126 break; 2127 default: 2128 backend_decl = NULL_TREE; 2129 break; 2130 } 2131 init_val_sym.backend_decl = backend_decl; 2132 2133 /* Create a fake symbol for the outer array reference. */ 2134 outer_sym = *sym; 2135 if (sym->as) 2136 outer_sym.as = gfc_copy_array_spec (sym->as); 2137 outer_sym.attr.dummy = 0; 2138 outer_sym.attr.result = 0; 2139 outer_sym.attr.flavor = FL_VARIABLE; 2140 outer_sym.backend_decl = outer_decl; 2141 if (decl != OMP_CLAUSE_DECL (c)) 2142 outer_sym.backend_decl = build_fold_indirect_ref (outer_decl); 2143 2144 /* Create fake symtrees for it. */ 2145 symtree1 = gfc_new_symtree (&root1, sym->name); 2146 symtree1->n.sym = sym; 2147 gcc_assert (symtree1 == root1); 2148 2149 symtree2 = gfc_new_symtree (&root2, sym->name); 2150 symtree2->n.sym = &init_val_sym; 2151 gcc_assert (symtree2 == root2); 2152 2153 symtree3 = gfc_new_symtree (&root3, sym->name); 2154 symtree3->n.sym = &outer_sym; 2155 gcc_assert (symtree3 == root3); 2156 2157 memset (omp_var_copy, 0, sizeof omp_var_copy); 2158 if (udr) 2159 { 2160 omp_var_copy[0] = *udr->omp_out; 2161 omp_var_copy[1] = *udr->omp_in; 2162 *udr->omp_out = outer_sym; 2163 *udr->omp_in = *sym; 2164 if (udr->initializer_ns) 2165 { 2166 omp_var_copy[2] = *udr->omp_priv; 2167 omp_var_copy[3] = *udr->omp_orig; 2168 *udr->omp_priv = *sym; 2169 *udr->omp_orig = outer_sym; 2170 } 2171 } 2172 2173 /* Create expressions. */ 2174 e1 = gfc_get_expr (); 2175 e1->expr_type = EXPR_VARIABLE; 2176 e1->where = where; 2177 e1->symtree = symtree1; 2178 e1->ts = sym->ts; 2179 if (sym->attr.dimension) 2180 { 2181 e1->ref = ref = gfc_get_ref (); 2182 ref->type = REF_ARRAY; 2183 ref->u.ar.where = where; 2184 ref->u.ar.as = sym->as; 2185 ref->u.ar.type = AR_FULL; 2186 ref->u.ar.dimen = 0; 2187 } 2188 t = gfc_resolve_expr (e1); 2189 gcc_assert (t); 2190 2191 e2 = NULL; 2192 if (backend_decl != NULL_TREE) 2193 { 2194 e2 = gfc_get_expr (); 2195 e2->expr_type = EXPR_VARIABLE; 2196 e2->where = where; 2197 e2->symtree = symtree2; 2198 e2->ts = sym->ts; 2199 t = gfc_resolve_expr (e2); 2200 gcc_assert (t); 2201 } 2202 else if (udr->initializer_ns == NULL) 2203 { 2204 gcc_assert (sym->ts.type == BT_DERIVED); 2205 e2 = gfc_default_initializer (&sym->ts); 2206 gcc_assert (e2); 2207 t = gfc_resolve_expr (e2); 2208 gcc_assert (t); 2209 } 2210 else if (n->u2.udr->initializer->op == EXEC_ASSIGN) 2211 { 2212 e2 = gfc_copy_expr (n->u2.udr->initializer->expr2); 2213 t = gfc_resolve_expr (e2); 2214 gcc_assert (t); 2215 } 2216 if (udr && udr->initializer_ns) 2217 { 2218 struct omp_udr_find_orig_data cd; 2219 cd.omp_udr = udr; 2220 cd.omp_orig_seen = false; 2221 gfc_code_walker (&n->u2.udr->initializer, 2222 gfc_dummy_code_callback, omp_udr_find_orig, &cd); 2223 if (cd.omp_orig_seen) 2224 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; 2225 } 2226 2227 e3 = gfc_copy_expr (e1); 2228 e3->symtree = symtree3; 2229 t = gfc_resolve_expr (e3); 2230 gcc_assert (t); 2231 2232 iname = NULL; 2233 e4 = NULL; 2234 switch (OMP_CLAUSE_REDUCTION_CODE (c)) 2235 { 2236 case PLUS_EXPR: 2237 case MINUS_EXPR: 2238 e4 = gfc_add (e3, e1); 2239 break; 2240 case MULT_EXPR: 2241 e4 = gfc_multiply (e3, e1); 2242 break; 2243 case TRUTH_ANDIF_EXPR: 2244 e4 = gfc_and (e3, e1); 2245 break; 2246 case TRUTH_ORIF_EXPR: 2247 e4 = gfc_or (e3, e1); 2248 break; 2249 case EQ_EXPR: 2250 e4 = gfc_eqv (e3, e1); 2251 break; 2252 case NE_EXPR: 2253 e4 = gfc_neqv (e3, e1); 2254 break; 2255 case MIN_EXPR: 2256 iname = "min"; 2257 break; 2258 case MAX_EXPR: 2259 iname = "max"; 2260 break; 2261 case BIT_AND_EXPR: 2262 iname = "iand"; 2263 break; 2264 case BIT_IOR_EXPR: 2265 iname = "ior"; 2266 break; 2267 case BIT_XOR_EXPR: 2268 iname = "ieor"; 2269 break; 2270 case ERROR_MARK: 2271 if (n->u2.udr->combiner->op == EXEC_ASSIGN) 2272 { 2273 gfc_free_expr (e3); 2274 e3 = gfc_copy_expr (n->u2.udr->combiner->expr1); 2275 e4 = gfc_copy_expr (n->u2.udr->combiner->expr2); 2276 t = gfc_resolve_expr (e3); 2277 gcc_assert (t); 2278 t = gfc_resolve_expr (e4); 2279 gcc_assert (t); 2280 } 2281 break; 2282 default: 2283 gcc_unreachable (); 2284 } 2285 if (iname != NULL) 2286 { 2287 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); 2288 intrinsic_sym.ns = sym->ns; 2289 intrinsic_sym.name = iname; 2290 intrinsic_sym.ts = sym->ts; 2291 intrinsic_sym.attr.referenced = 1; 2292 intrinsic_sym.attr.intrinsic = 1; 2293 intrinsic_sym.attr.function = 1; 2294 intrinsic_sym.attr.implicit_type = 1; 2295 intrinsic_sym.result = &intrinsic_sym; 2296 intrinsic_sym.declared_at = where; 2297 2298 symtree4 = gfc_new_symtree (&root4, iname); 2299 symtree4->n.sym = &intrinsic_sym; 2300 gcc_assert (symtree4 == root4); 2301 2302 e4 = gfc_get_expr (); 2303 e4->expr_type = EXPR_FUNCTION; 2304 e4->where = where; 2305 e4->symtree = symtree4; 2306 e4->value.function.actual = gfc_get_actual_arglist (); 2307 e4->value.function.actual->expr = e3; 2308 e4->value.function.actual->next = gfc_get_actual_arglist (); 2309 e4->value.function.actual->next->expr = e1; 2310 } 2311 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) 2312 { 2313 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ 2314 e1 = gfc_copy_expr (e1); 2315 e3 = gfc_copy_expr (e3); 2316 t = gfc_resolve_expr (e4); 2317 gcc_assert (t); 2318 } 2319 2320 /* Create the init statement list. */ 2321 pushlevel (); 2322 if (e2) 2323 stmt = gfc_trans_assignment (e1, e2, false, false); 2324 else 2325 stmt = gfc_trans_call (n->u2.udr->initializer, false, 2326 NULL_TREE, NULL_TREE, false); 2327 if (TREE_CODE (stmt) != BIND_EXPR) 2328 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 2329 else 2330 poplevel (0, 0); 2331 OMP_CLAUSE_REDUCTION_INIT (c) = stmt; 2332 2333 /* Create the merge statement list. */ 2334 pushlevel (); 2335 if (e4) 2336 stmt = gfc_trans_assignment (e3, e4, false, true); 2337 else 2338 stmt = gfc_trans_call (n->u2.udr->combiner, false, 2339 NULL_TREE, NULL_TREE, false); 2340 if (TREE_CODE (stmt) != BIND_EXPR) 2341 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 2342 else 2343 poplevel (0, 0); 2344 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; 2345 2346 /* And stick the placeholder VAR_DECL into the clause as well. */ 2347 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl; 2348 2349 gfc_current_locus = old_loc; 2350 2351 gfc_free_expr (e1); 2352 if (e2) 2353 gfc_free_expr (e2); 2354 gfc_free_expr (e3); 2355 if (e4) 2356 gfc_free_expr (e4); 2357 free (symtree1); 2358 free (symtree2); 2359 free (symtree3); 2360 free (symtree4); 2361 if (outer_sym.as) 2362 gfc_free_array_spec (outer_sym.as); 2363 2364 if (udr) 2365 { 2366 *udr->omp_out = omp_var_copy[0]; 2367 *udr->omp_in = omp_var_copy[1]; 2368 if (udr->initializer_ns) 2369 { 2370 *udr->omp_priv = omp_var_copy[2]; 2371 *udr->omp_orig = omp_var_copy[3]; 2372 } 2373 } 2374 } 2375 2376 static tree 2377 gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list, 2378 locus where, bool mark_addressable) 2379 { 2380 omp_clause_code clause = OMP_CLAUSE_REDUCTION; 2381 switch (kind) 2382 { 2383 case OMP_LIST_REDUCTION: 2384 case OMP_LIST_REDUCTION_INSCAN: 2385 case OMP_LIST_REDUCTION_TASK: 2386 break; 2387 case OMP_LIST_IN_REDUCTION: 2388 clause = OMP_CLAUSE_IN_REDUCTION; 2389 break; 2390 case OMP_LIST_TASK_REDUCTION: 2391 clause = OMP_CLAUSE_TASK_REDUCTION; 2392 break; 2393 default: 2394 gcc_unreachable (); 2395 } 2396 for (; namelist != NULL; namelist = namelist->next) 2397 if (namelist->sym->attr.referenced) 2398 { 2399 tree t = gfc_trans_omp_variable (namelist->sym, false); 2400 if (t != error_mark_node) 2401 { 2402 tree node = build_omp_clause (gfc_get_location (&namelist->where), 2403 clause); 2404 OMP_CLAUSE_DECL (node) = t; 2405 if (mark_addressable) 2406 TREE_ADDRESSABLE (t) = 1; 2407 if (kind == OMP_LIST_REDUCTION_INSCAN) 2408 OMP_CLAUSE_REDUCTION_INSCAN (node) = 1; 2409 if (kind == OMP_LIST_REDUCTION_TASK) 2410 OMP_CLAUSE_REDUCTION_TASK (node) = 1; 2411 switch (namelist->u.reduction_op) 2412 { 2413 case OMP_REDUCTION_PLUS: 2414 OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR; 2415 break; 2416 case OMP_REDUCTION_MINUS: 2417 OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR; 2418 break; 2419 case OMP_REDUCTION_TIMES: 2420 OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR; 2421 break; 2422 case OMP_REDUCTION_AND: 2423 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR; 2424 break; 2425 case OMP_REDUCTION_OR: 2426 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR; 2427 break; 2428 case OMP_REDUCTION_EQV: 2429 OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR; 2430 break; 2431 case OMP_REDUCTION_NEQV: 2432 OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR; 2433 break; 2434 case OMP_REDUCTION_MAX: 2435 OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR; 2436 break; 2437 case OMP_REDUCTION_MIN: 2438 OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR; 2439 break; 2440 case OMP_REDUCTION_IAND: 2441 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR; 2442 break; 2443 case OMP_REDUCTION_IOR: 2444 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR; 2445 break; 2446 case OMP_REDUCTION_IEOR: 2447 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR; 2448 break; 2449 case OMP_REDUCTION_USER: 2450 OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK; 2451 break; 2452 default: 2453 gcc_unreachable (); 2454 } 2455 if (namelist->sym->attr.dimension 2456 || namelist->u.reduction_op == OMP_REDUCTION_USER 2457 || namelist->sym->attr.allocatable) 2458 gfc_trans_omp_array_reduction_or_udr (node, namelist, where); 2459 list = gfc_trans_add_clause (node, list); 2460 } 2461 } 2462 return list; 2463 } 2464 2465 static inline tree 2466 gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr) 2467 { 2468 gfc_se se; 2469 tree result; 2470 2471 gfc_init_se (&se, NULL ); 2472 gfc_conv_expr (&se, expr); 2473 gfc_add_block_to_block (block, &se.pre); 2474 result = gfc_evaluate_now (se.expr, block); 2475 gfc_add_block_to_block (block, &se.post); 2476 2477 return result; 2478 } 2479 2480 static vec<tree, va_heap, vl_embed> *doacross_steps; 2481 2482 2483 /* Translate an array section or array element. */ 2484 2485 static void 2486 gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op, 2487 gfc_omp_namelist *n, tree decl, bool element, 2488 bool openmp, gomp_map_kind ptr_kind, tree &node, 2489 tree &node2, tree &node3, tree &node4) 2490 { 2491 gfc_se se; 2492 tree ptr, ptr2; 2493 tree elemsz = NULL_TREE; 2494 2495 gfc_init_se (&se, NULL); 2496 if (element) 2497 { 2498 gfc_conv_expr_reference (&se, n->expr); 2499 gfc_add_block_to_block (block, &se.pre); 2500 ptr = se.expr; 2501 } 2502 else 2503 { 2504 gfc_conv_expr_descriptor (&se, n->expr); 2505 ptr = gfc_conv_array_data (se.expr); 2506 } 2507 if (n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred) 2508 { 2509 gcc_assert (se.string_length); 2510 tree len = gfc_evaluate_now (se.string_length, block); 2511 elemsz = gfc_get_char_type (n->expr->ts.kind); 2512 elemsz = TYPE_SIZE_UNIT (elemsz); 2513 elemsz = fold_build2 (MULT_EXPR, size_type_node, 2514 fold_convert (size_type_node, len), elemsz); 2515 } 2516 if (element) 2517 { 2518 if (!elemsz) 2519 elemsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); 2520 OMP_CLAUSE_SIZE (node) = elemsz; 2521 } 2522 else 2523 { 2524 tree type = TREE_TYPE (se.expr); 2525 gfc_add_block_to_block (block, &se.pre); 2526 OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, 2527 GFC_TYPE_ARRAY_RANK (type)); 2528 if (!elemsz) 2529 elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 2530 elemsz = fold_convert (gfc_array_index_type, elemsz); 2531 OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, 2532 OMP_CLAUSE_SIZE (node), elemsz); 2533 } 2534 gcc_assert (se.post.head == NULL_TREE); 2535 gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); 2536 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); 2537 ptr = fold_convert (ptrdiff_type_node, ptr); 2538 2539 if (POINTER_TYPE_P (TREE_TYPE (decl)) 2540 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) 2541 && ptr_kind == GOMP_MAP_POINTER 2542 && op != EXEC_OMP_TARGET_EXIT_DATA 2543 && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_RELEASE 2544 && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_DELETE) 2545 2546 { 2547 node4 = build_omp_clause (input_location, 2548 OMP_CLAUSE_MAP); 2549 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); 2550 OMP_CLAUSE_DECL (node4) = decl; 2551 OMP_CLAUSE_SIZE (node4) = size_int (0); 2552 decl = build_fold_indirect_ref (decl); 2553 } 2554 else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER 2555 && n->expr->ts.type == BT_CHARACTER 2556 && n->expr->ts.deferred) 2557 { 2558 gomp_map_kind map_kind; 2559 if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE) 2560 map_kind = OMP_CLAUSE_MAP_KIND (node); 2561 else if (op == EXEC_OMP_TARGET_EXIT_DATA 2562 || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE) 2563 map_kind = GOMP_MAP_RELEASE; 2564 else 2565 map_kind = GOMP_MAP_TO; 2566 gcc_assert (se.string_length); 2567 node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 2568 OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); 2569 OMP_CLAUSE_DECL (node4) = se.string_length; 2570 OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node); 2571 } 2572 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 2573 { 2574 tree type = TREE_TYPE (decl); 2575 ptr2 = gfc_conv_descriptor_data_get (decl); 2576 node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 2577 OMP_CLAUSE_DECL (node2) = decl; 2578 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); 2579 if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE 2580 || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE 2581 || op == EXEC_OMP_TARGET_EXIT_DATA 2582 || op == EXEC_OACC_EXIT_DATA) 2583 { 2584 gomp_map_kind map_kind 2585 = OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE ? GOMP_MAP_DELETE 2586 : GOMP_MAP_RELEASE; 2587 OMP_CLAUSE_SET_MAP_KIND (node2, map_kind); 2588 OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1; 2589 } 2590 else 2591 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); 2592 node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 2593 OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); 2594 OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (decl); 2595 /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra 2596 cast prevents gimplify.cc from recognising it as being part of the 2597 struct - and adding an 'alloc: for the 'desc.data' pointer, which 2598 would break as the 'desc' (the descriptor) is also mapped 2599 (see node4 above). */ 2600 if (ptr_kind == GOMP_MAP_ATTACH_DETACH && !openmp) 2601 STRIP_NOPS (OMP_CLAUSE_DECL (node3)); 2602 } 2603 else 2604 { 2605 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) 2606 { 2607 tree offset; 2608 ptr2 = build_fold_addr_expr (decl); 2609 offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr, 2610 fold_convert (ptrdiff_type_node, ptr2)); 2611 offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node, 2612 offset, fold_convert (ptrdiff_type_node, elemsz)); 2613 offset = build4_loc (input_location, ARRAY_REF, 2614 TREE_TYPE (TREE_TYPE (decl)), 2615 decl, offset, NULL_TREE, NULL_TREE); 2616 OMP_CLAUSE_DECL (node) = offset; 2617 2618 if (ptr_kind == GOMP_MAP_ATTACH_DETACH && openmp) 2619 return; 2620 } 2621 else 2622 { 2623 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); 2624 ptr2 = decl; 2625 } 2626 node3 = build_omp_clause (input_location, 2627 OMP_CLAUSE_MAP); 2628 OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); 2629 OMP_CLAUSE_DECL (node3) = decl; 2630 } 2631 ptr2 = fold_convert (ptrdiff_type_node, ptr2); 2632 OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node, 2633 ptr, ptr2); 2634 } 2635 2636 static tree 2637 handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) 2638 { 2639 tree list = NULL_TREE; 2640 for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink) 2641 { 2642 gfc_constructor *c; 2643 gfc_se se; 2644 2645 tree last = make_tree_vec (6); 2646 tree iter_var = gfc_get_symbol_decl (sym); 2647 tree type = TREE_TYPE (iter_var); 2648 TREE_VEC_ELT (last, 0) = iter_var; 2649 DECL_CHAIN (iter_var) = BLOCK_VARS (block); 2650 BLOCK_VARS (block) = iter_var; 2651 2652 /* begin */ 2653 c = gfc_constructor_first (sym->value->value.constructor); 2654 gfc_init_se (&se, NULL); 2655 gfc_conv_expr (&se, c->expr); 2656 gfc_add_block_to_block (iter_block, &se.pre); 2657 gfc_add_block_to_block (iter_block, &se.post); 2658 TREE_VEC_ELT (last, 1) = fold_convert (type, 2659 gfc_evaluate_now (se.expr, 2660 iter_block)); 2661 /* end */ 2662 c = gfc_constructor_next (c); 2663 gfc_init_se (&se, NULL); 2664 gfc_conv_expr (&se, c->expr); 2665 gfc_add_block_to_block (iter_block, &se.pre); 2666 gfc_add_block_to_block (iter_block, &se.post); 2667 TREE_VEC_ELT (last, 2) = fold_convert (type, 2668 gfc_evaluate_now (se.expr, 2669 iter_block)); 2670 /* step */ 2671 c = gfc_constructor_next (c); 2672 tree step; 2673 if (c) 2674 { 2675 gfc_init_se (&se, NULL); 2676 gfc_conv_expr (&se, c->expr); 2677 gfc_add_block_to_block (iter_block, &se.pre); 2678 gfc_add_block_to_block (iter_block, &se.post); 2679 gfc_conv_expr (&se, c->expr); 2680 step = fold_convert (type, 2681 gfc_evaluate_now (se.expr, 2682 iter_block)); 2683 } 2684 else 2685 step = build_int_cst (type, 1); 2686 TREE_VEC_ELT (last, 3) = step; 2687 /* orig_step */ 2688 TREE_VEC_ELT (last, 4) = save_expr (step); 2689 TREE_CHAIN (last) = list; 2690 list = last; 2691 } 2692 return list; 2693 } 2694 2695 /* To alleviate quadratic behaviour in checking each entry of a 2696 gfc_omp_namelist against every other entry, we build a hashtable indexed by 2697 gfc_symbol pointer, which we can use in the usual case that a map 2698 expression has a symbol as its root term. Return a namelist based on the 2699 root symbol used by N, building a new table in SYM_ROOTED_NL using the 2700 gfc_omp_namelist N2 (all clauses) if we haven't done so already. */ 2701 2702 static gfc_omp_namelist * 2703 get_symbol_rooted_namelist (hash_map<gfc_symbol *, 2704 gfc_omp_namelist *> *&sym_rooted_nl, 2705 gfc_omp_namelist *n, 2706 gfc_omp_namelist *n2, bool *sym_based) 2707 { 2708 /* Early-out if we have a NULL clause list (e.g. for OpenACC). */ 2709 if (!n2) 2710 return NULL; 2711 2712 gfc_symbol *use_sym = NULL; 2713 2714 /* We're only interested in cases where we have an expression, e.g. a 2715 component access. */ 2716 if (n->expr && n->expr->expr_type == EXPR_VARIABLE && n->expr->symtree) 2717 use_sym = n->expr->symtree->n.sym; 2718 2719 *sym_based = false; 2720 2721 if (!use_sym) 2722 return n2; 2723 2724 if (!sym_rooted_nl) 2725 { 2726 sym_rooted_nl = new hash_map<gfc_symbol *, gfc_omp_namelist *> (); 2727 2728 for (; n2 != NULL; n2 = n2->next) 2729 { 2730 if (!n2->expr 2731 || n2->expr->expr_type != EXPR_VARIABLE 2732 || !n2->expr->symtree) 2733 continue; 2734 2735 gfc_omp_namelist *nl_copy = gfc_get_omp_namelist (); 2736 memcpy (nl_copy, n2, sizeof *nl_copy); 2737 nl_copy->u2.duplicate_of = n2; 2738 nl_copy->next = NULL; 2739 2740 gfc_symbol *idx_sym = n2->expr->symtree->n.sym; 2741 2742 bool existed; 2743 gfc_omp_namelist *&entry 2744 = sym_rooted_nl->get_or_insert (idx_sym, &existed); 2745 if (existed) 2746 nl_copy->next = entry; 2747 entry = nl_copy; 2748 } 2749 } 2750 2751 gfc_omp_namelist **n2_sym = sym_rooted_nl->get (use_sym); 2752 2753 if (n2_sym) 2754 { 2755 *sym_based = true; 2756 return *n2_sym; 2757 } 2758 2759 return NULL; 2760 } 2761 2762 static tree 2763 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, 2764 locus where, bool declare_simd = false, 2765 bool openacc = false, gfc_exec_op op = EXEC_NOP) 2766 { 2767 tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c; 2768 tree iterator = NULL_TREE; 2769 tree tree_block = NULL_TREE; 2770 stmtblock_t iter_block; 2771 int list, ifc; 2772 enum omp_clause_code clause_code; 2773 gfc_omp_namelist *prev = NULL; 2774 gfc_se se; 2775 2776 if (clauses == NULL) 2777 return NULL_TREE; 2778 2779 hash_map<gfc_symbol *, gfc_omp_namelist *> *sym_rooted_nl = NULL; 2780 2781 for (list = 0; list < OMP_LIST_NUM; list++) 2782 { 2783 gfc_omp_namelist *n = clauses->lists[list]; 2784 2785 if (n == NULL) 2786 continue; 2787 switch (list) 2788 { 2789 case OMP_LIST_REDUCTION: 2790 case OMP_LIST_REDUCTION_INSCAN: 2791 case OMP_LIST_REDUCTION_TASK: 2792 case OMP_LIST_IN_REDUCTION: 2793 case OMP_LIST_TASK_REDUCTION: 2794 /* An OpenACC async clause indicates the need to set reduction 2795 arguments addressable, to allow asynchronous copy-out. */ 2796 omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses, 2797 where, clauses->async); 2798 break; 2799 case OMP_LIST_PRIVATE: 2800 clause_code = OMP_CLAUSE_PRIVATE; 2801 goto add_clause; 2802 case OMP_LIST_SHARED: 2803 clause_code = OMP_CLAUSE_SHARED; 2804 goto add_clause; 2805 case OMP_LIST_FIRSTPRIVATE: 2806 clause_code = OMP_CLAUSE_FIRSTPRIVATE; 2807 goto add_clause; 2808 case OMP_LIST_LASTPRIVATE: 2809 clause_code = OMP_CLAUSE_LASTPRIVATE; 2810 goto add_clause; 2811 case OMP_LIST_COPYIN: 2812 clause_code = OMP_CLAUSE_COPYIN; 2813 goto add_clause; 2814 case OMP_LIST_COPYPRIVATE: 2815 clause_code = OMP_CLAUSE_COPYPRIVATE; 2816 goto add_clause; 2817 case OMP_LIST_UNIFORM: 2818 clause_code = OMP_CLAUSE_UNIFORM; 2819 goto add_clause; 2820 case OMP_LIST_USE_DEVICE: 2821 case OMP_LIST_USE_DEVICE_PTR: 2822 clause_code = OMP_CLAUSE_USE_DEVICE_PTR; 2823 goto add_clause; 2824 case OMP_LIST_USE_DEVICE_ADDR: 2825 clause_code = OMP_CLAUSE_USE_DEVICE_ADDR; 2826 goto add_clause; 2827 case OMP_LIST_IS_DEVICE_PTR: 2828 clause_code = OMP_CLAUSE_IS_DEVICE_PTR; 2829 goto add_clause; 2830 case OMP_LIST_HAS_DEVICE_ADDR: 2831 clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR; 2832 goto add_clause; 2833 case OMP_LIST_NONTEMPORAL: 2834 clause_code = OMP_CLAUSE_NONTEMPORAL; 2835 goto add_clause; 2836 case OMP_LIST_SCAN_IN: 2837 clause_code = OMP_CLAUSE_INCLUSIVE; 2838 goto add_clause; 2839 case OMP_LIST_SCAN_EX: 2840 clause_code = OMP_CLAUSE_EXCLUSIVE; 2841 goto add_clause; 2842 2843 add_clause: 2844 omp_clauses 2845 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses, 2846 declare_simd); 2847 break; 2848 case OMP_LIST_ALIGNED: 2849 for (; n != NULL; n = n->next) 2850 if (n->sym->attr.referenced || declare_simd) 2851 { 2852 tree t = gfc_trans_omp_variable (n->sym, declare_simd); 2853 if (t != error_mark_node) 2854 { 2855 tree node = build_omp_clause (input_location, 2856 OMP_CLAUSE_ALIGNED); 2857 OMP_CLAUSE_DECL (node) = t; 2858 if (n->expr) 2859 { 2860 tree alignment_var; 2861 2862 if (declare_simd) 2863 alignment_var = gfc_conv_constant_to_tree (n->expr); 2864 else 2865 { 2866 gfc_init_se (&se, NULL); 2867 gfc_conv_expr (&se, n->expr); 2868 gfc_add_block_to_block (block, &se.pre); 2869 alignment_var = gfc_evaluate_now (se.expr, block); 2870 gfc_add_block_to_block (block, &se.post); 2871 } 2872 OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var; 2873 } 2874 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2875 } 2876 } 2877 break; 2878 case OMP_LIST_ALLOCATE: 2879 { 2880 tree allocator_ = NULL_TREE; 2881 gfc_expr *alloc_expr = NULL; 2882 for (; n != NULL; n = n->next) 2883 if (n->sym->attr.referenced) 2884 { 2885 tree t = gfc_trans_omp_variable (n->sym, false); 2886 if (t != error_mark_node) 2887 { 2888 tree node = build_omp_clause (input_location, 2889 OMP_CLAUSE_ALLOCATE); 2890 OMP_CLAUSE_DECL (node) = t; 2891 if (n->u2.allocator) 2892 { 2893 if (alloc_expr != n->u2.allocator) 2894 { 2895 gfc_init_se (&se, NULL); 2896 gfc_conv_expr (&se, n->u2.allocator); 2897 gfc_add_block_to_block (block, &se.pre); 2898 allocator_ = gfc_evaluate_now (se.expr, block); 2899 gfc_add_block_to_block (block, &se.post); 2900 } 2901 OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_; 2902 } 2903 alloc_expr = n->u2.allocator; 2904 if (n->u.align) 2905 { 2906 tree align_; 2907 gfc_init_se (&se, NULL); 2908 gfc_conv_expr (&se, n->u.align); 2909 gcc_assert (CONSTANT_CLASS_P (se.expr) 2910 && se.pre.head == NULL 2911 && se.post.head == NULL); 2912 align_ = se.expr; 2913 OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_; 2914 } 2915 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2916 } 2917 } 2918 else 2919 alloc_expr = n->u2.allocator; 2920 } 2921 break; 2922 case OMP_LIST_LINEAR: 2923 { 2924 gfc_expr *last_step_expr = NULL; 2925 tree last_step = NULL_TREE; 2926 bool last_step_parm = false; 2927 2928 for (; n != NULL; n = n->next) 2929 { 2930 if (n->expr) 2931 { 2932 last_step_expr = n->expr; 2933 last_step = NULL_TREE; 2934 last_step_parm = false; 2935 } 2936 if (n->sym->attr.referenced || declare_simd) 2937 { 2938 tree t = gfc_trans_omp_variable (n->sym, declare_simd); 2939 if (t != error_mark_node) 2940 { 2941 tree node = build_omp_clause (input_location, 2942 OMP_CLAUSE_LINEAR); 2943 OMP_CLAUSE_DECL (node) = t; 2944 omp_clause_linear_kind kind; 2945 switch (n->u.linear.op) 2946 { 2947 case OMP_LINEAR_DEFAULT: 2948 kind = OMP_CLAUSE_LINEAR_DEFAULT; 2949 break; 2950 case OMP_LINEAR_REF: 2951 kind = OMP_CLAUSE_LINEAR_REF; 2952 break; 2953 case OMP_LINEAR_VAL: 2954 kind = OMP_CLAUSE_LINEAR_VAL; 2955 break; 2956 case OMP_LINEAR_UVAL: 2957 kind = OMP_CLAUSE_LINEAR_UVAL; 2958 break; 2959 default: 2960 gcc_unreachable (); 2961 } 2962 OMP_CLAUSE_LINEAR_KIND (node) = kind; 2963 OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node) 2964 = n->u.linear.old_modifier; 2965 if (last_step_expr && last_step == NULL_TREE) 2966 { 2967 if (!declare_simd) 2968 { 2969 gfc_init_se (&se, NULL); 2970 gfc_conv_expr (&se, last_step_expr); 2971 gfc_add_block_to_block (block, &se.pre); 2972 last_step = gfc_evaluate_now (se.expr, block); 2973 gfc_add_block_to_block (block, &se.post); 2974 } 2975 else if (last_step_expr->expr_type == EXPR_VARIABLE) 2976 { 2977 gfc_symbol *s = last_step_expr->symtree->n.sym; 2978 last_step = gfc_trans_omp_variable (s, true); 2979 last_step_parm = true; 2980 } 2981 else 2982 last_step 2983 = gfc_conv_constant_to_tree (last_step_expr); 2984 } 2985 if (last_step_parm) 2986 { 2987 OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1; 2988 OMP_CLAUSE_LINEAR_STEP (node) = last_step; 2989 } 2990 else 2991 { 2992 if (kind == OMP_CLAUSE_LINEAR_REF) 2993 { 2994 tree type; 2995 if (n->sym->attr.flavor == FL_PROCEDURE) 2996 { 2997 type = gfc_get_function_type (n->sym); 2998 type = build_pointer_type (type); 2999 } 3000 else 3001 type = gfc_sym_type (n->sym); 3002 if (POINTER_TYPE_P (type)) 3003 type = TREE_TYPE (type); 3004 /* Otherwise to be determined what exactly 3005 should be done. */ 3006 tree t = fold_convert (sizetype, last_step); 3007 t = size_binop (MULT_EXPR, t, 3008 TYPE_SIZE_UNIT (type)); 3009 OMP_CLAUSE_LINEAR_STEP (node) = t; 3010 } 3011 else 3012 { 3013 tree type 3014 = gfc_typenode_for_spec (&n->sym->ts); 3015 OMP_CLAUSE_LINEAR_STEP (node) 3016 = fold_convert (type, last_step); 3017 } 3018 } 3019 if (n->sym->attr.dimension || n->sym->attr.allocatable) 3020 OMP_CLAUSE_LINEAR_ARRAY (node) = 1; 3021 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 3022 } 3023 } 3024 } 3025 } 3026 break; 3027 case OMP_LIST_AFFINITY: 3028 case OMP_LIST_DEPEND: 3029 iterator = NULL_TREE; 3030 prev = NULL; 3031 prev_clauses = omp_clauses; 3032 for (; n != NULL; n = n->next) 3033 { 3034 if (iterator && prev->u2.ns != n->u2.ns) 3035 { 3036 BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); 3037 TREE_VEC_ELT (iterator, 5) = tree_block; 3038 for (tree c = omp_clauses; c != prev_clauses; 3039 c = OMP_CLAUSE_CHAIN (c)) 3040 OMP_CLAUSE_DECL (c) = build_tree_list (iterator, 3041 OMP_CLAUSE_DECL (c)); 3042 prev_clauses = omp_clauses; 3043 iterator = NULL_TREE; 3044 } 3045 if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns)) 3046 { 3047 gfc_init_block (&iter_block); 3048 tree_block = make_node (BLOCK); 3049 TREE_USED (tree_block) = 1; 3050 BLOCK_VARS (tree_block) = NULL_TREE; 3051 iterator = handle_iterator (n->u2.ns, block, 3052 tree_block); 3053 } 3054 if (!iterator) 3055 gfc_init_block (&iter_block); 3056 prev = n; 3057 if (list == OMP_LIST_DEPEND 3058 && (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST 3059 || n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST)) 3060 { 3061 tree vec = NULL_TREE; 3062 unsigned int i; 3063 bool is_depend 3064 = n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST; 3065 for (i = 0; ; i++) 3066 { 3067 tree addend = integer_zero_node, t; 3068 bool neg = false; 3069 if (n->sym && n->expr) 3070 { 3071 addend = gfc_conv_constant_to_tree (n->expr); 3072 if (TREE_CODE (addend) == INTEGER_CST 3073 && tree_int_cst_sgn (addend) == -1) 3074 { 3075 neg = true; 3076 addend = const_unop (NEGATE_EXPR, 3077 TREE_TYPE (addend), addend); 3078 } 3079 } 3080 3081 if (n->sym == NULL) 3082 t = null_pointer_node; /* "omp_cur_iteration - 1". */ 3083 else 3084 t = gfc_trans_omp_variable (n->sym, false); 3085 if (t != error_mark_node) 3086 { 3087 if (i < vec_safe_length (doacross_steps) 3088 && !integer_zerop (addend) 3089 && (*doacross_steps)[i]) 3090 { 3091 tree step = (*doacross_steps)[i]; 3092 addend = fold_convert (TREE_TYPE (step), addend); 3093 addend = build2 (TRUNC_DIV_EXPR, 3094 TREE_TYPE (step), addend, step); 3095 } 3096 vec = tree_cons (addend, t, vec); 3097 if (neg) 3098 OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1; 3099 } 3100 if (n->next == NULL 3101 || n->next->u.depend_doacross_op != OMP_DOACROSS_SINK) 3102 break; 3103 n = n->next; 3104 } 3105 if (vec == NULL_TREE) 3106 continue; 3107 3108 tree node = build_omp_clause (input_location, 3109 OMP_CLAUSE_DOACROSS); 3110 OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK; 3111 OMP_CLAUSE_DOACROSS_DEPEND (node) = is_depend; 3112 OMP_CLAUSE_DECL (node) = nreverse (vec); 3113 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 3114 continue; 3115 } 3116 3117 if (n->sym && !n->sym->attr.referenced) 3118 continue; 3119 3120 tree node = build_omp_clause (input_location, 3121 list == OMP_LIST_DEPEND 3122 ? OMP_CLAUSE_DEPEND 3123 : OMP_CLAUSE_AFFINITY); 3124 if (n->sym == NULL) /* omp_all_memory */ 3125 OMP_CLAUSE_DECL (node) = null_pointer_node; 3126 else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) 3127 { 3128 tree decl = gfc_trans_omp_variable (n->sym, false); 3129 if (gfc_omp_privatize_by_reference (decl)) 3130 decl = build_fold_indirect_ref (decl); 3131 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 3132 { 3133 decl = gfc_conv_descriptor_data_get (decl); 3134 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); 3135 decl = build_fold_indirect_ref (decl); 3136 } 3137 else if (n->sym->attr.allocatable || n->sym->attr.pointer) 3138 decl = build_fold_indirect_ref (decl); 3139 else if (DECL_P (decl)) 3140 TREE_ADDRESSABLE (decl) = 1; 3141 OMP_CLAUSE_DECL (node) = decl; 3142 } 3143 else 3144 { 3145 tree ptr; 3146 gfc_init_se (&se, NULL); 3147 /* The first ref can be an element selection on the base 3148 object while the full expression still denotes an array, 3149 e.g. x(j)%a. Pick the lowering path from the overall 3150 expression rank, not from the first REF_ARRAY. */ 3151 if (n->expr->rank == 0) 3152 { 3153 gfc_conv_expr_reference (&se, n->expr); 3154 ptr = se.expr; 3155 } 3156 else 3157 { 3158 gfc_conv_expr_descriptor (&se, n->expr); 3159 ptr = gfc_conv_array_data (se.expr); 3160 } 3161 gfc_add_block_to_block (&iter_block, &se.pre); 3162 gfc_add_block_to_block (&iter_block, &se.post); 3163 gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); 3164 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); 3165 } 3166 if (list == OMP_LIST_DEPEND) 3167 switch (n->u.depend_doacross_op) 3168 { 3169 case OMP_DEPEND_IN: 3170 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; 3171 break; 3172 case OMP_DEPEND_OUT: 3173 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; 3174 break; 3175 case OMP_DEPEND_INOUT: 3176 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; 3177 break; 3178 case OMP_DEPEND_INOUTSET: 3179 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET; 3180 break; 3181 case OMP_DEPEND_MUTEXINOUTSET: 3182 OMP_CLAUSE_DEPEND_KIND (node) 3183 = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; 3184 break; 3185 case OMP_DEPEND_DEPOBJ: 3186 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ; 3187 break; 3188 default: 3189 gcc_unreachable (); 3190 } 3191 if (!iterator) 3192 gfc_add_block_to_block (block, &iter_block); 3193 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 3194 } 3195 if (iterator) 3196 { 3197 BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); 3198 TREE_VEC_ELT (iterator, 5) = tree_block; 3199 for (tree c = omp_clauses; c != prev_clauses; 3200 c = OMP_CLAUSE_CHAIN (c)) 3201 OMP_CLAUSE_DECL (c) = build_tree_list (iterator, 3202 OMP_CLAUSE_DECL (c)); 3203 } 3204 break; 3205 case OMP_LIST_MAP: 3206 for (; n != NULL; n = n->next) 3207 { 3208 if (!n->sym->attr.referenced) 3209 continue; 3210 3211 bool always_modifier = false; 3212 tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); 3213 tree node2 = NULL_TREE; 3214 tree node3 = NULL_TREE; 3215 tree node4 = NULL_TREE; 3216 tree node5 = NULL_TREE; 3217 3218 /* OpenMP: automatically map pointer targets with the pointer; 3219 hence, always update the descriptor/pointer itself. */ 3220 if (!openacc 3221 && ((n->expr == NULL && n->sym->attr.pointer) 3222 || (n->expr && gfc_expr_attr (n->expr).pointer))) 3223 always_modifier = true; 3224 3225 if (n->u.map.readonly) 3226 OMP_CLAUSE_MAP_READONLY (node) = 1; 3227 3228 switch (n->u.map.op) 3229 { 3230 case OMP_MAP_ALLOC: 3231 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); 3232 break; 3233 case OMP_MAP_IF_PRESENT: 3234 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); 3235 break; 3236 case OMP_MAP_ATTACH: 3237 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); 3238 break; 3239 case OMP_MAP_TO: 3240 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); 3241 break; 3242 case OMP_MAP_FROM: 3243 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM); 3244 break; 3245 case OMP_MAP_TOFROM: 3246 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM); 3247 break; 3248 case OMP_MAP_ALWAYS_TO: 3249 always_modifier = true; 3250 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO); 3251 break; 3252 case OMP_MAP_ALWAYS_FROM: 3253 always_modifier = true; 3254 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM); 3255 break; 3256 case OMP_MAP_ALWAYS_TOFROM: 3257 always_modifier = true; 3258 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); 3259 break; 3260 case OMP_MAP_PRESENT_ALLOC: 3261 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC); 3262 break; 3263 case OMP_MAP_PRESENT_TO: 3264 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO); 3265 break; 3266 case OMP_MAP_PRESENT_FROM: 3267 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM); 3268 break; 3269 case OMP_MAP_PRESENT_TOFROM: 3270 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM); 3271 break; 3272 case OMP_MAP_ALWAYS_PRESENT_TO: 3273 always_modifier = true; 3274 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO); 3275 break; 3276 case OMP_MAP_ALWAYS_PRESENT_FROM: 3277 always_modifier = true; 3278 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM); 3279 break; 3280 case OMP_MAP_ALWAYS_PRESENT_TOFROM: 3281 always_modifier = true; 3282 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM); 3283 break; 3284 case OMP_MAP_RELEASE: 3285 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); 3286 break; 3287 case OMP_MAP_DELETE: 3288 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); 3289 break; 3290 case OMP_MAP_DETACH: 3291 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); 3292 break; 3293 case OMP_MAP_FORCE_ALLOC: 3294 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); 3295 break; 3296 case OMP_MAP_FORCE_TO: 3297 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO); 3298 break; 3299 case OMP_MAP_FORCE_FROM: 3300 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM); 3301 break; 3302 case OMP_MAP_FORCE_TOFROM: 3303 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM); 3304 break; 3305 case OMP_MAP_FORCE_PRESENT: 3306 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT); 3307 break; 3308 case OMP_MAP_FORCE_DEVICEPTR: 3309 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR); 3310 break; 3311 default: 3312 gcc_unreachable (); 3313 } 3314 3315 tree decl = gfc_trans_omp_variable (n->sym, false); 3316 if (DECL_P (decl)) 3317 TREE_ADDRESSABLE (decl) = 1; 3318 3319 gfc_ref *lastref = NULL; 3320 3321 if (n->expr) 3322 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) 3323 if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY) 3324 lastref = ref; 3325 3326 bool allocatable = false, pointer = false; 3327 3328 if (lastref && lastref->type == REF_COMPONENT) 3329 { 3330 gfc_component *c = lastref->u.c.component; 3331 3332 if (c->ts.type == BT_CLASS) 3333 { 3334 pointer = CLASS_DATA (c)->attr.class_pointer; 3335 allocatable = CLASS_DATA (c)->attr.allocatable; 3336 } 3337 else 3338 { 3339 pointer = c->attr.pointer; 3340 allocatable = c->attr.allocatable; 3341 } 3342 } 3343 3344 if (n->expr == NULL 3345 || (n->expr->ref->type == REF_ARRAY 3346 && n->expr->ref->u.ar.type == AR_FULL)) 3347 { 3348 gomp_map_kind map_kind; 3349 tree type = TREE_TYPE (decl); 3350 if (n->sym->ts.type == BT_CHARACTER 3351 && n->sym->ts.deferred 3352 && n->sym->attr.omp_declare_target 3353 && (always_modifier || n->sym->attr.pointer) 3354 && op != EXEC_OMP_TARGET_EXIT_DATA 3355 && n->u.map.op != OMP_MAP_DELETE 3356 && n->u.map.op != OMP_MAP_RELEASE) 3357 { 3358 gcc_assert (n->sym->ts.u.cl->backend_decl); 3359 node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 3360 OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO); 3361 OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl; 3362 OMP_CLAUSE_SIZE (node5) 3363 = TYPE_SIZE_UNIT (gfc_charlen_type_node); 3364 } 3365 3366 tree present = gfc_omp_check_optional_argument (decl, true); 3367 if (openacc && n->sym->ts.type == BT_CLASS) 3368 { 3369 if (n->sym->attr.optional) 3370 sorry ("optional class parameter"); 3371 tree ptr = gfc_class_data_get (decl); 3372 ptr = build_fold_indirect_ref (ptr); 3373 OMP_CLAUSE_DECL (node) = ptr; 3374 OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl); 3375 node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 3376 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH); 3377 OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl); 3378 OMP_CLAUSE_SIZE (node2) = size_int (0); 3379 goto finalize_map_clause; 3380 } 3381 else if (POINTER_TYPE_P (type) 3382 && (gfc_omp_privatize_by_reference (decl) 3383 || GFC_DECL_GET_SCALAR_POINTER (decl) 3384 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 3385 || GFC_DECL_CRAY_POINTEE (decl) 3386 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) 3387 || (n->sym->ts.type == BT_DERIVED 3388 && (n->sym->ts.u.derived->ts.f90_type 3389 != BT_VOID)))) 3390 { 3391 tree orig_decl = decl; 3392 bool bare_attach_detach 3393 = (openacc 3394 && (n->u.map.op == OMP_MAP_ATTACH 3395 || n->u.map.op == OMP_MAP_DETACH) 3396 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) 3397 && !(POINTER_TYPE_P (TREE_TYPE (decl)) 3398 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE 3399 (TREE_TYPE (decl))))); 3400 3401 /* For nonallocatable, nonpointer arrays, a temporary 3402 variable is generated, but this one is only defined if 3403 the variable is present; hence, we now set it to NULL 3404 to avoid accessing undefined variables. We cannot use 3405 a temporary variable here as otherwise the replacement 3406 of the variables in omp-low.cc will not work. */ 3407 if (present && GFC_ARRAY_TYPE_P (type)) 3408 { 3409 tree tmp = fold_build2_loc (input_location, 3410 MODIFY_EXPR, 3411 void_type_node, decl, 3412 null_pointer_node); 3413 tree cond = fold_build1_loc (input_location, 3414 TRUTH_NOT_EXPR, 3415 boolean_type_node, 3416 present); 3417 gfc_add_expr_to_block (block, 3418 build3_loc (input_location, 3419 COND_EXPR, 3420 void_type_node, 3421 cond, tmp, 3422 NULL_TREE)); 3423 } 3424 /* Bare OpenACC attach/detach on scalar pointer-like 3425 variables wants a single attach operation on the 3426 pointer itself, not a standalone pointer-mapping 3427 node. Component and descriptor cases have dedicated 3428 handling below; this covers the plain scalar path. */ 3429 if (bare_attach_detach) 3430 { 3431 decl = build_fold_indirect_ref (decl); 3432 OMP_CLAUSE_DECL (node) = build_fold_addr_expr (decl); 3433 OMP_CLAUSE_SIZE (node) = size_zero_node; 3434 goto finalize_map_clause; 3435 } 3436 /* For descriptor types, the unmapping happens below. */ 3437 if (op != EXEC_OMP_TARGET_EXIT_DATA 3438 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 3439 { 3440 enum gomp_map_kind gmk = GOMP_MAP_POINTER; 3441 if (op == EXEC_OMP_TARGET_EXIT_DATA 3442 && n->u.map.op == OMP_MAP_DELETE) 3443 gmk = GOMP_MAP_DELETE; 3444 else if (op == EXEC_OMP_TARGET_EXIT_DATA) 3445 gmk = GOMP_MAP_RELEASE; 3446 tree size; 3447 if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE) 3448 size = TYPE_SIZE_UNIT (TREE_TYPE (decl)); 3449 else 3450 size = size_int (0); 3451 node4 = build_omp_clause (input_location, 3452 OMP_CLAUSE_MAP); 3453 OMP_CLAUSE_SET_MAP_KIND (node4, gmk); 3454 OMP_CLAUSE_DECL (node4) = decl; 3455 OMP_CLAUSE_SIZE (node4) = size; 3456 } 3457 decl = build_fold_indirect_ref (decl); 3458 if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE 3459 || gfc_omp_is_optional_argument (orig_decl)) 3460 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) 3461 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) 3462 { 3463 enum gomp_map_kind gmk; 3464 if (op == EXEC_OMP_TARGET_EXIT_DATA 3465 && n->u.map.op == OMP_MAP_DELETE) 3466 gmk = GOMP_MAP_DELETE; 3467 else if (op == EXEC_OMP_TARGET_EXIT_DATA) 3468 gmk = GOMP_MAP_RELEASE; 3469 else 3470 gmk = GOMP_MAP_POINTER; 3471 tree size; 3472 if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE) 3473 size = TYPE_SIZE_UNIT (TREE_TYPE (decl)); 3474 else 3475 size = size_int (0); 3476 node3 = build_omp_clause (input_location, 3477 OMP_CLAUSE_MAP); 3478 OMP_CLAUSE_SET_MAP_KIND (node3, gmk); 3479 OMP_CLAUSE_DECL (node3) = decl; 3480 OMP_CLAUSE_SIZE (node3) = size; 3481 decl = build_fold_indirect_ref (decl); 3482 } 3483 } 3484 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 3485 { 3486 tree type = TREE_TYPE (decl); 3487 tree ptr = gfc_conv_descriptor_data_get (decl); 3488 if (present) 3489 ptr = gfc_build_cond_assign_expr (block, present, ptr, 3490 null_pointer_node); 3491 gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); 3492 ptr = build_fold_indirect_ref (ptr); 3493 OMP_CLAUSE_DECL (node) = ptr; 3494 node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 3495 OMP_CLAUSE_DECL (node2) = decl; 3496 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); 3497 if (n->u.map.op == OMP_MAP_DELETE) 3498 map_kind = GOMP_MAP_DELETE; 3499 else if (op == EXEC_OMP_TARGET_EXIT_DATA 3500 || n->u.map.op == OMP_MAP_RELEASE) 3501 map_kind = GOMP_MAP_RELEASE; 3502 else 3503 map_kind = GOMP_MAP_TO_PSET; 3504 OMP_CLAUSE_SET_MAP_KIND (node2, map_kind); 3505 3506 if (op != EXEC_OMP_TARGET_EXIT_DATA 3507 && n->u.map.op != OMP_MAP_DELETE 3508 && n->u.map.op != OMP_MAP_RELEASE) 3509 { 3510 node3 = build_omp_clause (input_location, 3511 OMP_CLAUSE_MAP); 3512 if (present) 3513 { 3514 ptr = gfc_conv_descriptor_data_get (decl); 3515 ptr = gfc_build_addr_expr (NULL, ptr); 3516 ptr = gfc_build_cond_assign_expr ( 3517 block, present, ptr, null_pointer_node); 3518 ptr = build_fold_indirect_ref (ptr); 3519 OMP_CLAUSE_DECL (node3) = ptr; 3520 } 3521 else 3522 OMP_CLAUSE_DECL (node3) 3523 = gfc_conv_descriptor_data_get (decl); 3524 OMP_CLAUSE_SIZE (node3) = size_int (0); 3525 3526 if (n->u.map.op == OMP_MAP_ATTACH) 3527 { 3528 /* Standalone attach clauses used with arrays with 3529 descriptors must copy the descriptor to the 3530 target, else they won't have anything to 3531 perform the attachment onto (see OpenACC 2.6, 3532 "2.6.3. Data Structures with Pointers"). */ 3533 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH); 3534 /* We don't want to map PTR at all in this case, 3535 so delete its node and shuffle the others 3536 down. */ 3537 node = node2; 3538 node2 = node3; 3539 node3 = NULL; 3540 goto finalize_map_clause; 3541 } 3542 else if (n->u.map.op == OMP_MAP_DETACH) 3543 { 3544 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH); 3545 /* Similarly to above, we don't want to unmap PTR 3546 here. */ 3547 node = node2; 3548 node2 = node3; 3549 node3 = NULL; 3550 goto finalize_map_clause; 3551 } 3552 else 3553 OMP_CLAUSE_SET_MAP_KIND (node3, 3554 always_modifier 3555 ? GOMP_MAP_ALWAYS_POINTER 3556 : GOMP_MAP_POINTER); 3557 } 3558 3559 /* We have to check for n->sym->attr.dimension because 3560 of scalar coarrays. */ 3561 if ((n->sym->attr.pointer || n->sym->attr.allocatable) 3562 && n->sym->attr.dimension) 3563 { 3564 stmtblock_t cond_block; 3565 tree size 3566 = gfc_create_var (gfc_array_index_type, NULL); 3567 tree tem, then_b, else_b, zero, cond; 3568 3569 gfc_init_block (&cond_block); 3570 tem 3571 = gfc_full_array_size (&cond_block, decl, 3572 GFC_TYPE_ARRAY_RANK (type)); 3573 tree elemsz; 3574 if (n->sym->ts.type == BT_CHARACTER 3575 && n->sym->ts.deferred) 3576 { 3577 tree len = n->sym->ts.u.cl->backend_decl; 3578 len = fold_convert (size_type_node, len); 3579 elemsz = gfc_get_char_type (n->sym->ts.kind); 3580 elemsz = TYPE_SIZE_UNIT (elemsz); 3581 elemsz = fold_build2 (MULT_EXPR, size_type_node, 3582 len, elemsz); 3583 } 3584 else 3585 elemsz 3586 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 3587 elemsz = fold_convert (gfc_array_index_type, elemsz); 3588 tem = fold_build2 (MULT_EXPR, gfc_array_index_type, 3589 tem, elemsz); 3590 gfc_add_modify (&cond_block, size, tem); 3591 then_b = gfc_finish_block (&cond_block); 3592 gfc_init_block (&cond_block); 3593 zero = build_int_cst (gfc_array_index_type, 0); 3594 gfc_add_modify (&cond_block, size, zero); 3595 else_b = gfc_finish_block (&cond_block); 3596 tem = gfc_conv_descriptor_data_get (decl); 3597 tem = fold_convert (pvoid_type_node, tem); 3598 cond = fold_build2_loc (input_location, NE_EXPR, 3599 boolean_type_node, 3600 tem, null_pointer_node); 3601 if (present) 3602 cond = fold_build2_loc (input_location, 3603 TRUTH_ANDIF_EXPR, 3604 boolean_type_node, 3605 present, cond); 3606 gfc_add_expr_to_block (block, 3607 build3_loc (input_location, 3608 COND_EXPR, 3609 void_type_node, 3610 cond, then_b, 3611 else_b)); 3612 OMP_CLAUSE_SIZE (node) = size; 3613 } 3614 else if (n->sym->attr.dimension) 3615 { 3616 stmtblock_t cond_block; 3617 gfc_init_block (&cond_block); 3618 tree size = gfc_full_array_size (&cond_block, decl, 3619 GFC_TYPE_ARRAY_RANK (type)); 3620 tree elemsz 3621 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 3622 elemsz = fold_convert (gfc_array_index_type, elemsz); 3623 size = fold_build2 (MULT_EXPR, gfc_array_index_type, 3624 size, elemsz); 3625 size = gfc_evaluate_now (size, &cond_block); 3626 if (present) 3627 { 3628 tree var = gfc_create_var (gfc_array_index_type, 3629 NULL); 3630 gfc_add_modify (&cond_block, var, size); 3631 tree cond_body = gfc_finish_block (&cond_block); 3632 tree cond = build3_loc (input_location, COND_EXPR, 3633 void_type_node, present, 3634 cond_body, NULL_TREE); 3635 gfc_add_expr_to_block (block, cond); 3636 OMP_CLAUSE_SIZE (node) = var; 3637 } 3638 else 3639 { 3640 gfc_add_block_to_block (block, &cond_block); 3641 OMP_CLAUSE_SIZE (node) = size; 3642 } 3643 } 3644 } 3645 else if (present 3646 && INDIRECT_REF_P (decl) 3647 && INDIRECT_REF_P (TREE_OPERAND (decl, 0))) 3648 { 3649 /* A single indirectref is handled by the middle end. */ 3650 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); 3651 decl = TREE_OPERAND (decl, 0); 3652 decl = gfc_build_cond_assign_expr (block, present, decl, 3653 null_pointer_node); 3654 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl); 3655 } 3656 else 3657 OMP_CLAUSE_DECL (node) = decl; 3658 3659 if (!n->sym->attr.dimension 3660 && n->sym->ts.type == BT_CHARACTER 3661 && n->sym->ts.deferred) 3662 { 3663 if (!DECL_P (decl)) 3664 { 3665 gcc_assert (TREE_CODE (decl) == INDIRECT_REF); 3666 decl = TREE_OPERAND (decl, 0); 3667 } 3668 tree cond = fold_build2_loc (input_location, NE_EXPR, 3669 boolean_type_node, 3670 decl, null_pointer_node); 3671 if (present) 3672 cond = fold_build2_loc (input_location, 3673 TRUTH_ANDIF_EXPR, 3674 boolean_type_node, 3675 present, cond); 3676 tree len = n->sym->ts.u.cl->backend_decl; 3677 len = fold_convert (size_type_node, len); 3678 tree size = gfc_get_char_type (n->sym->ts.kind); 3679 size = TYPE_SIZE_UNIT (size); 3680 size = fold_build2 (MULT_EXPR, size_type_node, len, size); 3681 size = build3_loc (input_location, 3682 COND_EXPR, 3683 size_type_node, 3684 cond, size, 3685 size_zero_node); 3686 size = gfc_evaluate_now (size, block); 3687 OMP_CLAUSE_SIZE (node) = size; 3688 } 3689 } 3690 else if (n->expr 3691 && n->expr->expr_type == EXPR_VARIABLE 3692 && n->expr->ref->type == REF_ARRAY 3693 && !n->expr->ref->next) 3694 { 3695 /* An array element or array section which is not part of a 3696 derived type, etc. */ 3697 bool element = n->expr->ref->u.ar.type == AR_ELEMENT; 3698 tree type = TREE_TYPE (decl); 3699 gomp_map_kind k = GOMP_MAP_POINTER; 3700 if (!openacc 3701 && !GFC_DESCRIPTOR_TYPE_P (type) 3702 && !(POINTER_TYPE_P (type) 3703 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))) 3704 k = GOMP_MAP_FIRSTPRIVATE_POINTER; 3705 gfc_trans_omp_array_section (block, op, n, decl, element, 3706 !openacc, k, node, node2, 3707 node3, node4); 3708 } 3709 else if (n->expr 3710 && n->expr->expr_type == EXPR_VARIABLE 3711 && (n->expr->ref->type == REF_COMPONENT 3712 || n->expr->ref->type == REF_ARRAY) 3713 && lastref 3714 && lastref->type == REF_COMPONENT 3715 && lastref->u.c.component->ts.type != BT_CLASS 3716 && lastref->u.c.component->ts.type != BT_DERIVED 3717 && !lastref->u.c.component->attr.dimension) 3718 { 3719 /* Derived type access with last component being a scalar. */ 3720 gfc_init_se (&se, NULL); 3721 3722 gfc_conv_expr (&se, n->expr); 3723 gfc_add_block_to_block (block, &se.pre); 3724 /* For BT_CHARACTER a pointer is returned. */ 3725 OMP_CLAUSE_DECL (node) 3726 = POINTER_TYPE_P (TREE_TYPE (se.expr)) 3727 ? build_fold_indirect_ref (se.expr) : se.expr; 3728 gfc_add_block_to_block (block, &se.post); 3729 if (pointer || allocatable) 3730 { 3731 /* If it's a bare attach/detach clause, we just want 3732 to perform a single attach/detach operation, of the 3733 pointer itself, not of the pointed-to object. */ 3734 if (openacc 3735 && (n->u.map.op == OMP_MAP_ATTACH 3736 || n->u.map.op == OMP_MAP_DETACH)) 3737 { 3738 OMP_CLAUSE_DECL (node) 3739 = build_fold_addr_expr (OMP_CLAUSE_DECL (node)); 3740 OMP_CLAUSE_SIZE (node) = size_zero_node; 3741 goto finalize_map_clause; 3742 } 3743 3744 node2 = build_omp_clause (input_location, 3745 OMP_CLAUSE_MAP); 3746 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH); 3747 OMP_CLAUSE_DECL (node2) 3748 = POINTER_TYPE_P (TREE_TYPE (se.expr)) 3749 ? se.expr 3750 : gfc_build_addr_expr (NULL, se.expr); 3751 OMP_CLAUSE_SIZE (node2) = size_int (0); 3752 if (!openacc 3753 && n->expr->ts.type == BT_CHARACTER 3754 && n->expr->ts.deferred) 3755 { 3756 gcc_assert (se.string_length); 3757 tree tmp 3758 = gfc_get_char_type (n->expr->ts.kind); 3759 OMP_CLAUSE_SIZE (node) 3760 = fold_build2 (MULT_EXPR, size_type_node, 3761 fold_convert (size_type_node, 3762 se.string_length), 3763 TYPE_SIZE_UNIT (tmp)); 3764 gomp_map_kind kind; 3765 if (n->u.map.op == OMP_MAP_DELETE) 3766 kind = GOMP_MAP_DELETE; 3767 else if (op == EXEC_OMP_TARGET_EXIT_DATA) 3768 kind = GOMP_MAP_RELEASE; 3769 else 3770 kind = GOMP_MAP_TO; 3771 node3 = build_omp_clause (input_location, 3772 OMP_CLAUSE_MAP); 3773 OMP_CLAUSE_SET_MAP_KIND (node3, kind); 3774 OMP_CLAUSE_DECL (node3) = se.string_length; 3775 OMP_CLAUSE_SIZE (node3) 3776 = TYPE_SIZE_UNIT (gfc_charlen_type_node); 3777 } 3778 } 3779 } 3780 else if (n->expr 3781 && n->expr->expr_type == EXPR_VARIABLE 3782 && (n->expr->ref->type == REF_COMPONENT 3783 || n->expr->ref->type == REF_ARRAY)) 3784 { 3785 gfc_init_se (&se, NULL); 3786 se.expr = gfc_maybe_dereference_var (n->sym, decl); 3787 3788 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) 3789 { 3790 if (ref->type == REF_COMPONENT) 3791 { 3792 if (ref->u.c.sym->attr.extension) 3793 conv_parent_component_references (&se, ref); 3794 3795 gfc_conv_component_ref (&se, ref); 3796 } 3797 else if (ref->type == REF_ARRAY) 3798 { 3799 if (ref->u.ar.type == AR_ELEMENT && ref->next) 3800 gfc_conv_array_ref (&se, &ref->u.ar, n->expr, 3801 &n->expr->where); 3802 else 3803 gcc_assert (!ref->next); 3804 } 3805 else 3806 sorry ("unhandled expression type"); 3807 } 3808 3809 tree inner = se.expr; 3810 3811 /* Last component is a derived type or class pointer. */ 3812 if (lastref->type == REF_COMPONENT 3813 && (lastref->u.c.component->ts.type == BT_DERIVED 3814 || lastref->u.c.component->ts.type == BT_CLASS)) 3815 { 3816 if (pointer || (openacc && allocatable)) 3817 { 3818 /* If it's a bare attach/detach clause, we just want 3819 to perform a single attach/detach operation, of the 3820 pointer itself, not of the pointed-to object. */ 3821 if (openacc 3822 && (n->u.map.op == OMP_MAP_ATTACH 3823 || n->u.map.op == OMP_MAP_DETACH)) 3824 { 3825 OMP_CLAUSE_DECL (node) 3826 = build_fold_addr_expr (inner); 3827 OMP_CLAUSE_SIZE (node) = size_zero_node; 3828 goto finalize_map_clause; 3829 } 3830 3831 gfc_omp_namelist *n2 3832 = openacc ? NULL : clauses->lists[OMP_LIST_MAP]; 3833 3834 bool sym_based; 3835 n2 = get_symbol_rooted_namelist (sym_rooted_nl, n, 3836 n2, &sym_based); 3837 3838 /* If the last reference is a pointer to a derived 3839 type ("foo%dt_ptr"), check if any subcomponents 3840 of the same derived type member are being mapped 3841 elsewhere in the clause list ("foo%dt_ptr%x", 3842 etc.). If we have such subcomponent mappings, 3843 we only create an ALLOC node for the pointer 3844 itself, and inhibit mapping the whole derived 3845 type. */ 3846 3847 for (; n2 != NULL; n2 = n2->next) 3848 { 3849 if ((!sym_based && n == n2) 3850 || (sym_based && n == n2->u2.duplicate_of) 3851 || !n2->expr) 3852 continue; 3853 3854 if (!gfc_omp_expr_prefix_same (n->expr, 3855 n2->expr)) 3856 continue; 3857 3858 gfc_ref *ref1 = n->expr->ref; 3859 gfc_ref *ref2 = n2->expr->ref; 3860 3861 while (ref1->next && ref2->next) 3862 { 3863 ref1 = ref1->next; 3864 ref2 = ref2->next; 3865 } 3866 3867 if (ref2->next) 3868 { 3869 inner = build_fold_addr_expr (inner); 3870 OMP_CLAUSE_SET_MAP_KIND (node, 3871 GOMP_MAP_ALLOC); 3872 OMP_CLAUSE_DECL (node) = inner; 3873 OMP_CLAUSE_SIZE (node) 3874 = TYPE_SIZE_UNIT (TREE_TYPE (inner)); 3875 goto finalize_map_clause; 3876 } 3877 } 3878 3879 tree data, size; 3880 3881 if (lastref->u.c.component->ts.type == BT_CLASS) 3882 { 3883 data = gfc_class_data_get (inner); 3884 gcc_assert (POINTER_TYPE_P (TREE_TYPE (data))); 3885 data = build_fold_indirect_ref (data); 3886 size = gfc_class_vtab_size_get (inner); 3887 } 3888 else /* BT_DERIVED. */ 3889 { 3890 data = inner; 3891 size = TYPE_SIZE_UNIT (TREE_TYPE (inner)); 3892 } 3893 3894 OMP_CLAUSE_DECL (node) = data; 3895 OMP_CLAUSE_SIZE (node) = size; 3896 node2 = build_omp_clause (input_location, 3897 OMP_CLAUSE_MAP); 3898 OMP_CLAUSE_SET_MAP_KIND (node2, 3899 GOMP_MAP_ATTACH_DETACH); 3900 OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data); 3901 OMP_CLAUSE_SIZE (node2) = size_int (0); 3902 } 3903 else 3904 { 3905 OMP_CLAUSE_DECL (node) = inner; 3906 OMP_CLAUSE_SIZE (node) 3907 = TYPE_SIZE_UNIT (TREE_TYPE (inner)); 3908 } 3909 } 3910 else if (lastref->type == REF_ARRAY 3911 && lastref->u.ar.type == AR_FULL) 3912 { 3913 /* Bare attach and detach clauses don't want any 3914 additional nodes. */ 3915 if ((n->u.map.op == OMP_MAP_ATTACH 3916 || n->u.map.op == OMP_MAP_DETACH) 3917 && (POINTER_TYPE_P (TREE_TYPE (inner)) 3918 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))) 3919 { 3920 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) 3921 { 3922 tree ptr = gfc_conv_descriptor_data_get (inner); 3923 OMP_CLAUSE_DECL (node) = ptr; 3924 } 3925 else 3926 OMP_CLAUSE_DECL (node) = inner; 3927 OMP_CLAUSE_SIZE (node) = size_zero_node; 3928 goto finalize_map_clause; 3929 } 3930 3931 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) 3932 { 3933 gomp_map_kind map_kind; 3934 tree type = TREE_TYPE (inner); 3935 tree ptr = gfc_conv_descriptor_data_get (inner); 3936 ptr = build_fold_indirect_ref (ptr); 3937 OMP_CLAUSE_DECL (node) = ptr; 3938 int rank = GFC_TYPE_ARRAY_RANK (type); 3939 OMP_CLAUSE_SIZE (node) 3940 = gfc_full_array_size (block, inner, rank); 3941 tree elemsz 3942 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 3943 map_kind = OMP_CLAUSE_MAP_KIND (node); 3944 if (GOMP_MAP_COPY_TO_P (map_kind) 3945 || map_kind == GOMP_MAP_ALLOC) 3946 map_kind = ((GOMP_MAP_ALWAYS_P (map_kind) 3947 || gfc_expr_attr (n->expr).pointer) 3948 ? GOMP_MAP_ALWAYS_TO : GOMP_MAP_TO); 3949 else if (n->u.map.op == OMP_MAP_RELEASE 3950 || n->u.map.op == OMP_MAP_DELETE) 3951 ; 3952 else if (op == EXEC_OMP_TARGET_EXIT_DATA 3953 || op == EXEC_OACC_EXIT_DATA) 3954 map_kind = GOMP_MAP_RELEASE; 3955 else 3956 map_kind = GOMP_MAP_ALLOC; 3957 if (!openacc 3958 && n->expr->ts.type == BT_CHARACTER 3959 && n->expr->ts.deferred) 3960 { 3961 gcc_assert (se.string_length); 3962 tree len = fold_convert (size_type_node, 3963 se.string_length); 3964 elemsz = gfc_get_char_type (n->expr->ts.kind); 3965 elemsz = TYPE_SIZE_UNIT (elemsz); 3966 elemsz = fold_build2 (MULT_EXPR, size_type_node, 3967 len, elemsz); 3968 node4 = build_omp_clause (input_location, 3969 OMP_CLAUSE_MAP); 3970 OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); 3971 OMP_CLAUSE_DECL (node4) = se.string_length; 3972 OMP_CLAUSE_SIZE (node4) 3973 = TYPE_SIZE_UNIT (gfc_charlen_type_node); 3974 } 3975 elemsz = fold_convert (gfc_array_index_type, elemsz); 3976 OMP_CLAUSE_SIZE (node) 3977 = fold_build2 (MULT_EXPR, gfc_array_index_type, 3978 OMP_CLAUSE_SIZE (node), elemsz); 3979 node2 = build_omp_clause (input_location, 3980 OMP_CLAUSE_MAP); 3981 if (map_kind == GOMP_MAP_RELEASE 3982 || map_kind == GOMP_MAP_DELETE) 3983 { 3984 OMP_CLAUSE_SET_MAP_KIND (node2, map_kind); 3985 OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1; 3986 } 3987 else 3988 OMP_CLAUSE_SET_MAP_KIND (node2, 3989 GOMP_MAP_TO_PSET); 3990 OMP_CLAUSE_DECL (node2) = inner; 3991 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); 3992 if (!openacc) 3993 { 3994 gfc_omp_namelist *n2 3995 = clauses->lists[OMP_LIST_MAP]; 3996 3997 /* If we don't have a mapping of a smaller part 3998 of the array -- or we can't prove that we do 3999 statically -- set this flag. If there is a 4000 mapping of a smaller part of the array after 4001 all, this will turn into a no-op at 4002 runtime. */ 4003 OMP_CLAUSE_MAP_RUNTIME_IMPLICIT_P (node) = 1; 4004 4005 bool sym_based; 4006 n2 = get_symbol_rooted_namelist (sym_rooted_nl, 4007 n, n2, 4008 &sym_based); 4009 4010 bool drop_mapping = false; 4011 4012 for (; n2 != NULL; n2 = n2->next) 4013 { 4014 if ((!sym_based && n == n2) 4015 || (sym_based && n == n2->u2.duplicate_of) 4016 || !n2->expr) 4017 continue; 4018 4019 if (!gfc_omp_expr_prefix_same (n->expr, 4020 n2->expr)) 4021 continue; 4022 4023 gfc_ref *ref1 = n->expr->ref; 4024 gfc_ref *ref2 = n2->expr->ref; 4025 4026 /* We know ref1 and ref2 overlap. We're 4027 interested in whether ref2 describes a 4028 smaller part of the array than ref1, which 4029 we already know refers to the full 4030 array. */ 4031 4032 while (ref1->next && ref2->next) 4033 { 4034 ref1 = ref1->next; 4035 ref2 = ref2->next; 4036 } 4037 4038 if (ref2->next 4039 || (ref2->type == REF_ARRAY 4040 && (ref2->u.ar.type == AR_ELEMENT 4041 || (ref2->u.ar.type 4042 == AR_SECTION)))) 4043 { 4044 drop_mapping = true; 4045 break; 4046 } 4047 } 4048 if (drop_mapping) 4049 continue; 4050 } 4051 node3 = build_omp_clause (input_location, 4052 OMP_CLAUSE_MAP); 4053 OMP_CLAUSE_SET_MAP_KIND (node3, 4054 GOMP_MAP_ATTACH_DETACH); 4055 OMP_CLAUSE_DECL (node3) 4056 = gfc_conv_descriptor_data_get (inner); 4057 /* Similar to gfc_trans_omp_array_section (details 4058 there), we add/keep the cast for OpenMP to prevent 4059 that an 'alloc:' gets added for node3 ('desc.data') 4060 as that is part of the whole descriptor (node3). 4061 TODO: Remove once the ME handles this properly. */ 4062 if (!openacc) 4063 OMP_CLAUSE_DECL (node3) 4064 = fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)), 4065 OMP_CLAUSE_DECL (node3)); 4066 else 4067 STRIP_NOPS (OMP_CLAUSE_DECL (node3)); 4068 OMP_CLAUSE_SIZE (node3) = size_int (0); 4069 } 4070 else 4071 OMP_CLAUSE_DECL (node) = inner; 4072 } 4073 else if (lastref->type == REF_ARRAY) 4074 { 4075 /* An array element or section. */ 4076 bool element = lastref->u.ar.type == AR_ELEMENT; 4077 gomp_map_kind kind = GOMP_MAP_ATTACH_DETACH; 4078 gfc_trans_omp_array_section (block, op, n, inner, element, 4079 !openacc, kind, node, node2, 4080 node3, node4); 4081 } 4082 else 4083 gcc_unreachable (); 4084 } 4085 else 4086 sorry ("unhandled expression"); 4087 4088 finalize_map_clause: 4089 4090 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 4091 if (node2) 4092 omp_clauses = gfc_trans_add_clause (node2, omp_clauses); 4093 if (node3) 4094 omp_clauses = gfc_trans_add_clause (node3, omp_clauses); 4095 if (node4) 4096 omp_clauses = gfc_trans_add_clause (node4, omp_clauses); 4097 if (node5) 4098 omp_clauses = gfc_trans_add_clause (node5, omp_clauses); 4099 } 4100 break; 4101 case OMP_LIST_TO: 4102 case OMP_LIST_FROM: 4103 case OMP_LIST_CACHE: 4104 for (; n != NULL; n = n->next) 4105 { 4106 if (!n->sym->attr.referenced) 4107 continue; 4108 4109 switch (list) 4110 { 4111 case OMP_LIST_TO: 4112 clause_code = OMP_CLAUSE_TO; 4113 break; 4114 case OMP_LIST_FROM: 4115 clause_code = OMP_CLAUSE_FROM; 4116 break; 4117 case OMP_LIST_CACHE: 4118 clause_code = OMP_CLAUSE__CACHE_; 4119 break; 4120 default: 4121 gcc_unreachable (); 4122 } 4123 tree node = build_omp_clause (input_location, clause_code); 4124 if (n->expr == NULL 4125 || (n->expr->ref->type == REF_ARRAY 4126 && n->expr->ref->u.ar.type == AR_FULL 4127 && n->expr->ref->next == NULL)) 4128 { 4129 tree decl = gfc_trans_omp_variable (n->sym, false); 4130 if (gfc_omp_privatize_by_reference (decl)) 4131 { 4132 if (gfc_omp_is_allocatable_or_ptr (decl)) 4133 decl = build_fold_indirect_ref (decl); 4134 decl = build_fold_indirect_ref (decl); 4135 } 4136 else if (DECL_P (decl)) 4137 TREE_ADDRESSABLE (decl) = 1; 4138 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 4139 { 4140 tree type = TREE_TYPE (decl); 4141 tree ptr = gfc_conv_descriptor_data_get (decl); 4142 gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); 4143 ptr = build_fold_indirect_ref (ptr); 4144 OMP_CLAUSE_DECL (node) = ptr; 4145 OMP_CLAUSE_SIZE (node) 4146 = gfc_full_array_size (block, decl, 4147 GFC_TYPE_ARRAY_RANK (type)); 4148 tree elemsz 4149 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 4150 elemsz = fold_convert (gfc_array_index_type, elemsz); 4151 OMP_CLAUSE_SIZE (node) 4152 = fold_build2 (MULT_EXPR, gfc_array_index_type, 4153 OMP_CLAUSE_SIZE (node), elemsz); 4154 } 4155 else 4156 { 4157 OMP_CLAUSE_DECL (node) = decl; 4158 if (gfc_omp_is_allocatable_or_ptr (decl)) 4159 OMP_CLAUSE_SIZE (node) 4160 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl))); 4161 } 4162 } 4163 else 4164 { 4165 tree ptr; 4166 gfc_init_se (&se, NULL); 4167 if (n->expr->rank == 0) 4168 { 4169 gfc_conv_expr_reference (&se, n->expr); 4170 ptr = se.expr; 4171 gfc_add_block_to_block (block, &se.pre); 4172 OMP_CLAUSE_SIZE (node) 4173 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); 4174 } 4175 else 4176 { 4177 gfc_conv_expr_descriptor (&se, n->expr); 4178 ptr = gfc_conv_array_data (se.expr); 4179 tree type = TREE_TYPE (se.expr); 4180 gfc_add_block_to_block (block, &se.pre); 4181 OMP_CLAUSE_SIZE (node) 4182 = gfc_full_array_size (block, se.expr, 4183 GFC_TYPE_ARRAY_RANK (type)); 4184 tree elemsz 4185 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 4186 elemsz = fold_convert (gfc_array_index_type, elemsz); 4187 OMP_CLAUSE_SIZE (node) 4188 = fold_build2 (MULT_EXPR, gfc_array_index_type, 4189 OMP_CLAUSE_SIZE (node), elemsz); 4190 } 4191 gfc_add_block_to_block (block, &se.post); 4192 gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); 4193 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); 4194 } 4195 if (n->u.present_modifier) 4196 OMP_CLAUSE_MOTION_PRESENT (node) = 1; 4197 if (list == OMP_LIST_CACHE && n->u.map.readonly) 4198 OMP_CLAUSE__CACHE__READONLY (node) = 1; 4199 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 4200 } 4201 break; 4202 case OMP_LIST_USES_ALLOCATORS: 4203 /* Ignore pre-defined allocators as no special treatment is needed. */ 4204 for (; n != NULL; n = n->next) 4205 if (n->sym->attr.flavor == FL_VARIABLE) 4206 break; 4207 if (n != NULL) 4208 sorry_at (input_location, "%<uses_allocators%> clause with traits " 4209 "and memory spaces"); 4210 break; 4211 default: 4212 break; 4213 } 4214 } 4215 4216 /* Free hashmap if we built it. */ 4217 if (sym_rooted_nl) 4218 { 4219 typedef hash_map<gfc_symbol *, gfc_omp_namelist *>::iterator hti; 4220 for (hti it = sym_rooted_nl->begin (); it != sym_rooted_nl->end (); ++it) 4221 { 4222 gfc_omp_namelist *&nl = (*it).second; 4223 while (nl) 4224 { 4225 gfc_omp_namelist *next = nl->next; 4226 free (nl); 4227 nl = next; 4228 } 4229 } 4230 delete sym_rooted_nl; 4231 } 4232 4233 if (clauses->if_expr) 4234 { 4235 tree if_var; 4236 4237 gfc_init_se (&se, NULL); 4238 gfc_conv_expr (&se, clauses->if_expr); 4239 gfc_add_block_to_block (block, &se.pre); 4240 if_var = gfc_evaluate_now (se.expr, block); 4241 gfc_add_block_to_block (block, &se.post); 4242 4243 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); 4244 OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK; 4245 OMP_CLAUSE_IF_EXPR (c) = if_var; 4246 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4247 } 4248 4249 for (ifc = 0; ifc < OMP_IF_LAST; ifc++) 4250 if (clauses->if_exprs[ifc]) 4251 { 4252 tree if_var; 4253 4254 gfc_init_se (&se, NULL); 4255 gfc_conv_expr (&se, clauses->if_exprs[ifc]); 4256 gfc_add_block_to_block (block, &se.pre); 4257 if_var = gfc_evaluate_now (se.expr, block); 4258 gfc_add_block_to_block (block, &se.post); 4259 4260 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); 4261 switch (ifc) 4262 { 4263 case OMP_IF_CANCEL: 4264 OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST; 4265 break; 4266 case OMP_IF_PARALLEL: 4267 OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL; 4268 break; 4269 case OMP_IF_SIMD: 4270 OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD; 4271 break; 4272 case OMP_IF_TASK: 4273 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK; 4274 break; 4275 case OMP_IF_TASKLOOP: 4276 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP; 4277 break; 4278 case OMP_IF_TARGET: 4279 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET; 4280 break; 4281 case OMP_IF_TARGET_DATA: 4282 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA; 4283 break; 4284 case OMP_IF_TARGET_UPDATE: 4285 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE; 4286 break; 4287 case OMP_IF_TARGET_ENTER_DATA: 4288 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA; 4289 break; 4290 case OMP_IF_TARGET_EXIT_DATA: 4291 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA; 4292 break; 4293 default: 4294 gcc_unreachable (); 4295 } 4296 OMP_CLAUSE_IF_EXPR (c) = if_var; 4297 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4298 } 4299 4300 if (clauses->self_expr) 4301 { 4302 tree self_var; 4303 4304 gfc_init_se (&se, NULL); 4305 gfc_conv_expr (&se, clauses->self_expr); 4306 gfc_add_block_to_block (block, &se.pre); 4307 self_var = gfc_evaluate_now (se.expr, block); 4308 gfc_add_block_to_block (block, &se.post); 4309 4310 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SELF); 4311 OMP_CLAUSE_SELF_EXPR (c) = self_var; 4312 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4313 } 4314 4315 if (clauses->final_expr) 4316 { 4317 tree final_var; 4318 4319 gfc_init_se (&se, NULL); 4320 gfc_conv_expr (&se, clauses->final_expr); 4321 gfc_add_block_to_block (block, &se.pre); 4322 final_var = gfc_evaluate_now (se.expr, block); 4323 gfc_add_block_to_block (block, &se.post); 4324 4325 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL); 4326 OMP_CLAUSE_FINAL_EXPR (c) = final_var; 4327 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4328 } 4329 4330 if (clauses->num_threads) 4331 { 4332 tree num_threads; 4333 4334 gfc_init_se (&se, NULL); 4335 gfc_conv_expr (&se, clauses->num_threads); 4336 gfc_add_block_to_block (block, &se.pre); 4337 num_threads = gfc_evaluate_now (se.expr, block); 4338 gfc_add_block_to_block (block, &se.post); 4339 4340 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS); 4341 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; 4342 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4343 } 4344 4345 chunk_size = NULL_TREE; 4346 if (clauses->chunk_size) 4347 { 4348 gfc_init_se (&se, NULL); 4349 gfc_conv_expr (&se, clauses->chunk_size); 4350 gfc_add_block_to_block (block, &se.pre); 4351 chunk_size = gfc_evaluate_now (se.expr, block); 4352 gfc_add_block_to_block (block, &se.post); 4353 } 4354 4355 if (clauses->sched_kind != OMP_SCHED_NONE) 4356 { 4357 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE); 4358 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; 4359 switch (clauses->sched_kind) 4360 { 4361 case OMP_SCHED_STATIC: 4362 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; 4363 break; 4364 case OMP_SCHED_DYNAMIC: 4365 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; 4366 break; 4367 case OMP_SCHED_GUIDED: 4368 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; 4369 break; 4370 case OMP_SCHED_RUNTIME: 4371 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; 4372 break; 4373 case OMP_SCHED_AUTO: 4374 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO; 4375 break; 4376 default: 4377 gcc_unreachable (); 4378 } 4379 if (clauses->sched_monotonic) 4380 OMP_CLAUSE_SCHEDULE_KIND (c) 4381 = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) 4382 | OMP_CLAUSE_SCHEDULE_MONOTONIC); 4383 else if (clauses->sched_nonmonotonic) 4384 OMP_CLAUSE_SCHEDULE_KIND (c) 4385 = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) 4386 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC); 4387 if (clauses->sched_simd) 4388 OMP_CLAUSE_SCHEDULE_SIMD (c) = 1; 4389 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4390 } 4391 4392 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) 4393 { 4394 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT); 4395 switch (clauses->default_sharing) 4396 { 4397 case OMP_DEFAULT_NONE: 4398 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; 4399 break; 4400 case OMP_DEFAULT_SHARED: 4401 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; 4402 break; 4403 case OMP_DEFAULT_PRIVATE: 4404 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; 4405 break; 4406 case OMP_DEFAULT_FIRSTPRIVATE: 4407 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; 4408 break; 4409 case OMP_DEFAULT_PRESENT: 4410 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT; 4411 break; 4412 default: 4413 gcc_unreachable (); 4414 } 4415 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4416 } 4417 4418 if (clauses->nowait) 4419 { 4420 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT); 4421 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4422 } 4423 4424 if (clauses->ordered) 4425 { 4426 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED); 4427 OMP_CLAUSE_ORDERED_EXPR (c) 4428 = clauses->orderedc ? build_int_cst (integer_type_node, 4429 clauses->orderedc) : NULL_TREE; 4430 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4431 } 4432 4433 if (clauses->order_concurrent) 4434 { 4435 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER); 4436 OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained; 4437 OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible; 4438 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4439 } 4440 4441 if (clauses->untied) 4442 { 4443 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED); 4444 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4445 } 4446 4447 if (clauses->mergeable) 4448 { 4449 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE); 4450 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4451 } 4452 4453 if (clauses->collapse) 4454 { 4455 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE); 4456 OMP_CLAUSE_COLLAPSE_EXPR (c) 4457 = build_int_cst (integer_type_node, clauses->collapse); 4458 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4459 } 4460 4461 if (clauses->inbranch) 4462 { 4463 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH); 4464 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4465 } 4466 4467 if (clauses->notinbranch) 4468 { 4469 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH); 4470 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4471 } 4472 4473 switch (clauses->cancel) 4474 { 4475 case OMP_CANCEL_UNKNOWN: 4476 break; 4477 case OMP_CANCEL_PARALLEL: 4478 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL); 4479 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4480 break; 4481 case OMP_CANCEL_SECTIONS: 4482 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS); 4483 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4484 break; 4485 case OMP_CANCEL_DO: 4486 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR); 4487 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4488 break; 4489 case OMP_CANCEL_TASKGROUP: 4490 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP); 4491 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4492 break; 4493 } 4494 4495 if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) 4496 { 4497 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND); 4498 switch (clauses->proc_bind) 4499 { 4500 case OMP_PROC_BIND_PRIMARY: 4501 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY; 4502 break; 4503 case OMP_PROC_BIND_MASTER: 4504 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER; 4505 break; 4506 case OMP_PROC_BIND_SPREAD: 4507 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD; 4508 break; 4509 case OMP_PROC_BIND_CLOSE: 4510 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE; 4511 break; 4512 default: 4513 gcc_unreachable (); 4514 } 4515 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4516 } 4517 4518 if (clauses->safelen_expr) 4519 { 4520 tree safelen_var; 4521 4522 gfc_init_se (&se, NULL); 4523 gfc_conv_expr (&se, clauses->safelen_expr); 4524 gfc_add_block_to_block (block, &se.pre); 4525 safelen_var = gfc_evaluate_now (se.expr, block); 4526 gfc_add_block_to_block (block, &se.post); 4527 4528 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN); 4529 OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var; 4530 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4531 } 4532 4533 if (clauses->simdlen_expr) 4534 { 4535 if (declare_simd) 4536 { 4537 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); 4538 OMP_CLAUSE_SIMDLEN_EXPR (c) 4539 = gfc_conv_constant_to_tree (clauses->simdlen_expr); 4540 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4541 } 4542 else 4543 { 4544 tree simdlen_var; 4545 4546 gfc_init_se (&se, NULL); 4547 gfc_conv_expr (&se, clauses->simdlen_expr); 4548 gfc_add_block_to_block (block, &se.pre); 4549 simdlen_var = gfc_evaluate_now (se.expr, block); 4550 gfc_add_block_to_block (block, &se.post); 4551 4552 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); 4553 OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var; 4554 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4555 } 4556 } 4557 4558 if (clauses->num_teams_upper) 4559 { 4560 tree num_teams_lower = NULL_TREE, num_teams_upper; 4561 4562 gfc_init_se (&se, NULL); 4563 gfc_conv_expr (&se, clauses->num_teams_upper); 4564 gfc_add_block_to_block (block, &se.pre); 4565 num_teams_upper = gfc_evaluate_now (se.expr, block); 4566 gfc_add_block_to_block (block, &se.post); 4567 4568 if (clauses->num_teams_lower) 4569 { 4570 gfc_init_se (&se, NULL); 4571 gfc_conv_expr (&se, clauses->num_teams_lower); 4572 gfc_add_block_to_block (block, &se.pre); 4573 num_teams_lower = gfc_evaluate_now (se.expr, block); 4574 gfc_add_block_to_block (block, &se.post); 4575 } 4576 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS); 4577 OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower; 4578 OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper; 4579 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4580 } 4581 4582 if (clauses->device) 4583 { 4584 tree device; 4585 4586 gfc_init_se (&se, NULL); 4587 gfc_conv_expr (&se, clauses->device); 4588 gfc_add_block_to_block (block, &se.pre); 4589 device = gfc_evaluate_now (se.expr, block); 4590 gfc_add_block_to_block (block, &se.post); 4591 4592 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE); 4593 OMP_CLAUSE_DEVICE_ID (c) = device; 4594 4595 if (clauses->ancestor) 4596 OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1; 4597 4598 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4599 } 4600 4601 if (clauses->thread_limit) 4602 { 4603 tree thread_limit; 4604 4605 gfc_init_se (&se, NULL); 4606 gfc_conv_expr (&se, clauses->thread_limit); 4607 gfc_add_block_to_block (block, &se.pre); 4608 thread_limit = gfc_evaluate_now (se.expr, block); 4609 gfc_add_block_to_block (block, &se.post); 4610 4611 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT); 4612 OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; 4613 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4614 } 4615 4616 chunk_size = NULL_TREE; 4617 if (clauses->dist_chunk_size) 4618 { 4619 gfc_init_se (&se, NULL); 4620 gfc_conv_expr (&se, clauses->dist_chunk_size); 4621 gfc_add_block_to_block (block, &se.pre); 4622 chunk_size = gfc_evaluate_now (se.expr, block); 4623 gfc_add_block_to_block (block, &se.post); 4624 } 4625 4626 if (clauses->dist_sched_kind != OMP_SCHED_NONE) 4627 { 4628 c = build_omp_clause (gfc_get_location (&where), 4629 OMP_CLAUSE_DIST_SCHEDULE); 4630 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; 4631 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4632 } 4633 4634 if (clauses->grainsize) 4635 { 4636 tree grainsize; 4637 4638 gfc_init_se (&se, NULL); 4639 gfc_conv_expr (&se, clauses->grainsize); 4640 gfc_add_block_to_block (block, &se.pre); 4641 grainsize = gfc_evaluate_now (se.expr, block); 4642 gfc_add_block_to_block (block, &se.post); 4643 4644 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE); 4645 OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize; 4646 if (clauses->grainsize_strict) 4647 OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1; 4648 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4649 } 4650 4651 if (clauses->num_tasks) 4652 { 4653 tree num_tasks; 4654 4655 gfc_init_se (&se, NULL); 4656 gfc_conv_expr (&se, clauses->num_tasks); 4657 gfc_add_block_to_block (block, &se.pre); 4658 num_tasks = gfc_evaluate_now (se.expr, block); 4659 gfc_add_block_to_block (block, &se.post); 4660 4661 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS); 4662 OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks; 4663 if (clauses->num_tasks_strict) 4664 OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1; 4665 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4666 } 4667 4668 if (clauses->priority) 4669 { 4670 tree priority; 4671 4672 gfc_init_se (&se, NULL); 4673 gfc_conv_expr (&se, clauses->priority); 4674 gfc_add_block_to_block (block, &se.pre); 4675 priority = gfc_evaluate_now (se.expr, block); 4676 gfc_add_block_to_block (block, &se.post); 4677 4678 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY); 4679 OMP_CLAUSE_PRIORITY_EXPR (c) = priority; 4680 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4681 } 4682 4683 if (clauses->detach) 4684 { 4685 tree detach; 4686 4687 gfc_init_se (&se, NULL); 4688 gfc_conv_expr (&se, clauses->detach); 4689 gfc_add_block_to_block (block, &se.pre); 4690 detach = se.expr; 4691 gfc_add_block_to_block (block, &se.post); 4692 4693 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH); 4694 TREE_ADDRESSABLE (detach) = 1; 4695 OMP_CLAUSE_DECL (c) = detach; 4696 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4697 } 4698 4699 if (clauses->filter) 4700 { 4701 tree filter; 4702 4703 gfc_init_se (&se, NULL); 4704 gfc_conv_expr (&se, clauses->filter); 4705 gfc_add_block_to_block (block, &se.pre); 4706 filter = gfc_evaluate_now (se.expr, block); 4707 gfc_add_block_to_block (block, &se.post); 4708 4709 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER); 4710 OMP_CLAUSE_FILTER_EXPR (c) = filter; 4711 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4712 } 4713 4714 if (clauses->hint) 4715 { 4716 tree hint; 4717 4718 gfc_init_se (&se, NULL); 4719 gfc_conv_expr (&se, clauses->hint); 4720 gfc_add_block_to_block (block, &se.pre); 4721 hint = gfc_evaluate_now (se.expr, block); 4722 gfc_add_block_to_block (block, &se.post); 4723 4724 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT); 4725 OMP_CLAUSE_HINT_EXPR (c) = hint; 4726 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4727 } 4728 4729 if (clauses->simd) 4730 { 4731 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD); 4732 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4733 } 4734 if (clauses->threads) 4735 { 4736 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS); 4737 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4738 } 4739 if (clauses->nogroup) 4740 { 4741 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP); 4742 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4743 } 4744 4745 for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) 4746 { 4747 if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) 4748 continue; 4749 enum omp_clause_defaultmap_kind behavior, category; 4750 switch ((gfc_omp_defaultmap_category) i) 4751 { 4752 case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: 4753 category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; 4754 break; 4755 case OMP_DEFAULTMAP_CAT_ALL: 4756 category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALL; 4757 break; 4758 case OMP_DEFAULTMAP_CAT_SCALAR: 4759 category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR; 4760 break; 4761 case OMP_DEFAULTMAP_CAT_AGGREGATE: 4762 category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE; 4763 break; 4764 case OMP_DEFAULTMAP_CAT_ALLOCATABLE: 4765 category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE; 4766 break; 4767 case OMP_DEFAULTMAP_CAT_POINTER: 4768 category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER; 4769 break; 4770 default: gcc_unreachable (); 4771 } 4772 switch (clauses->defaultmap[i]) 4773 { 4774 case OMP_DEFAULTMAP_ALLOC: 4775 behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC; 4776 break; 4777 case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break; 4778 case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break; 4779 case OMP_DEFAULTMAP_TOFROM: 4780 behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM; 4781 break; 4782 case OMP_DEFAULTMAP_FIRSTPRIVATE: 4783 behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE; 4784 break; 4785 case OMP_DEFAULTMAP_PRESENT: 4786 behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT; 4787 break; 4788 case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break; 4789 case OMP_DEFAULTMAP_DEFAULT: 4790 behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT; 4791 break; 4792 default: gcc_unreachable (); 4793 } 4794 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP); 4795 OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category); 4796 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4797 } 4798 4799 if (clauses->doacross_source) 4800 { 4801 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS); 4802 OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE; 4803 OMP_CLAUSE_DOACROSS_DEPEND (c) = clauses->depend_source; 4804 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4805 } 4806 4807 if (clauses->async) 4808 { 4809 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC); 4810 if (clauses->async_expr) 4811 OMP_CLAUSE_ASYNC_EXPR (c) 4812 = gfc_convert_expr_to_tree (block, clauses->async_expr); 4813 else 4814 OMP_CLAUSE_ASYNC_EXPR (c) = NULL; 4815 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4816 } 4817 if (clauses->seq) 4818 { 4819 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ); 4820 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4821 } 4822 if (clauses->par_auto) 4823 { 4824 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO); 4825 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4826 } 4827 if (clauses->if_present) 4828 { 4829 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT); 4830 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4831 } 4832 if (clauses->finalize) 4833 { 4834 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE); 4835 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4836 } 4837 if (clauses->independent) 4838 { 4839 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT); 4840 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4841 } 4842 if (clauses->wait_list) 4843 { 4844 gfc_expr_list *el; 4845 4846 for (el = clauses->wait_list; el; el = el->next) 4847 { 4848 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT); 4849 OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr); 4850 OMP_CLAUSE_CHAIN (c) = omp_clauses; 4851 omp_clauses = c; 4852 } 4853 } 4854 if (clauses->num_gangs_expr) 4855 { 4856 tree num_gangs_var 4857 = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr); 4858 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS); 4859 OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var; 4860 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4861 } 4862 if (clauses->num_workers_expr) 4863 { 4864 tree num_workers_var 4865 = gfc_convert_expr_to_tree (block, clauses->num_workers_expr); 4866 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS); 4867 OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var; 4868 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4869 } 4870 if (clauses->vector_length_expr) 4871 { 4872 tree vector_length_var 4873 = gfc_convert_expr_to_tree (block, clauses->vector_length_expr); 4874 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH); 4875 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var; 4876 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4877 } 4878 if (clauses->tile_list) 4879 { 4880 vec<tree, va_gc> *tvec; 4881 gfc_expr_list *el; 4882 4883 vec_alloc (tvec, 4); 4884 4885 for (el = clauses->tile_list; el; el = el->next) 4886 vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr)); 4887 4888 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE); 4889 OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec); 4890 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4891 tvec->truncate (0); 4892 } 4893 if (clauses->vector) 4894 { 4895 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR); 4896 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4897 4898 if (clauses->vector_expr) 4899 { 4900 tree vector_var 4901 = gfc_convert_expr_to_tree (block, clauses->vector_expr); 4902 OMP_CLAUSE_VECTOR_EXPR (c) = vector_var; 4903 4904 /* TODO: We're not capturing location information for individual 4905 clauses. However, if we have an expression attached to the 4906 clause, that one provides better location information. */ 4907 OMP_CLAUSE_LOCATION (c) 4908 = gfc_get_location (&clauses->vector_expr->where); 4909 } 4910 } 4911 if (clauses->worker) 4912 { 4913 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER); 4914 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4915 4916 if (clauses->worker_expr) 4917 { 4918 tree worker_var 4919 = gfc_convert_expr_to_tree (block, clauses->worker_expr); 4920 OMP_CLAUSE_WORKER_EXPR (c) = worker_var; 4921 4922 /* TODO: We're not capturing location information for individual 4923 clauses. However, if we have an expression attached to the 4924 clause, that one provides better location information. */ 4925 OMP_CLAUSE_LOCATION (c) 4926 = gfc_get_location (&clauses->worker_expr->where); 4927 } 4928 } 4929 if (clauses->gang) 4930 { 4931 tree arg; 4932 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG); 4933 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4934 4935 if (clauses->gang_num_expr) 4936 { 4937 arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr); 4938 OMP_CLAUSE_GANG_EXPR (c) = arg; 4939 4940 /* TODO: We're not capturing location information for individual 4941 clauses. However, if we have an expression attached to the 4942 clause, that one provides better location information. */ 4943 OMP_CLAUSE_LOCATION (c) 4944 = gfc_get_location (&clauses->gang_num_expr->where); 4945 } 4946 4947 if (clauses->gang_static) 4948 { 4949 arg = clauses->gang_static_expr 4950 ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr) 4951 : integer_minus_one_node; 4952 OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg; 4953 } 4954 } 4955 if (clauses->bind != OMP_BIND_UNSET) 4956 { 4957 c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND); 4958 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 4959 switch (clauses->bind) 4960 { 4961 case OMP_BIND_TEAMS: 4962 OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS; 4963 break; 4964 case OMP_BIND_PARALLEL: 4965 OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL; 4966 break; 4967 case OMP_BIND_THREAD: 4968 OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD; 4969 break; 4970 default: 4971 gcc_unreachable (); 4972 } 4973 } 4974 /* OpenACC 'nohost' clauses cannot appear here. */ 4975 gcc_checking_assert (!clauses->nohost); 4976 4977 return nreverse (omp_clauses); 4978 } 4979 4980 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ 4981 4982 static tree 4983 gfc_trans_omp_code (gfc_code *code, bool force_empty) 4984 { 4985 tree stmt; 4986 4987 pushlevel (); 4988 stmt = gfc_trans_code (code); 4989 if (TREE_CODE (stmt) != BIND_EXPR) 4990 { 4991 if (!IS_EMPTY_STMT (stmt) || force_empty) 4992 { 4993 tree block = poplevel (1, 0); 4994 stmt = build3_v (BIND_EXPR, NULL, stmt, block); 4995 } 4996 else 4997 poplevel (0, 0); 4998 } 4999 else 5000 poplevel (0, 0); 5001 return stmt; 5002 } 5003 5004 /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data' 5005 construct. */ 5006 5007 static tree 5008 gfc_trans_oacc_construct (gfc_code *code) 5009 { 5010 stmtblock_t block; 5011 tree stmt, oacc_clauses; 5012 enum tree_code construct_code; 5013 5014 switch (code->op) 5015 { 5016 case EXEC_OACC_PARALLEL: 5017 construct_code = OACC_PARALLEL; 5018 break; 5019 case EXEC_OACC_KERNELS: 5020 construct_code = OACC_KERNELS; 5021 break; 5022 case EXEC_OACC_SERIAL: 5023 construct_code = OACC_SERIAL; 5024 break; 5025 case EXEC_OACC_DATA: 5026 construct_code = OACC_DATA; 5027 break; 5028 case EXEC_OACC_HOST_DATA: 5029 construct_code = OACC_HOST_DATA; 5030 break; 5031 default: 5032 gcc_unreachable (); 5033 } 5034 5035 gfc_start_block (&block); 5036 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 5037 code->loc, false, true); 5038 pushlevel (); 5039 stmt = gfc_trans_omp_code (code->block->next, true); 5040 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 5041 stmt = build2_loc (gfc_get_location (&code->loc), construct_code, 5042 void_type_node, stmt, oacc_clauses); 5043 gfc_add_expr_to_block (&block, stmt); 5044 return gfc_finish_block (&block); 5045 } 5046 5047 /* update, enter_data, exit_data, cache. */ 5048 static tree 5049 gfc_trans_oacc_executable_directive (gfc_code *code) 5050 { 5051 stmtblock_t block; 5052 tree stmt, oacc_clauses; 5053 enum tree_code construct_code; 5054 5055 switch (code->op) 5056 { 5057 case EXEC_OACC_UPDATE: 5058 construct_code = OACC_UPDATE; 5059 break; 5060 case EXEC_OACC_ENTER_DATA: 5061 construct_code = OACC_ENTER_DATA; 5062 break; 5063 case EXEC_OACC_EXIT_DATA: 5064 construct_code = OACC_EXIT_DATA; 5065 break; 5066 case EXEC_OACC_CACHE: 5067 construct_code = OACC_CACHE; 5068 break; 5069 default: 5070 gcc_unreachable (); 5071 } 5072 5073 gfc_start_block (&block); 5074 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 5075 code->loc, false, true, code->op); 5076 stmt = build1_loc (input_location, construct_code, void_type_node, 5077 oacc_clauses); 5078 gfc_add_expr_to_block (&block, stmt); 5079 return gfc_finish_block (&block); 5080 } 5081 5082 static tree 5083 gfc_trans_oacc_wait_directive (gfc_code *code) 5084 { 5085 stmtblock_t block; 5086 tree stmt, t; 5087 vec<tree, va_gc> *args; 5088 int nparms = 0; 5089 gfc_expr_list *el; 5090 gfc_omp_clauses *clauses = code->ext.omp_clauses; 5091 location_t loc = input_location; 5092 5093 for (el = clauses->wait_list; el; el = el->next) 5094 nparms++; 5095 5096 vec_alloc (args, nparms + 2); 5097 stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT); 5098 5099 gfc_start_block (&block); 5100 5101 if (clauses->async_expr) 5102 t = gfc_convert_expr_to_tree (&block, clauses->async_expr); 5103 else 5104 t = build_int_cst (integer_type_node, -2); 5105 5106 args->quick_push (t); 5107 args->quick_push (build_int_cst (integer_type_node, nparms)); 5108 5109 for (el = clauses->wait_list; el; el = el->next) 5110 args->quick_push (gfc_convert_expr_to_tree (&block, el->expr)); 5111 5112 stmt = build_call_expr_loc_vec (loc, stmt, args); 5113 gfc_add_expr_to_block (&block, stmt); 5114 5115 vec_free (args); 5116 5117 return gfc_finish_block (&block); 5118 } 5119 5120 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); 5121 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); 5122 5123 static tree 5124 gfc_trans_omp_allocators (gfc_code *code) 5125 { 5126 static bool warned = false; 5127 gfc_omp_namelist *omp_allocate 5128 = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; 5129 if (!flag_openmp_allocators && !warned) 5130 { 5131 omp_allocate = NULL; 5132 gfc_error ("%<!$OMP %s%> at %L requires %<-fopenmp-allocators%>", 5133 code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS", 5134 &code->loc); 5135 warning (0, "All files that might deallocate such a variable must be " 5136 "compiled with %<-fopenmp-allocators%>"); 5137 inform (UNKNOWN_LOCATION, 5138 "This includes explicit DEALLOCATE, reallocation on intrinsic " 5139 "assignment, INTENT(OUT) for allocatable dummy arguments, and " 5140 "reallocation of allocatable components allocated with an " 5141 "OpenMP allocator"); 5142 warned = true; 5143 } 5144 return gfc_trans_allocate (code->block->next, omp_allocate); 5145 } 5146 5147 static tree 5148 gfc_trans_omp_assume (gfc_code *code) 5149 { 5150 stmtblock_t block; 5151 gfc_init_block (&block); 5152 gfc_omp_assumptions *assume = code->ext.omp_clauses->assume; 5153 if (assume) 5154 for (gfc_expr_list *el = assume->holds; el; el = el->next) 5155 { 5156 location_t loc = gfc_get_location (&el->expr->where); 5157 gfc_se se; 5158 gfc_init_se (&se, NULL); 5159 gfc_conv_expr (&se, el->expr); 5160 tree t; 5161 if (se.pre.head == NULL_TREE && se.post.head == NULL_TREE) 5162 t = se.expr; 5163 else 5164 { 5165 tree var = create_tmp_var_raw (boolean_type_node); 5166 DECL_CONTEXT (var) = current_function_decl; 5167 stmtblock_t block2; 5168 gfc_init_block (&block2); 5169 gfc_add_block_to_block (&block2, &se.pre); 5170 gfc_add_modify_loc (loc, &block2, var, 5171 fold_convert_loc (loc, boolean_type_node, 5172 se.expr)); 5173 gfc_add_block_to_block (&block2, &se.post); 5174 t = gfc_finish_block (&block2); 5175 t = build4 (TARGET_EXPR, boolean_type_node, var, t, NULL, NULL); 5176 } 5177 t = build_call_expr_internal_loc (loc, IFN_ASSUME, 5178 void_type_node, 1, t); 5179 gfc_add_expr_to_block (&block, t); 5180 } 5181 gfc_add_expr_to_block (&block, gfc_trans_omp_code (code->block->next, true)); 5182 return gfc_finish_block (&block); 5183 } 5184 5185 static tree 5186 gfc_trans_omp_atomic (gfc_code *code) 5187 { 5188 gfc_code *atomic_code = code->block; 5189 gfc_se lse; 5190 gfc_se rse; 5191 gfc_se vse; 5192 gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL; 5193 gfc_symbol *var; 5194 stmtblock_t block; 5195 tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE; 5196 enum tree_code op = ERROR_MARK; 5197 enum tree_code aop = OMP_ATOMIC; 5198 bool var_on_left = false, else_branch = false; 5199 enum omp_memory_order mo, fail_mo; 5200 switch (atomic_code->ext.omp_clauses->memorder) 5201 { 5202 case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break; 5203 case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break; 5204 case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break; 5205 case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break; 5206 case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break; 5207 case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break; 5208 default: gcc_unreachable (); 5209 } 5210 switch (atomic_code->ext.omp_clauses->fail) 5211 { 5212 case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break; 5213 case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break; 5214 case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break; 5215 case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break; 5216 default: gcc_unreachable (); 5217 } 5218 mo = (omp_memory_order) (mo | fail_mo); 5219 5220 code = code->block->next; 5221 if (atomic_code->ext.omp_clauses->compare) 5222 { 5223 gfc_expr *comp_expr; 5224 if (code->op == EXEC_IF) 5225 { 5226 comp_expr = code->block->expr1; 5227 gcc_assert (code->block->next->op == EXEC_ASSIGN); 5228 expr1 = code->block->next->expr1; 5229 expr2 = code->block->next->expr2; 5230 if (code->block->block) 5231 { 5232 gcc_assert (atomic_code->ext.omp_clauses->capture 5233 && code->block->block->next->op == EXEC_ASSIGN); 5234 else_branch = true; 5235 aop = OMP_ATOMIC_CAPTURE_OLD; 5236 capture_expr1 = code->block->block->next->expr1; 5237 capture_expr2 = code->block->block->next->expr2; 5238 } 5239 else if (atomic_code->ext.omp_clauses->capture) 5240 { 5241 gcc_assert (code->next->op == EXEC_ASSIGN); 5242 aop = OMP_ATOMIC_CAPTURE_NEW; 5243 capture_expr1 = code->next->expr1; 5244 capture_expr2 = code->next->expr2; 5245 } 5246 } 5247 else 5248 { 5249 gcc_assert (atomic_code->ext.omp_clauses->capture 5250 && code->op == EXEC_ASSIGN 5251 && code->next->op == EXEC_IF); 5252 aop = OMP_ATOMIC_CAPTURE_OLD; 5253 capture_expr1 = code->expr1; 5254 capture_expr2 = code->expr2; 5255 expr1 = code->next->block->next->expr1; 5256 expr2 = code->next->block->next->expr2; 5257 comp_expr = code->next->block->expr1; 5258 } 5259 gfc_init_se (&lse, NULL); 5260 gfc_conv_expr (&lse, comp_expr->value.op.op2); 5261 gfc_add_block_to_block (&block, &lse.pre); 5262 compare = lse.expr; 5263 var = expr1->symtree->n.sym; 5264 } 5265 else 5266 { 5267 gcc_assert (code->op == EXEC_ASSIGN); 5268 expr1 = code->expr1; 5269 expr2 = code->expr2; 5270 if (atomic_code->ext.omp_clauses->capture 5271 && (expr2->expr_type == EXPR_VARIABLE 5272 || (expr2->expr_type == EXPR_FUNCTION 5273 && expr2->value.function.isym 5274 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION 5275 && (expr2->value.function.actual->expr->expr_type 5276 == EXPR_VARIABLE)))) 5277 { 5278 capture_expr1 = expr1; 5279 capture_expr2 = expr2; 5280 expr1 = code->next->expr1; 5281 expr2 = code->next->expr2; 5282 aop = OMP_ATOMIC_CAPTURE_OLD; 5283 } 5284 else if (atomic_code->ext.omp_clauses->capture) 5285 { 5286 aop = OMP_ATOMIC_CAPTURE_NEW; 5287 capture_expr1 = code->next->expr1; 5288 capture_expr2 = code->next->expr2; 5289 } 5290 var = expr1->symtree->n.sym; 5291 } 5292 5293 gfc_init_se (&lse, NULL); 5294 gfc_init_se (&rse, NULL); 5295 gfc_init_se (&vse, NULL); 5296 gfc_start_block (&block); 5297 5298 if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) 5299 != GFC_OMP_ATOMIC_WRITE) 5300 && expr2->expr_type == EXPR_FUNCTION 5301 && expr2->value.function.isym 5302 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) 5303 expr2 = expr2->value.function.actual->expr; 5304 5305 if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) 5306 == GFC_OMP_ATOMIC_READ) 5307 { 5308 gfc_conv_expr (&vse, expr1); 5309 gfc_add_block_to_block (&block, &vse.pre); 5310 5311 gfc_conv_expr (&lse, expr2); 5312 gfc_add_block_to_block (&block, &lse.pre); 5313 type = TREE_TYPE (lse.expr); 5314 lhsaddr = gfc_build_addr_expr (NULL, lse.expr); 5315 5316 x = build1 (OMP_ATOMIC_READ, type, lhsaddr); 5317 OMP_ATOMIC_MEMORY_ORDER (x) = mo; 5318 x = convert (TREE_TYPE (vse.expr), x); 5319 gfc_add_modify (&block, vse.expr, x); 5320 5321 gfc_add_block_to_block (&block, &lse.pre); 5322 gfc_add_block_to_block (&block, &rse.pre); 5323 5324 return gfc_finish_block (&block); 5325 } 5326 5327 if (capture_expr2 5328 && capture_expr2->expr_type == EXPR_FUNCTION 5329 && capture_expr2->value.function.isym 5330 && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION) 5331 capture_expr2 = capture_expr2->value.function.actual->expr; 5332 gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE); 5333 5334 if (aop == OMP_ATOMIC_CAPTURE_OLD) 5335 { 5336 gfc_conv_expr (&vse, capture_expr1); 5337 gfc_add_block_to_block (&block, &vse.pre); 5338 gfc_conv_expr (&lse, capture_expr2); 5339 gfc_add_block_to_block (&block, &lse.pre); 5340 gfc_init_se (&lse, NULL); 5341 } 5342 5343 gfc_conv_expr (&lse, expr1); 5344 gfc_add_block_to_block (&block, &lse.pre); 5345 type = TREE_TYPE (lse.expr); 5346 lhsaddr = gfc_build_addr_expr (NULL, lse.expr); 5347 5348 if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) 5349 == GFC_OMP_ATOMIC_WRITE) 5350 || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP) 5351 || compare) 5352 { 5353 gfc_conv_expr (&rse, expr2); 5354 gfc_add_block_to_block (&block, &rse.pre); 5355 } 5356 else if (expr2->expr_type == EXPR_OP) 5357 { 5358 gfc_expr *e; 5359 switch (expr2->value.op.op) 5360 { 5361 case INTRINSIC_PLUS: 5362 op = PLUS_EXPR; 5363 break; 5364 case INTRINSIC_TIMES: 5365 op = MULT_EXPR; 5366 break; 5367 case INTRINSIC_MINUS: 5368 op = MINUS_EXPR; 5369 break; 5370 case INTRINSIC_DIVIDE: 5371 if (expr2->ts.type == BT_INTEGER) 5372 op = TRUNC_DIV_EXPR; 5373 else 5374 op = RDIV_EXPR; 5375 break; 5376 case INTRINSIC_AND: 5377 op = TRUTH_ANDIF_EXPR; 5378 break; 5379 case INTRINSIC_OR: 5380 op = TRUTH_ORIF_EXPR; 5381 break; 5382 case INTRINSIC_EQV: 5383 op = EQ_EXPR; 5384 break; 5385 case INTRINSIC_NEQV: 5386 op = NE_EXPR; 5387 break; 5388 default: 5389 gcc_unreachable (); 5390 } 5391 e = expr2->value.op.op1; 5392 if (e->expr_type == EXPR_FUNCTION 5393 && e->value.function.isym 5394 && e->value.function.isym->id == GFC_ISYM_CONVERSION) 5395 e = e->value.function.actual->expr; 5396 if (e->expr_type == EXPR_VARIABLE 5397 && e->symtree != NULL 5398 && e->symtree->n.sym == var) 5399 { 5400 expr2 = expr2->value.op.op2; 5401 var_on_left = true; 5402 } 5403 else 5404 { 5405 e = expr2->value.op.op2; 5406 if (e->expr_type == EXPR_FUNCTION 5407 && e->value.function.isym 5408 && e->value.function.isym->id == GFC_ISYM_CONVERSION) 5409 e = e->value.function.actual->expr; 5410 gcc_assert (e->expr_type == EXPR_VARIABLE 5411 && e->symtree != NULL 5412 && e->symtree->n.sym == var); 5413 expr2 = expr2->value.op.op1; 5414 var_on_left = false; 5415 } 5416 gfc_conv_expr (&rse, expr2); 5417 gfc_add_block_to_block (&block, &rse.pre); 5418 } 5419 else 5420 { 5421 gcc_assert (expr2->expr_type == EXPR_FUNCTION); 5422 switch (expr2->value.function.isym->id) 5423 { 5424 case GFC_ISYM_MIN: 5425 op = MIN_EXPR; 5426 break; 5427 case GFC_ISYM_MAX: 5428 op = MAX_EXPR; 5429 break; 5430 case GFC_ISYM_IAND: 5431 op = BIT_AND_EXPR; 5432 break; 5433 case GFC_ISYM_IOR: 5434 op = BIT_IOR_EXPR; 5435 break; 5436 case GFC_ISYM_IEOR: 5437 op = BIT_XOR_EXPR; 5438 break; 5439 default: 5440 gcc_unreachable (); 5441 } 5442 e = expr2->value.function.actual->expr; 5443 if (e->expr_type == EXPR_FUNCTION 5444 && e->value.function.isym 5445 && e->value.function.isym->id == GFC_ISYM_CONVERSION) 5446 e = e->value.function.actual->expr; 5447 gcc_assert (e->expr_type == EXPR_VARIABLE 5448 && e->symtree != NULL 5449 && e->symtree->n.sym == var); 5450 5451 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); 5452 gfc_add_block_to_block (&block, &rse.pre); 5453 if (expr2->value.function.actual->next->next != NULL) 5454 { 5455 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); 5456 gfc_actual_arglist *arg; 5457 5458 gfc_add_modify (&block, accum, rse.expr); 5459 for (arg = expr2->value.function.actual->next->next; arg; 5460 arg = arg->next) 5461 { 5462 gfc_init_block (&rse.pre); 5463 gfc_conv_expr (&rse, arg->expr); 5464 gfc_add_block_to_block (&block, &rse.pre); 5465 x = fold_build2_loc (input_location, op, TREE_TYPE (accum), 5466 accum, rse.expr); 5467 gfc_add_modify (&block, accum, x); 5468 } 5469 5470 rse.expr = accum; 5471 } 5472 5473 expr2 = expr2->value.function.actual->next->expr; 5474 } 5475 5476 lhsaddr = save_expr (lhsaddr); 5477 if (TREE_CODE (lhsaddr) != SAVE_EXPR 5478 && (TREE_CODE (lhsaddr) != ADDR_EXPR 5479 || !VAR_P (TREE_OPERAND (lhsaddr, 0)))) 5480 { 5481 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize 5482 it even after unsharing function body. */ 5483 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); 5484 DECL_CONTEXT (var) = current_function_decl; 5485 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, 5486 NULL_TREE, NULL_TREE); 5487 } 5488 5489 if (compare) 5490 { 5491 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); 5492 DECL_CONTEXT (var) = current_function_decl; 5493 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL, 5494 NULL); 5495 lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr); 5496 compare = convert (TREE_TYPE (lse.expr), compare); 5497 compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 5498 lse.expr, compare); 5499 } 5500 5501 if (expr2->expr_type == EXPR_VARIABLE || compare) 5502 rhs = rse.expr; 5503 else 5504 rhs = gfc_evaluate_now (rse.expr, &block); 5505 5506 if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) 5507 == GFC_OMP_ATOMIC_WRITE) 5508 || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP) 5509 || compare) 5510 x = rhs; 5511 else 5512 { 5513 x = convert (TREE_TYPE (rhs), 5514 build_fold_indirect_ref_loc (input_location, lhsaddr)); 5515 if (var_on_left) 5516 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs); 5517 else 5518 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x); 5519 } 5520 5521 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE 5522 && TREE_CODE (type) != COMPLEX_TYPE) 5523 x = fold_build1_loc (input_location, REALPART_EXPR, 5524 TREE_TYPE (TREE_TYPE (rhs)), x); 5525 5526 gfc_add_block_to_block (&block, &lse.pre); 5527 gfc_add_block_to_block (&block, &rse.pre); 5528 5529 if (aop == OMP_ATOMIC_CAPTURE_NEW) 5530 { 5531 gfc_conv_expr (&vse, capture_expr1); 5532 gfc_add_block_to_block (&block, &vse.pre); 5533 gfc_add_block_to_block (&block, &lse.pre); 5534 } 5535 5536 if (compare && else_branch) 5537 { 5538 tree var2 = create_tmp_var_raw (boolean_type_node); 5539 DECL_CONTEXT (var2) = current_function_decl; 5540 comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2, 5541 boolean_false_node, NULL, NULL); 5542 compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2), 5543 var2, compare); 5544 TREE_OPERAND (compare, 0) = comp_tgt; 5545 compare = omit_one_operand_loc (input_location, boolean_type_node, 5546 compare, comp_tgt); 5547 } 5548 5549 if (compare) 5550 x = build3_loc (input_location, COND_EXPR, type, compare, 5551 convert (type, x), lse.expr); 5552 5553 if (aop == OMP_ATOMIC) 5554 { 5555 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); 5556 OMP_ATOMIC_MEMORY_ORDER (x) = mo; 5557 OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; 5558 gfc_add_expr_to_block (&block, x); 5559 } 5560 else 5561 { 5562 x = build2 (aop, type, lhsaddr, convert (type, x)); 5563 OMP_ATOMIC_MEMORY_ORDER (x) = mo; 5564 OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; 5565 if (compare && else_branch) 5566 { 5567 tree vtmp = create_tmp_var_raw (TREE_TYPE (x)); 5568 DECL_CONTEXT (vtmp) = current_function_decl; 5569 x = fold_build2_loc (input_location, MODIFY_EXPR, 5570 TREE_TYPE (vtmp), vtmp, x); 5571 vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp, 5572 build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL); 5573 TREE_OPERAND (x, 0) = vtmp; 5574 tree x2 = convert (TREE_TYPE (vse.expr), vtmp); 5575 x2 = fold_build2_loc (input_location, MODIFY_EXPR, 5576 TREE_TYPE (vse.expr), vse.expr, x2); 5577 x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt, 5578 void_node, x2); 5579 x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x); 5580 gfc_add_expr_to_block (&block, x); 5581 } 5582 else 5583 { 5584 x = convert (TREE_TYPE (vse.expr), x); 5585 gfc_add_modify (&block, vse.expr, x); 5586 } 5587 } 5588 5589 return gfc_finish_block (&block); 5590 } 5591 5592 static tree 5593 gfc_trans_omp_barrier (void) 5594 { 5595 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER); 5596 return build_call_expr_loc (input_location, decl, 0); 5597 } 5598 5599 static tree 5600 gfc_trans_omp_cancel (gfc_code *code) 5601 { 5602 int mask = 0; 5603 tree ifc = boolean_true_node; 5604 stmtblock_t block; 5605 switch (code->ext.omp_clauses->cancel) 5606 { 5607 case OMP_CANCEL_PARALLEL: mask = 1; break; 5608 case OMP_CANCEL_DO: mask = 2; break; 5609 case OMP_CANCEL_SECTIONS: mask = 4; break; 5610 case OMP_CANCEL_TASKGROUP: mask = 8; break; 5611 default: gcc_unreachable (); 5612 } 5613 gfc_start_block (&block); 5614 if (code->ext.omp_clauses->if_expr 5615 || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]) 5616 { 5617 gfc_se se; 5618 tree if_var; 5619 5620 gcc_assert ((code->ext.omp_clauses->if_expr == NULL) 5621 ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL)); 5622 gfc_init_se (&se, NULL); 5623 gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL 5624 ? code->ext.omp_clauses->if_expr 5625 : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]); 5626 gfc_add_block_to_block (&block, &se.pre); 5627 if_var = gfc_evaluate_now (se.expr, &block); 5628 gfc_add_block_to_block (&block, &se.post); 5629 tree type = TREE_TYPE (if_var); 5630 ifc = fold_build2_loc (input_location, NE_EXPR, 5631 boolean_type_node, if_var, 5632 build_zero_cst (type)); 5633 } 5634 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL); 5635 tree c_bool_type = TREE_TYPE (TREE_TYPE (decl)); 5636 ifc = fold_convert (c_bool_type, ifc); 5637 gfc_add_expr_to_block (&block, 5638 build_call_expr_loc (input_location, decl, 2, 5639 build_int_cst (integer_type_node, 5640 mask), ifc)); 5641 return gfc_finish_block (&block); 5642 } 5643 5644 static tree 5645 gfc_trans_omp_cancellation_point (gfc_code *code) 5646 { 5647 int mask = 0; 5648 switch (code->ext.omp_clauses->cancel) 5649 { 5650 case OMP_CANCEL_PARALLEL: mask = 1; break; 5651 case OMP_CANCEL_DO: mask = 2; break; 5652 case OMP_CANCEL_SECTIONS: mask = 4; break; 5653 case OMP_CANCEL_TASKGROUP: mask = 8; break; 5654 default: gcc_unreachable (); 5655 } 5656 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT); 5657 return build_call_expr_loc (input_location, decl, 1, 5658 build_int_cst (integer_type_node, mask)); 5659 } 5660 5661 static tree 5662 gfc_trans_omp_critical (gfc_code *code) 5663 { 5664 stmtblock_t block; 5665 tree stmt, name = NULL_TREE; 5666 if (code->ext.omp_clauses->critical_name != NULL) 5667 name = get_identifier (code->ext.omp_clauses->critical_name); 5668 gfc_start_block (&block); 5669 stmt = make_node (OMP_CRITICAL); 5670 SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); 5671 TREE_TYPE (stmt) = void_type_node; 5672 OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next); 5673 OMP_CRITICAL_NAME (stmt) = name; 5674 OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, 5675 code->ext.omp_clauses, 5676 code->loc); 5677 gfc_add_expr_to_block (&block, stmt); 5678 return gfc_finish_block (&block); 5679 } 5680 5681 typedef struct dovar_init_d { 5682 gfc_symbol *sym; 5683 tree var; 5684 tree init; 5685 bool non_unit_iter; 5686 } dovar_init; 5687 5688 static bool 5689 gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n, 5690 gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits, 5691 int simple, gfc_expr *curr_loop_var) 5692 { 5693 int i; 5694 for (i = 0; i < loop_n; i++) 5695 { 5696 gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE); 5697 if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr)) 5698 break; 5699 code = code->block->next; 5700 } 5701 if (i >= loop_n) 5702 return false; 5703 5704 /* Canonical format: TREE_VEC with [var, multiplier, offset]. */ 5705 gfc_symbol *var = code->ext.iterator->var->symtree->n.sym; 5706 5707 tree tree_var = NULL_TREE; 5708 tree a1 = integer_one_node; 5709 tree a2 = integer_zero_node; 5710 5711 if (!simple) 5712 { 5713 /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */ 5714 sorry_at (gfc_get_location (&curr_loop_var->where), 5715 "non-rectangular loop nest with non-constant step for %qs", 5716 curr_loop_var->symtree->n.sym->name); 5717 return false; 5718 } 5719 5720 dovar_init *di; 5721 unsigned ix; 5722 FOR_EACH_VEC_ELT (*inits, ix, di) 5723 if (di->sym == var) 5724 { 5725 if (!di->non_unit_iter) 5726 { 5727 tree_var = di->init; 5728 gcc_assert (DECL_P (tree_var)); 5729 break; 5730 } 5731 else 5732 { 5733 /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */ 5734 sorry_at (gfc_get_location (&code->loc), 5735 "non-rectangular loop nest with non-constant step " 5736 "for %qs", var->name); 5737 inform (gfc_get_location (&expr->where), "Used here"); 5738 return false; 5739 } 5740 } 5741 if (tree_var == NULL_TREE) 5742 tree_var = var->backend_decl; 5743 5744 if (expr->expr_type == EXPR_VARIABLE) 5745 gcc_assert (expr->symtree->n.sym == var); 5746 else if (expr->expr_type != EXPR_OP 5747 || (expr->value.op.op != INTRINSIC_TIMES 5748 && expr->value.op.op != INTRINSIC_PLUS 5749 && expr->value.op.op != INTRINSIC_MINUS)) 5750 gcc_unreachable (); 5751 else 5752 { 5753 gfc_se se; 5754 gfc_expr *et = NULL, *eo = NULL, *e = expr; 5755 if (expr->value.op.op != INTRINSIC_TIMES) 5756 { 5757 if (gfc_find_sym_in_expr (var, expr->value.op.op1)) 5758 { 5759 e = expr->value.op.op1; 5760 eo = expr->value.op.op2; 5761 } 5762 else 5763 { 5764 eo = expr->value.op.op1; 5765 e = expr->value.op.op2; 5766 } 5767 } 5768 if (e->value.op.op == INTRINSIC_TIMES) 5769 { 5770 if (e->value.op.op1->expr_type == EXPR_VARIABLE 5771 && e->value.op.op1->symtree->n.sym == var) 5772 et = e->value.op.op2; 5773 else 5774 { 5775 et = e->value.op.op1; 5776 gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE 5777 && e->value.op.op2->symtree->n.sym == var); 5778 } 5779 } 5780 else 5781 gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var); 5782 if (et != NULL) 5783 { 5784 gfc_init_se (&se, NULL); 5785 gfc_conv_expr_val (&se, et); 5786 gfc_add_block_to_block (pblock, &se.pre); 5787 a1 = se.expr; 5788 } 5789 if (eo != NULL) 5790 { 5791 gfc_init_se (&se, NULL); 5792 gfc_conv_expr_val (&se, eo); 5793 gfc_add_block_to_block (pblock, &se.pre); 5794 a2 = se.expr; 5795 if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo) 5796 /* outer-var - a2. */ 5797 a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2); 5798 else if (expr->value.op.op == INTRINSIC_MINUS) 5799 /* a2 - outer-var. */ 5800 a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1); 5801 } 5802 a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock); 5803 a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock); 5804 } 5805 5806 gfc_init_se (sep, NULL); 5807 sep->expr = make_tree_vec (3); 5808 TREE_VEC_ELT (sep->expr, 0) = tree_var; 5809 TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1); 5810 TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2); 5811 5812 return true; 5813 } 5814 5815 static tree 5816 gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, 5817 gfc_omp_clauses *do_clauses, tree par_clauses) 5818 { 5819 gfc_se se; 5820 tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls; 5821 tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses; 5822 stmtblock_t block; 5823 stmtblock_t body; 5824 gfc_omp_clauses *clauses = code->ext.omp_clauses; 5825 int i, collapse = clauses->collapse; 5826 vec<dovar_init> inits = vNULL; 5827 dovar_init *di; 5828 unsigned ix; 5829 vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps; 5830 gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list; 5831 gfc_code *orig_code = code; 5832 5833 /* Both collapsed and tiled loops are lowered the same way. In 5834 OpenACC, those clauses are not compatible, so prioritize the tile 5835 clause, if present. */ 5836 if (tile) 5837 { 5838 collapse = 0; 5839 for (gfc_expr_list *el = tile; el; el = el->next) 5840 collapse++; 5841 } 5842 5843 doacross_steps = NULL; 5844 if (clauses->orderedc) 5845 collapse = clauses->orderedc; 5846 if (collapse <= 0) 5847 collapse = 1; 5848 5849 code = code->block->next; 5850 gcc_assert (code->op == EXEC_DO); 5851 5852 init = make_tree_vec (collapse); 5853 cond = make_tree_vec (collapse); 5854 incr = make_tree_vec (collapse); 5855 orig_decls = clauses->ordered ? make_tree_vec (collapse) : NULL_TREE; 5856 5857 if (pblock == NULL) 5858 { 5859 gfc_start_block (&block); 5860 pblock = █ 5861 } 5862 5863 /* simd schedule modifier is only useful for composite do simd and other 5864 constructs including that, where gfc_trans_omp_do is only called 5865 on the simd construct and DO's clauses are translated elsewhere. */ 5866 do_clauses->sched_simd = false; 5867 5868 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); 5869 5870 for (i = 0; i < collapse; i++) 5871 { 5872 int simple = 0; 5873 int dovar_found = 0; 5874 tree dovar_decl; 5875 5876 if (clauses) 5877 { 5878 gfc_omp_namelist *n = NULL; 5879 if (op == EXEC_OMP_SIMD && collapse == 1) 5880 for (n = clauses->lists[OMP_LIST_LINEAR]; 5881 n != NULL; n = n->next) 5882 if (code->ext.iterator->var->symtree->n.sym == n->sym) 5883 { 5884 dovar_found = 3; 5885 break; 5886 } 5887 if (n == NULL && op != EXEC_OMP_DISTRIBUTE) 5888 for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; 5889 n != NULL; n = n->next) 5890 if (code->ext.iterator->var->symtree->n.sym == n->sym) 5891 { 5892 dovar_found = 2; 5893 break; 5894 } 5895 if (n == NULL) 5896 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) 5897 if (code->ext.iterator->var->symtree->n.sym == n->sym) 5898 { 5899 dovar_found = 1; 5900 break; 5901 } 5902 } 5903 5904 /* Evaluate all the expressions in the iterator. */ 5905 gfc_init_se (&se, NULL); 5906 gfc_conv_expr_lhs (&se, code->ext.iterator->var); 5907 gfc_add_block_to_block (pblock, &se.pre); 5908 local_dovar = dovar_decl = dovar = se.expr; 5909 type = TREE_TYPE (dovar); 5910 gcc_assert (TREE_CODE (type) == INTEGER_TYPE); 5911 5912 gfc_init_se (&se, NULL); 5913 gfc_conv_expr_val (&se, code->ext.iterator->step); 5914 gfc_add_block_to_block (pblock, &se.pre); 5915 step = gfc_evaluate_now (se.expr, pblock); 5916 5917 if (TREE_CODE (step) == INTEGER_CST) 5918 simple = tree_int_cst_sgn (step); 5919 5920 gfc_init_se (&se, NULL); 5921 if (!clauses->non_rectangular 5922 || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next, 5923 code->ext.iterator->start, &inits, simple, 5924 code->ext.iterator->var)) 5925 { 5926 gfc_conv_expr_val (&se, code->ext.iterator->start); 5927 gfc_add_block_to_block (pblock, &se.pre); 5928 if (!DECL_P (se.expr)) 5929 se.expr = gfc_evaluate_now (se.expr, pblock); 5930 } 5931 from = se.expr; 5932 5933 gfc_init_se (&se, NULL); 5934 if (!clauses->non_rectangular 5935 || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next, 5936 code->ext.iterator->end, &inits, simple, 5937 code->ext.iterator->var)) 5938 { 5939 gfc_conv_expr_val (&se, code->ext.iterator->end); 5940 gfc_add_block_to_block (pblock, &se.pre); 5941 if (!DECL_P (se.expr)) 5942 se.expr = gfc_evaluate_now (se.expr, pblock); 5943 } 5944 to = se.expr; 5945 5946 if (!DECL_P (dovar)) 5947 dovar_decl 5948 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym, 5949 false); 5950 if (simple && !DECL_P (dovar)) 5951 { 5952 const char *name = code->ext.iterator->var->symtree->n.sym->name; 5953 local_dovar = gfc_create_var (type, name); 5954 dovar_init e = {code->ext.iterator->var->symtree->n.sym, 5955 dovar, local_dovar, false}; 5956 inits.safe_push (e); 5957 } 5958 /* Loop body. */ 5959 if (simple) 5960 { 5961 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from); 5962 /* The condition should not be folded. */ 5963 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0 5964 ? LE_EXPR : GE_EXPR, 5965 logical_type_node, local_dovar, 5966 to); 5967 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, 5968 type, local_dovar, step); 5969 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, 5970 MODIFY_EXPR, 5971 type, local_dovar, 5972 TREE_VEC_ELT (incr, i)); 5973 if (orig_decls && !clauses->orderedc) 5974 orig_decls = NULL; 5975 else if (orig_decls) 5976 TREE_VEC_ELT (orig_decls, i) = dovar_decl; 5977 } 5978 else 5979 { 5980 /* STEP is not 1 or -1. Use: 5981 for (count = 0; count < (to + step - from) / step; count++) 5982 { 5983 dovar = from + count * step; 5984 body; 5985 cycle_label:; 5986 } */ 5987 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from); 5988 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp); 5989 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp, 5990 step); 5991 tmp = gfc_evaluate_now (tmp, pblock); 5992 local_dovar = gfc_create_var (type, "count"); 5993 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, 5994 build_int_cst (type, 0)); 5995 /* The condition should not be folded. */ 5996 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR, 5997 logical_type_node, 5998 local_dovar, tmp); 5999 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, 6000 type, local_dovar, 6001 build_int_cst (type, 1)); 6002 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, 6003 MODIFY_EXPR, type, 6004 local_dovar, 6005 TREE_VEC_ELT (incr, i)); 6006 6007 /* Initialize DOVAR. */ 6008 tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar, 6009 step); 6010 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp); 6011 dovar_init e = {code->ext.iterator->var->symtree->n.sym, 6012 dovar, tmp, true}; 6013 inits.safe_push (e); 6014 if (clauses->orderedc) 6015 { 6016 if (doacross_steps == NULL) 6017 vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true); 6018 (*doacross_steps)[i] = step; 6019 } 6020 if (orig_decls) 6021 TREE_VEC_ELT (orig_decls, i) = dovar_decl; 6022 } 6023 6024 if (dovar_found == 3 6025 && op == EXEC_OMP_SIMD 6026 && collapse == 1 6027 && local_dovar != dovar) 6028 { 6029 for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp)) 6030 if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR 6031 && OMP_CLAUSE_DECL (tmp) == dovar) 6032 { 6033 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; 6034 break; 6035 } 6036 } 6037 if (!dovar_found && op == EXEC_OMP_SIMD) 6038 { 6039 if (collapse == 1) 6040 { 6041 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); 6042 OMP_CLAUSE_LINEAR_STEP (tmp) = step; 6043 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; 6044 OMP_CLAUSE_DECL (tmp) = dovar_decl; 6045 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); 6046 if (local_dovar != dovar) 6047 dovar_found = 3; 6048 } 6049 } 6050 else if (!dovar_found && local_dovar != dovar) 6051 { 6052 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); 6053 OMP_CLAUSE_DECL (tmp) = dovar_decl; 6054 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); 6055 } 6056 if (dovar_found > 1) 6057 { 6058 tree c = NULL; 6059 6060 tmp = NULL; 6061 if (local_dovar != dovar) 6062 { 6063 /* If dovar is lastprivate, but different counter is used, 6064 dovar += step needs to be added to 6065 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar 6066 will have the value on entry of the last loop, rather 6067 than value after iterator increment. */ 6068 if (clauses->orderedc) 6069 { 6070 if (clauses->collapse <= 1 || i >= clauses->collapse) 6071 tmp = local_dovar; 6072 else 6073 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6074 type, local_dovar, 6075 build_one_cst (type)); 6076 tmp = fold_build2_loc (input_location, MULT_EXPR, type, 6077 tmp, step); 6078 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, 6079 from, tmp); 6080 } 6081 else 6082 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, 6083 dovar, step); 6084 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, 6085 dovar, tmp); 6086 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) 6087 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE 6088 && OMP_CLAUSE_DECL (c) == dovar_decl) 6089 { 6090 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; 6091 break; 6092 } 6093 else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR 6094 && OMP_CLAUSE_DECL (c) == dovar_decl) 6095 { 6096 OMP_CLAUSE_LINEAR_STMT (c) = tmp; 6097 break; 6098 } 6099 } 6100 if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL) 6101 { 6102 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) 6103 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE 6104 && OMP_CLAUSE_DECL (c) == dovar_decl) 6105 { 6106 tree l = build_omp_clause (input_location, 6107 OMP_CLAUSE_LASTPRIVATE); 6108 if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c)) 6109 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1; 6110 OMP_CLAUSE_DECL (l) = dovar_decl; 6111 OMP_CLAUSE_CHAIN (l) = omp_clauses; 6112 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; 6113 omp_clauses = l; 6114 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED); 6115 break; 6116 } 6117 } 6118 gcc_assert (local_dovar == dovar || c != NULL); 6119 } 6120 if (local_dovar != dovar) 6121 { 6122 if (op != EXEC_OMP_SIMD || dovar_found == 1) 6123 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); 6124 else if (collapse == 1) 6125 { 6126 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); 6127 OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1); 6128 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; 6129 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1; 6130 } 6131 else 6132 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); 6133 OMP_CLAUSE_DECL (tmp) = local_dovar; 6134 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); 6135 } 6136 6137 if (i + 1 < collapse) 6138 code = code->block->next; 6139 } 6140 6141 if (pblock != &block) 6142 { 6143 pushlevel (); 6144 gfc_start_block (&block); 6145 } 6146 6147 gfc_start_block (&body); 6148 6149 FOR_EACH_VEC_ELT (inits, ix, di) 6150 gfc_add_modify (&body, di->var, di->init); 6151 inits.release (); 6152 6153 /* Cycle statement is implemented with a goto. Exit statement must not be 6154 present for this loop. */ 6155 cycle_label = gfc_build_label_decl (NULL_TREE); 6156 6157 /* Put these labels where they can be found later. */ 6158 6159 code->cycle_label = cycle_label; 6160 code->exit_label = NULL_TREE; 6161 6162 /* Main loop body. */ 6163 if (clauses->lists[OMP_LIST_REDUCTION_INSCAN]) 6164 { 6165 gfc_code *code1, *scan, *code2, *tmpcode; 6166 code1 = tmpcode = code->block->next; 6167 if (tmpcode && tmpcode->op != EXEC_OMP_SCAN) 6168 while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN) 6169 tmpcode = tmpcode->next; 6170 scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next; 6171 if (code1 != scan) 6172 tmpcode->next = NULL; 6173 code2 = scan->next; 6174 gcc_assert (scan->op == EXEC_OMP_SCAN); 6175 location_t loc = gfc_get_location (&scan->loc); 6176 6177 tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc); 6178 tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE); 6179 SET_EXPR_LOCATION (tmp, loc); 6180 gfc_add_expr_to_block (&body, tmp); 6181 input_location = loc; 6182 tree c = gfc_trans_omp_clauses (&body, scan->ext.omp_clauses, scan->loc); 6183 tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc); 6184 tmp = build2 (OMP_SCAN, void_type_node, tmp, c); 6185 SET_EXPR_LOCATION (tmp, loc); 6186 if (code1 != scan) 6187 tmpcode->next = scan; 6188 } 6189 else 6190 tmp = gfc_trans_omp_code (code->block->next, true); 6191 gfc_add_expr_to_block (&body, tmp); 6192 6193 /* Label for cycle statements (if needed). */ 6194 if (TREE_USED (cycle_label)) 6195 { 6196 tmp = build1_v (LABEL_EXPR, cycle_label); 6197 gfc_add_expr_to_block (&body, tmp); 6198 } 6199 6200 /* End of loop body. */ 6201 switch (op) 6202 { 6203 case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; 6204 case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; 6205 case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; 6206 case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break; 6207 case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break; 6208 case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break; 6209 default: gcc_unreachable (); 6210 } 6211 6212 SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc)); 6213 TREE_TYPE (stmt) = void_type_node; 6214 OMP_FOR_BODY (stmt) = gfc_finish_block (&body); 6215 OMP_FOR_CLAUSES (stmt) = omp_clauses; 6216 OMP_FOR_INIT (stmt) = init; 6217 OMP_FOR_COND (stmt) = cond; 6218 OMP_FOR_INCR (stmt) = incr; 6219 if (orig_decls) 6220 OMP_FOR_ORIG_DECLS (stmt) = orig_decls; 6221 OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular; 6222 gfc_add_expr_to_block (&block, stmt); 6223 6224 vec_free (doacross_steps); 6225 doacross_steps = saved_doacross_steps; 6226 6227 return gfc_finish_block (&block); 6228 } 6229 6230 /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop' 6231 construct. */ 6232 6233 static tree 6234 gfc_trans_oacc_combined_directive (gfc_code *code) 6235 { 6236 stmtblock_t block, *pblock = NULL; 6237 gfc_omp_clauses construct_clauses, loop_clauses; 6238 tree stmt, oacc_clauses = NULL_TREE; 6239 enum tree_code construct_code; 6240 location_t loc = input_location; 6241 6242 switch (code->op) 6243 { 6244 case EXEC_OACC_PARALLEL_LOOP: 6245 construct_code = OACC_PARALLEL; 6246 break; 6247 case EXEC_OACC_KERNELS_LOOP: 6248 construct_code = OACC_KERNELS; 6249 break; 6250 case EXEC_OACC_SERIAL_LOOP: 6251 construct_code = OACC_SERIAL; 6252 break; 6253 default: 6254 gcc_unreachable (); 6255 } 6256 6257 gfc_start_block (&block); 6258 6259 memset (&loop_clauses, 0, sizeof (loop_clauses)); 6260 if (code->ext.omp_clauses != NULL) 6261 { 6262 memcpy (&construct_clauses, code->ext.omp_clauses, 6263 sizeof (construct_clauses)); 6264 loop_clauses.collapse = construct_clauses.collapse; 6265 loop_clauses.gang = construct_clauses.gang; 6266 loop_clauses.gang_static = construct_clauses.gang_static; 6267 loop_clauses.gang_num_expr = construct_clauses.gang_num_expr; 6268 loop_clauses.gang_static_expr = construct_clauses.gang_static_expr; 6269 loop_clauses.vector = construct_clauses.vector; 6270 loop_clauses.vector_expr = construct_clauses.vector_expr; 6271 loop_clauses.worker = construct_clauses.worker; 6272 loop_clauses.worker_expr = construct_clauses.worker_expr; 6273 loop_clauses.seq = construct_clauses.seq; 6274 loop_clauses.par_auto = construct_clauses.par_auto; 6275 loop_clauses.independent = construct_clauses.independent; 6276 loop_clauses.tile_list = construct_clauses.tile_list; 6277 loop_clauses.lists[OMP_LIST_PRIVATE] 6278 = construct_clauses.lists[OMP_LIST_PRIVATE]; 6279 loop_clauses.lists[OMP_LIST_REDUCTION] 6280 = construct_clauses.lists[OMP_LIST_REDUCTION]; 6281 construct_clauses.gang = false; 6282 construct_clauses.gang_static = false; 6283 construct_clauses.gang_num_expr = NULL; 6284 construct_clauses.gang_static_expr = NULL; 6285 construct_clauses.vector = false; 6286 construct_clauses.vector_expr = NULL; 6287 construct_clauses.worker = false; 6288 construct_clauses.worker_expr = NULL; 6289 construct_clauses.seq = false; 6290 construct_clauses.par_auto = false; 6291 construct_clauses.independent = false; 6292 construct_clauses.independent = false; 6293 construct_clauses.tile_list = NULL; 6294 construct_clauses.lists[OMP_LIST_PRIVATE] = NULL; 6295 if (construct_code == OACC_KERNELS) 6296 construct_clauses.lists[OMP_LIST_REDUCTION] = NULL; 6297 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses, 6298 code->loc, false, true); 6299 } 6300 if (!loop_clauses.seq) 6301 pblock = █ 6302 else 6303 pushlevel (); 6304 stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL); 6305 protected_set_expr_location (stmt, loc); 6306 if (TREE_CODE (stmt) != BIND_EXPR) 6307 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 6308 else 6309 poplevel (0, 0); 6310 stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses); 6311 gfc_add_expr_to_block (&block, stmt); 6312 return gfc_finish_block (&block); 6313 } 6314 6315 static tree 6316 gfc_trans_omp_depobj (gfc_code *code) 6317 { 6318 stmtblock_t block; 6319 gfc_se se; 6320 gfc_init_se (&se, NULL); 6321 gfc_init_block (&block); 6322 gfc_conv_expr (&se, code->ext.omp_clauses->depobj); 6323 gcc_assert (se.pre.head == NULL && se.post.head == NULL); 6324 tree depobj = se.expr; 6325 location_t loc = EXPR_LOCATION (depobj); 6326 if (!POINTER_TYPE_P (TREE_TYPE (depobj))) 6327 depobj = gfc_build_addr_expr (NULL, depobj); 6328 depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node, 6329 TYPE_MODE (ptr_type_node), 6330 true), depobj); 6331 gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND]; 6332 if (n) 6333 { 6334 tree var; 6335 if (!n->sym) /* omp_all_memory. */ 6336 var = null_pointer_node; 6337 else if (n->expr && n->expr->ref->u.ar.type != AR_FULL) 6338 { 6339 gfc_init_se (&se, NULL); 6340 if (n->expr->rank == 0) 6341 { 6342 gfc_conv_expr_reference (&se, n->expr); 6343 var = se.expr; 6344 } 6345 else 6346 { 6347 gfc_conv_expr_descriptor (&se, n->expr); 6348 var = gfc_conv_array_data (se.expr); 6349 } 6350 gfc_add_block_to_block (&block, &se.pre); 6351 gfc_add_block_to_block (&block, &se.post); 6352 gcc_assert (POINTER_TYPE_P (TREE_TYPE (var))); 6353 } 6354 else 6355 { 6356 var = gfc_get_symbol_decl (n->sym); 6357 if (POINTER_TYPE_P (TREE_TYPE (var)) 6358 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var)))) 6359 var = build_fold_indirect_ref (var); 6360 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var))) 6361 { 6362 var = gfc_conv_descriptor_data_get (var); 6363 gcc_assert (POINTER_TYPE_P (TREE_TYPE (var))); 6364 } 6365 else if ((n->sym->attr.allocatable || n->sym->attr.pointer) 6366 && n->sym->attr.dummy) 6367 var = build_fold_indirect_ref (var); 6368 else if (!POINTER_TYPE_P (TREE_TYPE (var)) 6369 || (n->sym->ts.f90_type == BT_VOID 6370 && !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var))) 6371 && !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var))))) 6372 { 6373 TREE_ADDRESSABLE (var) = 1; 6374 var = gfc_build_addr_expr (NULL, var); 6375 } 6376 } 6377 depobj = save_expr (depobj); 6378 tree r = build_fold_indirect_ref_loc (loc, depobj); 6379 gfc_add_expr_to_block (&block, 6380 build2 (MODIFY_EXPR, void_type_node, r, var)); 6381 } 6382 6383 /* Only one may be set. */ 6384 gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy) 6385 + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET)) 6386 == 1); 6387 int k = -1; /* omp_clauses->destroy */ 6388 if (!code->ext.omp_clauses->destroy) 6389 switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET 6390 ? code->ext.omp_clauses->depobj_update : n->u.depend_doacross_op) 6391 { 6392 case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break; 6393 case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break; 6394 case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break; 6395 case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break; 6396 case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break; 6397 default: gcc_unreachable (); 6398 } 6399 tree t = build_int_cst (ptr_type_node, k); 6400 depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj, 6401 TYPE_SIZE_UNIT (ptr_type_node)); 6402 depobj = build_fold_indirect_ref_loc (loc, depobj); 6403 gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t)); 6404 6405 return gfc_finish_block (&block); 6406 } 6407 6408 static tree 6409 gfc_trans_omp_error (gfc_code *code) 6410 { 6411 stmtblock_t block; 6412 gfc_se se; 6413 tree len, message; 6414 bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL; 6415 tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR 6416 : BUILT_IN_GOMP_WARNING); 6417 gfc_start_block (&block); 6418 gfc_init_se (&se, NULL ); 6419 if (!code->ext.omp_clauses->message) 6420 { 6421 message = null_pointer_node; 6422 len = build_int_cst (size_type_node, 0); 6423 } 6424 else 6425 { 6426 gfc_conv_expr (&se, code->ext.omp_clauses->message); 6427 message = se.expr; 6428 if (!POINTER_TYPE_P (TREE_TYPE (message))) 6429 /* To ensure an ARRAY_TYPE is not passed as such. */ 6430 message = gfc_build_addr_expr (NULL, message); 6431 len = se.string_length; 6432 } 6433 gfc_add_block_to_block (&block, &se.pre); 6434 gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl, 6435 2, message, len)); 6436 gfc_add_block_to_block (&block, &se.post); 6437 return gfc_finish_block (&block); 6438 } 6439 6440 static tree 6441 gfc_trans_omp_flush (gfc_code *code) 6442 { 6443 tree call; 6444 if (!code->ext.omp_clauses 6445 || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET 6446 || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST) 6447 { 6448 call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); 6449 call = build_call_expr_loc (input_location, call, 0); 6450 } 6451 else 6452 { 6453 enum memmodel mo = MEMMODEL_LAST; 6454 switch (code->ext.omp_clauses->memorder) 6455 { 6456 case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break; 6457 case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break; 6458 case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break; 6459 default: gcc_unreachable (); break; 6460 } 6461 call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE); 6462 call = build_call_expr_loc (input_location, call, 1, 6463 build_int_cst (integer_type_node, mo)); 6464 } 6465 return call; 6466 } 6467 6468 static tree 6469 gfc_trans_omp_master (gfc_code *code) 6470 { 6471 tree stmt = gfc_trans_code (code->block->next); 6472 if (IS_EMPTY_STMT (stmt)) 6473 return stmt; 6474 return build1_v (OMP_MASTER, stmt); 6475 } 6476 6477 static tree 6478 gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses) 6479 { 6480 stmtblock_t block; 6481 tree body = gfc_trans_code (code->block->next); 6482 if (IS_EMPTY_STMT (body)) 6483 return body; 6484 if (!clauses) 6485 clauses = code->ext.omp_clauses; 6486 gfc_start_block (&block); 6487 tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); 6488 tree stmt = make_node (OMP_MASKED); 6489 SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); 6490 TREE_TYPE (stmt) = void_type_node; 6491 OMP_MASKED_BODY (stmt) = body; 6492 OMP_MASKED_CLAUSES (stmt) = omp_clauses; 6493 gfc_add_expr_to_block (&block, stmt); 6494 return gfc_finish_block (&block); 6495 } 6496 6497 6498 static tree 6499 gfc_trans_omp_ordered (gfc_code *code) 6500 { 6501 if (!flag_openmp) 6502 { 6503 if (!code->ext.omp_clauses->simd) 6504 return gfc_trans_code (code->block ? code->block->next : NULL); 6505 code->ext.omp_clauses->threads = 0; 6506 } 6507 tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses, 6508 code->loc); 6509 return build2_loc (input_location, OMP_ORDERED, void_type_node, 6510 code->block ? gfc_trans_code (code->block->next) 6511 : NULL_TREE, omp_clauses); 6512 } 6513 6514 static tree 6515 gfc_trans_omp_parallel (gfc_code *code) 6516 { 6517 stmtblock_t block; 6518 tree stmt, omp_clauses; 6519 6520 gfc_start_block (&block); 6521 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 6522 code->loc); 6523 pushlevel (); 6524 stmt = gfc_trans_omp_code (code->block->next, true); 6525 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 6526 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 6527 omp_clauses); 6528 gfc_add_expr_to_block (&block, stmt); 6529 return gfc_finish_block (&block); 6530 } 6531 6532 enum 6533 { 6534 GFC_OMP_SPLIT_SIMD, 6535 GFC_OMP_SPLIT_DO, 6536 GFC_OMP_SPLIT_PARALLEL, 6537 GFC_OMP_SPLIT_DISTRIBUTE, 6538 GFC_OMP_SPLIT_TEAMS, 6539 GFC_OMP_SPLIT_TARGET, 6540 GFC_OMP_SPLIT_TASKLOOP, 6541 GFC_OMP_SPLIT_MASKED, 6542 GFC_OMP_SPLIT_NUM 6543 }; 6544 6545 enum 6546 { 6547 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD), 6548 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO), 6549 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL), 6550 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), 6551 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), 6552 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET), 6553 GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP), 6554 GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED) 6555 }; 6556 6557 /* If a var is in lastprivate/firstprivate/reduction but not in a 6558 data mapping/sharing clause, add it to 'map(tofrom:' if is_target 6559 and to 'shared' otherwise. */ 6560 static void 6561 gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out, 6562 gfc_omp_clauses *clauses_in, 6563 bool is_target, bool is_parallel_do) 6564 { 6565 int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED; 6566 gfc_omp_namelist *tail = NULL; 6567 for (int i = 0; i < 5; ++i) 6568 { 6569 gfc_omp_namelist *n; 6570 switch (i) 6571 { 6572 case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break; 6573 case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break; 6574 case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break; 6575 case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break; 6576 case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break; 6577 default: gcc_unreachable (); 6578 } 6579 for (; n != NULL; n = n->next) 6580 { 6581 gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL; 6582 for (int j = 0; j < 6; ++j) 6583 { 6584 gfc_omp_namelist **n2ref = NULL, *prev2 = NULL; 6585 switch (j) 6586 { 6587 case 0: 6588 n2ref = &clauses_out->lists[clauselist_to_add]; 6589 break; 6590 case 1: 6591 n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE]; 6592 break; 6593 case 2: 6594 if (is_target) 6595 n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE]; 6596 else 6597 n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE]; 6598 break; 6599 case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break; 6600 case 4: 6601 n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN]; 6602 break; 6603 case 5: 6604 n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK]; 6605 break; 6606 default: gcc_unreachable (); 6607 } 6608 for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next) 6609 if (n2->sym == n->sym) 6610 break; 6611 if (n2) 6612 { 6613 if (j == 0 /* clauselist_to_add */) 6614 break; /* Already present. */ 6615 if (j == 1 /* OMP_LIST_FIRSTPRIVATE */) 6616 { 6617 n_firstp = prev2 ? &prev2->next : n2ref; 6618 continue; 6619 } 6620 if (j == 2 /* OMP_LIST_LASTPRIVATE */) 6621 { 6622 n_lastp = prev2 ? &prev2->next : n2ref; 6623 continue; 6624 } 6625 break; 6626 } 6627 } 6628 if (n_firstp && n_lastp) 6629 { 6630 /* For parallel do, GCC puts firstprivate/lastprivate 6631 on the parallel. */ 6632 if (is_parallel_do) 6633 continue; 6634 *n_firstp = (*n_firstp)->next; 6635 if (!is_target) 6636 *n_lastp = (*n_lastp)->next; 6637 } 6638 else if (is_target && n_lastp) 6639 ; 6640 else if (n2 || n_firstp || n_lastp) 6641 continue; 6642 if (clauses_out->lists[clauselist_to_add] 6643 && (clauses_out->lists[clauselist_to_add] 6644 == clauses_in->lists[clauselist_to_add])) 6645 { 6646 gfc_omp_namelist *p = NULL; 6647 for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next) 6648 { 6649 if (p) 6650 { 6651 p->next = gfc_get_omp_namelist (); 6652 p = p->next; 6653 } 6654 else 6655 { 6656 p = gfc_get_omp_namelist (); 6657 clauses_out->lists[clauselist_to_add] = p; 6658 } 6659 *p = *n2; 6660 } 6661 } 6662 if (!tail) 6663 { 6664 tail = clauses_out->lists[clauselist_to_add]; 6665 for (; tail && tail->next; tail = tail->next) 6666 ; 6667 } 6668 n2 = gfc_get_omp_namelist (); 6669 n2->where = n->where; 6670 n2->sym = n->sym; 6671 if (is_target) 6672 n2->u.map.op = OMP_MAP_TOFROM; 6673 if (tail) 6674 { 6675 tail->next = n2; 6676 tail = n2; 6677 } 6678 else 6679 clauses_out->lists[clauselist_to_add] = n2; 6680 } 6681 } 6682 } 6683 6684 /* Kind of opposite to above, add firstprivate to CLAUSES_OUT if it is mapped 6685 in CLAUSES_IN's FIRSTPRIVATE list but not its MAP list. */ 6686 6687 static void 6688 gfc_add_firstprivate_if_unmapped (gfc_omp_clauses *clauses_out, 6689 gfc_omp_clauses *clauses_in) 6690 { 6691 gfc_omp_namelist *n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; 6692 gfc_omp_namelist **tail = NULL; 6693 6694 for (; n != NULL; n = n->next) 6695 { 6696 gfc_omp_namelist *n2 = clauses_out->lists[OMP_LIST_MAP]; 6697 for (; n2 != NULL; n2 = n2->next) 6698 if (n->sym == n2->sym) 6699 break; 6700 if (n2 == NULL) 6701 { 6702 gfc_omp_namelist *dup = gfc_get_omp_namelist (); 6703 *dup = *n; 6704 dup->next = NULL; 6705 if (!tail) 6706 { 6707 tail = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE]; 6708 while (*tail && (*tail)->next) 6709 tail = &(*tail)->next; 6710 } 6711 *tail = dup; 6712 tail = &(*tail)->next; 6713 } 6714 } 6715 } 6716 6717 static void 6718 gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa) 6719 { 6720 for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i) 6721 for (int j = 0; j < OMP_LIST_NUM; ++j) 6722 if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j]) 6723 for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;) 6724 { 6725 gfc_omp_namelist *p = n; 6726 n = n->next; 6727 free (p); 6728 } 6729 } 6730 6731 static void 6732 gfc_split_omp_clauses (gfc_code *code, 6733 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) 6734 { 6735 int mask = 0, innermost = 0; 6736 bool is_loop = false; 6737 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); 6738 switch (code->op) 6739 { 6740 case EXEC_OMP_DISTRIBUTE: 6741 innermost = GFC_OMP_SPLIT_DISTRIBUTE; 6742 break; 6743 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 6744 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 6745 innermost = GFC_OMP_SPLIT_DO; 6746 break; 6747 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 6748 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL 6749 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 6750 innermost = GFC_OMP_SPLIT_SIMD; 6751 break; 6752 case EXEC_OMP_DISTRIBUTE_SIMD: 6753 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; 6754 innermost = GFC_OMP_SPLIT_SIMD; 6755 break; 6756 case EXEC_OMP_DO: 6757 case EXEC_OMP_LOOP: 6758 innermost = GFC_OMP_SPLIT_DO; 6759 break; 6760 case EXEC_OMP_DO_SIMD: 6761 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 6762 innermost = GFC_OMP_SPLIT_SIMD; 6763 break; 6764 case EXEC_OMP_PARALLEL: 6765 innermost = GFC_OMP_SPLIT_PARALLEL; 6766 break; 6767 case EXEC_OMP_PARALLEL_DO: 6768 case EXEC_OMP_PARALLEL_LOOP: 6769 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 6770 innermost = GFC_OMP_SPLIT_DO; 6771 break; 6772 case EXEC_OMP_PARALLEL_DO_SIMD: 6773 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 6774 innermost = GFC_OMP_SPLIT_SIMD; 6775 break; 6776 case EXEC_OMP_PARALLEL_MASKED: 6777 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED; 6778 innermost = GFC_OMP_SPLIT_MASKED; 6779 break; 6780 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: 6781 mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED 6782 | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); 6783 innermost = GFC_OMP_SPLIT_TASKLOOP; 6784 break; 6785 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: 6786 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; 6787 innermost = GFC_OMP_SPLIT_TASKLOOP; 6788 break; 6789 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: 6790 mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED 6791 | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); 6792 innermost = GFC_OMP_SPLIT_SIMD; 6793 break; 6794 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: 6795 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; 6796 innermost = GFC_OMP_SPLIT_SIMD; 6797 break; 6798 case EXEC_OMP_SIMD: 6799 innermost = GFC_OMP_SPLIT_SIMD; 6800 break; 6801 case EXEC_OMP_TARGET: 6802 innermost = GFC_OMP_SPLIT_TARGET; 6803 break; 6804 case EXEC_OMP_TARGET_PARALLEL: 6805 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL; 6806 innermost = GFC_OMP_SPLIT_PARALLEL; 6807 break; 6808 case EXEC_OMP_TARGET_PARALLEL_DO: 6809 case EXEC_OMP_TARGET_PARALLEL_LOOP: 6810 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 6811 innermost = GFC_OMP_SPLIT_DO; 6812 break; 6813 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 6814 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO 6815 | GFC_OMP_MASK_SIMD; 6816 innermost = GFC_OMP_SPLIT_SIMD; 6817 break; 6818 case EXEC_OMP_TARGET_SIMD: 6819 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD; 6820 innermost = GFC_OMP_SPLIT_SIMD; 6821 break; 6822 case EXEC_OMP_TARGET_TEAMS: 6823 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS; 6824 innermost = GFC_OMP_SPLIT_TEAMS; 6825 break; 6826 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 6827 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS 6828 | GFC_OMP_MASK_DISTRIBUTE; 6829 innermost = GFC_OMP_SPLIT_DISTRIBUTE; 6830 break; 6831 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 6832 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 6833 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 6834 innermost = GFC_OMP_SPLIT_DO; 6835 break; 6836 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 6837 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 6838 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 6839 innermost = GFC_OMP_SPLIT_SIMD; 6840 break; 6841 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 6842 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS 6843 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; 6844 innermost = GFC_OMP_SPLIT_SIMD; 6845 break; 6846 case EXEC_OMP_TARGET_TEAMS_LOOP: 6847 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; 6848 innermost = GFC_OMP_SPLIT_DO; 6849 break; 6850 case EXEC_OMP_MASKED_TASKLOOP: 6851 mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP; 6852 innermost = GFC_OMP_SPLIT_TASKLOOP; 6853 break; 6854 case EXEC_OMP_MASTER_TASKLOOP: 6855 case EXEC_OMP_TASKLOOP: 6856 innermost = GFC_OMP_SPLIT_TASKLOOP; 6857 break; 6858 case EXEC_OMP_MASKED_TASKLOOP_SIMD: 6859 mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; 6860 innermost = GFC_OMP_SPLIT_SIMD; 6861 break; 6862 case EXEC_OMP_MASTER_TASKLOOP_SIMD: 6863 case EXEC_OMP_TASKLOOP_SIMD: 6864 mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; 6865 innermost = GFC_OMP_SPLIT_SIMD; 6866 break; 6867 case EXEC_OMP_TEAMS: 6868 innermost = GFC_OMP_SPLIT_TEAMS; 6869 break; 6870 case EXEC_OMP_TEAMS_DISTRIBUTE: 6871 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE; 6872 innermost = GFC_OMP_SPLIT_DISTRIBUTE; 6873 break; 6874 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 6875 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 6876 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 6877 innermost = GFC_OMP_SPLIT_DO; 6878 break; 6879 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 6880 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 6881 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 6882 innermost = GFC_OMP_SPLIT_SIMD; 6883 break; 6884 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 6885 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; 6886 innermost = GFC_OMP_SPLIT_SIMD; 6887 break; 6888 case EXEC_OMP_TEAMS_LOOP: 6889 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; 6890 innermost = GFC_OMP_SPLIT_DO; 6891 break; 6892 default: 6893 gcc_unreachable (); 6894 } 6895 if (mask == 0) 6896 { 6897 clausesa[innermost] = *code->ext.omp_clauses; 6898 return; 6899 } 6900 /* Loops are similar to DO but still a bit different. */ 6901 switch (code->op) 6902 { 6903 case EXEC_OMP_LOOP: 6904 case EXEC_OMP_PARALLEL_LOOP: 6905 case EXEC_OMP_TEAMS_LOOP: 6906 case EXEC_OMP_TARGET_PARALLEL_LOOP: 6907 case EXEC_OMP_TARGET_TEAMS_LOOP: 6908 is_loop = true; 6909 default: 6910 break; 6911 } 6912 if (code->ext.omp_clauses != NULL) 6913 { 6914 if (mask & GFC_OMP_MASK_TARGET) 6915 { 6916 /* First the clauses that are unique to some constructs. */ 6917 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP] 6918 = code->ext.omp_clauses->lists[OMP_LIST_MAP]; 6919 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR] 6920 = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR]; 6921 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_HAS_DEVICE_ADDR] 6922 = code->ext.omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR]; 6923 clausesa[GFC_OMP_SPLIT_TARGET].device 6924 = code->ext.omp_clauses->device; 6925 clausesa[GFC_OMP_SPLIT_TARGET].thread_limit 6926 = code->ext.omp_clauses->thread_limit; 6927 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS] 6928 = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS]; 6929 for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) 6930 clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i] 6931 = code->ext.omp_clauses->defaultmap[i]; 6932 clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET] 6933 = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET]; 6934 /* And this is copied to all. */ 6935 clausesa[GFC_OMP_SPLIT_TARGET].if_expr 6936 = code->ext.omp_clauses->if_expr; 6937 clausesa[GFC_OMP_SPLIT_TARGET].nowait 6938 = code->ext.omp_clauses->nowait; 6939 } 6940 if (mask & GFC_OMP_MASK_TEAMS) 6941 { 6942 /* First the clauses that are unique to some constructs. */ 6943 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower 6944 = code->ext.omp_clauses->num_teams_lower; 6945 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper 6946 = code->ext.omp_clauses->num_teams_upper; 6947 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit 6948 = code->ext.omp_clauses->thread_limit; 6949 /* Shared and default clauses are allowed on parallel, teams 6950 and taskloop. */ 6951 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED] 6952 = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; 6953 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing 6954 = code->ext.omp_clauses->default_sharing; 6955 } 6956 if (mask & GFC_OMP_MASK_DISTRIBUTE) 6957 { 6958 /* First the clauses that are unique to some constructs. */ 6959 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind 6960 = code->ext.omp_clauses->dist_sched_kind; 6961 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size 6962 = code->ext.omp_clauses->dist_chunk_size; 6963 /* Duplicate collapse. */ 6964 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse 6965 = code->ext.omp_clauses->collapse; 6966 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent 6967 = code->ext.omp_clauses->order_concurrent; 6968 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained 6969 = code->ext.omp_clauses->order_unconstrained; 6970 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible 6971 = code->ext.omp_clauses->order_reproducible; 6972 } 6973 if (mask & GFC_OMP_MASK_PARALLEL) 6974 { 6975 /* First the clauses that are unique to some constructs. */ 6976 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN] 6977 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN]; 6978 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads 6979 = code->ext.omp_clauses->num_threads; 6980 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind 6981 = code->ext.omp_clauses->proc_bind; 6982 /* Shared and default clauses are allowed on parallel, teams 6983 and taskloop. */ 6984 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED] 6985 = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; 6986 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing 6987 = code->ext.omp_clauses->default_sharing; 6988 clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL] 6989 = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL]; 6990 /* And this is copied to all. */ 6991 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr 6992 = code->ext.omp_clauses->if_expr; 6993 } 6994 if (mask & GFC_OMP_MASK_MASKED) 6995 clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter; 6996 if ((mask & GFC_OMP_MASK_DO) && !is_loop) 6997 { 6998 /* First the clauses that are unique to some constructs. */ 6999 clausesa[GFC_OMP_SPLIT_DO].ordered 7000 = code->ext.omp_clauses->ordered; 7001 clausesa[GFC_OMP_SPLIT_DO].orderedc 7002 = code->ext.omp_clauses->orderedc; 7003 clausesa[GFC_OMP_SPLIT_DO].sched_kind 7004 = code->ext.omp_clauses->sched_kind; 7005 if (innermost == GFC_OMP_SPLIT_SIMD) 7006 clausesa[GFC_OMP_SPLIT_DO].sched_simd 7007 = code->ext.omp_clauses->sched_simd; 7008 clausesa[GFC_OMP_SPLIT_DO].sched_monotonic 7009 = code->ext.omp_clauses->sched_monotonic; 7010 clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic 7011 = code->ext.omp_clauses->sched_nonmonotonic; 7012 clausesa[GFC_OMP_SPLIT_DO].chunk_size 7013 = code->ext.omp_clauses->chunk_size; 7014 clausesa[GFC_OMP_SPLIT_DO].nowait 7015 = code->ext.omp_clauses->nowait; 7016 } 7017 if (mask & GFC_OMP_MASK_DO) 7018 { 7019 clausesa[GFC_OMP_SPLIT_DO].bind 7020 = code->ext.omp_clauses->bind; 7021 /* Duplicate collapse. */ 7022 clausesa[GFC_OMP_SPLIT_DO].collapse 7023 = code->ext.omp_clauses->collapse; 7024 clausesa[GFC_OMP_SPLIT_DO].order_concurrent 7025 = code->ext.omp_clauses->order_concurrent; 7026 clausesa[GFC_OMP_SPLIT_DO].order_unconstrained 7027 = code->ext.omp_clauses->order_unconstrained; 7028 clausesa[GFC_OMP_SPLIT_DO].order_reproducible 7029 = code->ext.omp_clauses->order_reproducible; 7030 } 7031 if (mask & GFC_OMP_MASK_SIMD) 7032 { 7033 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr 7034 = code->ext.omp_clauses->safelen_expr; 7035 clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr 7036 = code->ext.omp_clauses->simdlen_expr; 7037 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED] 7038 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED]; 7039 /* Duplicate collapse. */ 7040 clausesa[GFC_OMP_SPLIT_SIMD].collapse 7041 = code->ext.omp_clauses->collapse; 7042 clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD] 7043 = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD]; 7044 clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent 7045 = code->ext.omp_clauses->order_concurrent; 7046 clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained 7047 = code->ext.omp_clauses->order_unconstrained; 7048 clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible 7049 = code->ext.omp_clauses->order_reproducible; 7050 /* And this is copied to all. */ 7051 clausesa[GFC_OMP_SPLIT_SIMD].if_expr 7052 = code->ext.omp_clauses->if_expr; 7053 } 7054 if (mask & GFC_OMP_MASK_TASKLOOP) 7055 { 7056 /* First the clauses that are unique to some constructs. */ 7057 clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup 7058 = code->ext.omp_clauses->nogroup; 7059 clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize 7060 = code->ext.omp_clauses->grainsize; 7061 clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict 7062 = code->ext.omp_clauses->grainsize_strict; 7063 clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks 7064 = code->ext.omp_clauses->num_tasks; 7065 clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict 7066 = code->ext.omp_clauses->num_tasks_strict; 7067 clausesa[GFC_OMP_SPLIT_TASKLOOP].priority 7068 = code->ext.omp_clauses->priority; 7069 clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr 7070 = code->ext.omp_clauses->final_expr; 7071 clausesa[GFC_OMP_SPLIT_TASKLOOP].untied 7072 = code->ext.omp_clauses->untied; 7073 clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable 7074 = code->ext.omp_clauses->mergeable; 7075 clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP] 7076 = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP]; 7077 /* And this is copied to all. */ 7078 clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr 7079 = code->ext.omp_clauses->if_expr; 7080 /* Shared and default clauses are allowed on parallel, teams 7081 and taskloop. */ 7082 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED] 7083 = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; 7084 clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing 7085 = code->ext.omp_clauses->default_sharing; 7086 /* Duplicate collapse. */ 7087 clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse 7088 = code->ext.omp_clauses->collapse; 7089 } 7090 /* Private clause is supported on all constructs but master/masked, 7091 it is enough to put it on the innermost one except for master/masked. For 7092 !$ omp parallel do put it on parallel though, 7093 as that's what we did for OpenMP 3.1. */ 7094 clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop) 7095 || code->op == EXEC_OMP_PARALLEL_MASTER 7096 || code->op == EXEC_OMP_PARALLEL_MASKED) 7097 ? (int) GFC_OMP_SPLIT_PARALLEL 7098 : innermost].lists[OMP_LIST_PRIVATE] 7099 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE]; 7100 /* Firstprivate clause is supported on all constructs but 7101 simd and masked/master. Put it on the outermost of those and duplicate 7102 on parallel and teams. */ 7103 if (mask & GFC_OMP_MASK_TARGET) 7104 gfc_add_firstprivate_if_unmapped (&clausesa[GFC_OMP_SPLIT_TARGET], 7105 code->ext.omp_clauses); 7106 if (mask & GFC_OMP_MASK_TEAMS) 7107 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE] 7108 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 7109 else if (mask & GFC_OMP_MASK_DISTRIBUTE) 7110 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] 7111 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 7112 if (mask & GFC_OMP_MASK_TASKLOOP) 7113 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE] 7114 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 7115 if ((mask & GFC_OMP_MASK_PARALLEL) 7116 && !(mask & GFC_OMP_MASK_TASKLOOP)) 7117 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE] 7118 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 7119 else if ((mask & GFC_OMP_MASK_DO) && !is_loop) 7120 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE] 7121 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 7122 /* Lastprivate is allowed on distribute, do, simd, taskloop and loop. 7123 In parallel do{, simd} we actually want to put it on 7124 parallel rather than do. */ 7125 if (mask & GFC_OMP_MASK_DISTRIBUTE) 7126 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE] 7127 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 7128 if (mask & GFC_OMP_MASK_TASKLOOP) 7129 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE] 7130 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 7131 if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop 7132 && !(mask & GFC_OMP_MASK_TASKLOOP)) 7133 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE] 7134 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 7135 else if (mask & GFC_OMP_MASK_DO) 7136 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE] 7137 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 7138 if (mask & GFC_OMP_MASK_SIMD) 7139 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE] 7140 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 7141 /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop. 7142 Duplicate it on all of them, but 7143 - omit on do if parallel is present; 7144 - omit on task and parallel if loop is present; 7145 additionally, inscan applies to do/simd only. */ 7146 for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++) 7147 { 7148 if (mask & GFC_OMP_MASK_TASKLOOP 7149 && i != OMP_LIST_REDUCTION_INSCAN) 7150 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i] 7151 = code->ext.omp_clauses->lists[i]; 7152 if (mask & GFC_OMP_MASK_TEAMS 7153 && i != OMP_LIST_REDUCTION_INSCAN 7154 && !is_loop) 7155 clausesa[GFC_OMP_SPLIT_TEAMS].lists[i] 7156 = code->ext.omp_clauses->lists[i]; 7157 if (mask & GFC_OMP_MASK_PARALLEL 7158 && i != OMP_LIST_REDUCTION_INSCAN 7159 && !(mask & GFC_OMP_MASK_TASKLOOP) 7160 && !is_loop) 7161 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i] 7162 = code->ext.omp_clauses->lists[i]; 7163 else if (mask & GFC_OMP_MASK_DO) 7164 clausesa[GFC_OMP_SPLIT_DO].lists[i] 7165 = code->ext.omp_clauses->lists[i]; 7166 if (mask & GFC_OMP_MASK_SIMD) 7167 clausesa[GFC_OMP_SPLIT_SIMD].lists[i] 7168 = code->ext.omp_clauses->lists[i]; 7169 } 7170 if (mask & GFC_OMP_MASK_TARGET) 7171 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION] 7172 = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION]; 7173 if (mask & GFC_OMP_MASK_TASKLOOP) 7174 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION] 7175 = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION]; 7176 /* Linear clause is supported on do and simd, 7177 put it on the innermost one. */ 7178 clausesa[innermost].lists[OMP_LIST_LINEAR] 7179 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR]; 7180 } 7181 /* Propagate firstprivate/lastprivate/reduction vars to 7182 shared (parallel, teams) and map-tofrom (target). */ 7183 if (mask & GFC_OMP_MASK_TARGET) 7184 gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET], 7185 code->ext.omp_clauses, true, false); 7186 if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL) 7187 gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL], 7188 code->ext.omp_clauses, false, 7189 mask & GFC_OMP_MASK_DO); 7190 if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS) 7191 gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS], 7192 code->ext.omp_clauses, false, false); 7193 if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) 7194 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) 7195 && !is_loop) 7196 clausesa[GFC_OMP_SPLIT_DO].nowait = true; 7197 7198 /* Distribute allocate clause to do, parallel, distribute, teams, target 7199 and taskloop. The code below iterates over variables in the 7200 allocate list and checks if that available is also in any 7201 privatization clause on those construct. If yes, then we add it 7202 to the list of 'allocate'ed variables for that construct. If a 7203 variable is found in none of them then we issue an error. */ 7204 7205 if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]) 7206 { 7207 gfc_omp_namelist *alloc_nl, *priv_nl; 7208 gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM]; 7209 for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; 7210 alloc_nl; alloc_nl = alloc_nl->next) 7211 { 7212 bool found = false; 7213 for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++) 7214 { 7215 gfc_omp_namelist *p; 7216 int list; 7217 for (list = 0; list < OMP_LIST_NUM; list++) 7218 { 7219 switch (list) 7220 { 7221 case OMP_LIST_PRIVATE: 7222 case OMP_LIST_FIRSTPRIVATE: 7223 case OMP_LIST_LASTPRIVATE: 7224 case OMP_LIST_REDUCTION: 7225 case OMP_LIST_REDUCTION_INSCAN: 7226 case OMP_LIST_REDUCTION_TASK: 7227 case OMP_LIST_IN_REDUCTION: 7228 case OMP_LIST_TASK_REDUCTION: 7229 case OMP_LIST_LINEAR: 7230 for (priv_nl = clausesa[i].lists[list]; priv_nl; 7231 priv_nl = priv_nl->next) 7232 if (alloc_nl->sym == priv_nl->sym) 7233 { 7234 found = true; 7235 p = gfc_get_omp_namelist (); 7236 p->sym = alloc_nl->sym; 7237 p->expr = alloc_nl->expr; 7238 p->u.align = alloc_nl->u.align; 7239 p->u2.allocator = alloc_nl->u2.allocator; 7240 p->where = alloc_nl->where; 7241 if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL) 7242 { 7243 clausesa[i].lists[OMP_LIST_ALLOCATE] = p; 7244 tails[i] = p; 7245 } 7246 else 7247 { 7248 tails[i]->next = p; 7249 tails[i] = tails[i]->next; 7250 } 7251 } 7252 break; 7253 default: 7254 break; 7255 } 7256 } 7257 } 7258 if (!found) 7259 gfc_error ("%qs specified in 'allocate' clause at %L but not " 7260 "in an explicit privatization clause", 7261 alloc_nl->sym->name, &alloc_nl->where); 7262 } 7263 } 7264 } 7265 7266 static tree 7267 gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, 7268 gfc_omp_clauses *clausesa, tree omp_clauses) 7269 { 7270 stmtblock_t block; 7271 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 7272 tree stmt, body, omp_do_clauses = NULL_TREE; 7273 bool free_clausesa = false; 7274 7275 if (pblock == NULL) 7276 gfc_start_block (&block); 7277 else 7278 gfc_init_block (&block); 7279 7280 if (clausesa == NULL) 7281 { 7282 clausesa = clausesa_buf; 7283 gfc_split_omp_clauses (code, clausesa); 7284 free_clausesa = true; 7285 } 7286 if (flag_openmp) 7287 omp_do_clauses 7288 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc); 7289 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block, 7290 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses); 7291 if (pblock == NULL) 7292 { 7293 if (TREE_CODE (body) != BIND_EXPR) 7294 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0)); 7295 else 7296 poplevel (0, 0); 7297 } 7298 else if (TREE_CODE (body) != BIND_EXPR) 7299 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE); 7300 if (flag_openmp) 7301 { 7302 stmt = make_node (OMP_FOR); 7303 SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); 7304 TREE_TYPE (stmt) = void_type_node; 7305 OMP_FOR_BODY (stmt) = body; 7306 OMP_FOR_CLAUSES (stmt) = omp_do_clauses; 7307 } 7308 else 7309 stmt = body; 7310 gfc_add_expr_to_block (&block, stmt); 7311 if (free_clausesa) 7312 gfc_free_split_omp_clauses (code, clausesa); 7313 return gfc_finish_block (&block); 7314 } 7315 7316 static tree 7317 gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock, 7318 gfc_omp_clauses *clausesa) 7319 { 7320 stmtblock_t block, *new_pblock = pblock; 7321 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 7322 tree stmt, omp_clauses = NULL_TREE; 7323 bool free_clausesa = false; 7324 7325 if (pblock == NULL) 7326 gfc_start_block (&block); 7327 else 7328 gfc_init_block (&block); 7329 7330 if (clausesa == NULL) 7331 { 7332 clausesa = clausesa_buf; 7333 gfc_split_omp_clauses (code, clausesa); 7334 free_clausesa = true; 7335 } 7336 omp_clauses 7337 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], 7338 code->loc); 7339 if (pblock == NULL) 7340 { 7341 if (!clausesa[GFC_OMP_SPLIT_DO].ordered 7342 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC) 7343 new_pblock = █ 7344 else 7345 pushlevel (); 7346 } 7347 stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO, 7348 new_pblock, &clausesa[GFC_OMP_SPLIT_DO], 7349 omp_clauses); 7350 if (pblock == NULL) 7351 { 7352 if (TREE_CODE (stmt) != BIND_EXPR) 7353 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7354 else 7355 poplevel (0, 0); 7356 } 7357 else if (TREE_CODE (stmt) != BIND_EXPR) 7358 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); 7359 stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, 7360 void_type_node, stmt, omp_clauses); 7361 OMP_PARALLEL_COMBINED (stmt) = 1; 7362 gfc_add_expr_to_block (&block, stmt); 7363 if (free_clausesa) 7364 gfc_free_split_omp_clauses (code, clausesa); 7365 return gfc_finish_block (&block); 7366 } 7367 7368 static tree 7369 gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, 7370 gfc_omp_clauses *clausesa) 7371 { 7372 stmtblock_t block; 7373 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 7374 tree stmt, omp_clauses = NULL_TREE; 7375 bool free_clausesa = false; 7376 7377 if (pblock == NULL) 7378 gfc_start_block (&block); 7379 else 7380 gfc_init_block (&block); 7381 7382 if (clausesa == NULL) 7383 { 7384 clausesa = clausesa_buf; 7385 gfc_split_omp_clauses (code, clausesa); 7386 free_clausesa = true; 7387 } 7388 if (flag_openmp) 7389 omp_clauses 7390 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], 7391 code->loc); 7392 if (pblock == NULL) 7393 pushlevel (); 7394 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses); 7395 if (pblock == NULL) 7396 { 7397 if (TREE_CODE (stmt) != BIND_EXPR) 7398 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7399 else 7400 poplevel (0, 0); 7401 } 7402 else if (TREE_CODE (stmt) != BIND_EXPR) 7403 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); 7404 if (flag_openmp) 7405 { 7406 stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, 7407 void_type_node, stmt, omp_clauses); 7408 OMP_PARALLEL_COMBINED (stmt) = 1; 7409 } 7410 gfc_add_expr_to_block (&block, stmt); 7411 if (free_clausesa) 7412 gfc_free_split_omp_clauses (code, clausesa); 7413 return gfc_finish_block (&block); 7414 } 7415 7416 static tree 7417 gfc_trans_omp_parallel_sections (gfc_code *code) 7418 { 7419 stmtblock_t block; 7420 gfc_omp_clauses section_clauses; 7421 tree stmt, omp_clauses; 7422 7423 memset (§ion_clauses, 0, sizeof (section_clauses)); 7424 section_clauses.nowait = true; 7425 7426 gfc_start_block (&block); 7427 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 7428 code->loc); 7429 pushlevel (); 7430 stmt = gfc_trans_omp_sections (code, §ion_clauses); 7431 if (TREE_CODE (stmt) != BIND_EXPR) 7432 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7433 else 7434 poplevel (0, 0); 7435 stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, 7436 void_type_node, stmt, omp_clauses); 7437 OMP_PARALLEL_COMBINED (stmt) = 1; 7438 gfc_add_expr_to_block (&block, stmt); 7439 return gfc_finish_block (&block); 7440 } 7441 7442 static tree 7443 gfc_trans_omp_parallel_workshare (gfc_code *code) 7444 { 7445 stmtblock_t block; 7446 gfc_omp_clauses workshare_clauses; 7447 tree stmt, omp_clauses; 7448 7449 memset (&workshare_clauses, 0, sizeof (workshare_clauses)); 7450 workshare_clauses.nowait = true; 7451 7452 gfc_start_block (&block); 7453 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 7454 code->loc); 7455 pushlevel (); 7456 stmt = gfc_trans_omp_workshare (code, &workshare_clauses); 7457 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7458 stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, 7459 void_type_node, stmt, omp_clauses); 7460 OMP_PARALLEL_COMBINED (stmt) = 1; 7461 gfc_add_expr_to_block (&block, stmt); 7462 return gfc_finish_block (&block); 7463 } 7464 7465 static tree 7466 gfc_trans_omp_scope (gfc_code *code) 7467 { 7468 stmtblock_t block; 7469 tree body = gfc_trans_code (code->block->next); 7470 if (IS_EMPTY_STMT (body)) 7471 return body; 7472 gfc_start_block (&block); 7473 tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 7474 code->loc); 7475 tree stmt = make_node (OMP_SCOPE); 7476 SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); 7477 TREE_TYPE (stmt) = void_type_node; 7478 OMP_SCOPE_BODY (stmt) = body; 7479 OMP_SCOPE_CLAUSES (stmt) = omp_clauses; 7480 gfc_add_expr_to_block (&block, stmt); 7481 return gfc_finish_block (&block); 7482 } 7483 7484 static tree 7485 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) 7486 { 7487 stmtblock_t block, body; 7488 tree omp_clauses, stmt; 7489 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL; 7490 location_t loc = gfc_get_location (&code->loc); 7491 7492 gfc_start_block (&block); 7493 7494 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); 7495 7496 gfc_init_block (&body); 7497 for (code = code->block; code; code = code->block) 7498 { 7499 /* Last section is special because of lastprivate, so even if it 7500 is empty, chain it in. */ 7501 stmt = gfc_trans_omp_code (code->next, 7502 has_lastprivate && code->block == NULL); 7503 if (! IS_EMPTY_STMT (stmt)) 7504 { 7505 stmt = build1_v (OMP_SECTION, stmt); 7506 gfc_add_expr_to_block (&body, stmt); 7507 } 7508 } 7509 stmt = gfc_finish_block (&body); 7510 7511 stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses); 7512 gfc_add_expr_to_block (&block, stmt); 7513 7514 return gfc_finish_block (&block); 7515 } 7516 7517 static tree 7518 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) 7519 { 7520 stmtblock_t block; 7521 gfc_start_block (&block); 7522 tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); 7523 tree stmt = gfc_trans_omp_code (code->block->next, true); 7524 stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node, 7525 stmt, omp_clauses); 7526 gfc_add_expr_to_block (&block, stmt); 7527 return gfc_finish_block (&block); 7528 } 7529 7530 static tree 7531 gfc_trans_omp_task (gfc_code *code) 7532 { 7533 stmtblock_t block; 7534 tree stmt, omp_clauses; 7535 7536 gfc_start_block (&block); 7537 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 7538 code->loc); 7539 pushlevel (); 7540 stmt = gfc_trans_omp_code (code->block->next, true); 7541 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7542 stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node, 7543 stmt, omp_clauses); 7544 gfc_add_expr_to_block (&block, stmt); 7545 return gfc_finish_block (&block); 7546 } 7547 7548 static tree 7549 gfc_trans_omp_taskgroup (gfc_code *code) 7550 { 7551 stmtblock_t block; 7552 gfc_start_block (&block); 7553 tree body = gfc_trans_code (code->block->next); 7554 tree stmt = make_node (OMP_TASKGROUP); 7555 SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); 7556 TREE_TYPE (stmt) = void_type_node; 7557 OMP_TASKGROUP_BODY (stmt) = body; 7558 OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, 7559 code->ext.omp_clauses, 7560 code->loc); 7561 gfc_add_expr_to_block (&block, stmt); 7562 return gfc_finish_block (&block); 7563 } 7564 7565 static tree 7566 gfc_trans_omp_taskwait (gfc_code *code) 7567 { 7568 if (!code->ext.omp_clauses) 7569 { 7570 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); 7571 return build_call_expr_loc (input_location, decl, 0); 7572 } 7573 stmtblock_t block; 7574 gfc_start_block (&block); 7575 tree stmt = make_node (OMP_TASK); 7576 SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); 7577 TREE_TYPE (stmt) = void_type_node; 7578 OMP_TASK_BODY (stmt) = NULL_TREE; 7579 OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, 7580 code->ext.omp_clauses, 7581 code->loc); 7582 gfc_add_expr_to_block (&block, stmt); 7583 return gfc_finish_block (&block); 7584 } 7585 7586 static tree 7587 gfc_trans_omp_taskyield (void) 7588 { 7589 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD); 7590 return build_call_expr_loc (input_location, decl, 0); 7591 } 7592 7593 static tree 7594 gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) 7595 { 7596 stmtblock_t block; 7597 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 7598 tree stmt, omp_clauses = NULL_TREE; 7599 bool free_clausesa = false; 7600 7601 gfc_start_block (&block); 7602 if (clausesa == NULL) 7603 { 7604 clausesa = clausesa_buf; 7605 gfc_split_omp_clauses (code, clausesa); 7606 free_clausesa = true; 7607 } 7608 if (flag_openmp) 7609 omp_clauses 7610 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], 7611 code->loc); 7612 switch (code->op) 7613 { 7614 case EXEC_OMP_DISTRIBUTE: 7615 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 7616 case EXEC_OMP_TEAMS_DISTRIBUTE: 7617 /* This is handled in gfc_trans_omp_do. */ 7618 gcc_unreachable (); 7619 break; 7620 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 7621 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 7622 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 7623 stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa); 7624 if (TREE_CODE (stmt) != BIND_EXPR) 7625 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7626 else 7627 poplevel (0, 0); 7628 break; 7629 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 7630 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 7631 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 7632 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); 7633 if (TREE_CODE (stmt) != BIND_EXPR) 7634 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7635 else 7636 poplevel (0, 0); 7637 break; 7638 case EXEC_OMP_DISTRIBUTE_SIMD: 7639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 7640 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 7641 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, 7642 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); 7643 if (TREE_CODE (stmt) != BIND_EXPR) 7644 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7645 else 7646 poplevel (0, 0); 7647 break; 7648 default: 7649 gcc_unreachable (); 7650 } 7651 if (flag_openmp) 7652 { 7653 tree distribute = make_node (OMP_DISTRIBUTE); 7654 SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc)); 7655 TREE_TYPE (distribute) = void_type_node; 7656 OMP_FOR_BODY (distribute) = stmt; 7657 OMP_FOR_CLAUSES (distribute) = omp_clauses; 7658 stmt = distribute; 7659 } 7660 gfc_add_expr_to_block (&block, stmt); 7661 if (free_clausesa) 7662 gfc_free_split_omp_clauses (code, clausesa); 7663 return gfc_finish_block (&block); 7664 } 7665 7666 static tree 7667 gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, 7668 tree omp_clauses) 7669 { 7670 stmtblock_t block; 7671 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 7672 tree stmt; 7673 bool combined = true, free_clausesa = false; 7674 7675 gfc_start_block (&block); 7676 if (clausesa == NULL) 7677 { 7678 clausesa = clausesa_buf; 7679 gfc_split_omp_clauses (code, clausesa); 7680 free_clausesa = true; 7681 } 7682 if (flag_openmp) 7683 { 7684 omp_clauses 7685 = chainon (omp_clauses, 7686 gfc_trans_omp_clauses (&block, 7687 &clausesa[GFC_OMP_SPLIT_TEAMS], 7688 code->loc)); 7689 pushlevel (); 7690 } 7691 switch (code->op) 7692 { 7693 case EXEC_OMP_TARGET_TEAMS: 7694 case EXEC_OMP_TEAMS: 7695 stmt = gfc_trans_omp_code (code->block->next, true); 7696 combined = false; 7697 break; 7698 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 7699 case EXEC_OMP_TEAMS_DISTRIBUTE: 7700 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL, 7701 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], 7702 NULL); 7703 break; 7704 case EXEC_OMP_TARGET_TEAMS_LOOP: 7705 case EXEC_OMP_TEAMS_LOOP: 7706 stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL, 7707 &clausesa[GFC_OMP_SPLIT_DO], 7708 NULL); 7709 break; 7710 default: 7711 stmt = gfc_trans_omp_distribute (code, clausesa); 7712 break; 7713 } 7714 if (flag_openmp) 7715 { 7716 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7717 stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS, 7718 void_type_node, stmt, omp_clauses); 7719 if (combined) 7720 OMP_TEAMS_COMBINED (stmt) = 1; 7721 } 7722 gfc_add_expr_to_block (&block, stmt); 7723 if (free_clausesa) 7724 gfc_free_split_omp_clauses (code, clausesa); 7725 return gfc_finish_block (&block); 7726 } 7727 7728 static tree 7729 gfc_trans_omp_target (gfc_code *code) 7730 { 7731 stmtblock_t block; 7732 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; 7733 tree stmt, omp_clauses = NULL_TREE; 7734 7735 gfc_start_block (&block); 7736 gfc_split_omp_clauses (code, clausesa); 7737 if (flag_openmp) 7738 omp_clauses 7739 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], 7740 code->loc); 7741 switch (code->op) 7742 { 7743 case EXEC_OMP_TARGET: 7744 pushlevel (); 7745 stmt = gfc_trans_omp_code (code->block->next, true); 7746 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7747 break; 7748 case EXEC_OMP_TARGET_PARALLEL: 7749 { 7750 stmtblock_t iblock; 7751 7752 pushlevel (); 7753 gfc_start_block (&iblock); 7754 tree inner_clauses 7755 = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL], 7756 code->loc); 7757 stmt = gfc_trans_omp_code (code->block->next, true); 7758 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 7759 inner_clauses); 7760 gfc_add_expr_to_block (&iblock, stmt); 7761 stmt = gfc_finish_block (&iblock); 7762 if (TREE_CODE (stmt) != BIND_EXPR) 7763 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7764 else 7765 poplevel (0, 0); 7766 } 7767 break; 7768 case EXEC_OMP_TARGET_PARALLEL_DO: 7769 case EXEC_OMP_TARGET_PARALLEL_LOOP: 7770 stmt = gfc_trans_omp_parallel_do (code, 7771 (code->op 7772 == EXEC_OMP_TARGET_PARALLEL_LOOP), 7773 &block, clausesa); 7774 if (TREE_CODE (stmt) != BIND_EXPR) 7775 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7776 else 7777 poplevel (0, 0); 7778 break; 7779 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 7780 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); 7781 if (TREE_CODE (stmt) != BIND_EXPR) 7782 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7783 else 7784 poplevel (0, 0); 7785 break; 7786 case EXEC_OMP_TARGET_SIMD: 7787 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, 7788 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); 7789 if (TREE_CODE (stmt) != BIND_EXPR) 7790 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7791 else 7792 poplevel (0, 0); 7793 break; 7794 default: 7795 if (flag_openmp 7796 && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper 7797 || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit)) 7798 { 7799 gfc_omp_clauses clausesb; 7800 tree teams_clauses; 7801 /* For combined !$omp target teams, the num_teams and 7802 thread_limit clauses are evaluated before entering the 7803 target construct. */ 7804 memset (&clausesb, '\0', sizeof (clausesb)); 7805 clausesb.num_teams_lower 7806 = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower; 7807 clausesb.num_teams_upper 7808 = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper; 7809 clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit; 7810 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL; 7811 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL; 7812 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL; 7813 teams_clauses 7814 = gfc_trans_omp_clauses (&block, &clausesb, code->loc); 7815 pushlevel (); 7816 stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses); 7817 } 7818 else 7819 { 7820 pushlevel (); 7821 stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE); 7822 } 7823 if (TREE_CODE (stmt) != BIND_EXPR) 7824 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7825 else 7826 poplevel (0, 0); 7827 break; 7828 } 7829 if (flag_openmp) 7830 { 7831 stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET, 7832 void_type_node, stmt, omp_clauses); 7833 if (code->op != EXEC_OMP_TARGET) 7834 OMP_TARGET_COMBINED (stmt) = 1; 7835 cfun->has_omp_target = true; 7836 } 7837 gfc_add_expr_to_block (&block, stmt); 7838 gfc_free_split_omp_clauses (code, clausesa); 7839 return gfc_finish_block (&block); 7840 } 7841 7842 static tree 7843 gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op) 7844 { 7845 stmtblock_t block; 7846 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; 7847 tree stmt, omp_clauses = NULL_TREE; 7848 7849 gfc_start_block (&block); 7850 gfc_split_omp_clauses (code, clausesa); 7851 if (flag_openmp) 7852 omp_clauses 7853 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP], 7854 code->loc); 7855 switch (op) 7856 { 7857 case EXEC_OMP_TASKLOOP: 7858 /* This is handled in gfc_trans_omp_do. */ 7859 gcc_unreachable (); 7860 break; 7861 case EXEC_OMP_TASKLOOP_SIMD: 7862 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, 7863 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); 7864 if (TREE_CODE (stmt) != BIND_EXPR) 7865 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7866 else 7867 poplevel (0, 0); 7868 break; 7869 default: 7870 gcc_unreachable (); 7871 } 7872 if (flag_openmp) 7873 { 7874 tree taskloop = make_node (OMP_TASKLOOP); 7875 SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc)); 7876 TREE_TYPE (taskloop) = void_type_node; 7877 OMP_FOR_BODY (taskloop) = stmt; 7878 OMP_FOR_CLAUSES (taskloop) = omp_clauses; 7879 stmt = taskloop; 7880 } 7881 gfc_add_expr_to_block (&block, stmt); 7882 gfc_free_split_omp_clauses (code, clausesa); 7883 return gfc_finish_block (&block); 7884 } 7885 7886 static tree 7887 gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op) 7888 { 7889 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; 7890 stmtblock_t block; 7891 tree stmt; 7892 7893 if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD 7894 && code->op != EXEC_OMP_MASTER_TASKLOOP) 7895 gfc_split_omp_clauses (code, clausesa); 7896 7897 pushlevel (); 7898 if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD 7899 || op == EXEC_OMP_MASTER_TASKLOOP_SIMD) 7900 stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD); 7901 else 7902 { 7903 gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP 7904 || op == EXEC_OMP_MASTER_TASKLOOP); 7905 stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL, 7906 code->op != EXEC_OMP_MASTER_TASKLOOP 7907 ? &clausesa[GFC_OMP_SPLIT_TASKLOOP] 7908 : code->ext.omp_clauses, NULL); 7909 } 7910 if (TREE_CODE (stmt) != BIND_EXPR) 7911 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7912 else 7913 poplevel (0, 0); 7914 gfc_start_block (&block); 7915 if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD) 7916 { 7917 tree clauses = gfc_trans_omp_clauses (&block, 7918 &clausesa[GFC_OMP_SPLIT_MASKED], 7919 code->loc); 7920 tree msk = make_node (OMP_MASKED); 7921 SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc)); 7922 TREE_TYPE (msk) = void_type_node; 7923 OMP_MASKED_BODY (msk) = stmt; 7924 OMP_MASKED_CLAUSES (msk) = clauses; 7925 OMP_MASKED_COMBINED (msk) = 1; 7926 gfc_add_expr_to_block (&block, msk); 7927 } 7928 else 7929 { 7930 gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP 7931 || op == EXEC_OMP_MASTER_TASKLOOP_SIMD); 7932 stmt = build1_v (OMP_MASTER, stmt); 7933 gfc_add_expr_to_block (&block, stmt); 7934 } 7935 if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD 7936 && code->op != EXEC_OMP_MASTER_TASKLOOP) 7937 gfc_free_split_omp_clauses (code, clausesa); 7938 return gfc_finish_block (&block); 7939 } 7940 7941 static tree 7942 gfc_trans_omp_parallel_master_masked (gfc_code *code) 7943 { 7944 stmtblock_t block; 7945 tree stmt, omp_clauses; 7946 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; 7947 bool parallel_combined = false; 7948 7949 if (code->op != EXEC_OMP_PARALLEL_MASTER) 7950 gfc_split_omp_clauses (code, clausesa); 7951 7952 gfc_start_block (&block); 7953 omp_clauses = gfc_trans_omp_clauses (&block, 7954 code->op == EXEC_OMP_PARALLEL_MASTER 7955 ? code->ext.omp_clauses 7956 : &clausesa[GFC_OMP_SPLIT_PARALLEL], 7957 code->loc); 7958 pushlevel (); 7959 if (code->op == EXEC_OMP_PARALLEL_MASTER) 7960 stmt = gfc_trans_omp_master (code); 7961 else if (code->op == EXEC_OMP_PARALLEL_MASKED) 7962 stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]); 7963 else 7964 { 7965 gfc_exec_op op; 7966 switch (code->op) 7967 { 7968 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: 7969 op = EXEC_OMP_MASKED_TASKLOOP; 7970 break; 7971 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: 7972 op = EXEC_OMP_MASKED_TASKLOOP_SIMD; 7973 break; 7974 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: 7975 op = EXEC_OMP_MASTER_TASKLOOP; 7976 break; 7977 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: 7978 op = EXEC_OMP_MASTER_TASKLOOP_SIMD; 7979 break; 7980 default: 7981 gcc_unreachable (); 7982 } 7983 stmt = gfc_trans_omp_master_masked_taskloop (code, op); 7984 parallel_combined = true; 7985 } 7986 if (TREE_CODE (stmt) != BIND_EXPR) 7987 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 7988 else 7989 poplevel (0, 0); 7990 stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, 7991 void_type_node, stmt, omp_clauses); 7992 /* masked does have just filter clause, but during gimplification 7993 isn't represented by a gimplification omp context, so for 7994 !$omp parallel masked don't set OMP_PARALLEL_COMBINED, 7995 so that 7996 !$omp parallel masked 7997 !$omp taskloop simd lastprivate (x) 7998 isn't confused with 7999 !$omp parallel masked taskloop simd lastprivate (x) */ 8000 if (parallel_combined) 8001 OMP_PARALLEL_COMBINED (stmt) = 1; 8002 gfc_add_expr_to_block (&block, stmt); 8003 if (code->op != EXEC_OMP_PARALLEL_MASTER) 8004 gfc_free_split_omp_clauses (code, clausesa); 8005 return gfc_finish_block (&block); 8006 } 8007 8008 static tree 8009 gfc_trans_omp_target_data (gfc_code *code) 8010 { 8011 stmtblock_t block; 8012 tree stmt, omp_clauses; 8013 8014 gfc_start_block (&block); 8015 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 8016 code->loc); 8017 stmt = gfc_trans_omp_code (code->block->next, true); 8018 stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA, 8019 void_type_node, stmt, omp_clauses); 8020 gfc_add_expr_to_block (&block, stmt); 8021 return gfc_finish_block (&block); 8022 } 8023 8024 static tree 8025 gfc_trans_omp_target_enter_data (gfc_code *code) 8026 { 8027 stmtblock_t block; 8028 tree stmt, omp_clauses; 8029 8030 gfc_start_block (&block); 8031 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 8032 code->loc); 8033 stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node, 8034 omp_clauses); 8035 gfc_add_expr_to_block (&block, stmt); 8036 return gfc_finish_block (&block); 8037 } 8038 8039 static tree 8040 gfc_trans_omp_target_exit_data (gfc_code *code) 8041 { 8042 stmtblock_t block; 8043 tree stmt, omp_clauses; 8044 8045 gfc_start_block (&block); 8046 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 8047 code->loc, false, false, code->op); 8048 stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node, 8049 omp_clauses); 8050 gfc_add_expr_to_block (&block, stmt); 8051 return gfc_finish_block (&block); 8052 } 8053 8054 static tree 8055 gfc_trans_omp_target_update (gfc_code *code) 8056 { 8057 stmtblock_t block; 8058 tree stmt, omp_clauses; 8059 8060 gfc_start_block (&block); 8061 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 8062 code->loc); 8063 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node, 8064 omp_clauses); 8065 gfc_add_expr_to_block (&block, stmt); 8066 return gfc_finish_block (&block); 8067 } 8068 8069 static tree 8070 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) 8071 { 8072 tree res, tmp, stmt; 8073 stmtblock_t block, *pblock = NULL; 8074 stmtblock_t singleblock; 8075 int saved_ompws_flags; 8076 bool singleblock_in_progress = false; 8077 /* True if previous gfc_code in workshare construct is not workshared. */ 8078 bool prev_singleunit; 8079 location_t loc = gfc_get_location (&code->loc); 8080 8081 code = code->block->next; 8082 8083 pushlevel (); 8084 8085 gfc_start_block (&block); 8086 pblock = █ 8087 8088 ompws_flags = OMPWS_WORKSHARE_FLAG; 8089 prev_singleunit = false; 8090 8091 /* Translate statements one by one to trees until we reach 8092 the end of the workshare construct. Adjacent gfc_codes that 8093 are a single unit of work are clustered and encapsulated in a 8094 single OMP_SINGLE construct. */ 8095 for (; code; code = code->next) 8096 { 8097 if (code->here != 0) 8098 { 8099 res = gfc_trans_label_here (code); 8100 gfc_add_expr_to_block (pblock, res); 8101 } 8102 8103 /* No dependence analysis, use for clauses with wait. 8104 If this is the last gfc_code, use default omp_clauses. */ 8105 if (code->next == NULL && clauses->nowait) 8106 ompws_flags |= OMPWS_NOWAIT; 8107 8108 /* By default, every gfc_code is a single unit of work. */ 8109 ompws_flags |= OMPWS_CURR_SINGLEUNIT; 8110 ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY); 8111 8112 switch (code->op) 8113 { 8114 case EXEC_NOP: 8115 res = NULL_TREE; 8116 break; 8117 8118 case EXEC_ASSIGN: 8119 res = gfc_trans_assign (code); 8120 break; 8121 8122 case EXEC_POINTER_ASSIGN: 8123 res = gfc_trans_pointer_assign (code); 8124 break; 8125 8126 case EXEC_INIT_ASSIGN: 8127 res = gfc_trans_init_assign (code); 8128 break; 8129 8130 case EXEC_FORALL: 8131 res = gfc_trans_forall (code); 8132 break; 8133 8134 case EXEC_WHERE: 8135 res = gfc_trans_where (code); 8136 break; 8137 8138 case EXEC_OMP_ATOMIC: 8139 res = gfc_trans_omp_directive (code); 8140 break; 8141 8142 case EXEC_OMP_PARALLEL: 8143 case EXEC_OMP_PARALLEL_DO: 8144 case EXEC_OMP_PARALLEL_MASTER: 8145 case EXEC_OMP_PARALLEL_SECTIONS: 8146 case EXEC_OMP_PARALLEL_WORKSHARE: 8147 case EXEC_OMP_CRITICAL: 8148 saved_ompws_flags = ompws_flags; 8149 ompws_flags = 0; 8150 res = gfc_trans_omp_directive (code); 8151 ompws_flags = saved_ompws_flags; 8152 break; 8153 8154 case EXEC_BLOCK: 8155 res = gfc_trans_block_construct (code); 8156 break; 8157 8158 default: 8159 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code"); 8160 } 8161 8162 gfc_set_backend_locus (&code->loc); 8163 8164 if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) 8165 { 8166 if (prev_singleunit) 8167 { 8168 if (ompws_flags & OMPWS_CURR_SINGLEUNIT) 8169 /* Add current gfc_code to single block. */ 8170 gfc_add_expr_to_block (&singleblock, res); 8171 else 8172 { 8173 /* Finish single block and add it to pblock. */ 8174 tmp = gfc_finish_block (&singleblock); 8175 tmp = build2_loc (loc, OMP_SINGLE, 8176 void_type_node, tmp, NULL_TREE); 8177 gfc_add_expr_to_block (pblock, tmp); 8178 /* Add current gfc_code to pblock. */ 8179 gfc_add_expr_to_block (pblock, res); 8180 singleblock_in_progress = false; 8181 } 8182 } 8183 else 8184 { 8185 if (ompws_flags & OMPWS_CURR_SINGLEUNIT) 8186 { 8187 /* Start single block. */ 8188 gfc_init_block (&singleblock); 8189 gfc_add_expr_to_block (&singleblock, res); 8190 singleblock_in_progress = true; 8191 loc = gfc_get_location (&code->loc); 8192 } 8193 else 8194 /* Add the new statement to the block. */ 8195 gfc_add_expr_to_block (pblock, res); 8196 } 8197 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0; 8198 } 8199 } 8200 8201 /* Finish remaining SINGLE block, if we were in the middle of one. */ 8202 if (singleblock_in_progress) 8203 { 8204 /* Finish single block and add it to pblock. */ 8205 tmp = gfc_finish_block (&singleblock); 8206 tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp, 8207 clauses->nowait 8208 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT) 8209 : NULL_TREE); 8210 gfc_add_expr_to_block (pblock, tmp); 8211 } 8212 8213 stmt = gfc_finish_block (pblock); 8214 if (TREE_CODE (stmt) != BIND_EXPR) 8215 { 8216 if (!IS_EMPTY_STMT (stmt)) 8217 { 8218 tree bindblock = poplevel (1, 0); 8219 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock); 8220 } 8221 else 8222 poplevel (0, 0); 8223 } 8224 else 8225 poplevel (0, 0); 8226 8227 if (IS_EMPTY_STMT (stmt) && !clauses->nowait) 8228 stmt = gfc_trans_omp_barrier (); 8229 8230 ompws_flags = 0; 8231 return stmt; 8232 } 8233 8234 tree 8235 gfc_trans_oacc_declare (gfc_code *code) 8236 { 8237 stmtblock_t block; 8238 tree stmt, oacc_clauses; 8239 enum tree_code construct_code; 8240 8241 construct_code = OACC_DATA; 8242 8243 gfc_start_block (&block); 8244 8245 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses, 8246 code->loc, false, true); 8247 stmt = gfc_trans_omp_code (code->block->next, true); 8248 stmt = build2_loc (input_location, construct_code, void_type_node, stmt, 8249 oacc_clauses); 8250 gfc_add_expr_to_block (&block, stmt); 8251 8252 return gfc_finish_block (&block); 8253 } 8254 8255 tree 8256 gfc_trans_oacc_directive (gfc_code *code) 8257 { 8258 switch (code->op) 8259 { 8260 case EXEC_OACC_PARALLEL_LOOP: 8261 case EXEC_OACC_KERNELS_LOOP: 8262 case EXEC_OACC_SERIAL_LOOP: 8263 return gfc_trans_oacc_combined_directive (code); 8264 case EXEC_OACC_PARALLEL: 8265 case EXEC_OACC_KERNELS: 8266 case EXEC_OACC_SERIAL: 8267 case EXEC_OACC_DATA: 8268 case EXEC_OACC_HOST_DATA: 8269 return gfc_trans_oacc_construct (code); 8270 case EXEC_OACC_LOOP: 8271 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, 8272 NULL); 8273 case EXEC_OACC_UPDATE: 8274 case EXEC_OACC_CACHE: 8275 case EXEC_OACC_ENTER_DATA: 8276 case EXEC_OACC_EXIT_DATA: 8277 return gfc_trans_oacc_executable_directive (code); 8278 case EXEC_OACC_WAIT: 8279 return gfc_trans_oacc_wait_directive (code); 8280 case EXEC_OACC_ATOMIC: 8281 return gfc_trans_omp_atomic (code); 8282 case EXEC_OACC_DECLARE: 8283 return gfc_trans_oacc_declare (code); 8284 default: 8285 gcc_unreachable (); 8286 } 8287 } 8288 8289 tree 8290 gfc_trans_omp_directive (gfc_code *code) 8291 { 8292 switch (code->op) 8293 { 8294 case EXEC_OMP_ALLOCATE: 8295 case EXEC_OMP_ALLOCATORS: 8296 return gfc_trans_omp_allocators (code); 8297 case EXEC_OMP_ASSUME: 8298 return gfc_trans_omp_assume (code); 8299 case EXEC_OMP_ATOMIC: 8300 return gfc_trans_omp_atomic (code); 8301 case EXEC_OMP_BARRIER: 8302 return gfc_trans_omp_barrier (); 8303 case EXEC_OMP_CANCEL: 8304 return gfc_trans_omp_cancel (code); 8305 case EXEC_OMP_CANCELLATION_POINT: 8306 return gfc_trans_omp_cancellation_point (code); 8307 case EXEC_OMP_CRITICAL: 8308 return gfc_trans_omp_critical (code); 8309 case EXEC_OMP_DEPOBJ: 8310 return gfc_trans_omp_depobj (code); 8311 case EXEC_OMP_DISTRIBUTE: 8312 case EXEC_OMP_DO: 8313 case EXEC_OMP_LOOP: 8314 case EXEC_OMP_SIMD: 8315 case EXEC_OMP_TASKLOOP: 8316 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, 8317 NULL); 8318 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 8319 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 8320 case EXEC_OMP_DISTRIBUTE_SIMD: 8321 return gfc_trans_omp_distribute (code, NULL); 8322 case EXEC_OMP_DO_SIMD: 8323 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); 8324 case EXEC_OMP_ERROR: 8325 return gfc_trans_omp_error (code); 8326 case EXEC_OMP_FLUSH: 8327 return gfc_trans_omp_flush (code); 8328 case EXEC_OMP_MASKED: 8329 return gfc_trans_omp_masked (code, NULL); 8330 case EXEC_OMP_MASTER: 8331 return gfc_trans_omp_master (code); 8332 case EXEC_OMP_MASKED_TASKLOOP: 8333 case EXEC_OMP_MASKED_TASKLOOP_SIMD: 8334 case EXEC_OMP_MASTER_TASKLOOP: 8335 case EXEC_OMP_MASTER_TASKLOOP_SIMD: 8336 return gfc_trans_omp_master_masked_taskloop (code, code->op); 8337 case EXEC_OMP_ORDERED: 8338 return gfc_trans_omp_ordered (code); 8339 case EXEC_OMP_PARALLEL: 8340 return gfc_trans_omp_parallel (code); 8341 case EXEC_OMP_PARALLEL_DO: 8342 return gfc_trans_omp_parallel_do (code, false, NULL, NULL); 8343 case EXEC_OMP_PARALLEL_LOOP: 8344 return gfc_trans_omp_parallel_do (code, true, NULL, NULL); 8345 case EXEC_OMP_PARALLEL_DO_SIMD: 8346 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); 8347 case EXEC_OMP_PARALLEL_MASKED: 8348 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: 8349 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: 8350 case EXEC_OMP_PARALLEL_MASTER: 8351 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: 8352 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: 8353 return gfc_trans_omp_parallel_master_masked (code); 8354 case EXEC_OMP_PARALLEL_SECTIONS: 8355 return gfc_trans_omp_parallel_sections (code); 8356 case EXEC_OMP_PARALLEL_WORKSHARE: 8357 return gfc_trans_omp_parallel_workshare (code); 8358 case EXEC_OMP_SCOPE: 8359 return gfc_trans_omp_scope (code); 8360 case EXEC_OMP_SECTIONS: 8361 return gfc_trans_omp_sections (code, code->ext.omp_clauses); 8362 case EXEC_OMP_SINGLE: 8363 return gfc_trans_omp_single (code, code->ext.omp_clauses); 8364 case EXEC_OMP_TARGET: 8365 case EXEC_OMP_TARGET_PARALLEL: 8366 case EXEC_OMP_TARGET_PARALLEL_DO: 8367 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 8368 case EXEC_OMP_TARGET_PARALLEL_LOOP: 8369 case EXEC_OMP_TARGET_SIMD: 8370 case EXEC_OMP_TARGET_TEAMS: 8371 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 8372 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 8373 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 8374 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 8375 case EXEC_OMP_TARGET_TEAMS_LOOP: 8376 return gfc_trans_omp_target (code); 8377 case EXEC_OMP_TARGET_DATA: 8378 return gfc_trans_omp_target_data (code); 8379 case EXEC_OMP_TARGET_ENTER_DATA: 8380 return gfc_trans_omp_target_enter_data (code); 8381 case EXEC_OMP_TARGET_EXIT_DATA: 8382 return gfc_trans_omp_target_exit_data (code); 8383 case EXEC_OMP_TARGET_UPDATE: 8384 return gfc_trans_omp_target_update (code); 8385 case EXEC_OMP_TASK: 8386 return gfc_trans_omp_task (code); 8387 case EXEC_OMP_TASKGROUP: 8388 return gfc_trans_omp_taskgroup (code); 8389 case EXEC_OMP_TASKLOOP_SIMD: 8390 return gfc_trans_omp_taskloop (code, code->op); 8391 case EXEC_OMP_TASKWAIT: 8392 return gfc_trans_omp_taskwait (code); 8393 case EXEC_OMP_TASKYIELD: 8394 return gfc_trans_omp_taskyield (); 8395 case EXEC_OMP_TEAMS: 8396 case EXEC_OMP_TEAMS_DISTRIBUTE: 8397 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 8398 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 8399 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 8400 case EXEC_OMP_TEAMS_LOOP: 8401 return gfc_trans_omp_teams (code, NULL, NULL_TREE); 8402 case EXEC_OMP_WORKSHARE: 8403 return gfc_trans_omp_workshare (code, code->ext.omp_clauses); 8404 default: 8405 gcc_unreachable (); 8406 } 8407 } 8408 8409 void 8410 gfc_trans_omp_declare_simd (gfc_namespace *ns) 8411 { 8412 if (ns->entries) 8413 return; 8414 8415 gfc_omp_declare_simd *ods; 8416 for (ods = ns->omp_declare_simd; ods; ods = ods->next) 8417 { 8418 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true); 8419 tree fndecl = ns->proc_name->backend_decl; 8420 if (c != NULL_TREE) 8421 c = tree_cons (NULL_TREE, c, NULL_TREE); 8422 c = build_tree_list (get_identifier ("omp declare simd"), c); 8423 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl); 8424 DECL_ATTRIBUTES (fndecl) = c; 8425 } 8426 } 8427 8428 void 8429 gfc_trans_omp_declare_variant (gfc_namespace *ns) 8430 { 8431 tree base_fn_decl = ns->proc_name->backend_decl; 8432 gfc_namespace *search_ns = ns; 8433 gfc_omp_declare_variant *next; 8434 8435 for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant; 8436 search_ns; odv = next) 8437 { 8438 /* Look in the parent namespace if there are no more directives in the 8439 current namespace. */ 8440 if (!odv) 8441 { 8442 search_ns = search_ns->parent; 8443 if (search_ns) 8444 next = search_ns->omp_declare_variant; 8445 continue; 8446 } 8447 8448 next = odv->next; 8449 8450 if (odv->error_p) 8451 continue; 8452 8453 /* Check directive the first time it is encountered. */ 8454 bool error_found = true; 8455 8456 if (odv->checked_p) 8457 error_found = false; 8458 if (odv->base_proc_symtree == NULL) 8459 { 8460 if (!search_ns->proc_name->attr.function 8461 && !search_ns->proc_name->attr.subroutine) 8462 gfc_error ("The base name for 'declare variant' must be " 8463 "specified at %L ", &odv->where); 8464 else 8465 error_found = false; 8466 } 8467 else 8468 { 8469 if (!search_ns->contained 8470 && strcmp (odv->base_proc_symtree->name, 8471 ns->proc_name->name)) 8472 gfc_error ("The base name at %L does not match the name of the " 8473 "current procedure", &odv->where); 8474 else if (odv->base_proc_symtree->n.sym->attr.entry) 8475 gfc_error ("The base name at %L must not be an entry name", 8476 &odv->where); 8477 else if (odv->base_proc_symtree->n.sym->attr.generic) 8478 gfc_error ("The base name at %L must not be a generic name", 8479 &odv->where); 8480 else if (odv->base_proc_symtree->n.sym->attr.proc_pointer) 8481 gfc_error ("The base name at %L must not be a procedure pointer", 8482 &odv->where); 8483 else if (odv->base_proc_symtree->n.sym->attr.implicit_type) 8484 gfc_error ("The base procedure at %L must have an explicit " 8485 "interface", &odv->where); 8486 else 8487 error_found = false; 8488 } 8489 8490 odv->checked_p = true; 8491 if (error_found) 8492 { 8493 odv->error_p = true; 8494 continue; 8495 } 8496 8497 /* Ignore directives that do not apply to the current procedure. */ 8498 if ((odv->base_proc_symtree == NULL && search_ns != ns) 8499 || (odv->base_proc_symtree != NULL 8500 && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))) 8501 continue; 8502 8503 tree set_selectors = NULL_TREE; 8504 gfc_omp_set_selector *oss; 8505 8506 for (oss = odv->set_selectors; oss; oss = oss->next) 8507 { 8508 tree selectors = NULL_TREE; 8509 gfc_omp_selector *os; 8510 enum omp_tss_code set = oss->code; 8511 gcc_assert (set != OMP_TRAIT_SET_INVALID); 8512 8513 for (os = oss->trait_selectors; os; os = os->next) 8514 { 8515 tree scoreval = NULL_TREE; 8516 tree properties = NULL_TREE; 8517 gfc_omp_trait_property *otp; 8518 enum omp_ts_code sel = os->code; 8519 8520 /* Per the spec, "Implementations can ignore specified 8521 selectors that are not those described in this section"; 8522 however, we must record such selectors because they 8523 cause match failures. */ 8524 if (sel == OMP_TRAIT_INVALID) 8525 { 8526 selectors = make_trait_selector (sel, NULL_TREE, NULL_TREE, 8527 selectors); 8528 continue; 8529 } 8530 8531 for (otp = os->properties; otp; otp = otp->next) 8532 { 8533 switch (otp->property_kind) 8534 { 8535 case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR: 8536 case OMP_TRAIT_PROPERTY_BOOL_EXPR: 8537 { 8538 gfc_se se; 8539 gfc_init_se (&se, NULL); 8540 gfc_conv_expr (&se, otp->expr); 8541 properties = make_trait_property (NULL_TREE, se.expr, 8542 properties); 8543 } 8544 break; 8545 case OMP_TRAIT_PROPERTY_ID: 8546 properties 8547 = make_trait_property (get_identifier (otp->name), 8548 NULL_TREE, properties); 8549 break; 8550 case OMP_TRAIT_PROPERTY_NAME_LIST: 8551 { 8552 tree prop = OMP_TP_NAMELIST_NODE; 8553 tree value = NULL_TREE; 8554 if (otp->is_name) 8555 value = get_identifier (otp->name); 8556 else 8557 value = gfc_conv_constant_to_tree (otp->expr); 8558 8559 properties = make_trait_property (prop, value, 8560 properties); 8561 } 8562 break; 8563 case OMP_TRAIT_PROPERTY_CLAUSE_LIST: 8564 properties = gfc_trans_omp_clauses (NULL, otp->clauses, 8565 odv->where, true); 8566 break; 8567 default: 8568 gcc_unreachable (); 8569 } 8570 } 8571 8572 if (os->score) 8573 { 8574 gfc_se se; 8575 gfc_init_se (&se, NULL); 8576 gfc_conv_expr (&se, os->score); 8577 scoreval = se.expr; 8578 } 8579 8580 selectors = make_trait_selector (sel, scoreval, 8581 properties, selectors); 8582 } 8583 set_selectors = make_trait_set_selector (set, selectors, 8584 set_selectors); 8585 } 8586 8587 const char *variant_proc_name = odv->variant_proc_symtree->name; 8588 gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; 8589 if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type) 8590 { 8591 gfc_symtree *proc_st; 8592 gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); 8593 variant_proc_sym = proc_st->n.sym; 8594 } 8595 if (variant_proc_sym == NULL) 8596 { 8597 gfc_error ("Cannot find symbol %qs", variant_proc_name); 8598 continue; 8599 } 8600 set_selectors = omp_check_context_selector 8601 (gfc_get_location (&odv->where), set_selectors); 8602 if (set_selectors != error_mark_node) 8603 { 8604 if (!variant_proc_sym->attr.implicit_type 8605 && !variant_proc_sym->attr.subroutine 8606 && !variant_proc_sym->attr.function) 8607 { 8608 gfc_error ("variant %qs at %L is not a function or subroutine", 8609 variant_proc_name, &odv->where); 8610 variant_proc_sym = NULL; 8611 } 8612 else if (omp_get_context_selector (set_selectors, 8613 OMP_TRAIT_SET_CONSTRUCT, 8614 OMP_TRAIT_CONSTRUCT_SIMD) 8615 == NULL_TREE) 8616 { 8617 char err[256]; 8618 if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym, 8619 variant_proc_sym->name, 0, 1, 8620 err, sizeof (err), NULL, NULL)) 8621 { 8622 gfc_error ("variant %qs and base %qs at %L have " 8623 "incompatible types: %s", 8624 variant_proc_name, ns->proc_name->name, 8625 &odv->where, err); 8626 variant_proc_sym = NULL; 8627 } 8628 } 8629 if (variant_proc_sym != NULL) 8630 { 8631 gfc_set_sym_referenced (variant_proc_sym); 8632 tree construct 8633 = omp_get_context_selector_list (set_selectors, 8634 OMP_TRAIT_SET_CONSTRUCT); 8635 omp_mark_declare_variant (gfc_get_location (&odv->where), 8636 gfc_get_symbol_decl (variant_proc_sym), 8637 construct); 8638 if (omp_context_selector_matches (set_selectors)) 8639 { 8640 tree id = get_identifier ("omp declare variant base"); 8641 tree variant = gfc_get_symbol_decl (variant_proc_sym); 8642 DECL_ATTRIBUTES (base_fn_decl) 8643 = tree_cons (id, build_tree_list (variant, set_selectors), 8644 DECL_ATTRIBUTES (base_fn_decl)); 8645 } 8646 } 8647 } 8648 } 8649 } 8650 8651 /* Add ptr for tracking as being allocated by GOMP_alloc. */ 8652 8653 tree 8654 gfc_omp_call_add_alloc (tree ptr) 8655 { 8656 static tree fn = NULL_TREE; 8657 if (fn == NULL_TREE) 8658 { 8659 fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE); 8660 tree att = build_tree_list (NULL_TREE, build_string (4, ". R ")); 8661 att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn)); 8662 fn = build_type_attribute_variant (fn, att); 8663 fn = build_fn_decl ("GOMP_add_alloc", fn); 8664 } 8665 return build_call_expr_loc (input_location, fn, 1, ptr); 8666 } 8667 8668 /* Generated function returns true when it was tracked via GOMP_add_alloc and 8669 removes it from the tracking. As called just before GOMP_free or omp_realloc 8670 the pointer is or might become invalid, thus, it is always removed. */ 8671 8672 tree 8673 gfc_omp_call_is_alloc (tree ptr) 8674 { 8675 static tree fn = NULL_TREE; 8676 if (fn == NULL_TREE) 8677 { 8678 fn = build_function_type_list (boolean_type_node, ptr_type_node, 8679 NULL_TREE); 8680 tree att = build_tree_list (NULL_TREE, build_string (4, ". R ")); 8681 att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn)); 8682 fn = build_type_attribute_variant (fn, att); 8683 fn = build_fn_decl ("GOMP_is_alloc", fn); 8684 } 8685 return build_call_expr_loc (input_location, fn, 1, ptr); 8686 } 8687
Indexes created Mon Oct 12 00:27:07 UTC 2026