1 /* OpenMP directive translation -- generate GCC trees from gfc_code. 2 Copyright (C) 2005-2019 Free Software Foundation, Inc. 3 Contributed by Jakub Jelinek <jakub@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 "gomp-constants.h" 39 #include "omp-general.h" 40 #include "omp-low.h" 41 #undef GCC_DIAG_STYLE 42 #define GCC_DIAG_STYLE __gcc_tdiag__ 43 #include "diagnostic-core.h" 44 #undef GCC_DIAG_STYLE 45 #define GCC_DIAG_STYLE __gcc_gfc__ 46 #include "attribs.h" 47 48 int ompws_flags; 49 50 /* True if OpenMP should privatize what this DECL points to rather 51 than the DECL itself. */ 52 53 bool 54 gfc_omp_privatize_by_reference (const_tree decl) 55 { 56 tree type = TREE_TYPE (decl); 57 58 if (TREE_CODE (type) == REFERENCE_TYPE 59 && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL)) 60 return true; 61 62 if (TREE_CODE (type) == POINTER_TYPE) 63 { 64 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables 65 that have POINTER_TYPE type and aren't scalar pointers, scalar 66 allocatables, Cray pointees or C pointers are supposed to be 67 privatized by reference. */ 68 if (GFC_DECL_GET_SCALAR_POINTER (decl) 69 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 70 || GFC_DECL_CRAY_POINTEE (decl) 71 || GFC_DECL_ASSOCIATE_VAR_P (decl) 72 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) 73 return false; 74 75 if (!DECL_ARTIFICIAL (decl) 76 && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) 77 return true; 78 79 /* Some arrays are expanded as DECL_ARTIFICIAL pointers 80 by the frontend. */ 81 if (DECL_LANG_SPECIFIC (decl) 82 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 83 return true; 84 } 85 86 return false; 87 } 88 89 /* True if OpenMP sharing attribute of DECL is predetermined. */ 90 91 enum omp_clause_default_kind 92 gfc_omp_predetermined_sharing (tree decl) 93 { 94 /* Associate names preserve the association established during ASSOCIATE. 95 As they are implemented either as pointers to the selector or array 96 descriptor and shouldn't really change in the ASSOCIATE region, 97 this decl can be either shared or firstprivate. If it is a pointer, 98 use firstprivate, as it is cheaper that way, otherwise make it shared. */ 99 if (GFC_DECL_ASSOCIATE_VAR_P (decl)) 100 { 101 if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) 102 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; 103 else 104 return OMP_CLAUSE_DEFAULT_SHARED; 105 } 106 107 if (DECL_ARTIFICIAL (decl) 108 && ! GFC_DECL_RESULT (decl) 109 && ! (DECL_LANG_SPECIFIC (decl) 110 && GFC_DECL_SAVED_DESCRIPTOR (decl))) 111 return OMP_CLAUSE_DEFAULT_SHARED; 112 113 /* Cray pointees shouldn't be listed in any clauses and should be 114 gimplified to dereference of the corresponding Cray pointer. 115 Make them all private, so that they are emitted in the debug 116 information. */ 117 if (GFC_DECL_CRAY_POINTEE (decl)) 118 return OMP_CLAUSE_DEFAULT_PRIVATE; 119 120 /* Assumed-size arrays are predetermined shared. */ 121 if (TREE_CODE (decl) == PARM_DECL 122 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) 123 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN 124 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), 125 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) 126 == NULL) 127 return OMP_CLAUSE_DEFAULT_SHARED; 128 129 /* Dummy procedures aren't considered variables by OpenMP, thus are 130 disallowed in OpenMP clauses. They are represented as PARM_DECLs 131 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here 132 to avoid complaining about their uses with default(none). */ 133 if (TREE_CODE (decl) == PARM_DECL 134 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE 135 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) 136 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; 137 138 /* COMMON and EQUIVALENCE decls are shared. They 139 are only referenced through DECL_VALUE_EXPR of the variables 140 contained in them. If those are privatized, they will not be 141 gimplified to the COMMON or EQUIVALENCE decls. */ 142 if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) 143 return OMP_CLAUSE_DEFAULT_SHARED; 144 145 if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) 146 return OMP_CLAUSE_DEFAULT_SHARED; 147 148 /* These are either array or derived parameters, or vtables. 149 In the former cases, the OpenMP standard doesn't consider them to be 150 variables at all (they can't be redefined), but they can nevertheless appear 151 in parallel/task regions and for default(none) purposes treat them as shared. 152 For vtables likely the same handling is desirable. */ 153 if (VAR_P (decl) && TREE_READONLY (decl) 154 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) 155 return OMP_CLAUSE_DEFAULT_SHARED; 156 157 return OMP_CLAUSE_DEFAULT_UNSPECIFIED; 158 } 159 160 /* Return decl that should be used when reporting DEFAULT(NONE) 161 diagnostics. */ 162 163 tree 164 gfc_omp_report_decl (tree decl) 165 { 166 if (DECL_ARTIFICIAL (decl) 167 && DECL_LANG_SPECIFIC (decl) 168 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 169 return GFC_DECL_SAVED_DESCRIPTOR (decl); 170 171 return decl; 172 } 173 174 /* Return true if TYPE has any allocatable components. */ 175 176 static bool 177 gfc_has_alloc_comps (tree type, tree decl) 178 { 179 tree field, ftype; 180 181 if (POINTER_TYPE_P (type)) 182 { 183 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) 184 type = TREE_TYPE (type); 185 else if (GFC_DECL_GET_SCALAR_POINTER (decl)) 186 return false; 187 } 188 189 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) 190 type = gfc_get_element_type (type); 191 192 if (TREE_CODE (type) != RECORD_TYPE) 193 return false; 194 195 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) 196 { 197 ftype = TREE_TYPE (field); 198 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 199 return true; 200 if (GFC_DESCRIPTOR_TYPE_P (ftype) 201 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 202 return true; 203 if (gfc_has_alloc_comps (ftype, field)) 204 return true; 205 } 206 return false; 207 } 208 209 /* Return true if DECL in private clause needs 210 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ 211 bool 212 gfc_omp_private_outer_ref (tree decl) 213 { 214 tree type = TREE_TYPE (decl); 215 216 if (gfc_omp_privatize_by_reference (decl)) 217 type = TREE_TYPE (type); 218 219 if (GFC_DESCRIPTOR_TYPE_P (type) 220 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) 221 return true; 222 223 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) 224 return true; 225 226 if (gfc_has_alloc_comps (type, decl)) 227 return true; 228 229 return false; 230 } 231 232 /* Callback for gfc_omp_unshare_expr. */ 233 234 static tree 235 gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *) 236 { 237 tree t = *tp; 238 enum tree_code code = TREE_CODE (t); 239 240 /* Stop at types, decls, constants like copy_tree_r. */ 241 if (TREE_CODE_CLASS (code) == tcc_type 242 || TREE_CODE_CLASS (code) == tcc_declaration 243 || TREE_CODE_CLASS (code) == tcc_constant 244 || code == BLOCK) 245 *walk_subtrees = 0; 246 else if (handled_component_p (t) 247 || TREE_CODE (t) == MEM_REF) 248 { 249 *tp = unshare_expr (t); 250 *walk_subtrees = 0; 251 } 252 253 return NULL_TREE; 254 } 255 256 /* Unshare in expr anything that the FE which normally doesn't 257 care much about tree sharing (because during gimplification 258 everything is unshared) could cause problems with tree sharing 259 at omp-low.c time. */ 260 261 static tree 262 gfc_omp_unshare_expr (tree expr) 263 { 264 walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL); 265 return expr; 266 } 267 268 enum walk_alloc_comps 269 { 270 WALK_ALLOC_COMPS_DTOR, 271 WALK_ALLOC_COMPS_DEFAULT_CTOR, 272 WALK_ALLOC_COMPS_COPY_CTOR 273 }; 274 275 /* Handle allocatable components in OpenMP clauses. */ 276 277 static tree 278 gfc_walk_alloc_comps (tree decl, tree dest, tree var, 279 enum walk_alloc_comps kind) 280 { 281 stmtblock_t block, tmpblock; 282 tree type = TREE_TYPE (decl), then_b, tem, field; 283 gfc_init_block (&block); 284 285 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) 286 { 287 if (GFC_DESCRIPTOR_TYPE_P (type)) 288 { 289 gfc_init_block (&tmpblock); 290 tem = gfc_full_array_size (&tmpblock, decl, 291 GFC_TYPE_ARRAY_RANK (type)); 292 then_b = gfc_finish_block (&tmpblock); 293 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b)); 294 tem = gfc_omp_unshare_expr (tem); 295 tem = fold_build2_loc (input_location, MINUS_EXPR, 296 gfc_array_index_type, tem, 297 gfc_index_one_node); 298 } 299 else 300 { 301 bool compute_nelts = false; 302 if (!TYPE_DOMAIN (type) 303 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE 304 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node 305 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) 306 compute_nelts = true; 307 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) 308 { 309 tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); 310 if (lookup_attribute ("omp dummy var", a)) 311 compute_nelts = true; 312 } 313 if (compute_nelts) 314 { 315 tem = fold_build2 (EXACT_DIV_EXPR, sizetype, 316 TYPE_SIZE_UNIT (type), 317 TYPE_SIZE_UNIT (TREE_TYPE (type))); 318 tem = size_binop (MINUS_EXPR, tem, size_one_node); 319 } 320 else 321 tem = array_type_nelts (type); 322 tem = fold_convert (gfc_array_index_type, tem); 323 } 324 325 tree nelems = gfc_evaluate_now (tem, &block); 326 tree index = gfc_create_var (gfc_array_index_type, "S"); 327 328 gfc_init_block (&tmpblock); 329 tem = gfc_conv_array_data (decl); 330 tree declvar = build_fold_indirect_ref_loc (input_location, tem); 331 tree declvref = gfc_build_array_ref (declvar, index, NULL); 332 tree destvar, destvref = NULL_TREE; 333 if (dest) 334 { 335 tem = gfc_conv_array_data (dest); 336 destvar = build_fold_indirect_ref_loc (input_location, tem); 337 destvref = gfc_build_array_ref (destvar, index, NULL); 338 } 339 gfc_add_expr_to_block (&tmpblock, 340 gfc_walk_alloc_comps (declvref, destvref, 341 var, kind)); 342 343 gfc_loopinfo loop; 344 gfc_init_loopinfo (&loop); 345 loop.dimen = 1; 346 loop.from[0] = gfc_index_zero_node; 347 loop.loopvar[0] = index; 348 loop.to[0] = nelems; 349 gfc_trans_scalarizing_loops (&loop, &tmpblock); 350 gfc_add_block_to_block (&block, &loop.pre); 351 return gfc_finish_block (&block); 352 } 353 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var)) 354 { 355 decl = build_fold_indirect_ref_loc (input_location, decl); 356 if (dest) 357 dest = build_fold_indirect_ref_loc (input_location, dest); 358 type = TREE_TYPE (decl); 359 } 360 361 gcc_assert (TREE_CODE (type) == RECORD_TYPE); 362 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) 363 { 364 tree ftype = TREE_TYPE (field); 365 tree declf, destf = NULL_TREE; 366 bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); 367 if ((!GFC_DESCRIPTOR_TYPE_P (ftype) 368 || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) 369 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) 370 && !has_alloc_comps) 371 continue; 372 declf = fold_build3_loc (input_location, COMPONENT_REF, ftype, 373 decl, field, NULL_TREE); 374 if (dest) 375 destf = fold_build3_loc (input_location, COMPONENT_REF, ftype, 376 dest, field, NULL_TREE); 377 378 tem = NULL_TREE; 379 switch (kind) 380 { 381 case WALK_ALLOC_COMPS_DTOR: 382 break; 383 case WALK_ALLOC_COMPS_DEFAULT_CTOR: 384 if (GFC_DESCRIPTOR_TYPE_P (ftype) 385 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 386 { 387 gfc_add_modify (&block, unshare_expr (destf), 388 unshare_expr (declf)); 389 tem = gfc_duplicate_allocatable_nocopy 390 (destf, declf, ftype, 391 GFC_TYPE_ARRAY_RANK (ftype)); 392 } 393 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 394 tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0); 395 break; 396 case WALK_ALLOC_COMPS_COPY_CTOR: 397 if (GFC_DESCRIPTOR_TYPE_P (ftype) 398 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 399 tem = gfc_duplicate_allocatable (destf, declf, ftype, 400 GFC_TYPE_ARRAY_RANK (ftype), 401 NULL_TREE); 402 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 403 tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, 404 NULL_TREE); 405 break; 406 } 407 if (tem) 408 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); 409 if (has_alloc_comps) 410 { 411 gfc_init_block (&tmpblock); 412 gfc_add_expr_to_block (&tmpblock, 413 gfc_walk_alloc_comps (declf, destf, 414 field, kind)); 415 then_b = gfc_finish_block (&tmpblock); 416 if (GFC_DESCRIPTOR_TYPE_P (ftype) 417 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 418 tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); 419 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 420 tem = unshare_expr (declf); 421 else 422 tem = NULL_TREE; 423 if (tem) 424 { 425 tem = fold_convert (pvoid_type_node, tem); 426 tem = fold_build2_loc (input_location, NE_EXPR, 427 logical_type_node, tem, 428 null_pointer_node); 429 then_b = build3_loc (input_location, COND_EXPR, void_type_node, 430 tem, then_b, 431 build_empty_stmt (input_location)); 432 } 433 gfc_add_expr_to_block (&block, then_b); 434 } 435 if (kind == WALK_ALLOC_COMPS_DTOR) 436 { 437 if (GFC_DESCRIPTOR_TYPE_P (ftype) 438 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 439 { 440 tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); 441 tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, 442 NULL_TREE, NULL_TREE, true, 443 NULL, 444 GFC_CAF_COARRAY_NOCOARRAY); 445 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); 446 } 447 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) 448 { 449 tem = gfc_call_free (unshare_expr (declf)); 450 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); 451 } 452 } 453 } 454 455 return gfc_finish_block (&block); 456 } 457 458 /* Return code to initialize DECL with its default constructor, or 459 NULL if there's nothing to do. */ 460 461 tree 462 gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) 463 { 464 tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b; 465 stmtblock_t block, cond_block; 466 467 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE 468 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE 469 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR 470 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION); 471 472 if ((! GFC_DESCRIPTOR_TYPE_P (type) 473 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 474 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 475 || !POINTER_TYPE_P (type))) 476 { 477 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 478 { 479 gcc_assert (outer); 480 gfc_start_block (&block); 481 tree tem = gfc_walk_alloc_comps (outer, decl, 482 OMP_CLAUSE_DECL (clause), 483 WALK_ALLOC_COMPS_DEFAULT_CTOR); 484 gfc_add_expr_to_block (&block, tem); 485 return gfc_finish_block (&block); 486 } 487 return NULL_TREE; 488 } 489 490 gcc_assert (outer != NULL_TREE); 491 492 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to 493 "not currently allocated" allocation status if outer 494 array is "not currently allocated", otherwise should be allocated. */ 495 gfc_start_block (&block); 496 497 gfc_init_block (&cond_block); 498 499 if (GFC_DESCRIPTOR_TYPE_P (type)) 500 { 501 gfc_add_modify (&cond_block, decl, outer); 502 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 503 size = gfc_conv_descriptor_ubound_get (decl, rank); 504 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 505 size, 506 gfc_conv_descriptor_lbound_get (decl, rank)); 507 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 508 size, gfc_index_one_node); 509 if (GFC_TYPE_ARRAY_RANK (type) > 1) 510 size = fold_build2_loc (input_location, MULT_EXPR, 511 gfc_array_index_type, size, 512 gfc_conv_descriptor_stride_get (decl, rank)); 513 tree esize = fold_convert (gfc_array_index_type, 514 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 515 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 516 size, esize); 517 size = unshare_expr (size); 518 size = gfc_evaluate_now (fold_convert (size_type_node, size), 519 &cond_block); 520 } 521 else 522 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 523 ptr = gfc_create_var (pvoid_type_node, NULL); 524 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); 525 if (GFC_DESCRIPTOR_TYPE_P (type)) 526 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr); 527 else 528 gfc_add_modify (&cond_block, unshare_expr (decl), 529 fold_convert (TREE_TYPE (decl), ptr)); 530 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 531 { 532 tree tem = gfc_walk_alloc_comps (outer, decl, 533 OMP_CLAUSE_DECL (clause), 534 WALK_ALLOC_COMPS_DEFAULT_CTOR); 535 gfc_add_expr_to_block (&cond_block, tem); 536 } 537 then_b = gfc_finish_block (&cond_block); 538 539 /* Reduction clause requires allocated ALLOCATABLE. */ 540 if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION) 541 { 542 gfc_init_block (&cond_block); 543 if (GFC_DESCRIPTOR_TYPE_P (type)) 544 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), 545 null_pointer_node); 546 else 547 gfc_add_modify (&cond_block, unshare_expr (decl), 548 build_zero_cst (TREE_TYPE (decl))); 549 else_b = gfc_finish_block (&cond_block); 550 551 tree tem = fold_convert (pvoid_type_node, 552 GFC_DESCRIPTOR_TYPE_P (type) 553 ? gfc_conv_descriptor_data_get (outer) : outer); 554 tem = unshare_expr (tem); 555 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 556 tem, null_pointer_node); 557 gfc_add_expr_to_block (&block, 558 build3_loc (input_location, COND_EXPR, 559 void_type_node, cond, then_b, 560 else_b)); 561 /* Avoid -W*uninitialized warnings. */ 562 if (DECL_P (decl)) 563 TREE_NO_WARNING (decl) = 1; 564 } 565 else 566 gfc_add_expr_to_block (&block, then_b); 567 568 return gfc_finish_block (&block); 569 } 570 571 /* Build and return code for a copy constructor from SRC to DEST. */ 572 573 tree 574 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) 575 { 576 tree type = TREE_TYPE (dest), ptr, size, call; 577 tree cond, then_b, else_b; 578 stmtblock_t block, cond_block; 579 580 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE 581 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); 582 583 if ((! GFC_DESCRIPTOR_TYPE_P (type) 584 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 585 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 586 || !POINTER_TYPE_P (type))) 587 { 588 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 589 { 590 gfc_start_block (&block); 591 gfc_add_modify (&block, dest, src); 592 tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), 593 WALK_ALLOC_COMPS_COPY_CTOR); 594 gfc_add_expr_to_block (&block, tem); 595 return gfc_finish_block (&block); 596 } 597 else 598 return build2_v (MODIFY_EXPR, dest, src); 599 } 600 601 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated 602 and copied from SRC. */ 603 gfc_start_block (&block); 604 605 gfc_init_block (&cond_block); 606 607 gfc_add_modify (&cond_block, dest, src); 608 if (GFC_DESCRIPTOR_TYPE_P (type)) 609 { 610 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 611 size = gfc_conv_descriptor_ubound_get (dest, rank); 612 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 613 size, 614 gfc_conv_descriptor_lbound_get (dest, rank)); 615 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 616 size, gfc_index_one_node); 617 if (GFC_TYPE_ARRAY_RANK (type) > 1) 618 size = fold_build2_loc (input_location, MULT_EXPR, 619 gfc_array_index_type, size, 620 gfc_conv_descriptor_stride_get (dest, rank)); 621 tree esize = fold_convert (gfc_array_index_type, 622 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 623 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 624 size, esize); 625 size = unshare_expr (size); 626 size = gfc_evaluate_now (fold_convert (size_type_node, size), 627 &cond_block); 628 } 629 else 630 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 631 ptr = gfc_create_var (pvoid_type_node, NULL); 632 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); 633 if (GFC_DESCRIPTOR_TYPE_P (type)) 634 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr); 635 else 636 gfc_add_modify (&cond_block, unshare_expr (dest), 637 fold_convert (TREE_TYPE (dest), ptr)); 638 639 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) 640 ? gfc_conv_descriptor_data_get (src) : src; 641 srcptr = unshare_expr (srcptr); 642 srcptr = fold_convert (pvoid_type_node, srcptr); 643 call = build_call_expr_loc (input_location, 644 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, 645 srcptr, size); 646 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); 647 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 648 { 649 tree tem = gfc_walk_alloc_comps (src, dest, 650 OMP_CLAUSE_DECL (clause), 651 WALK_ALLOC_COMPS_COPY_CTOR); 652 gfc_add_expr_to_block (&cond_block, tem); 653 } 654 then_b = gfc_finish_block (&cond_block); 655 656 gfc_init_block (&cond_block); 657 if (GFC_DESCRIPTOR_TYPE_P (type)) 658 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), 659 null_pointer_node); 660 else 661 gfc_add_modify (&cond_block, unshare_expr (dest), 662 build_zero_cst (TREE_TYPE (dest))); 663 else_b = gfc_finish_block (&cond_block); 664 665 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 666 unshare_expr (srcptr), null_pointer_node); 667 gfc_add_expr_to_block (&block, 668 build3_loc (input_location, COND_EXPR, 669 void_type_node, cond, then_b, else_b)); 670 /* Avoid -W*uninitialized warnings. */ 671 if (DECL_P (dest)) 672 TREE_NO_WARNING (dest) = 1; 673 674 return gfc_finish_block (&block); 675 } 676 677 /* Similarly, except use an intrinsic or pointer assignment operator 678 instead. */ 679 680 tree 681 gfc_omp_clause_assign_op (tree clause, tree dest, tree src) 682 { 683 tree type = TREE_TYPE (dest), ptr, size, call, nonalloc; 684 tree cond, then_b, else_b; 685 stmtblock_t block, cond_block, cond_block2, inner_block; 686 687 if ((! GFC_DESCRIPTOR_TYPE_P (type) 688 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 689 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 690 || !POINTER_TYPE_P (type))) 691 { 692 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 693 { 694 gfc_start_block (&block); 695 /* First dealloc any allocatable components in DEST. */ 696 tree tem = gfc_walk_alloc_comps (dest, NULL_TREE, 697 OMP_CLAUSE_DECL (clause), 698 WALK_ALLOC_COMPS_DTOR); 699 gfc_add_expr_to_block (&block, tem); 700 /* Then copy over toplevel data. */ 701 gfc_add_modify (&block, dest, src); 702 /* Finally allocate any allocatable components and copy. */ 703 tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), 704 WALK_ALLOC_COMPS_COPY_CTOR); 705 gfc_add_expr_to_block (&block, tem); 706 return gfc_finish_block (&block); 707 } 708 else 709 return build2_v (MODIFY_EXPR, dest, src); 710 } 711 712 gfc_start_block (&block); 713 714 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 715 { 716 then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), 717 WALK_ALLOC_COMPS_DTOR); 718 tree tem = fold_convert (pvoid_type_node, 719 GFC_DESCRIPTOR_TYPE_P (type) 720 ? gfc_conv_descriptor_data_get (dest) : dest); 721 tem = unshare_expr (tem); 722 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 723 tem, null_pointer_node); 724 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, 725 then_b, build_empty_stmt (input_location)); 726 gfc_add_expr_to_block (&block, tem); 727 } 728 729 gfc_init_block (&cond_block); 730 731 if (GFC_DESCRIPTOR_TYPE_P (type)) 732 { 733 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 734 size = gfc_conv_descriptor_ubound_get (src, rank); 735 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 736 size, 737 gfc_conv_descriptor_lbound_get (src, rank)); 738 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 739 size, gfc_index_one_node); 740 if (GFC_TYPE_ARRAY_RANK (type) > 1) 741 size = fold_build2_loc (input_location, MULT_EXPR, 742 gfc_array_index_type, size, 743 gfc_conv_descriptor_stride_get (src, rank)); 744 tree esize = fold_convert (gfc_array_index_type, 745 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 746 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 747 size, esize); 748 size = unshare_expr (size); 749 size = gfc_evaluate_now (fold_convert (size_type_node, size), 750 &cond_block); 751 } 752 else 753 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 754 ptr = gfc_create_var (pvoid_type_node, NULL); 755 756 tree destptr = GFC_DESCRIPTOR_TYPE_P (type) 757 ? gfc_conv_descriptor_data_get (dest) : dest; 758 destptr = unshare_expr (destptr); 759 destptr = fold_convert (pvoid_type_node, destptr); 760 gfc_add_modify (&cond_block, ptr, destptr); 761 762 nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 763 destptr, null_pointer_node); 764 cond = nonalloc; 765 if (GFC_DESCRIPTOR_TYPE_P (type)) 766 { 767 int i; 768 for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++) 769 { 770 tree rank = gfc_rank_cst[i]; 771 tree tem = gfc_conv_descriptor_ubound_get (src, rank); 772 tem = fold_build2_loc (input_location, MINUS_EXPR, 773 gfc_array_index_type, tem, 774 gfc_conv_descriptor_lbound_get (src, rank)); 775 tem = fold_build2_loc (input_location, PLUS_EXPR, 776 gfc_array_index_type, tem, 777 gfc_conv_descriptor_lbound_get (dest, rank)); 778 tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 779 tem, gfc_conv_descriptor_ubound_get (dest, 780 rank)); 781 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, 782 logical_type_node, cond, tem); 783 } 784 } 785 786 gfc_init_block (&cond_block2); 787 788 if (GFC_DESCRIPTOR_TYPE_P (type)) 789 { 790 gfc_init_block (&inner_block); 791 gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE); 792 then_b = gfc_finish_block (&inner_block); 793 794 gfc_init_block (&inner_block); 795 gfc_add_modify (&inner_block, ptr, 796 gfc_call_realloc (&inner_block, ptr, size)); 797 else_b = gfc_finish_block (&inner_block); 798 799 gfc_add_expr_to_block (&cond_block2, 800 build3_loc (input_location, COND_EXPR, 801 void_type_node, 802 unshare_expr (nonalloc), 803 then_b, else_b)); 804 gfc_add_modify (&cond_block2, dest, src); 805 gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr); 806 } 807 else 808 { 809 gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE); 810 gfc_add_modify (&cond_block2, unshare_expr (dest), 811 fold_convert (type, ptr)); 812 } 813 then_b = gfc_finish_block (&cond_block2); 814 else_b = build_empty_stmt (input_location); 815 816 gfc_add_expr_to_block (&cond_block, 817 build3_loc (input_location, COND_EXPR, 818 void_type_node, unshare_expr (cond), 819 then_b, else_b)); 820 821 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) 822 ? gfc_conv_descriptor_data_get (src) : src; 823 srcptr = unshare_expr (srcptr); 824 srcptr = fold_convert (pvoid_type_node, srcptr); 825 call = build_call_expr_loc (input_location, 826 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, 827 srcptr, size); 828 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); 829 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 830 { 831 tree tem = gfc_walk_alloc_comps (src, dest, 832 OMP_CLAUSE_DECL (clause), 833 WALK_ALLOC_COMPS_COPY_CTOR); 834 gfc_add_expr_to_block (&cond_block, tem); 835 } 836 then_b = gfc_finish_block (&cond_block); 837 838 if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN) 839 { 840 gfc_init_block (&cond_block); 841 if (GFC_DESCRIPTOR_TYPE_P (type)) 842 { 843 tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest)); 844 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, 845 NULL_TREE, NULL_TREE, true, NULL, 846 GFC_CAF_COARRAY_NOCOARRAY); 847 gfc_add_expr_to_block (&cond_block, tmp); 848 } 849 else 850 { 851 destptr = gfc_evaluate_now (destptr, &cond_block); 852 gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr)); 853 gfc_add_modify (&cond_block, unshare_expr (dest), 854 build_zero_cst (TREE_TYPE (dest))); 855 } 856 else_b = gfc_finish_block (&cond_block); 857 858 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 859 unshare_expr (srcptr), null_pointer_node); 860 gfc_add_expr_to_block (&block, 861 build3_loc (input_location, COND_EXPR, 862 void_type_node, cond, 863 then_b, else_b)); 864 } 865 else 866 gfc_add_expr_to_block (&block, then_b); 867 868 return gfc_finish_block (&block); 869 } 870 871 static void 872 gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src, 873 tree add, tree nelems) 874 { 875 stmtblock_t tmpblock; 876 tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S"); 877 nelems = gfc_evaluate_now (nelems, block); 878 879 gfc_init_block (&tmpblock); 880 if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE) 881 { 882 desta = gfc_build_array_ref (dest, index, NULL); 883 srca = gfc_build_array_ref (src, index, NULL); 884 } 885 else 886 { 887 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest))); 888 tree idx = fold_build2 (MULT_EXPR, sizetype, 889 fold_convert (sizetype, index), 890 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest)))); 891 desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, 892 TREE_TYPE (dest), dest, 893 idx)); 894 srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, 895 TREE_TYPE (src), src, 896 idx)); 897 } 898 gfc_add_modify (&tmpblock, desta, 899 fold_build2 (PLUS_EXPR, TREE_TYPE (desta), 900 srca, add)); 901 902 gfc_loopinfo loop; 903 gfc_init_loopinfo (&loop); 904 loop.dimen = 1; 905 loop.from[0] = gfc_index_zero_node; 906 loop.loopvar[0] = index; 907 loop.to[0] = nelems; 908 gfc_trans_scalarizing_loops (&loop, &tmpblock); 909 gfc_add_block_to_block (block, &loop.pre); 910 } 911 912 /* Build and return code for a constructor of DEST that initializes 913 it to SRC plus ADD (ADD is scalar integer). */ 914 915 tree 916 gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add) 917 { 918 tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE; 919 stmtblock_t block; 920 921 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); 922 923 gfc_start_block (&block); 924 add = gfc_evaluate_now (add, &block); 925 926 if ((! GFC_DESCRIPTOR_TYPE_P (type) 927 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 928 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 929 || !POINTER_TYPE_P (type))) 930 { 931 bool compute_nelts = false; 932 gcc_assert (TREE_CODE (type) == ARRAY_TYPE); 933 if (!TYPE_DOMAIN (type) 934 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE 935 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node 936 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) 937 compute_nelts = true; 938 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) 939 { 940 tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); 941 if (lookup_attribute ("omp dummy var", a)) 942 compute_nelts = true; 943 } 944 if (compute_nelts) 945 { 946 nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, 947 TYPE_SIZE_UNIT (type), 948 TYPE_SIZE_UNIT (TREE_TYPE (type))); 949 nelems = size_binop (MINUS_EXPR, nelems, size_one_node); 950 } 951 else 952 nelems = array_type_nelts (type); 953 nelems = fold_convert (gfc_array_index_type, nelems); 954 955 gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems); 956 return gfc_finish_block (&block); 957 } 958 959 /* Allocatable arrays in LINEAR clauses need to be allocated 960 and copied from SRC. */ 961 gfc_add_modify (&block, dest, src); 962 if (GFC_DESCRIPTOR_TYPE_P (type)) 963 { 964 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; 965 size = gfc_conv_descriptor_ubound_get (dest, rank); 966 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 967 size, 968 gfc_conv_descriptor_lbound_get (dest, rank)); 969 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 970 size, gfc_index_one_node); 971 if (GFC_TYPE_ARRAY_RANK (type) > 1) 972 size = fold_build2_loc (input_location, MULT_EXPR, 973 gfc_array_index_type, size, 974 gfc_conv_descriptor_stride_get (dest, rank)); 975 tree esize = fold_convert (gfc_array_index_type, 976 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 977 nelems = gfc_evaluate_now (unshare_expr (size), &block); 978 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 979 nelems, unshare_expr (esize)); 980 size = gfc_evaluate_now (fold_convert (size_type_node, size), 981 &block); 982 nelems = fold_build2_loc (input_location, MINUS_EXPR, 983 gfc_array_index_type, nelems, 984 gfc_index_one_node); 985 } 986 else 987 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 988 ptr = gfc_create_var (pvoid_type_node, NULL); 989 gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); 990 if (GFC_DESCRIPTOR_TYPE_P (type)) 991 { 992 gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr); 993 tree etype = gfc_get_element_type (type); 994 ptr = fold_convert (build_pointer_type (etype), ptr); 995 tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src)); 996 srcptr = fold_convert (build_pointer_type (etype), srcptr); 997 gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems); 998 } 999 else 1000 { 1001 gfc_add_modify (&block, unshare_expr (dest), 1002 fold_convert (TREE_TYPE (dest), ptr)); 1003 ptr = fold_convert (TREE_TYPE (dest), ptr); 1004 tree dstm = build_fold_indirect_ref (ptr); 1005 tree srcm = build_fold_indirect_ref (unshare_expr (src)); 1006 gfc_add_modify (&block, dstm, 1007 fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add)); 1008 } 1009 return gfc_finish_block (&block); 1010 } 1011 1012 /* Build and return code destructing DECL. Return NULL if nothing 1013 to be done. */ 1014 1015 tree 1016 gfc_omp_clause_dtor (tree clause, tree decl) 1017 { 1018 tree type = TREE_TYPE (decl), tem; 1019 1020 if ((! GFC_DESCRIPTOR_TYPE_P (type) 1021 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) 1022 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) 1023 || !POINTER_TYPE_P (type))) 1024 { 1025 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1026 return gfc_walk_alloc_comps (decl, NULL_TREE, 1027 OMP_CLAUSE_DECL (clause), 1028 WALK_ALLOC_COMPS_DTOR); 1029 return NULL_TREE; 1030 } 1031 1032 if (GFC_DESCRIPTOR_TYPE_P (type)) 1033 { 1034 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need 1035 to be deallocated if they were allocated. */ 1036 tem = gfc_conv_descriptor_data_get (decl); 1037 tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE, 1038 NULL_TREE, true, NULL, 1039 GFC_CAF_COARRAY_NOCOARRAY); 1040 } 1041 else 1042 tem = gfc_call_free (decl); 1043 tem = gfc_omp_unshare_expr (tem); 1044 1045 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) 1046 { 1047 stmtblock_t block; 1048 tree then_b; 1049 1050 gfc_init_block (&block); 1051 gfc_add_expr_to_block (&block, 1052 gfc_walk_alloc_comps (decl, NULL_TREE, 1053 OMP_CLAUSE_DECL (clause), 1054 WALK_ALLOC_COMPS_DTOR)); 1055 gfc_add_expr_to_block (&block, tem); 1056 then_b = gfc_finish_block (&block); 1057 1058 tem = fold_convert (pvoid_type_node, 1059 GFC_DESCRIPTOR_TYPE_P (type) 1060 ? gfc_conv_descriptor_data_get (decl) : decl); 1061 tem = unshare_expr (tem); 1062 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1063 tem, null_pointer_node); 1064 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, 1065 then_b, build_empty_stmt (input_location)); 1066 } 1067 return tem; 1068 } 1069 1070 1071 void 1072 gfc_omp_finish_clause (tree c, gimple_seq *pre_p) 1073 { 1074 if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP) 1075 return; 1076 1077 tree decl = OMP_CLAUSE_DECL (c); 1078 1079 /* Assumed-size arrays can't be mapped implicitly, they have to be 1080 mapped explicitly using array sections. */ 1081 if (TREE_CODE (decl) == PARM_DECL 1082 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) 1083 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN 1084 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), 1085 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) 1086 == NULL) 1087 { 1088 error_at (OMP_CLAUSE_LOCATION (c), 1089 "implicit mapping of assumed size array %qD", decl); 1090 return; 1091 } 1092 1093 tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; 1094 if (POINTER_TYPE_P (TREE_TYPE (decl))) 1095 { 1096 if (!gfc_omp_privatize_by_reference (decl) 1097 && !GFC_DECL_GET_SCALAR_POINTER (decl) 1098 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 1099 && !GFC_DECL_CRAY_POINTEE (decl) 1100 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) 1101 return; 1102 tree orig_decl = decl; 1103 c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); 1104 OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); 1105 OMP_CLAUSE_DECL (c4) = decl; 1106 OMP_CLAUSE_SIZE (c4) = size_int (0); 1107 decl = build_fold_indirect_ref (decl); 1108 OMP_CLAUSE_DECL (c) = decl; 1109 OMP_CLAUSE_SIZE (c) = NULL_TREE; 1110 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE 1111 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) 1112 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) 1113 { 1114 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); 1115 OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); 1116 OMP_CLAUSE_DECL (c3) = unshare_expr (decl); 1117 OMP_CLAUSE_SIZE (c3) = size_int (0); 1118 decl = build_fold_indirect_ref (decl); 1119 OMP_CLAUSE_DECL (c) = decl; 1120 } 1121 } 1122 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 1123 { 1124 stmtblock_t block; 1125 gfc_start_block (&block); 1126 tree type = TREE_TYPE (decl); 1127 tree ptr = gfc_conv_descriptor_data_get (decl); 1128 ptr = fold_convert (build_pointer_type (char_type_node), ptr); 1129 ptr = build_fold_indirect_ref (ptr); 1130 OMP_CLAUSE_DECL (c) = ptr; 1131 c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); 1132 OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); 1133 OMP_CLAUSE_DECL (c2) = decl; 1134 OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); 1135 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); 1136 OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); 1137 OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); 1138 OMP_CLAUSE_SIZE (c3) = size_int (0); 1139 tree size = create_tmp_var (gfc_array_index_type); 1140 tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 1141 elemsz = fold_convert (gfc_array_index_type, elemsz); 1142 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER 1143 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) 1144 { 1145 stmtblock_t cond_block; 1146 tree tem, then_b, else_b, zero, cond; 1147 1148 gfc_init_block (&cond_block); 1149 tem = gfc_full_array_size (&cond_block, decl, 1150 GFC_TYPE_ARRAY_RANK (type)); 1151 gfc_add_modify (&cond_block, size, tem); 1152 gfc_add_modify (&cond_block, size, 1153 fold_build2 (MULT_EXPR, gfc_array_index_type, 1154 size, elemsz)); 1155 then_b = gfc_finish_block (&cond_block); 1156 gfc_init_block (&cond_block); 1157 zero = build_int_cst (gfc_array_index_type, 0); 1158 gfc_add_modify (&cond_block, size, zero); 1159 else_b = gfc_finish_block (&cond_block); 1160 tem = gfc_conv_descriptor_data_get (decl); 1161 tem = fold_convert (pvoid_type_node, tem); 1162 cond = fold_build2_loc (input_location, NE_EXPR, 1163 logical_type_node, tem, null_pointer_node); 1164 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, 1165 void_type_node, cond, 1166 then_b, else_b)); 1167 } 1168 else 1169 { 1170 gfc_add_modify (&block, size, 1171 gfc_full_array_size (&block, decl, 1172 GFC_TYPE_ARRAY_RANK (type))); 1173 gfc_add_modify (&block, size, 1174 fold_build2 (MULT_EXPR, gfc_array_index_type, 1175 size, elemsz)); 1176 } 1177 OMP_CLAUSE_SIZE (c) = size; 1178 tree stmt = gfc_finish_block (&block); 1179 gimplify_and_add (stmt, pre_p); 1180 } 1181 tree last = c; 1182 if (OMP_CLAUSE_SIZE (c) == NULL_TREE) 1183 OMP_CLAUSE_SIZE (c) 1184 = DECL_P (decl) ? DECL_SIZE_UNIT (decl) 1185 : TYPE_SIZE_UNIT (TREE_TYPE (decl)); 1186 if (c2) 1187 { 1188 OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); 1189 OMP_CLAUSE_CHAIN (last) = c2; 1190 last = c2; 1191 } 1192 if (c3) 1193 { 1194 OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last); 1195 OMP_CLAUSE_CHAIN (last) = c3; 1196 last = c3; 1197 } 1198 if (c4) 1199 { 1200 OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); 1201 OMP_CLAUSE_CHAIN (last) = c4; 1202 last = c4; 1203 } 1204 } 1205 1206 1207 /* Return true if DECL is a scalar variable (for the purpose of 1208 implicit firstprivatization). */ 1209 1210 bool 1211 gfc_omp_scalar_p (tree decl) 1212 { 1213 tree type = TREE_TYPE (decl); 1214 if (TREE_CODE (type) == REFERENCE_TYPE) 1215 type = TREE_TYPE (type); 1216 if (TREE_CODE (type) == POINTER_TYPE) 1217 { 1218 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 1219 || GFC_DECL_GET_SCALAR_POINTER (decl)) 1220 type = TREE_TYPE (type); 1221 if (GFC_ARRAY_TYPE_P (type) 1222 || GFC_CLASS_TYPE_P (type)) 1223 return false; 1224 } 1225 if (TYPE_STRING_FLAG (type)) 1226 return false; 1227 if (INTEGRAL_TYPE_P (type) 1228 || SCALAR_FLOAT_TYPE_P (type) 1229 || COMPLEX_FLOAT_TYPE_P (type)) 1230 return true; 1231 return false; 1232 } 1233 1234 1235 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be 1236 disregarded in OpenMP construct, because it is going to be 1237 remapped during OpenMP lowering. SHARED is true if DECL 1238 is going to be shared, false if it is going to be privatized. */ 1239 1240 bool 1241 gfc_omp_disregard_value_expr (tree decl, bool shared) 1242 { 1243 if (GFC_DECL_COMMON_OR_EQUIV (decl) 1244 && DECL_HAS_VALUE_EXPR_P (decl)) 1245 { 1246 tree value = DECL_VALUE_EXPR (decl); 1247 1248 if (TREE_CODE (value) == COMPONENT_REF 1249 && VAR_P (TREE_OPERAND (value, 0)) 1250 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) 1251 { 1252 /* If variable in COMMON or EQUIVALENCE is privatized, return 1253 true, as just that variable is supposed to be privatized, 1254 not the whole COMMON or whole EQUIVALENCE. 1255 For shared variables in COMMON or EQUIVALENCE, let them be 1256 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars 1257 from the same COMMON or EQUIVALENCE just one sharing of the 1258 whole COMMON or EQUIVALENCE is enough. */ 1259 return ! shared; 1260 } 1261 } 1262 1263 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl)) 1264 return ! shared; 1265 1266 return false; 1267 } 1268 1269 /* Return true if DECL that is shared iff SHARED is true should 1270 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG 1271 flag set. */ 1272 1273 bool 1274 gfc_omp_private_debug_clause (tree decl, bool shared) 1275 { 1276 if (GFC_DECL_CRAY_POINTEE (decl)) 1277 return true; 1278 1279 if (GFC_DECL_COMMON_OR_EQUIV (decl) 1280 && DECL_HAS_VALUE_EXPR_P (decl)) 1281 { 1282 tree value = DECL_VALUE_EXPR (decl); 1283 1284 if (TREE_CODE (value) == COMPONENT_REF 1285 && VAR_P (TREE_OPERAND (value, 0)) 1286 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) 1287 return shared; 1288 } 1289 1290 return false; 1291 } 1292 1293 /* Register language specific type size variables as potentially OpenMP 1294 firstprivate variables. */ 1295 1296 void 1297 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type) 1298 { 1299 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) 1300 { 1301 int r; 1302 1303 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL); 1304 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++) 1305 { 1306 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r)); 1307 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r)); 1308 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r)); 1309 } 1310 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type)); 1311 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type)); 1312 } 1313 } 1314 1315 1316 static inline tree 1317 gfc_trans_add_clause (tree node, tree tail) 1318 { 1319 OMP_CLAUSE_CHAIN (node) = tail; 1320 return node; 1321 } 1322 1323 static tree 1324 gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd) 1325 { 1326 if (declare_simd) 1327 { 1328 int cnt = 0; 1329 gfc_symbol *proc_sym; 1330 gfc_formal_arglist *f; 1331 1332 gcc_assert (sym->attr.dummy); 1333 proc_sym = sym->ns->proc_name; 1334 if (proc_sym->attr.entry_master) 1335 ++cnt; 1336 if (gfc_return_by_reference (proc_sym)) 1337 { 1338 ++cnt; 1339 if (proc_sym->ts.type == BT_CHARACTER) 1340 ++cnt; 1341 } 1342 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) 1343 if (f->sym == sym) 1344 break; 1345 else if (f->sym) 1346 ++cnt; 1347 gcc_assert (f); 1348 return build_int_cst (integer_type_node, cnt); 1349 } 1350 1351 tree t = gfc_get_symbol_decl (sym); 1352 tree parent_decl; 1353 int parent_flag; 1354 bool return_value; 1355 bool alternate_entry; 1356 bool entry_master; 1357 1358 return_value = sym->attr.function && sym->result == sym; 1359 alternate_entry = sym->attr.function && sym->attr.entry 1360 && sym->result == sym; 1361 entry_master = sym->attr.result 1362 && sym->ns->proc_name->attr.entry_master 1363 && !gfc_return_by_reference (sym->ns->proc_name); 1364 parent_decl = current_function_decl 1365 ? DECL_CONTEXT (current_function_decl) : NULL_TREE; 1366 1367 if ((t == parent_decl && return_value) 1368 || (sym->ns && sym->ns->proc_name 1369 && sym->ns->proc_name->backend_decl == parent_decl 1370 && (alternate_entry || entry_master))) 1371 parent_flag = 1; 1372 else 1373 parent_flag = 0; 1374 1375 /* Special case for assigning the return value of a function. 1376 Self recursive functions must have an explicit return value. */ 1377 if (return_value && (t == current_function_decl || parent_flag)) 1378 t = gfc_get_fake_result_decl (sym, parent_flag); 1379 1380 /* Similarly for alternate entry points. */ 1381 else if (alternate_entry 1382 && (sym->ns->proc_name->backend_decl == current_function_decl 1383 || parent_flag)) 1384 { 1385 gfc_entry_list *el = NULL; 1386 1387 for (el = sym->ns->entries; el; el = el->next) 1388 if (sym == el->sym) 1389 { 1390 t = gfc_get_fake_result_decl (sym, parent_flag); 1391 break; 1392 } 1393 } 1394 1395 else if (entry_master 1396 && (sym->ns->proc_name->backend_decl == current_function_decl 1397 || parent_flag)) 1398 t = gfc_get_fake_result_decl (sym, parent_flag); 1399 1400 return t; 1401 } 1402 1403 static tree 1404 gfc_trans_omp_variable_list (enum omp_clause_code code, 1405 gfc_omp_namelist *namelist, tree list, 1406 bool declare_simd) 1407 { 1408 for (; namelist != NULL; namelist = namelist->next) 1409 if (namelist->sym->attr.referenced || declare_simd) 1410 { 1411 tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); 1412 if (t != error_mark_node) 1413 { 1414 tree node = build_omp_clause (input_location, code); 1415 OMP_CLAUSE_DECL (node) = t; 1416 list = gfc_trans_add_clause (node, list); 1417 } 1418 } 1419 return list; 1420 } 1421 1422 struct omp_udr_find_orig_data 1423 { 1424 gfc_omp_udr *omp_udr; 1425 bool omp_orig_seen; 1426 }; 1427 1428 static int 1429 omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 1430 void *data) 1431 { 1432 struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data; 1433 if ((*e)->expr_type == EXPR_VARIABLE 1434 && (*e)->symtree->n.sym == cd->omp_udr->omp_orig) 1435 cd->omp_orig_seen = true; 1436 1437 return 0; 1438 } 1439 1440 static void 1441 gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) 1442 { 1443 gfc_symbol *sym = n->sym; 1444 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; 1445 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; 1446 gfc_symbol init_val_sym, outer_sym, intrinsic_sym; 1447 gfc_symbol omp_var_copy[4]; 1448 gfc_expr *e1, *e2, *e3, *e4; 1449 gfc_ref *ref; 1450 tree decl, backend_decl, stmt, type, outer_decl; 1451 locus old_loc = gfc_current_locus; 1452 const char *iname; 1453 bool t; 1454 gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL; 1455 1456 decl = OMP_CLAUSE_DECL (c); 1457 gfc_current_locus = where; 1458 type = TREE_TYPE (decl); 1459 outer_decl = create_tmp_var_raw (type); 1460 if (TREE_CODE (decl) == PARM_DECL 1461 && TREE_CODE (type) == REFERENCE_TYPE 1462 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) 1463 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE) 1464 { 1465 decl = build_fold_indirect_ref (decl); 1466 type = TREE_TYPE (type); 1467 } 1468 1469 /* Create a fake symbol for init value. */ 1470 memset (&init_val_sym, 0, sizeof (init_val_sym)); 1471 init_val_sym.ns = sym->ns; 1472 init_val_sym.name = sym->name; 1473 init_val_sym.ts = sym->ts; 1474 init_val_sym.attr.referenced = 1; 1475 init_val_sym.declared_at = where; 1476 init_val_sym.attr.flavor = FL_VARIABLE; 1477 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) 1478 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); 1479 else if (udr->initializer_ns) 1480 backend_decl = NULL; 1481 else 1482 switch (sym->ts.type) 1483 { 1484 case BT_LOGICAL: 1485 case BT_INTEGER: 1486 case BT_REAL: 1487 case BT_COMPLEX: 1488 backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym)); 1489 break; 1490 default: 1491 backend_decl = NULL_TREE; 1492 break; 1493 } 1494 init_val_sym.backend_decl = backend_decl; 1495 1496 /* Create a fake symbol for the outer array reference. */ 1497 outer_sym = *sym; 1498 if (sym->as) 1499 outer_sym.as = gfc_copy_array_spec (sym->as); 1500 outer_sym.attr.dummy = 0; 1501 outer_sym.attr.result = 0; 1502 outer_sym.attr.flavor = FL_VARIABLE; 1503 outer_sym.backend_decl = outer_decl; 1504 if (decl != OMP_CLAUSE_DECL (c)) 1505 outer_sym.backend_decl = build_fold_indirect_ref (outer_decl); 1506 1507 /* Create fake symtrees for it. */ 1508 symtree1 = gfc_new_symtree (&root1, sym->name); 1509 symtree1->n.sym = sym; 1510 gcc_assert (symtree1 == root1); 1511 1512 symtree2 = gfc_new_symtree (&root2, sym->name); 1513 symtree2->n.sym = &init_val_sym; 1514 gcc_assert (symtree2 == root2); 1515 1516 symtree3 = gfc_new_symtree (&root3, sym->name); 1517 symtree3->n.sym = &outer_sym; 1518 gcc_assert (symtree3 == root3); 1519 1520 memset (omp_var_copy, 0, sizeof omp_var_copy); 1521 if (udr) 1522 { 1523 omp_var_copy[0] = *udr->omp_out; 1524 omp_var_copy[1] = *udr->omp_in; 1525 *udr->omp_out = outer_sym; 1526 *udr->omp_in = *sym; 1527 if (udr->initializer_ns) 1528 { 1529 omp_var_copy[2] = *udr->omp_priv; 1530 omp_var_copy[3] = *udr->omp_orig; 1531 *udr->omp_priv = *sym; 1532 *udr->omp_orig = outer_sym; 1533 } 1534 } 1535 1536 /* Create expressions. */ 1537 e1 = gfc_get_expr (); 1538 e1->expr_type = EXPR_VARIABLE; 1539 e1->where = where; 1540 e1->symtree = symtree1; 1541 e1->ts = sym->ts; 1542 if (sym->attr.dimension) 1543 { 1544 e1->ref = ref = gfc_get_ref (); 1545 ref->type = REF_ARRAY; 1546 ref->u.ar.where = where; 1547 ref->u.ar.as = sym->as; 1548 ref->u.ar.type = AR_FULL; 1549 ref->u.ar.dimen = 0; 1550 } 1551 t = gfc_resolve_expr (e1); 1552 gcc_assert (t); 1553 1554 e2 = NULL; 1555 if (backend_decl != NULL_TREE) 1556 { 1557 e2 = gfc_get_expr (); 1558 e2->expr_type = EXPR_VARIABLE; 1559 e2->where = where; 1560 e2->symtree = symtree2; 1561 e2->ts = sym->ts; 1562 t = gfc_resolve_expr (e2); 1563 gcc_assert (t); 1564 } 1565 else if (udr->initializer_ns == NULL) 1566 { 1567 gcc_assert (sym->ts.type == BT_DERIVED); 1568 e2 = gfc_default_initializer (&sym->ts); 1569 gcc_assert (e2); 1570 t = gfc_resolve_expr (e2); 1571 gcc_assert (t); 1572 } 1573 else if (n->udr->initializer->op == EXEC_ASSIGN) 1574 { 1575 e2 = gfc_copy_expr (n->udr->initializer->expr2); 1576 t = gfc_resolve_expr (e2); 1577 gcc_assert (t); 1578 } 1579 if (udr && udr->initializer_ns) 1580 { 1581 struct omp_udr_find_orig_data cd; 1582 cd.omp_udr = udr; 1583 cd.omp_orig_seen = false; 1584 gfc_code_walker (&n->udr->initializer, 1585 gfc_dummy_code_callback, omp_udr_find_orig, &cd); 1586 if (cd.omp_orig_seen) 1587 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; 1588 } 1589 1590 e3 = gfc_copy_expr (e1); 1591 e3->symtree = symtree3; 1592 t = gfc_resolve_expr (e3); 1593 gcc_assert (t); 1594 1595 iname = NULL; 1596 e4 = NULL; 1597 switch (OMP_CLAUSE_REDUCTION_CODE (c)) 1598 { 1599 case PLUS_EXPR: 1600 case MINUS_EXPR: 1601 e4 = gfc_add (e3, e1); 1602 break; 1603 case MULT_EXPR: 1604 e4 = gfc_multiply (e3, e1); 1605 break; 1606 case TRUTH_ANDIF_EXPR: 1607 e4 = gfc_and (e3, e1); 1608 break; 1609 case TRUTH_ORIF_EXPR: 1610 e4 = gfc_or (e3, e1); 1611 break; 1612 case EQ_EXPR: 1613 e4 = gfc_eqv (e3, e1); 1614 break; 1615 case NE_EXPR: 1616 e4 = gfc_neqv (e3, e1); 1617 break; 1618 case MIN_EXPR: 1619 iname = "min"; 1620 break; 1621 case MAX_EXPR: 1622 iname = "max"; 1623 break; 1624 case BIT_AND_EXPR: 1625 iname = "iand"; 1626 break; 1627 case BIT_IOR_EXPR: 1628 iname = "ior"; 1629 break; 1630 case BIT_XOR_EXPR: 1631 iname = "ieor"; 1632 break; 1633 case ERROR_MARK: 1634 if (n->udr->combiner->op == EXEC_ASSIGN) 1635 { 1636 gfc_free_expr (e3); 1637 e3 = gfc_copy_expr (n->udr->combiner->expr1); 1638 e4 = gfc_copy_expr (n->udr->combiner->expr2); 1639 t = gfc_resolve_expr (e3); 1640 gcc_assert (t); 1641 t = gfc_resolve_expr (e4); 1642 gcc_assert (t); 1643 } 1644 break; 1645 default: 1646 gcc_unreachable (); 1647 } 1648 if (iname != NULL) 1649 { 1650 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); 1651 intrinsic_sym.ns = sym->ns; 1652 intrinsic_sym.name = iname; 1653 intrinsic_sym.ts = sym->ts; 1654 intrinsic_sym.attr.referenced = 1; 1655 intrinsic_sym.attr.intrinsic = 1; 1656 intrinsic_sym.attr.function = 1; 1657 intrinsic_sym.attr.implicit_type = 1; 1658 intrinsic_sym.result = &intrinsic_sym; 1659 intrinsic_sym.declared_at = where; 1660 1661 symtree4 = gfc_new_symtree (&root4, iname); 1662 symtree4->n.sym = &intrinsic_sym; 1663 gcc_assert (symtree4 == root4); 1664 1665 e4 = gfc_get_expr (); 1666 e4->expr_type = EXPR_FUNCTION; 1667 e4->where = where; 1668 e4->symtree = symtree4; 1669 e4->value.function.actual = gfc_get_actual_arglist (); 1670 e4->value.function.actual->expr = e3; 1671 e4->value.function.actual->next = gfc_get_actual_arglist (); 1672 e4->value.function.actual->next->expr = e1; 1673 } 1674 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) 1675 { 1676 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ 1677 e1 = gfc_copy_expr (e1); 1678 e3 = gfc_copy_expr (e3); 1679 t = gfc_resolve_expr (e4); 1680 gcc_assert (t); 1681 } 1682 1683 /* Create the init statement list. */ 1684 pushlevel (); 1685 if (e2) 1686 stmt = gfc_trans_assignment (e1, e2, false, false); 1687 else 1688 stmt = gfc_trans_call (n->udr->initializer, false, 1689 NULL_TREE, NULL_TREE, false); 1690 if (TREE_CODE (stmt) != BIND_EXPR) 1691 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 1692 else 1693 poplevel (0, 0); 1694 OMP_CLAUSE_REDUCTION_INIT (c) = stmt; 1695 1696 /* Create the merge statement list. */ 1697 pushlevel (); 1698 if (e4) 1699 stmt = gfc_trans_assignment (e3, e4, false, true); 1700 else 1701 stmt = gfc_trans_call (n->udr->combiner, false, 1702 NULL_TREE, NULL_TREE, false); 1703 if (TREE_CODE (stmt) != BIND_EXPR) 1704 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 1705 else 1706 poplevel (0, 0); 1707 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; 1708 1709 /* And stick the placeholder VAR_DECL into the clause as well. */ 1710 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl; 1711 1712 gfc_current_locus = old_loc; 1713 1714 gfc_free_expr (e1); 1715 if (e2) 1716 gfc_free_expr (e2); 1717 gfc_free_expr (e3); 1718 if (e4) 1719 gfc_free_expr (e4); 1720 free (symtree1); 1721 free (symtree2); 1722 free (symtree3); 1723 free (symtree4); 1724 if (outer_sym.as) 1725 gfc_free_array_spec (outer_sym.as); 1726 1727 if (udr) 1728 { 1729 *udr->omp_out = omp_var_copy[0]; 1730 *udr->omp_in = omp_var_copy[1]; 1731 if (udr->initializer_ns) 1732 { 1733 *udr->omp_priv = omp_var_copy[2]; 1734 *udr->omp_orig = omp_var_copy[3]; 1735 } 1736 } 1737 } 1738 1739 static tree 1740 gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list, 1741 locus where, bool mark_addressable) 1742 { 1743 for (; namelist != NULL; namelist = namelist->next) 1744 if (namelist->sym->attr.referenced) 1745 { 1746 tree t = gfc_trans_omp_variable (namelist->sym, false); 1747 if (t != error_mark_node) 1748 { 1749 tree node = build_omp_clause (where.lb->location, 1750 OMP_CLAUSE_REDUCTION); 1751 OMP_CLAUSE_DECL (node) = t; 1752 if (mark_addressable) 1753 TREE_ADDRESSABLE (t) = 1; 1754 switch (namelist->u.reduction_op) 1755 { 1756 case OMP_REDUCTION_PLUS: 1757 OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR; 1758 break; 1759 case OMP_REDUCTION_MINUS: 1760 OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR; 1761 break; 1762 case OMP_REDUCTION_TIMES: 1763 OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR; 1764 break; 1765 case OMP_REDUCTION_AND: 1766 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR; 1767 break; 1768 case OMP_REDUCTION_OR: 1769 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR; 1770 break; 1771 case OMP_REDUCTION_EQV: 1772 OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR; 1773 break; 1774 case OMP_REDUCTION_NEQV: 1775 OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR; 1776 break; 1777 case OMP_REDUCTION_MAX: 1778 OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR; 1779 break; 1780 case OMP_REDUCTION_MIN: 1781 OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR; 1782 break; 1783 case OMP_REDUCTION_IAND: 1784 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR; 1785 break; 1786 case OMP_REDUCTION_IOR: 1787 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR; 1788 break; 1789 case OMP_REDUCTION_IEOR: 1790 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR; 1791 break; 1792 case OMP_REDUCTION_USER: 1793 OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK; 1794 break; 1795 default: 1796 gcc_unreachable (); 1797 } 1798 if (namelist->sym->attr.dimension 1799 || namelist->u.reduction_op == OMP_REDUCTION_USER 1800 || namelist->sym->attr.allocatable) 1801 gfc_trans_omp_array_reduction_or_udr (node, namelist, where); 1802 list = gfc_trans_add_clause (node, list); 1803 } 1804 } 1805 return list; 1806 } 1807 1808 static inline tree 1809 gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr) 1810 { 1811 gfc_se se; 1812 tree result; 1813 1814 gfc_init_se (&se, NULL ); 1815 gfc_conv_expr (&se, expr); 1816 gfc_add_block_to_block (block, &se.pre); 1817 result = gfc_evaluate_now (se.expr, block); 1818 gfc_add_block_to_block (block, &se.post); 1819 1820 return result; 1821 } 1822 1823 static vec<tree, va_heap, vl_embed> *doacross_steps; 1824 1825 static tree 1826 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, 1827 locus where, bool declare_simd = false) 1828 { 1829 tree omp_clauses = NULL_TREE, chunk_size, c; 1830 int list, ifc; 1831 enum omp_clause_code clause_code; 1832 gfc_se se; 1833 1834 if (clauses == NULL) 1835 return NULL_TREE; 1836 1837 for (list = 0; list < OMP_LIST_NUM; list++) 1838 { 1839 gfc_omp_namelist *n = clauses->lists[list]; 1840 1841 if (n == NULL) 1842 continue; 1843 switch (list) 1844 { 1845 case OMP_LIST_REDUCTION: 1846 /* An OpenACC async clause indicates the need to set reduction 1847 arguments addressable, to allow asynchronous copy-out. */ 1848 omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where, 1849 clauses->async); 1850 break; 1851 case OMP_LIST_PRIVATE: 1852 clause_code = OMP_CLAUSE_PRIVATE; 1853 goto add_clause; 1854 case OMP_LIST_SHARED: 1855 clause_code = OMP_CLAUSE_SHARED; 1856 goto add_clause; 1857 case OMP_LIST_FIRSTPRIVATE: 1858 clause_code = OMP_CLAUSE_FIRSTPRIVATE; 1859 goto add_clause; 1860 case OMP_LIST_LASTPRIVATE: 1861 clause_code = OMP_CLAUSE_LASTPRIVATE; 1862 goto add_clause; 1863 case OMP_LIST_COPYIN: 1864 clause_code = OMP_CLAUSE_COPYIN; 1865 goto add_clause; 1866 case OMP_LIST_COPYPRIVATE: 1867 clause_code = OMP_CLAUSE_COPYPRIVATE; 1868 goto add_clause; 1869 case OMP_LIST_UNIFORM: 1870 clause_code = OMP_CLAUSE_UNIFORM; 1871 goto add_clause; 1872 case OMP_LIST_USE_DEVICE: 1873 case OMP_LIST_USE_DEVICE_PTR: 1874 clause_code = OMP_CLAUSE_USE_DEVICE_PTR; 1875 goto add_clause; 1876 case OMP_LIST_IS_DEVICE_PTR: 1877 clause_code = OMP_CLAUSE_IS_DEVICE_PTR; 1878 goto add_clause; 1879 1880 add_clause: 1881 omp_clauses 1882 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses, 1883 declare_simd); 1884 break; 1885 case OMP_LIST_ALIGNED: 1886 for (; n != NULL; n = n->next) 1887 if (n->sym->attr.referenced || declare_simd) 1888 { 1889 tree t = gfc_trans_omp_variable (n->sym, declare_simd); 1890 if (t != error_mark_node) 1891 { 1892 tree node = build_omp_clause (input_location, 1893 OMP_CLAUSE_ALIGNED); 1894 OMP_CLAUSE_DECL (node) = t; 1895 if (n->expr) 1896 { 1897 tree alignment_var; 1898 1899 if (declare_simd) 1900 alignment_var = gfc_conv_constant_to_tree (n->expr); 1901 else 1902 { 1903 gfc_init_se (&se, NULL); 1904 gfc_conv_expr (&se, n->expr); 1905 gfc_add_block_to_block (block, &se.pre); 1906 alignment_var = gfc_evaluate_now (se.expr, block); 1907 gfc_add_block_to_block (block, &se.post); 1908 } 1909 OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var; 1910 } 1911 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 1912 } 1913 } 1914 break; 1915 case OMP_LIST_LINEAR: 1916 { 1917 gfc_expr *last_step_expr = NULL; 1918 tree last_step = NULL_TREE; 1919 bool last_step_parm = false; 1920 1921 for (; n != NULL; n = n->next) 1922 { 1923 if (n->expr) 1924 { 1925 last_step_expr = n->expr; 1926 last_step = NULL_TREE; 1927 last_step_parm = false; 1928 } 1929 if (n->sym->attr.referenced || declare_simd) 1930 { 1931 tree t = gfc_trans_omp_variable (n->sym, declare_simd); 1932 if (t != error_mark_node) 1933 { 1934 tree node = build_omp_clause (input_location, 1935 OMP_CLAUSE_LINEAR); 1936 OMP_CLAUSE_DECL (node) = t; 1937 omp_clause_linear_kind kind; 1938 switch (n->u.linear_op) 1939 { 1940 case OMP_LINEAR_DEFAULT: 1941 kind = OMP_CLAUSE_LINEAR_DEFAULT; 1942 break; 1943 case OMP_LINEAR_REF: 1944 kind = OMP_CLAUSE_LINEAR_REF; 1945 break; 1946 case OMP_LINEAR_VAL: 1947 kind = OMP_CLAUSE_LINEAR_VAL; 1948 break; 1949 case OMP_LINEAR_UVAL: 1950 kind = OMP_CLAUSE_LINEAR_UVAL; 1951 break; 1952 default: 1953 gcc_unreachable (); 1954 } 1955 OMP_CLAUSE_LINEAR_KIND (node) = kind; 1956 if (last_step_expr && last_step == NULL_TREE) 1957 { 1958 if (!declare_simd) 1959 { 1960 gfc_init_se (&se, NULL); 1961 gfc_conv_expr (&se, last_step_expr); 1962 gfc_add_block_to_block (block, &se.pre); 1963 last_step = gfc_evaluate_now (se.expr, block); 1964 gfc_add_block_to_block (block, &se.post); 1965 } 1966 else if (last_step_expr->expr_type == EXPR_VARIABLE) 1967 { 1968 gfc_symbol *s = last_step_expr->symtree->n.sym; 1969 last_step = gfc_trans_omp_variable (s, true); 1970 last_step_parm = true; 1971 } 1972 else 1973 last_step 1974 = gfc_conv_constant_to_tree (last_step_expr); 1975 } 1976 if (last_step_parm) 1977 { 1978 OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1; 1979 OMP_CLAUSE_LINEAR_STEP (node) = last_step; 1980 } 1981 else 1982 { 1983 if (kind == OMP_CLAUSE_LINEAR_REF) 1984 { 1985 tree type; 1986 if (n->sym->attr.flavor == FL_PROCEDURE) 1987 { 1988 type = gfc_get_function_type (n->sym); 1989 type = build_pointer_type (type); 1990 } 1991 else 1992 type = gfc_sym_type (n->sym); 1993 if (POINTER_TYPE_P (type)) 1994 type = TREE_TYPE (type); 1995 /* Otherwise to be determined what exactly 1996 should be done. */ 1997 tree t = fold_convert (sizetype, last_step); 1998 t = size_binop (MULT_EXPR, t, 1999 TYPE_SIZE_UNIT (type)); 2000 OMP_CLAUSE_LINEAR_STEP (node) = t; 2001 } 2002 else 2003 { 2004 tree type 2005 = gfc_typenode_for_spec (&n->sym->ts); 2006 OMP_CLAUSE_LINEAR_STEP (node) 2007 = fold_convert (type, last_step); 2008 } 2009 } 2010 if (n->sym->attr.dimension || n->sym->attr.allocatable) 2011 OMP_CLAUSE_LINEAR_ARRAY (node) = 1; 2012 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2013 } 2014 } 2015 } 2016 } 2017 break; 2018 case OMP_LIST_DEPEND: 2019 for (; n != NULL; n = n->next) 2020 { 2021 if (n->u.depend_op == OMP_DEPEND_SINK_FIRST) 2022 { 2023 tree vec = NULL_TREE; 2024 unsigned int i; 2025 for (i = 0; ; i++) 2026 { 2027 tree addend = integer_zero_node, t; 2028 bool neg = false; 2029 if (n->expr) 2030 { 2031 addend = gfc_conv_constant_to_tree (n->expr); 2032 if (TREE_CODE (addend) == INTEGER_CST 2033 && tree_int_cst_sgn (addend) == -1) 2034 { 2035 neg = true; 2036 addend = const_unop (NEGATE_EXPR, 2037 TREE_TYPE (addend), addend); 2038 } 2039 } 2040 t = gfc_trans_omp_variable (n->sym, false); 2041 if (t != error_mark_node) 2042 { 2043 if (i < vec_safe_length (doacross_steps) 2044 && !integer_zerop (addend) 2045 && (*doacross_steps)[i]) 2046 { 2047 tree step = (*doacross_steps)[i]; 2048 addend = fold_convert (TREE_TYPE (step), addend); 2049 addend = build2 (TRUNC_DIV_EXPR, 2050 TREE_TYPE (step), addend, step); 2051 } 2052 vec = tree_cons (addend, t, vec); 2053 if (neg) 2054 OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec) = 1; 2055 } 2056 if (n->next == NULL 2057 || n->next->u.depend_op != OMP_DEPEND_SINK) 2058 break; 2059 n = n->next; 2060 } 2061 if (vec == NULL_TREE) 2062 continue; 2063 2064 tree node = build_omp_clause (input_location, 2065 OMP_CLAUSE_DEPEND); 2066 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_SINK; 2067 OMP_CLAUSE_DECL (node) = nreverse (vec); 2068 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2069 continue; 2070 } 2071 2072 if (!n->sym->attr.referenced) 2073 continue; 2074 2075 tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND); 2076 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) 2077 { 2078 tree decl = gfc_get_symbol_decl (n->sym); 2079 if (gfc_omp_privatize_by_reference (decl)) 2080 decl = build_fold_indirect_ref (decl); 2081 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 2082 { 2083 decl = gfc_conv_descriptor_data_get (decl); 2084 decl = fold_convert (build_pointer_type (char_type_node), 2085 decl); 2086 decl = build_fold_indirect_ref (decl); 2087 } 2088 else if (DECL_P (decl)) 2089 TREE_ADDRESSABLE (decl) = 1; 2090 OMP_CLAUSE_DECL (node) = decl; 2091 } 2092 else 2093 { 2094 tree ptr; 2095 gfc_init_se (&se, NULL); 2096 if (n->expr->ref->u.ar.type == AR_ELEMENT) 2097 { 2098 gfc_conv_expr_reference (&se, n->expr); 2099 ptr = se.expr; 2100 } 2101 else 2102 { 2103 gfc_conv_expr_descriptor (&se, n->expr); 2104 ptr = gfc_conv_array_data (se.expr); 2105 } 2106 gfc_add_block_to_block (block, &se.pre); 2107 gfc_add_block_to_block (block, &se.post); 2108 ptr = fold_convert (build_pointer_type (char_type_node), 2109 ptr); 2110 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); 2111 } 2112 switch (n->u.depend_op) 2113 { 2114 case OMP_DEPEND_IN: 2115 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; 2116 break; 2117 case OMP_DEPEND_OUT: 2118 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; 2119 break; 2120 case OMP_DEPEND_INOUT: 2121 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; 2122 break; 2123 default: 2124 gcc_unreachable (); 2125 } 2126 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2127 } 2128 break; 2129 case OMP_LIST_MAP: 2130 for (; n != NULL; n = n->next) 2131 { 2132 if (!n->sym->attr.referenced) 2133 continue; 2134 2135 tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); 2136 tree node2 = NULL_TREE; 2137 tree node3 = NULL_TREE; 2138 tree node4 = NULL_TREE; 2139 tree decl = gfc_get_symbol_decl (n->sym); 2140 if (DECL_P (decl)) 2141 TREE_ADDRESSABLE (decl) = 1; 2142 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) 2143 { 2144 if (POINTER_TYPE_P (TREE_TYPE (decl)) 2145 && (gfc_omp_privatize_by_reference (decl) 2146 || GFC_DECL_GET_SCALAR_POINTER (decl) 2147 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) 2148 || GFC_DECL_CRAY_POINTEE (decl) 2149 || GFC_DESCRIPTOR_TYPE_P 2150 (TREE_TYPE (TREE_TYPE (decl))))) 2151 { 2152 tree orig_decl = decl; 2153 node4 = build_omp_clause (input_location, 2154 OMP_CLAUSE_MAP); 2155 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); 2156 OMP_CLAUSE_DECL (node4) = decl; 2157 OMP_CLAUSE_SIZE (node4) = size_int (0); 2158 decl = build_fold_indirect_ref (decl); 2159 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE 2160 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) 2161 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) 2162 { 2163 node3 = build_omp_clause (input_location, 2164 OMP_CLAUSE_MAP); 2165 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); 2166 OMP_CLAUSE_DECL (node3) = decl; 2167 OMP_CLAUSE_SIZE (node3) = size_int (0); 2168 decl = build_fold_indirect_ref (decl); 2169 } 2170 } 2171 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 2172 { 2173 tree type = TREE_TYPE (decl); 2174 tree ptr = gfc_conv_descriptor_data_get (decl); 2175 ptr = fold_convert (build_pointer_type (char_type_node), 2176 ptr); 2177 ptr = build_fold_indirect_ref (ptr); 2178 OMP_CLAUSE_DECL (node) = ptr; 2179 node2 = build_omp_clause (input_location, 2180 OMP_CLAUSE_MAP); 2181 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); 2182 OMP_CLAUSE_DECL (node2) = decl; 2183 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); 2184 node3 = build_omp_clause (input_location, 2185 OMP_CLAUSE_MAP); 2186 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); 2187 OMP_CLAUSE_DECL (node3) 2188 = gfc_conv_descriptor_data_get (decl); 2189 OMP_CLAUSE_SIZE (node3) = size_int (0); 2190 2191 /* We have to check for n->sym->attr.dimension because 2192 of scalar coarrays. */ 2193 if (n->sym->attr.pointer && n->sym->attr.dimension) 2194 { 2195 stmtblock_t cond_block; 2196 tree size 2197 = gfc_create_var (gfc_array_index_type, NULL); 2198 tree tem, then_b, else_b, zero, cond; 2199 2200 gfc_init_block (&cond_block); 2201 tem 2202 = gfc_full_array_size (&cond_block, decl, 2203 GFC_TYPE_ARRAY_RANK (type)); 2204 gfc_add_modify (&cond_block, size, tem); 2205 then_b = gfc_finish_block (&cond_block); 2206 gfc_init_block (&cond_block); 2207 zero = build_int_cst (gfc_array_index_type, 0); 2208 gfc_add_modify (&cond_block, size, zero); 2209 else_b = gfc_finish_block (&cond_block); 2210 tem = gfc_conv_descriptor_data_get (decl); 2211 tem = fold_convert (pvoid_type_node, tem); 2212 cond = fold_build2_loc (input_location, NE_EXPR, 2213 logical_type_node, 2214 tem, null_pointer_node); 2215 gfc_add_expr_to_block (block, 2216 build3_loc (input_location, 2217 COND_EXPR, 2218 void_type_node, 2219 cond, then_b, 2220 else_b)); 2221 OMP_CLAUSE_SIZE (node) = size; 2222 } 2223 else if (n->sym->attr.dimension) 2224 OMP_CLAUSE_SIZE (node) 2225 = gfc_full_array_size (block, decl, 2226 GFC_TYPE_ARRAY_RANK (type)); 2227 if (n->sym->attr.dimension) 2228 { 2229 tree elemsz 2230 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 2231 elemsz = fold_convert (gfc_array_index_type, elemsz); 2232 OMP_CLAUSE_SIZE (node) 2233 = fold_build2 (MULT_EXPR, gfc_array_index_type, 2234 OMP_CLAUSE_SIZE (node), elemsz); 2235 } 2236 } 2237 else 2238 OMP_CLAUSE_DECL (node) = decl; 2239 } 2240 else 2241 { 2242 tree ptr, ptr2; 2243 gfc_init_se (&se, NULL); 2244 if (n->expr->ref->u.ar.type == AR_ELEMENT) 2245 { 2246 gfc_conv_expr_reference (&se, n->expr); 2247 gfc_add_block_to_block (block, &se.pre); 2248 ptr = se.expr; 2249 OMP_CLAUSE_SIZE (node) 2250 = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); 2251 } 2252 else 2253 { 2254 gfc_conv_expr_descriptor (&se, n->expr); 2255 ptr = gfc_conv_array_data (se.expr); 2256 tree type = TREE_TYPE (se.expr); 2257 gfc_add_block_to_block (block, &se.pre); 2258 OMP_CLAUSE_SIZE (node) 2259 = gfc_full_array_size (block, se.expr, 2260 GFC_TYPE_ARRAY_RANK (type)); 2261 tree elemsz 2262 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 2263 elemsz = fold_convert (gfc_array_index_type, elemsz); 2264 OMP_CLAUSE_SIZE (node) 2265 = fold_build2 (MULT_EXPR, gfc_array_index_type, 2266 OMP_CLAUSE_SIZE (node), elemsz); 2267 } 2268 gfc_add_block_to_block (block, &se.post); 2269 ptr = fold_convert (build_pointer_type (char_type_node), 2270 ptr); 2271 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); 2272 2273 if (POINTER_TYPE_P (TREE_TYPE (decl)) 2274 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) 2275 { 2276 node4 = build_omp_clause (input_location, 2277 OMP_CLAUSE_MAP); 2278 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); 2279 OMP_CLAUSE_DECL (node4) = decl; 2280 OMP_CLAUSE_SIZE (node4) = size_int (0); 2281 decl = build_fold_indirect_ref (decl); 2282 } 2283 ptr = fold_convert (sizetype, ptr); 2284 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 2285 { 2286 tree type = TREE_TYPE (decl); 2287 ptr2 = gfc_conv_descriptor_data_get (decl); 2288 node2 = build_omp_clause (input_location, 2289 OMP_CLAUSE_MAP); 2290 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); 2291 OMP_CLAUSE_DECL (node2) = decl; 2292 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); 2293 node3 = build_omp_clause (input_location, 2294 OMP_CLAUSE_MAP); 2295 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); 2296 OMP_CLAUSE_DECL (node3) 2297 = gfc_conv_descriptor_data_get (decl); 2298 } 2299 else 2300 { 2301 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) 2302 ptr2 = build_fold_addr_expr (decl); 2303 else 2304 { 2305 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); 2306 ptr2 = decl; 2307 } 2308 node3 = build_omp_clause (input_location, 2309 OMP_CLAUSE_MAP); 2310 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); 2311 OMP_CLAUSE_DECL (node3) = decl; 2312 } 2313 ptr2 = fold_convert (sizetype, ptr2); 2314 OMP_CLAUSE_SIZE (node3) 2315 = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); 2316 } 2317 switch (n->u.map_op) 2318 { 2319 case OMP_MAP_ALLOC: 2320 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); 2321 break; 2322 case OMP_MAP_TO: 2323 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); 2324 break; 2325 case OMP_MAP_FROM: 2326 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM); 2327 break; 2328 case OMP_MAP_TOFROM: 2329 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM); 2330 break; 2331 case OMP_MAP_ALWAYS_TO: 2332 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO); 2333 break; 2334 case OMP_MAP_ALWAYS_FROM: 2335 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM); 2336 break; 2337 case OMP_MAP_ALWAYS_TOFROM: 2338 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); 2339 break; 2340 case OMP_MAP_RELEASE: 2341 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); 2342 break; 2343 case OMP_MAP_DELETE: 2344 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); 2345 break; 2346 case OMP_MAP_FORCE_ALLOC: 2347 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); 2348 break; 2349 case OMP_MAP_FORCE_TO: 2350 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO); 2351 break; 2352 case OMP_MAP_FORCE_FROM: 2353 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM); 2354 break; 2355 case OMP_MAP_FORCE_TOFROM: 2356 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM); 2357 break; 2358 case OMP_MAP_FORCE_PRESENT: 2359 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT); 2360 break; 2361 case OMP_MAP_FORCE_DEVICEPTR: 2362 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR); 2363 break; 2364 default: 2365 gcc_unreachable (); 2366 } 2367 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2368 if (node2) 2369 omp_clauses = gfc_trans_add_clause (node2, omp_clauses); 2370 if (node3) 2371 omp_clauses = gfc_trans_add_clause (node3, omp_clauses); 2372 if (node4) 2373 omp_clauses = gfc_trans_add_clause (node4, omp_clauses); 2374 } 2375 break; 2376 case OMP_LIST_TO: 2377 case OMP_LIST_FROM: 2378 case OMP_LIST_CACHE: 2379 for (; n != NULL; n = n->next) 2380 { 2381 if (!n->sym->attr.referenced) 2382 continue; 2383 2384 switch (list) 2385 { 2386 case OMP_LIST_TO: 2387 clause_code = OMP_CLAUSE_TO; 2388 break; 2389 case OMP_LIST_FROM: 2390 clause_code = OMP_CLAUSE_FROM; 2391 break; 2392 case OMP_LIST_CACHE: 2393 clause_code = OMP_CLAUSE__CACHE_; 2394 break; 2395 default: 2396 gcc_unreachable (); 2397 } 2398 tree node = build_omp_clause (input_location, clause_code); 2399 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) 2400 { 2401 tree decl = gfc_get_symbol_decl (n->sym); 2402 if (gfc_omp_privatize_by_reference (decl)) 2403 decl = build_fold_indirect_ref (decl); 2404 else if (DECL_P (decl)) 2405 TREE_ADDRESSABLE (decl) = 1; 2406 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 2407 { 2408 tree type = TREE_TYPE (decl); 2409 tree ptr = gfc_conv_descriptor_data_get (decl); 2410 ptr = fold_convert (build_pointer_type (char_type_node), 2411 ptr); 2412 ptr = build_fold_indirect_ref (ptr); 2413 OMP_CLAUSE_DECL (node) = ptr; 2414 OMP_CLAUSE_SIZE (node) 2415 = gfc_full_array_size (block, decl, 2416 GFC_TYPE_ARRAY_RANK (type)); 2417 tree elemsz 2418 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 2419 elemsz = fold_convert (gfc_array_index_type, elemsz); 2420 OMP_CLAUSE_SIZE (node) 2421 = fold_build2 (MULT_EXPR, gfc_array_index_type, 2422 OMP_CLAUSE_SIZE (node), elemsz); 2423 } 2424 else 2425 OMP_CLAUSE_DECL (node) = decl; 2426 } 2427 else 2428 { 2429 tree ptr; 2430 gfc_init_se (&se, NULL); 2431 if (n->expr->ref->u.ar.type == AR_ELEMENT) 2432 { 2433 gfc_conv_expr_reference (&se, n->expr); 2434 ptr = se.expr; 2435 gfc_add_block_to_block (block, &se.pre); 2436 OMP_CLAUSE_SIZE (node) 2437 = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); 2438 } 2439 else 2440 { 2441 gfc_conv_expr_descriptor (&se, n->expr); 2442 ptr = gfc_conv_array_data (se.expr); 2443 tree type = TREE_TYPE (se.expr); 2444 gfc_add_block_to_block (block, &se.pre); 2445 OMP_CLAUSE_SIZE (node) 2446 = gfc_full_array_size (block, se.expr, 2447 GFC_TYPE_ARRAY_RANK (type)); 2448 tree elemsz 2449 = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 2450 elemsz = fold_convert (gfc_array_index_type, elemsz); 2451 OMP_CLAUSE_SIZE (node) 2452 = fold_build2 (MULT_EXPR, gfc_array_index_type, 2453 OMP_CLAUSE_SIZE (node), elemsz); 2454 } 2455 gfc_add_block_to_block (block, &se.post); 2456 ptr = fold_convert (build_pointer_type (char_type_node), 2457 ptr); 2458 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); 2459 } 2460 omp_clauses = gfc_trans_add_clause (node, omp_clauses); 2461 } 2462 break; 2463 default: 2464 break; 2465 } 2466 } 2467 2468 if (clauses->if_expr) 2469 { 2470 tree if_var; 2471 2472 gfc_init_se (&se, NULL); 2473 gfc_conv_expr (&se, clauses->if_expr); 2474 gfc_add_block_to_block (block, &se.pre); 2475 if_var = gfc_evaluate_now (se.expr, block); 2476 gfc_add_block_to_block (block, &se.post); 2477 2478 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF); 2479 OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK; 2480 OMP_CLAUSE_IF_EXPR (c) = if_var; 2481 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2482 } 2483 for (ifc = 0; ifc < OMP_IF_LAST; ifc++) 2484 if (clauses->if_exprs[ifc]) 2485 { 2486 tree if_var; 2487 2488 gfc_init_se (&se, NULL); 2489 gfc_conv_expr (&se, clauses->if_exprs[ifc]); 2490 gfc_add_block_to_block (block, &se.pre); 2491 if_var = gfc_evaluate_now (se.expr, block); 2492 gfc_add_block_to_block (block, &se.post); 2493 2494 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF); 2495 switch (ifc) 2496 { 2497 case OMP_IF_PARALLEL: 2498 OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL; 2499 break; 2500 case OMP_IF_TASK: 2501 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK; 2502 break; 2503 case OMP_IF_TASKLOOP: 2504 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP; 2505 break; 2506 case OMP_IF_TARGET: 2507 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET; 2508 break; 2509 case OMP_IF_TARGET_DATA: 2510 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA; 2511 break; 2512 case OMP_IF_TARGET_UPDATE: 2513 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE; 2514 break; 2515 case OMP_IF_TARGET_ENTER_DATA: 2516 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA; 2517 break; 2518 case OMP_IF_TARGET_EXIT_DATA: 2519 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA; 2520 break; 2521 default: 2522 gcc_unreachable (); 2523 } 2524 OMP_CLAUSE_IF_EXPR (c) = if_var; 2525 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2526 } 2527 2528 if (clauses->final_expr) 2529 { 2530 tree final_var; 2531 2532 gfc_init_se (&se, NULL); 2533 gfc_conv_expr (&se, clauses->final_expr); 2534 gfc_add_block_to_block (block, &se.pre); 2535 final_var = gfc_evaluate_now (se.expr, block); 2536 gfc_add_block_to_block (block, &se.post); 2537 2538 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL); 2539 OMP_CLAUSE_FINAL_EXPR (c) = final_var; 2540 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2541 } 2542 2543 if (clauses->num_threads) 2544 { 2545 tree num_threads; 2546 2547 gfc_init_se (&se, NULL); 2548 gfc_conv_expr (&se, clauses->num_threads); 2549 gfc_add_block_to_block (block, &se.pre); 2550 num_threads = gfc_evaluate_now (se.expr, block); 2551 gfc_add_block_to_block (block, &se.post); 2552 2553 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS); 2554 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; 2555 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2556 } 2557 2558 chunk_size = NULL_TREE; 2559 if (clauses->chunk_size) 2560 { 2561 gfc_init_se (&se, NULL); 2562 gfc_conv_expr (&se, clauses->chunk_size); 2563 gfc_add_block_to_block (block, &se.pre); 2564 chunk_size = gfc_evaluate_now (se.expr, block); 2565 gfc_add_block_to_block (block, &se.post); 2566 } 2567 2568 if (clauses->sched_kind != OMP_SCHED_NONE) 2569 { 2570 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE); 2571 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; 2572 switch (clauses->sched_kind) 2573 { 2574 case OMP_SCHED_STATIC: 2575 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; 2576 break; 2577 case OMP_SCHED_DYNAMIC: 2578 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; 2579 break; 2580 case OMP_SCHED_GUIDED: 2581 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; 2582 break; 2583 case OMP_SCHED_RUNTIME: 2584 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; 2585 break; 2586 case OMP_SCHED_AUTO: 2587 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO; 2588 break; 2589 default: 2590 gcc_unreachable (); 2591 } 2592 if (clauses->sched_monotonic) 2593 OMP_CLAUSE_SCHEDULE_KIND (c) 2594 = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) 2595 | OMP_CLAUSE_SCHEDULE_MONOTONIC); 2596 else if (clauses->sched_nonmonotonic) 2597 OMP_CLAUSE_SCHEDULE_KIND (c) 2598 = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) 2599 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC); 2600 if (clauses->sched_simd) 2601 OMP_CLAUSE_SCHEDULE_SIMD (c) = 1; 2602 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2603 } 2604 2605 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) 2606 { 2607 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT); 2608 switch (clauses->default_sharing) 2609 { 2610 case OMP_DEFAULT_NONE: 2611 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; 2612 break; 2613 case OMP_DEFAULT_SHARED: 2614 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; 2615 break; 2616 case OMP_DEFAULT_PRIVATE: 2617 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; 2618 break; 2619 case OMP_DEFAULT_FIRSTPRIVATE: 2620 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; 2621 break; 2622 case OMP_DEFAULT_PRESENT: 2623 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT; 2624 break; 2625 default: 2626 gcc_unreachable (); 2627 } 2628 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2629 } 2630 2631 if (clauses->nowait) 2632 { 2633 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT); 2634 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2635 } 2636 2637 if (clauses->ordered) 2638 { 2639 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED); 2640 OMP_CLAUSE_ORDERED_EXPR (c) 2641 = clauses->orderedc ? build_int_cst (integer_type_node, 2642 clauses->orderedc) : NULL_TREE; 2643 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2644 } 2645 2646 if (clauses->untied) 2647 { 2648 c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED); 2649 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2650 } 2651 2652 if (clauses->mergeable) 2653 { 2654 c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE); 2655 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2656 } 2657 2658 if (clauses->collapse) 2659 { 2660 c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE); 2661 OMP_CLAUSE_COLLAPSE_EXPR (c) 2662 = build_int_cst (integer_type_node, clauses->collapse); 2663 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2664 } 2665 2666 if (clauses->inbranch) 2667 { 2668 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH); 2669 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2670 } 2671 2672 if (clauses->notinbranch) 2673 { 2674 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH); 2675 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2676 } 2677 2678 switch (clauses->cancel) 2679 { 2680 case OMP_CANCEL_UNKNOWN: 2681 break; 2682 case OMP_CANCEL_PARALLEL: 2683 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL); 2684 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2685 break; 2686 case OMP_CANCEL_SECTIONS: 2687 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS); 2688 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2689 break; 2690 case OMP_CANCEL_DO: 2691 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR); 2692 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2693 break; 2694 case OMP_CANCEL_TASKGROUP: 2695 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP); 2696 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2697 break; 2698 } 2699 2700 if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) 2701 { 2702 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND); 2703 switch (clauses->proc_bind) 2704 { 2705 case OMP_PROC_BIND_MASTER: 2706 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER; 2707 break; 2708 case OMP_PROC_BIND_SPREAD: 2709 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD; 2710 break; 2711 case OMP_PROC_BIND_CLOSE: 2712 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE; 2713 break; 2714 default: 2715 gcc_unreachable (); 2716 } 2717 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2718 } 2719 2720 if (clauses->safelen_expr) 2721 { 2722 tree safelen_var; 2723 2724 gfc_init_se (&se, NULL); 2725 gfc_conv_expr (&se, clauses->safelen_expr); 2726 gfc_add_block_to_block (block, &se.pre); 2727 safelen_var = gfc_evaluate_now (se.expr, block); 2728 gfc_add_block_to_block (block, &se.post); 2729 2730 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN); 2731 OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var; 2732 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2733 } 2734 2735 if (clauses->simdlen_expr) 2736 { 2737 if (declare_simd) 2738 { 2739 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN); 2740 OMP_CLAUSE_SIMDLEN_EXPR (c) 2741 = gfc_conv_constant_to_tree (clauses->simdlen_expr); 2742 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2743 } 2744 else 2745 { 2746 tree simdlen_var; 2747 2748 gfc_init_se (&se, NULL); 2749 gfc_conv_expr (&se, clauses->simdlen_expr); 2750 gfc_add_block_to_block (block, &se.pre); 2751 simdlen_var = gfc_evaluate_now (se.expr, block); 2752 gfc_add_block_to_block (block, &se.post); 2753 2754 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN); 2755 OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var; 2756 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2757 } 2758 } 2759 2760 if (clauses->num_teams) 2761 { 2762 tree num_teams; 2763 2764 gfc_init_se (&se, NULL); 2765 gfc_conv_expr (&se, clauses->num_teams); 2766 gfc_add_block_to_block (block, &se.pre); 2767 num_teams = gfc_evaluate_now (se.expr, block); 2768 gfc_add_block_to_block (block, &se.post); 2769 2770 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS); 2771 OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams; 2772 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2773 } 2774 2775 if (clauses->device) 2776 { 2777 tree device; 2778 2779 gfc_init_se (&se, NULL); 2780 gfc_conv_expr (&se, clauses->device); 2781 gfc_add_block_to_block (block, &se.pre); 2782 device = gfc_evaluate_now (se.expr, block); 2783 gfc_add_block_to_block (block, &se.post); 2784 2785 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE); 2786 OMP_CLAUSE_DEVICE_ID (c) = device; 2787 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2788 } 2789 2790 if (clauses->thread_limit) 2791 { 2792 tree thread_limit; 2793 2794 gfc_init_se (&se, NULL); 2795 gfc_conv_expr (&se, clauses->thread_limit); 2796 gfc_add_block_to_block (block, &se.pre); 2797 thread_limit = gfc_evaluate_now (se.expr, block); 2798 gfc_add_block_to_block (block, &se.post); 2799 2800 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT); 2801 OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; 2802 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2803 } 2804 2805 chunk_size = NULL_TREE; 2806 if (clauses->dist_chunk_size) 2807 { 2808 gfc_init_se (&se, NULL); 2809 gfc_conv_expr (&se, clauses->dist_chunk_size); 2810 gfc_add_block_to_block (block, &se.pre); 2811 chunk_size = gfc_evaluate_now (se.expr, block); 2812 gfc_add_block_to_block (block, &se.post); 2813 } 2814 2815 if (clauses->dist_sched_kind != OMP_SCHED_NONE) 2816 { 2817 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE); 2818 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; 2819 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2820 } 2821 2822 if (clauses->grainsize) 2823 { 2824 tree grainsize; 2825 2826 gfc_init_se (&se, NULL); 2827 gfc_conv_expr (&se, clauses->grainsize); 2828 gfc_add_block_to_block (block, &se.pre); 2829 grainsize = gfc_evaluate_now (se.expr, block); 2830 gfc_add_block_to_block (block, &se.post); 2831 2832 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GRAINSIZE); 2833 OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize; 2834 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2835 } 2836 2837 if (clauses->num_tasks) 2838 { 2839 tree num_tasks; 2840 2841 gfc_init_se (&se, NULL); 2842 gfc_conv_expr (&se, clauses->num_tasks); 2843 gfc_add_block_to_block (block, &se.pre); 2844 num_tasks = gfc_evaluate_now (se.expr, block); 2845 gfc_add_block_to_block (block, &se.post); 2846 2847 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TASKS); 2848 OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks; 2849 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2850 } 2851 2852 if (clauses->priority) 2853 { 2854 tree priority; 2855 2856 gfc_init_se (&se, NULL); 2857 gfc_conv_expr (&se, clauses->priority); 2858 gfc_add_block_to_block (block, &se.pre); 2859 priority = gfc_evaluate_now (se.expr, block); 2860 gfc_add_block_to_block (block, &se.post); 2861 2862 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PRIORITY); 2863 OMP_CLAUSE_PRIORITY_EXPR (c) = priority; 2864 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2865 } 2866 2867 if (clauses->hint) 2868 { 2869 tree hint; 2870 2871 gfc_init_se (&se, NULL); 2872 gfc_conv_expr (&se, clauses->hint); 2873 gfc_add_block_to_block (block, &se.pre); 2874 hint = gfc_evaluate_now (se.expr, block); 2875 gfc_add_block_to_block (block, &se.post); 2876 2877 c = build_omp_clause (where.lb->location, OMP_CLAUSE_HINT); 2878 OMP_CLAUSE_HINT_EXPR (c) = hint; 2879 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2880 } 2881 2882 if (clauses->simd) 2883 { 2884 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMD); 2885 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2886 } 2887 if (clauses->threads) 2888 { 2889 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREADS); 2890 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2891 } 2892 if (clauses->nogroup) 2893 { 2894 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOGROUP); 2895 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2896 } 2897 if (clauses->defaultmap) 2898 { 2899 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULTMAP); 2900 OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, OMP_CLAUSE_DEFAULTMAP_TOFROM, 2901 OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR); 2902 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2903 } 2904 if (clauses->depend_source) 2905 { 2906 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEPEND); 2907 OMP_CLAUSE_DEPEND_KIND (c) = OMP_CLAUSE_DEPEND_SOURCE; 2908 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2909 } 2910 2911 if (clauses->async) 2912 { 2913 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC); 2914 if (clauses->async_expr) 2915 OMP_CLAUSE_ASYNC_EXPR (c) 2916 = gfc_convert_expr_to_tree (block, clauses->async_expr); 2917 else 2918 OMP_CLAUSE_ASYNC_EXPR (c) = NULL; 2919 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2920 } 2921 if (clauses->seq) 2922 { 2923 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ); 2924 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2925 } 2926 if (clauses->par_auto) 2927 { 2928 c = build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO); 2929 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2930 } 2931 if (clauses->if_present) 2932 { 2933 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF_PRESENT); 2934 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2935 } 2936 if (clauses->finalize) 2937 { 2938 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINALIZE); 2939 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2940 } 2941 if (clauses->independent) 2942 { 2943 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT); 2944 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2945 } 2946 if (clauses->wait_list) 2947 { 2948 gfc_expr_list *el; 2949 2950 for (el = clauses->wait_list; el; el = el->next) 2951 { 2952 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT); 2953 OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr); 2954 OMP_CLAUSE_CHAIN (c) = omp_clauses; 2955 omp_clauses = c; 2956 } 2957 } 2958 if (clauses->num_gangs_expr) 2959 { 2960 tree num_gangs_var 2961 = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr); 2962 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS); 2963 OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var; 2964 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2965 } 2966 if (clauses->num_workers_expr) 2967 { 2968 tree num_workers_var 2969 = gfc_convert_expr_to_tree (block, clauses->num_workers_expr); 2970 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS); 2971 OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var; 2972 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2973 } 2974 if (clauses->vector_length_expr) 2975 { 2976 tree vector_length_var 2977 = gfc_convert_expr_to_tree (block, clauses->vector_length_expr); 2978 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH); 2979 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var; 2980 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2981 } 2982 if (clauses->tile_list) 2983 { 2984 vec<tree, va_gc> *tvec; 2985 gfc_expr_list *el; 2986 2987 vec_alloc (tvec, 4); 2988 2989 for (el = clauses->tile_list; el; el = el->next) 2990 vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr)); 2991 2992 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TILE); 2993 OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec); 2994 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 2995 tvec->truncate (0); 2996 } 2997 if (clauses->vector) 2998 { 2999 if (clauses->vector_expr) 3000 { 3001 tree vector_var 3002 = gfc_convert_expr_to_tree (block, clauses->vector_expr); 3003 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR); 3004 OMP_CLAUSE_VECTOR_EXPR (c) = vector_var; 3005 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 3006 } 3007 else 3008 { 3009 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR); 3010 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 3011 } 3012 } 3013 if (clauses->worker) 3014 { 3015 if (clauses->worker_expr) 3016 { 3017 tree worker_var 3018 = gfc_convert_expr_to_tree (block, clauses->worker_expr); 3019 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER); 3020 OMP_CLAUSE_WORKER_EXPR (c) = worker_var; 3021 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 3022 } 3023 else 3024 { 3025 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER); 3026 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 3027 } 3028 } 3029 if (clauses->gang) 3030 { 3031 tree arg; 3032 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG); 3033 omp_clauses = gfc_trans_add_clause (c, omp_clauses); 3034 if (clauses->gang_num_expr) 3035 { 3036 arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr); 3037 OMP_CLAUSE_GANG_EXPR (c) = arg; 3038 } 3039 if (clauses->gang_static) 3040 { 3041 arg = clauses->gang_static_expr 3042 ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr) 3043 : integer_minus_one_node; 3044 OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg; 3045 } 3046 } 3047 3048 return nreverse (omp_clauses); 3049 } 3050 3051 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ 3052 3053 static tree 3054 gfc_trans_omp_code (gfc_code *code, bool force_empty) 3055 { 3056 tree stmt; 3057 3058 pushlevel (); 3059 stmt = gfc_trans_code (code); 3060 if (TREE_CODE (stmt) != BIND_EXPR) 3061 { 3062 if (!IS_EMPTY_STMT (stmt) || force_empty) 3063 { 3064 tree block = poplevel (1, 0); 3065 stmt = build3_v (BIND_EXPR, NULL, stmt, block); 3066 } 3067 else 3068 poplevel (0, 0); 3069 } 3070 else 3071 poplevel (0, 0); 3072 return stmt; 3073 } 3074 3075 /* Trans OpenACC directives. */ 3076 /* parallel, kernels, data and host_data. */ 3077 static tree 3078 gfc_trans_oacc_construct (gfc_code *code) 3079 { 3080 stmtblock_t block; 3081 tree stmt, oacc_clauses; 3082 enum tree_code construct_code; 3083 3084 switch (code->op) 3085 { 3086 case EXEC_OACC_PARALLEL: 3087 construct_code = OACC_PARALLEL; 3088 break; 3089 case EXEC_OACC_KERNELS: 3090 construct_code = OACC_KERNELS; 3091 break; 3092 case EXEC_OACC_DATA: 3093 construct_code = OACC_DATA; 3094 break; 3095 case EXEC_OACC_HOST_DATA: 3096 construct_code = OACC_HOST_DATA; 3097 break; 3098 default: 3099 gcc_unreachable (); 3100 } 3101 3102 gfc_start_block (&block); 3103 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 3104 code->loc); 3105 stmt = gfc_trans_omp_code (code->block->next, true); 3106 stmt = build2_loc (input_location, construct_code, void_type_node, stmt, 3107 oacc_clauses); 3108 gfc_add_expr_to_block (&block, stmt); 3109 return gfc_finish_block (&block); 3110 } 3111 3112 /* update, enter_data, exit_data, cache. */ 3113 static tree 3114 gfc_trans_oacc_executable_directive (gfc_code *code) 3115 { 3116 stmtblock_t block; 3117 tree stmt, oacc_clauses; 3118 enum tree_code construct_code; 3119 3120 switch (code->op) 3121 { 3122 case EXEC_OACC_UPDATE: 3123 construct_code = OACC_UPDATE; 3124 break; 3125 case EXEC_OACC_ENTER_DATA: 3126 construct_code = OACC_ENTER_DATA; 3127 break; 3128 case EXEC_OACC_EXIT_DATA: 3129 construct_code = OACC_EXIT_DATA; 3130 break; 3131 case EXEC_OACC_CACHE: 3132 construct_code = OACC_CACHE; 3133 break; 3134 default: 3135 gcc_unreachable (); 3136 } 3137 3138 gfc_start_block (&block); 3139 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 3140 code->loc); 3141 stmt = build1_loc (input_location, construct_code, void_type_node, 3142 oacc_clauses); 3143 gfc_add_expr_to_block (&block, stmt); 3144 return gfc_finish_block (&block); 3145 } 3146 3147 static tree 3148 gfc_trans_oacc_wait_directive (gfc_code *code) 3149 { 3150 stmtblock_t block; 3151 tree stmt, t; 3152 vec<tree, va_gc> *args; 3153 int nparms = 0; 3154 gfc_expr_list *el; 3155 gfc_omp_clauses *clauses = code->ext.omp_clauses; 3156 location_t loc = input_location; 3157 3158 for (el = clauses->wait_list; el; el = el->next) 3159 nparms++; 3160 3161 vec_alloc (args, nparms + 2); 3162 stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT); 3163 3164 gfc_start_block (&block); 3165 3166 if (clauses->async_expr) 3167 t = gfc_convert_expr_to_tree (&block, clauses->async_expr); 3168 else 3169 t = build_int_cst (integer_type_node, -2); 3170 3171 args->quick_push (t); 3172 args->quick_push (build_int_cst (integer_type_node, nparms)); 3173 3174 for (el = clauses->wait_list; el; el = el->next) 3175 args->quick_push (gfc_convert_expr_to_tree (&block, el->expr)); 3176 3177 stmt = build_call_expr_loc_vec (loc, stmt, args); 3178 gfc_add_expr_to_block (&block, stmt); 3179 3180 vec_free (args); 3181 3182 return gfc_finish_block (&block); 3183 } 3184 3185 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); 3186 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); 3187 3188 static tree 3189 gfc_trans_omp_atomic (gfc_code *code) 3190 { 3191 gfc_code *atomic_code = code; 3192 gfc_se lse; 3193 gfc_se rse; 3194 gfc_se vse; 3195 gfc_expr *expr2, *e; 3196 gfc_symbol *var; 3197 stmtblock_t block; 3198 tree lhsaddr, type, rhs, x; 3199 enum tree_code op = ERROR_MARK; 3200 enum tree_code aop = OMP_ATOMIC; 3201 bool var_on_left = false; 3202 enum omp_memory_order mo 3203 = ((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) 3204 ? OMP_MEMORY_ORDER_SEQ_CST : OMP_MEMORY_ORDER_RELAXED); 3205 3206 code = code->block->next; 3207 gcc_assert (code->op == EXEC_ASSIGN); 3208 var = code->expr1->symtree->n.sym; 3209 3210 gfc_init_se (&lse, NULL); 3211 gfc_init_se (&rse, NULL); 3212 gfc_init_se (&vse, NULL); 3213 gfc_start_block (&block); 3214 3215 expr2 = code->expr2; 3216 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) 3217 != GFC_OMP_ATOMIC_WRITE) 3218 && expr2->expr_type == EXPR_FUNCTION 3219 && expr2->value.function.isym 3220 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) 3221 expr2 = expr2->value.function.actual->expr; 3222 3223 switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) 3224 { 3225 case GFC_OMP_ATOMIC_READ: 3226 gfc_conv_expr (&vse, code->expr1); 3227 gfc_add_block_to_block (&block, &vse.pre); 3228 3229 gfc_conv_expr (&lse, expr2); 3230 gfc_add_block_to_block (&block, &lse.pre); 3231 type = TREE_TYPE (lse.expr); 3232 lhsaddr = gfc_build_addr_expr (NULL, lse.expr); 3233 3234 x = build1 (OMP_ATOMIC_READ, type, lhsaddr); 3235 OMP_ATOMIC_MEMORY_ORDER (x) = mo; 3236 x = convert (TREE_TYPE (vse.expr), x); 3237 gfc_add_modify (&block, vse.expr, x); 3238 3239 gfc_add_block_to_block (&block, &lse.pre); 3240 gfc_add_block_to_block (&block, &rse.pre); 3241 3242 return gfc_finish_block (&block); 3243 case GFC_OMP_ATOMIC_CAPTURE: 3244 aop = OMP_ATOMIC_CAPTURE_NEW; 3245 if (expr2->expr_type == EXPR_VARIABLE) 3246 { 3247 aop = OMP_ATOMIC_CAPTURE_OLD; 3248 gfc_conv_expr (&vse, code->expr1); 3249 gfc_add_block_to_block (&block, &vse.pre); 3250 3251 gfc_conv_expr (&lse, expr2); 3252 gfc_add_block_to_block (&block, &lse.pre); 3253 gfc_init_se (&lse, NULL); 3254 code = code->next; 3255 var = code->expr1->symtree->n.sym; 3256 expr2 = code->expr2; 3257 if (expr2->expr_type == EXPR_FUNCTION 3258 && expr2->value.function.isym 3259 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) 3260 expr2 = expr2->value.function.actual->expr; 3261 } 3262 break; 3263 default: 3264 break; 3265 } 3266 3267 gfc_conv_expr (&lse, code->expr1); 3268 gfc_add_block_to_block (&block, &lse.pre); 3269 type = TREE_TYPE (lse.expr); 3270 lhsaddr = gfc_build_addr_expr (NULL, lse.expr); 3271 3272 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) 3273 == GFC_OMP_ATOMIC_WRITE) 3274 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP)) 3275 { 3276 gfc_conv_expr (&rse, expr2); 3277 gfc_add_block_to_block (&block, &rse.pre); 3278 } 3279 else if (expr2->expr_type == EXPR_OP) 3280 { 3281 gfc_expr *e; 3282 switch (expr2->value.op.op) 3283 { 3284 case INTRINSIC_PLUS: 3285 op = PLUS_EXPR; 3286 break; 3287 case INTRINSIC_TIMES: 3288 op = MULT_EXPR; 3289 break; 3290 case INTRINSIC_MINUS: 3291 op = MINUS_EXPR; 3292 break; 3293 case INTRINSIC_DIVIDE: 3294 if (expr2->ts.type == BT_INTEGER) 3295 op = TRUNC_DIV_EXPR; 3296 else 3297 op = RDIV_EXPR; 3298 break; 3299 case INTRINSIC_AND: 3300 op = TRUTH_ANDIF_EXPR; 3301 break; 3302 case INTRINSIC_OR: 3303 op = TRUTH_ORIF_EXPR; 3304 break; 3305 case INTRINSIC_EQV: 3306 op = EQ_EXPR; 3307 break; 3308 case INTRINSIC_NEQV: 3309 op = NE_EXPR; 3310 break; 3311 default: 3312 gcc_unreachable (); 3313 } 3314 e = expr2->value.op.op1; 3315 if (e->expr_type == EXPR_FUNCTION 3316 && e->value.function.isym 3317 && e->value.function.isym->id == GFC_ISYM_CONVERSION) 3318 e = e->value.function.actual->expr; 3319 if (e->expr_type == EXPR_VARIABLE 3320 && e->symtree != NULL 3321 && e->symtree->n.sym == var) 3322 { 3323 expr2 = expr2->value.op.op2; 3324 var_on_left = true; 3325 } 3326 else 3327 { 3328 e = expr2->value.op.op2; 3329 if (e->expr_type == EXPR_FUNCTION 3330 && e->value.function.isym 3331 && e->value.function.isym->id == GFC_ISYM_CONVERSION) 3332 e = e->value.function.actual->expr; 3333 gcc_assert (e->expr_type == EXPR_VARIABLE 3334 && e->symtree != NULL 3335 && e->symtree->n.sym == var); 3336 expr2 = expr2->value.op.op1; 3337 var_on_left = false; 3338 } 3339 gfc_conv_expr (&rse, expr2); 3340 gfc_add_block_to_block (&block, &rse.pre); 3341 } 3342 else 3343 { 3344 gcc_assert (expr2->expr_type == EXPR_FUNCTION); 3345 switch (expr2->value.function.isym->id) 3346 { 3347 case GFC_ISYM_MIN: 3348 op = MIN_EXPR; 3349 break; 3350 case GFC_ISYM_MAX: 3351 op = MAX_EXPR; 3352 break; 3353 case GFC_ISYM_IAND: 3354 op = BIT_AND_EXPR; 3355 break; 3356 case GFC_ISYM_IOR: 3357 op = BIT_IOR_EXPR; 3358 break; 3359 case GFC_ISYM_IEOR: 3360 op = BIT_XOR_EXPR; 3361 break; 3362 default: 3363 gcc_unreachable (); 3364 } 3365 e = expr2->value.function.actual->expr; 3366 gcc_assert (e->expr_type == EXPR_VARIABLE 3367 && e->symtree != NULL 3368 && e->symtree->n.sym == var); 3369 3370 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); 3371 gfc_add_block_to_block (&block, &rse.pre); 3372 if (expr2->value.function.actual->next->next != NULL) 3373 { 3374 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); 3375 gfc_actual_arglist *arg; 3376 3377 gfc_add_modify (&block, accum, rse.expr); 3378 for (arg = expr2->value.function.actual->next->next; arg; 3379 arg = arg->next) 3380 { 3381 gfc_init_block (&rse.pre); 3382 gfc_conv_expr (&rse, arg->expr); 3383 gfc_add_block_to_block (&block, &rse.pre); 3384 x = fold_build2_loc (input_location, op, TREE_TYPE (accum), 3385 accum, rse.expr); 3386 gfc_add_modify (&block, accum, x); 3387 } 3388 3389 rse.expr = accum; 3390 } 3391 3392 expr2 = expr2->value.function.actual->next->expr; 3393 } 3394 3395 lhsaddr = save_expr (lhsaddr); 3396 if (TREE_CODE (lhsaddr) != SAVE_EXPR 3397 && (TREE_CODE (lhsaddr) != ADDR_EXPR 3398 || !VAR_P (TREE_OPERAND (lhsaddr, 0)))) 3399 { 3400 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize 3401 it even after unsharing function body. */ 3402 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); 3403 DECL_CONTEXT (var) = current_function_decl; 3404 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, 3405 NULL_TREE, NULL_TREE); 3406 } 3407 3408 rhs = gfc_evaluate_now (rse.expr, &block); 3409 3410 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) 3411 == GFC_OMP_ATOMIC_WRITE) 3412 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP)) 3413 x = rhs; 3414 else 3415 { 3416 x = convert (TREE_TYPE (rhs), 3417 build_fold_indirect_ref_loc (input_location, lhsaddr)); 3418 if (var_on_left) 3419 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs); 3420 else 3421 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x); 3422 } 3423 3424 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE 3425 && TREE_CODE (type) != COMPLEX_TYPE) 3426 x = fold_build1_loc (input_location, REALPART_EXPR, 3427 TREE_TYPE (TREE_TYPE (rhs)), x); 3428 3429 gfc_add_block_to_block (&block, &lse.pre); 3430 gfc_add_block_to_block (&block, &rse.pre); 3431 3432 if (aop == OMP_ATOMIC) 3433 { 3434 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); 3435 OMP_ATOMIC_MEMORY_ORDER (x) = mo; 3436 gfc_add_expr_to_block (&block, x); 3437 } 3438 else 3439 { 3440 if (aop == OMP_ATOMIC_CAPTURE_NEW) 3441 { 3442 code = code->next; 3443 expr2 = code->expr2; 3444 if (expr2->expr_type == EXPR_FUNCTION 3445 && expr2->value.function.isym 3446 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) 3447 expr2 = expr2->value.function.actual->expr; 3448 3449 gcc_assert (expr2->expr_type == EXPR_VARIABLE); 3450 gfc_conv_expr (&vse, code->expr1); 3451 gfc_add_block_to_block (&block, &vse.pre); 3452 3453 gfc_init_se (&lse, NULL); 3454 gfc_conv_expr (&lse, expr2); 3455 gfc_add_block_to_block (&block, &lse.pre); 3456 } 3457 x = build2 (aop, type, lhsaddr, convert (type, x)); 3458 OMP_ATOMIC_MEMORY_ORDER (x) = mo; 3459 x = convert (TREE_TYPE (vse.expr), x); 3460 gfc_add_modify (&block, vse.expr, x); 3461 } 3462 3463 return gfc_finish_block (&block); 3464 } 3465 3466 static tree 3467 gfc_trans_omp_barrier (void) 3468 { 3469 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER); 3470 return build_call_expr_loc (input_location, decl, 0); 3471 } 3472 3473 static tree 3474 gfc_trans_omp_cancel (gfc_code *code) 3475 { 3476 int mask = 0; 3477 tree ifc = boolean_true_node; 3478 stmtblock_t block; 3479 switch (code->ext.omp_clauses->cancel) 3480 { 3481 case OMP_CANCEL_PARALLEL: mask = 1; break; 3482 case OMP_CANCEL_DO: mask = 2; break; 3483 case OMP_CANCEL_SECTIONS: mask = 4; break; 3484 case OMP_CANCEL_TASKGROUP: mask = 8; break; 3485 default: gcc_unreachable (); 3486 } 3487 gfc_start_block (&block); 3488 if (code->ext.omp_clauses->if_expr) 3489 { 3490 gfc_se se; 3491 tree if_var; 3492 3493 gfc_init_se (&se, NULL); 3494 gfc_conv_expr (&se, code->ext.omp_clauses->if_expr); 3495 gfc_add_block_to_block (&block, &se.pre); 3496 if_var = gfc_evaluate_now (se.expr, &block); 3497 gfc_add_block_to_block (&block, &se.post); 3498 tree type = TREE_TYPE (if_var); 3499 ifc = fold_build2_loc (input_location, NE_EXPR, 3500 boolean_type_node, if_var, 3501 build_zero_cst (type)); 3502 } 3503 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL); 3504 tree c_bool_type = TREE_TYPE (TREE_TYPE (decl)); 3505 ifc = fold_convert (c_bool_type, ifc); 3506 gfc_add_expr_to_block (&block, 3507 build_call_expr_loc (input_location, decl, 2, 3508 build_int_cst (integer_type_node, 3509 mask), ifc)); 3510 return gfc_finish_block (&block); 3511 } 3512 3513 static tree 3514 gfc_trans_omp_cancellation_point (gfc_code *code) 3515 { 3516 int mask = 0; 3517 switch (code->ext.omp_clauses->cancel) 3518 { 3519 case OMP_CANCEL_PARALLEL: mask = 1; break; 3520 case OMP_CANCEL_DO: mask = 2; break; 3521 case OMP_CANCEL_SECTIONS: mask = 4; break; 3522 case OMP_CANCEL_TASKGROUP: mask = 8; break; 3523 default: gcc_unreachable (); 3524 } 3525 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT); 3526 return build_call_expr_loc (input_location, decl, 1, 3527 build_int_cst (integer_type_node, mask)); 3528 } 3529 3530 static tree 3531 gfc_trans_omp_critical (gfc_code *code) 3532 { 3533 tree name = NULL_TREE, stmt; 3534 if (code->ext.omp_clauses != NULL) 3535 name = get_identifier (code->ext.omp_clauses->critical_name); 3536 stmt = gfc_trans_code (code->block->next); 3537 return build3_loc (input_location, OMP_CRITICAL, void_type_node, stmt, 3538 NULL_TREE, name); 3539 } 3540 3541 typedef struct dovar_init_d { 3542 tree var; 3543 tree init; 3544 } dovar_init; 3545 3546 3547 static tree 3548 gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, 3549 gfc_omp_clauses *do_clauses, tree par_clauses) 3550 { 3551 gfc_se se; 3552 tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls; 3553 tree count = NULL_TREE, cycle_label, tmp, omp_clauses; 3554 stmtblock_t block; 3555 stmtblock_t body; 3556 gfc_omp_clauses *clauses = code->ext.omp_clauses; 3557 int i, collapse = clauses->collapse; 3558 vec<dovar_init> inits = vNULL; 3559 dovar_init *di; 3560 unsigned ix; 3561 vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps; 3562 gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list; 3563 3564 /* Both collapsed and tiled loops are lowered the same way. In 3565 OpenACC, those clauses are not compatible, so prioritize the tile 3566 clause, if present. */ 3567 if (tile) 3568 { 3569 collapse = 0; 3570 for (gfc_expr_list *el = tile; el; el = el->next) 3571 collapse++; 3572 } 3573 3574 doacross_steps = NULL; 3575 if (clauses->orderedc) 3576 collapse = clauses->orderedc; 3577 if (collapse <= 0) 3578 collapse = 1; 3579 3580 code = code->block->next; 3581 gcc_assert (code->op == EXEC_DO); 3582 3583 init = make_tree_vec (collapse); 3584 cond = make_tree_vec (collapse); 3585 incr = make_tree_vec (collapse); 3586 orig_decls = clauses->orderedc ? make_tree_vec (collapse) : NULL_TREE; 3587 3588 if (pblock == NULL) 3589 { 3590 gfc_start_block (&block); 3591 pblock = █ 3592 } 3593 3594 /* simd schedule modifier is only useful for composite do simd and other 3595 constructs including that, where gfc_trans_omp_do is only called 3596 on the simd construct and DO's clauses are translated elsewhere. */ 3597 do_clauses->sched_simd = false; 3598 3599 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); 3600 3601 for (i = 0; i < collapse; i++) 3602 { 3603 int simple = 0; 3604 int dovar_found = 0; 3605 tree dovar_decl; 3606 3607 if (clauses) 3608 { 3609 gfc_omp_namelist *n = NULL; 3610 if (op != EXEC_OMP_DISTRIBUTE) 3611 for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1) 3612 ? OMP_LIST_LINEAR : OMP_LIST_LASTPRIVATE]; 3613 n != NULL; n = n->next) 3614 if (code->ext.iterator->var->symtree->n.sym == n->sym) 3615 break; 3616 if (n != NULL) 3617 dovar_found = 1; 3618 else if (n == NULL && op != EXEC_OMP_SIMD) 3619 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) 3620 if (code->ext.iterator->var->symtree->n.sym == n->sym) 3621 break; 3622 if (n != NULL) 3623 dovar_found++; 3624 } 3625 3626 /* Evaluate all the expressions in the iterator. */ 3627 gfc_init_se (&se, NULL); 3628 gfc_conv_expr_lhs (&se, code->ext.iterator->var); 3629 gfc_add_block_to_block (pblock, &se.pre); 3630 dovar = se.expr; 3631 type = TREE_TYPE (dovar); 3632 gcc_assert (TREE_CODE (type) == INTEGER_TYPE); 3633 3634 gfc_init_se (&se, NULL); 3635 gfc_conv_expr_val (&se, code->ext.iterator->start); 3636 gfc_add_block_to_block (pblock, &se.pre); 3637 from = gfc_evaluate_now (se.expr, pblock); 3638 3639 gfc_init_se (&se, NULL); 3640 gfc_conv_expr_val (&se, code->ext.iterator->end); 3641 gfc_add_block_to_block (pblock, &se.pre); 3642 to = gfc_evaluate_now (se.expr, pblock); 3643 3644 gfc_init_se (&se, NULL); 3645 gfc_conv_expr_val (&se, code->ext.iterator->step); 3646 gfc_add_block_to_block (pblock, &se.pre); 3647 step = gfc_evaluate_now (se.expr, pblock); 3648 dovar_decl = dovar; 3649 3650 /* Special case simple loops. */ 3651 if (VAR_P (dovar)) 3652 { 3653 if (integer_onep (step)) 3654 simple = 1; 3655 else if (tree_int_cst_equal (step, integer_minus_one_node)) 3656 simple = -1; 3657 } 3658 else 3659 dovar_decl 3660 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym, 3661 false); 3662 3663 /* Loop body. */ 3664 if (simple) 3665 { 3666 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from); 3667 /* The condition should not be folded. */ 3668 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0 3669 ? LE_EXPR : GE_EXPR, 3670 logical_type_node, dovar, to); 3671 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, 3672 type, dovar, step); 3673 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, 3674 MODIFY_EXPR, 3675 type, dovar, 3676 TREE_VEC_ELT (incr, i)); 3677 } 3678 else 3679 { 3680 /* STEP is not 1 or -1. Use: 3681 for (count = 0; count < (to + step - from) / step; count++) 3682 { 3683 dovar = from + count * step; 3684 body; 3685 cycle_label:; 3686 } */ 3687 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from); 3688 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp); 3689 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp, 3690 step); 3691 tmp = gfc_evaluate_now (tmp, pblock); 3692 count = gfc_create_var (type, "count"); 3693 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count, 3694 build_int_cst (type, 0)); 3695 /* The condition should not be folded. */ 3696 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR, 3697 logical_type_node, 3698 count, tmp); 3699 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, 3700 type, count, 3701 build_int_cst (type, 1)); 3702 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, 3703 MODIFY_EXPR, type, count, 3704 TREE_VEC_ELT (incr, i)); 3705 3706 /* Initialize DOVAR. */ 3707 tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step); 3708 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp); 3709 dovar_init e = {dovar, tmp}; 3710 inits.safe_push (e); 3711 if (clauses->orderedc) 3712 { 3713 if (doacross_steps == NULL) 3714 vec_safe_grow_cleared (doacross_steps, clauses->orderedc); 3715 (*doacross_steps)[i] = step; 3716 } 3717 } 3718 if (orig_decls) 3719 TREE_VEC_ELT (orig_decls, i) = dovar_decl; 3720 3721 if (dovar_found == 2 3722 && op == EXEC_OMP_SIMD 3723 && collapse == 1 3724 && !simple) 3725 { 3726 for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp)) 3727 if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR 3728 && OMP_CLAUSE_DECL (tmp) == dovar) 3729 { 3730 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; 3731 break; 3732 } 3733 } 3734 if (!dovar_found) 3735 { 3736 if (op == EXEC_OMP_SIMD) 3737 { 3738 if (collapse == 1) 3739 { 3740 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); 3741 OMP_CLAUSE_LINEAR_STEP (tmp) = step; 3742 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; 3743 } 3744 else 3745 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); 3746 if (!simple) 3747 dovar_found = 2; 3748 } 3749 else 3750 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); 3751 OMP_CLAUSE_DECL (tmp) = dovar_decl; 3752 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); 3753 } 3754 if (dovar_found == 2) 3755 { 3756 tree c = NULL; 3757 3758 tmp = NULL; 3759 if (!simple) 3760 { 3761 /* If dovar is lastprivate, but different counter is used, 3762 dovar += step needs to be added to 3763 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar 3764 will have the value on entry of the last loop, rather 3765 than value after iterator increment. */ 3766 if (clauses->orderedc) 3767 { 3768 if (clauses->collapse <= 1 || i >= clauses->collapse) 3769 tmp = count; 3770 else 3771 tmp = fold_build2_loc (input_location, PLUS_EXPR, 3772 type, count, build_one_cst (type)); 3773 tmp = fold_build2_loc (input_location, MULT_EXPR, type, 3774 tmp, step); 3775 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, 3776 from, tmp); 3777 } 3778 else 3779 { 3780 tmp = gfc_evaluate_now (step, pblock); 3781 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, 3782 dovar, tmp); 3783 } 3784 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, 3785 dovar, tmp); 3786 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) 3787 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE 3788 && OMP_CLAUSE_DECL (c) == dovar_decl) 3789 { 3790 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; 3791 break; 3792 } 3793 else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR 3794 && OMP_CLAUSE_DECL (c) == dovar_decl) 3795 { 3796 OMP_CLAUSE_LINEAR_STMT (c) = tmp; 3797 break; 3798 } 3799 } 3800 if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL) 3801 { 3802 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) 3803 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE 3804 && OMP_CLAUSE_DECL (c) == dovar_decl) 3805 { 3806 tree l = build_omp_clause (input_location, 3807 OMP_CLAUSE_LASTPRIVATE); 3808 OMP_CLAUSE_DECL (l) = dovar_decl; 3809 OMP_CLAUSE_CHAIN (l) = omp_clauses; 3810 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; 3811 omp_clauses = l; 3812 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED); 3813 break; 3814 } 3815 } 3816 gcc_assert (simple || c != NULL); 3817 } 3818 if (!simple) 3819 { 3820 if (op != EXEC_OMP_SIMD) 3821 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); 3822 else if (collapse == 1) 3823 { 3824 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); 3825 OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1); 3826 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; 3827 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1; 3828 } 3829 else 3830 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); 3831 OMP_CLAUSE_DECL (tmp) = count; 3832 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); 3833 } 3834 3835 if (i + 1 < collapse) 3836 code = code->block->next; 3837 } 3838 3839 if (pblock != &block) 3840 { 3841 pushlevel (); 3842 gfc_start_block (&block); 3843 } 3844 3845 gfc_start_block (&body); 3846 3847 FOR_EACH_VEC_ELT (inits, ix, di) 3848 gfc_add_modify (&body, di->var, di->init); 3849 inits.release (); 3850 3851 /* Cycle statement is implemented with a goto. Exit statement must not be 3852 present for this loop. */ 3853 cycle_label = gfc_build_label_decl (NULL_TREE); 3854 3855 /* Put these labels where they can be found later. */ 3856 3857 code->cycle_label = cycle_label; 3858 code->exit_label = NULL_TREE; 3859 3860 /* Main loop body. */ 3861 tmp = gfc_trans_omp_code (code->block->next, true); 3862 gfc_add_expr_to_block (&body, tmp); 3863 3864 /* Label for cycle statements (if needed). */ 3865 if (TREE_USED (cycle_label)) 3866 { 3867 tmp = build1_v (LABEL_EXPR, cycle_label); 3868 gfc_add_expr_to_block (&body, tmp); 3869 } 3870 3871 /* End of loop body. */ 3872 switch (op) 3873 { 3874 case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; 3875 case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; 3876 case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; 3877 case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break; 3878 case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break; 3879 default: gcc_unreachable (); 3880 } 3881 3882 TREE_TYPE (stmt) = void_type_node; 3883 OMP_FOR_BODY (stmt) = gfc_finish_block (&body); 3884 OMP_FOR_CLAUSES (stmt) = omp_clauses; 3885 OMP_FOR_INIT (stmt) = init; 3886 OMP_FOR_COND (stmt) = cond; 3887 OMP_FOR_INCR (stmt) = incr; 3888 if (orig_decls) 3889 OMP_FOR_ORIG_DECLS (stmt) = orig_decls; 3890 gfc_add_expr_to_block (&block, stmt); 3891 3892 vec_free (doacross_steps); 3893 doacross_steps = saved_doacross_steps; 3894 3895 return gfc_finish_block (&block); 3896 } 3897 3898 /* parallel loop and kernels loop. */ 3899 static tree 3900 gfc_trans_oacc_combined_directive (gfc_code *code) 3901 { 3902 stmtblock_t block, *pblock = NULL; 3903 gfc_omp_clauses construct_clauses, loop_clauses; 3904 tree stmt, oacc_clauses = NULL_TREE; 3905 enum tree_code construct_code; 3906 location_t loc = input_location; 3907 3908 switch (code->op) 3909 { 3910 case EXEC_OACC_PARALLEL_LOOP: 3911 construct_code = OACC_PARALLEL; 3912 break; 3913 case EXEC_OACC_KERNELS_LOOP: 3914 construct_code = OACC_KERNELS; 3915 break; 3916 default: 3917 gcc_unreachable (); 3918 } 3919 3920 gfc_start_block (&block); 3921 3922 memset (&loop_clauses, 0, sizeof (loop_clauses)); 3923 if (code->ext.omp_clauses != NULL) 3924 { 3925 memcpy (&construct_clauses, code->ext.omp_clauses, 3926 sizeof (construct_clauses)); 3927 loop_clauses.collapse = construct_clauses.collapse; 3928 loop_clauses.gang = construct_clauses.gang; 3929 loop_clauses.gang_static = construct_clauses.gang_static; 3930 loop_clauses.gang_num_expr = construct_clauses.gang_num_expr; 3931 loop_clauses.gang_static_expr = construct_clauses.gang_static_expr; 3932 loop_clauses.vector = construct_clauses.vector; 3933 loop_clauses.vector_expr = construct_clauses.vector_expr; 3934 loop_clauses.worker = construct_clauses.worker; 3935 loop_clauses.worker_expr = construct_clauses.worker_expr; 3936 loop_clauses.seq = construct_clauses.seq; 3937 loop_clauses.par_auto = construct_clauses.par_auto; 3938 loop_clauses.independent = construct_clauses.independent; 3939 loop_clauses.tile_list = construct_clauses.tile_list; 3940 loop_clauses.lists[OMP_LIST_PRIVATE] 3941 = construct_clauses.lists[OMP_LIST_PRIVATE]; 3942 loop_clauses.lists[OMP_LIST_REDUCTION] 3943 = construct_clauses.lists[OMP_LIST_REDUCTION]; 3944 construct_clauses.gang = false; 3945 construct_clauses.gang_static = false; 3946 construct_clauses.gang_num_expr = NULL; 3947 construct_clauses.gang_static_expr = NULL; 3948 construct_clauses.vector = false; 3949 construct_clauses.vector_expr = NULL; 3950 construct_clauses.worker = false; 3951 construct_clauses.worker_expr = NULL; 3952 construct_clauses.seq = false; 3953 construct_clauses.par_auto = false; 3954 construct_clauses.independent = false; 3955 construct_clauses.independent = false; 3956 construct_clauses.tile_list = NULL; 3957 construct_clauses.lists[OMP_LIST_PRIVATE] = NULL; 3958 if (construct_code == OACC_KERNELS) 3959 construct_clauses.lists[OMP_LIST_REDUCTION] = NULL; 3960 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses, 3961 code->loc); 3962 } 3963 if (!loop_clauses.seq) 3964 pblock = █ 3965 else 3966 pushlevel (); 3967 stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL); 3968 protected_set_expr_location (stmt, loc); 3969 if (TREE_CODE (stmt) != BIND_EXPR) 3970 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 3971 else 3972 poplevel (0, 0); 3973 stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses); 3974 gfc_add_expr_to_block (&block, stmt); 3975 return gfc_finish_block (&block); 3976 } 3977 3978 static tree 3979 gfc_trans_omp_flush (void) 3980 { 3981 tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); 3982 return build_call_expr_loc (input_location, decl, 0); 3983 } 3984 3985 static tree 3986 gfc_trans_omp_master (gfc_code *code) 3987 { 3988 tree stmt = gfc_trans_code (code->block->next); 3989 if (IS_EMPTY_STMT (stmt)) 3990 return stmt; 3991 return build1_v (OMP_MASTER, stmt); 3992 } 3993 3994 static tree 3995 gfc_trans_omp_ordered (gfc_code *code) 3996 { 3997 if (!flag_openmp) 3998 { 3999 if (!code->ext.omp_clauses->simd) 4000 return gfc_trans_code (code->block ? code->block->next : NULL); 4001 code->ext.omp_clauses->threads = 0; 4002 } 4003 tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses, 4004 code->loc); 4005 return build2_loc (input_location, OMP_ORDERED, void_type_node, 4006 code->block ? gfc_trans_code (code->block->next) 4007 : NULL_TREE, omp_clauses); 4008 } 4009 4010 static tree 4011 gfc_trans_omp_parallel (gfc_code *code) 4012 { 4013 stmtblock_t block; 4014 tree stmt, omp_clauses; 4015 4016 gfc_start_block (&block); 4017 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4018 code->loc); 4019 pushlevel (); 4020 stmt = gfc_trans_omp_code (code->block->next, true); 4021 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4022 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 4023 omp_clauses); 4024 gfc_add_expr_to_block (&block, stmt); 4025 return gfc_finish_block (&block); 4026 } 4027 4028 enum 4029 { 4030 GFC_OMP_SPLIT_SIMD, 4031 GFC_OMP_SPLIT_DO, 4032 GFC_OMP_SPLIT_PARALLEL, 4033 GFC_OMP_SPLIT_DISTRIBUTE, 4034 GFC_OMP_SPLIT_TEAMS, 4035 GFC_OMP_SPLIT_TARGET, 4036 GFC_OMP_SPLIT_TASKLOOP, 4037 GFC_OMP_SPLIT_NUM 4038 }; 4039 4040 enum 4041 { 4042 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD), 4043 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO), 4044 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL), 4045 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), 4046 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), 4047 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET), 4048 GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP) 4049 }; 4050 4051 static void 4052 gfc_split_omp_clauses (gfc_code *code, 4053 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) 4054 { 4055 int mask = 0, innermost = 0; 4056 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); 4057 switch (code->op) 4058 { 4059 case EXEC_OMP_DISTRIBUTE: 4060 innermost = GFC_OMP_SPLIT_DISTRIBUTE; 4061 break; 4062 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 4063 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 4064 innermost = GFC_OMP_SPLIT_DO; 4065 break; 4066 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 4067 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL 4068 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 4069 innermost = GFC_OMP_SPLIT_SIMD; 4070 break; 4071 case EXEC_OMP_DISTRIBUTE_SIMD: 4072 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; 4073 innermost = GFC_OMP_SPLIT_SIMD; 4074 break; 4075 case EXEC_OMP_DO: 4076 innermost = GFC_OMP_SPLIT_DO; 4077 break; 4078 case EXEC_OMP_DO_SIMD: 4079 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 4080 innermost = GFC_OMP_SPLIT_SIMD; 4081 break; 4082 case EXEC_OMP_PARALLEL: 4083 innermost = GFC_OMP_SPLIT_PARALLEL; 4084 break; 4085 case EXEC_OMP_PARALLEL_DO: 4086 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 4087 innermost = GFC_OMP_SPLIT_DO; 4088 break; 4089 case EXEC_OMP_PARALLEL_DO_SIMD: 4090 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 4091 innermost = GFC_OMP_SPLIT_SIMD; 4092 break; 4093 case EXEC_OMP_SIMD: 4094 innermost = GFC_OMP_SPLIT_SIMD; 4095 break; 4096 case EXEC_OMP_TARGET: 4097 innermost = GFC_OMP_SPLIT_TARGET; 4098 break; 4099 case EXEC_OMP_TARGET_PARALLEL: 4100 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL; 4101 innermost = GFC_OMP_SPLIT_PARALLEL; 4102 break; 4103 case EXEC_OMP_TARGET_PARALLEL_DO: 4104 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 4105 innermost = GFC_OMP_SPLIT_DO; 4106 break; 4107 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 4108 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO 4109 | GFC_OMP_MASK_SIMD; 4110 innermost = GFC_OMP_SPLIT_SIMD; 4111 break; 4112 case EXEC_OMP_TARGET_SIMD: 4113 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD; 4114 innermost = GFC_OMP_SPLIT_SIMD; 4115 break; 4116 case EXEC_OMP_TARGET_TEAMS: 4117 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS; 4118 innermost = GFC_OMP_SPLIT_TEAMS; 4119 break; 4120 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 4121 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS 4122 | GFC_OMP_MASK_DISTRIBUTE; 4123 innermost = GFC_OMP_SPLIT_DISTRIBUTE; 4124 break; 4125 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 4126 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 4127 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 4128 innermost = GFC_OMP_SPLIT_DO; 4129 break; 4130 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4131 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 4132 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 4133 innermost = GFC_OMP_SPLIT_SIMD; 4134 break; 4135 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 4136 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS 4137 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; 4138 innermost = GFC_OMP_SPLIT_SIMD; 4139 break; 4140 case EXEC_OMP_TASKLOOP: 4141 innermost = GFC_OMP_SPLIT_TASKLOOP; 4142 break; 4143 case EXEC_OMP_TASKLOOP_SIMD: 4144 mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; 4145 innermost = GFC_OMP_SPLIT_SIMD; 4146 break; 4147 case EXEC_OMP_TEAMS: 4148 innermost = GFC_OMP_SPLIT_TEAMS; 4149 break; 4150 case EXEC_OMP_TEAMS_DISTRIBUTE: 4151 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE; 4152 innermost = GFC_OMP_SPLIT_DISTRIBUTE; 4153 break; 4154 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 4155 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 4156 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; 4157 innermost = GFC_OMP_SPLIT_DO; 4158 break; 4159 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4160 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE 4161 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; 4162 innermost = GFC_OMP_SPLIT_SIMD; 4163 break; 4164 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 4165 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; 4166 innermost = GFC_OMP_SPLIT_SIMD; 4167 break; 4168 default: 4169 gcc_unreachable (); 4170 } 4171 if (mask == 0) 4172 { 4173 clausesa[innermost] = *code->ext.omp_clauses; 4174 return; 4175 } 4176 if (code->ext.omp_clauses != NULL) 4177 { 4178 if (mask & GFC_OMP_MASK_TARGET) 4179 { 4180 /* First the clauses that are unique to some constructs. */ 4181 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP] 4182 = code->ext.omp_clauses->lists[OMP_LIST_MAP]; 4183 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR] 4184 = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR]; 4185 clausesa[GFC_OMP_SPLIT_TARGET].device 4186 = code->ext.omp_clauses->device; 4187 clausesa[GFC_OMP_SPLIT_TARGET].defaultmap 4188 = code->ext.omp_clauses->defaultmap; 4189 clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET] 4190 = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET]; 4191 /* And this is copied to all. */ 4192 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr 4193 = code->ext.omp_clauses->if_expr; 4194 } 4195 if (mask & GFC_OMP_MASK_TEAMS) 4196 { 4197 /* First the clauses that are unique to some constructs. */ 4198 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams 4199 = code->ext.omp_clauses->num_teams; 4200 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit 4201 = code->ext.omp_clauses->thread_limit; 4202 /* Shared and default clauses are allowed on parallel, teams 4203 and taskloop. */ 4204 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED] 4205 = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; 4206 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing 4207 = code->ext.omp_clauses->default_sharing; 4208 } 4209 if (mask & GFC_OMP_MASK_DISTRIBUTE) 4210 { 4211 /* First the clauses that are unique to some constructs. */ 4212 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind 4213 = code->ext.omp_clauses->dist_sched_kind; 4214 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size 4215 = code->ext.omp_clauses->dist_chunk_size; 4216 /* Duplicate collapse. */ 4217 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse 4218 = code->ext.omp_clauses->collapse; 4219 } 4220 if (mask & GFC_OMP_MASK_PARALLEL) 4221 { 4222 /* First the clauses that are unique to some constructs. */ 4223 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN] 4224 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN]; 4225 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads 4226 = code->ext.omp_clauses->num_threads; 4227 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind 4228 = code->ext.omp_clauses->proc_bind; 4229 /* Shared and default clauses are allowed on parallel, teams 4230 and taskloop. */ 4231 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED] 4232 = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; 4233 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing 4234 = code->ext.omp_clauses->default_sharing; 4235 clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL] 4236 = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL]; 4237 /* And this is copied to all. */ 4238 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr 4239 = code->ext.omp_clauses->if_expr; 4240 } 4241 if (mask & GFC_OMP_MASK_DO) 4242 { 4243 /* First the clauses that are unique to some constructs. */ 4244 clausesa[GFC_OMP_SPLIT_DO].ordered 4245 = code->ext.omp_clauses->ordered; 4246 clausesa[GFC_OMP_SPLIT_DO].orderedc 4247 = code->ext.omp_clauses->orderedc; 4248 clausesa[GFC_OMP_SPLIT_DO].sched_kind 4249 = code->ext.omp_clauses->sched_kind; 4250 if (innermost == GFC_OMP_SPLIT_SIMD) 4251 clausesa[GFC_OMP_SPLIT_DO].sched_simd 4252 = code->ext.omp_clauses->sched_simd; 4253 clausesa[GFC_OMP_SPLIT_DO].sched_monotonic 4254 = code->ext.omp_clauses->sched_monotonic; 4255 clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic 4256 = code->ext.omp_clauses->sched_nonmonotonic; 4257 clausesa[GFC_OMP_SPLIT_DO].chunk_size 4258 = code->ext.omp_clauses->chunk_size; 4259 clausesa[GFC_OMP_SPLIT_DO].nowait 4260 = code->ext.omp_clauses->nowait; 4261 /* Duplicate collapse. */ 4262 clausesa[GFC_OMP_SPLIT_DO].collapse 4263 = code->ext.omp_clauses->collapse; 4264 } 4265 if (mask & GFC_OMP_MASK_SIMD) 4266 { 4267 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr 4268 = code->ext.omp_clauses->safelen_expr; 4269 clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr 4270 = code->ext.omp_clauses->simdlen_expr; 4271 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED] 4272 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED]; 4273 /* Duplicate collapse. */ 4274 clausesa[GFC_OMP_SPLIT_SIMD].collapse 4275 = code->ext.omp_clauses->collapse; 4276 } 4277 if (mask & GFC_OMP_MASK_TASKLOOP) 4278 { 4279 /* First the clauses that are unique to some constructs. */ 4280 clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup 4281 = code->ext.omp_clauses->nogroup; 4282 clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize 4283 = code->ext.omp_clauses->grainsize; 4284 clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks 4285 = code->ext.omp_clauses->num_tasks; 4286 clausesa[GFC_OMP_SPLIT_TASKLOOP].priority 4287 = code->ext.omp_clauses->priority; 4288 clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr 4289 = code->ext.omp_clauses->final_expr; 4290 clausesa[GFC_OMP_SPLIT_TASKLOOP].untied 4291 = code->ext.omp_clauses->untied; 4292 clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable 4293 = code->ext.omp_clauses->mergeable; 4294 clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP] 4295 = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP]; 4296 /* And this is copied to all. */ 4297 clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr 4298 = code->ext.omp_clauses->if_expr; 4299 /* Shared and default clauses are allowed on parallel, teams 4300 and taskloop. */ 4301 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED] 4302 = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; 4303 clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing 4304 = code->ext.omp_clauses->default_sharing; 4305 /* Duplicate collapse. */ 4306 clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse 4307 = code->ext.omp_clauses->collapse; 4308 } 4309 /* Private clause is supported on all constructs, 4310 it is enough to put it on the innermost one. For 4311 !$ omp parallel do put it on parallel though, 4312 as that's what we did for OpenMP 3.1. */ 4313 clausesa[innermost == GFC_OMP_SPLIT_DO 4314 ? (int) GFC_OMP_SPLIT_PARALLEL 4315 : innermost].lists[OMP_LIST_PRIVATE] 4316 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE]; 4317 /* Firstprivate clause is supported on all constructs but 4318 simd. Put it on the outermost of those and duplicate 4319 on parallel and teams. */ 4320 if (mask & GFC_OMP_MASK_TARGET) 4321 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_FIRSTPRIVATE] 4322 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 4323 if (mask & GFC_OMP_MASK_TEAMS) 4324 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE] 4325 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 4326 else if (mask & GFC_OMP_MASK_DISTRIBUTE) 4327 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] 4328 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 4329 if (mask & GFC_OMP_MASK_PARALLEL) 4330 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE] 4331 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 4332 else if (mask & GFC_OMP_MASK_DO) 4333 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE] 4334 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; 4335 /* Lastprivate is allowed on distribute, do and simd. 4336 In parallel do{, simd} we actually want to put it on 4337 parallel rather than do. */ 4338 if (mask & GFC_OMP_MASK_DISTRIBUTE) 4339 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE] 4340 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 4341 if (mask & GFC_OMP_MASK_PARALLEL) 4342 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE] 4343 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 4344 else if (mask & GFC_OMP_MASK_DO) 4345 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE] 4346 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 4347 if (mask & GFC_OMP_MASK_SIMD) 4348 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE] 4349 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; 4350 /* Reduction is allowed on simd, do, parallel and teams. 4351 Duplicate it on all of them, but omit on do if 4352 parallel is present. */ 4353 if (mask & GFC_OMP_MASK_TEAMS) 4354 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION] 4355 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; 4356 if (mask & GFC_OMP_MASK_PARALLEL) 4357 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION] 4358 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; 4359 else if (mask & GFC_OMP_MASK_DO) 4360 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION] 4361 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; 4362 if (mask & GFC_OMP_MASK_SIMD) 4363 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION] 4364 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; 4365 /* Linear clause is supported on do and simd, 4366 put it on the innermost one. */ 4367 clausesa[innermost].lists[OMP_LIST_LINEAR] 4368 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR]; 4369 } 4370 if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) 4371 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) 4372 clausesa[GFC_OMP_SPLIT_DO].nowait = true; 4373 } 4374 4375 static tree 4376 gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, 4377 gfc_omp_clauses *clausesa, tree omp_clauses) 4378 { 4379 stmtblock_t block; 4380 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 4381 tree stmt, body, omp_do_clauses = NULL_TREE; 4382 4383 if (pblock == NULL) 4384 gfc_start_block (&block); 4385 else 4386 gfc_init_block (&block); 4387 4388 if (clausesa == NULL) 4389 { 4390 clausesa = clausesa_buf; 4391 gfc_split_omp_clauses (code, clausesa); 4392 } 4393 if (flag_openmp) 4394 omp_do_clauses 4395 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc); 4396 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block, 4397 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses); 4398 if (pblock == NULL) 4399 { 4400 if (TREE_CODE (body) != BIND_EXPR) 4401 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0)); 4402 else 4403 poplevel (0, 0); 4404 } 4405 else if (TREE_CODE (body) != BIND_EXPR) 4406 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE); 4407 if (flag_openmp) 4408 { 4409 stmt = make_node (OMP_FOR); 4410 TREE_TYPE (stmt) = void_type_node; 4411 OMP_FOR_BODY (stmt) = body; 4412 OMP_FOR_CLAUSES (stmt) = omp_do_clauses; 4413 } 4414 else 4415 stmt = body; 4416 gfc_add_expr_to_block (&block, stmt); 4417 return gfc_finish_block (&block); 4418 } 4419 4420 static tree 4421 gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, 4422 gfc_omp_clauses *clausesa) 4423 { 4424 stmtblock_t block, *new_pblock = pblock; 4425 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 4426 tree stmt, omp_clauses = NULL_TREE; 4427 4428 if (pblock == NULL) 4429 gfc_start_block (&block); 4430 else 4431 gfc_init_block (&block); 4432 4433 if (clausesa == NULL) 4434 { 4435 clausesa = clausesa_buf; 4436 gfc_split_omp_clauses (code, clausesa); 4437 } 4438 omp_clauses 4439 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], 4440 code->loc); 4441 if (pblock == NULL) 4442 { 4443 if (!clausesa[GFC_OMP_SPLIT_DO].ordered 4444 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC) 4445 new_pblock = █ 4446 else 4447 pushlevel (); 4448 } 4449 stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock, 4450 &clausesa[GFC_OMP_SPLIT_DO], omp_clauses); 4451 if (pblock == NULL) 4452 { 4453 if (TREE_CODE (stmt) != BIND_EXPR) 4454 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4455 else 4456 poplevel (0, 0); 4457 } 4458 else if (TREE_CODE (stmt) != BIND_EXPR) 4459 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); 4460 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 4461 omp_clauses); 4462 OMP_PARALLEL_COMBINED (stmt) = 1; 4463 gfc_add_expr_to_block (&block, stmt); 4464 return gfc_finish_block (&block); 4465 } 4466 4467 static tree 4468 gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, 4469 gfc_omp_clauses *clausesa) 4470 { 4471 stmtblock_t block; 4472 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 4473 tree stmt, omp_clauses = NULL_TREE; 4474 4475 if (pblock == NULL) 4476 gfc_start_block (&block); 4477 else 4478 gfc_init_block (&block); 4479 4480 if (clausesa == NULL) 4481 { 4482 clausesa = clausesa_buf; 4483 gfc_split_omp_clauses (code, clausesa); 4484 } 4485 if (flag_openmp) 4486 omp_clauses 4487 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], 4488 code->loc); 4489 if (pblock == NULL) 4490 pushlevel (); 4491 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses); 4492 if (pblock == NULL) 4493 { 4494 if (TREE_CODE (stmt) != BIND_EXPR) 4495 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4496 else 4497 poplevel (0, 0); 4498 } 4499 else if (TREE_CODE (stmt) != BIND_EXPR) 4500 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); 4501 if (flag_openmp) 4502 { 4503 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 4504 omp_clauses); 4505 OMP_PARALLEL_COMBINED (stmt) = 1; 4506 } 4507 gfc_add_expr_to_block (&block, stmt); 4508 return gfc_finish_block (&block); 4509 } 4510 4511 static tree 4512 gfc_trans_omp_parallel_sections (gfc_code *code) 4513 { 4514 stmtblock_t block; 4515 gfc_omp_clauses section_clauses; 4516 tree stmt, omp_clauses; 4517 4518 memset (§ion_clauses, 0, sizeof (section_clauses)); 4519 section_clauses.nowait = true; 4520 4521 gfc_start_block (&block); 4522 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4523 code->loc); 4524 pushlevel (); 4525 stmt = gfc_trans_omp_sections (code, §ion_clauses); 4526 if (TREE_CODE (stmt) != BIND_EXPR) 4527 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4528 else 4529 poplevel (0, 0); 4530 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 4531 omp_clauses); 4532 OMP_PARALLEL_COMBINED (stmt) = 1; 4533 gfc_add_expr_to_block (&block, stmt); 4534 return gfc_finish_block (&block); 4535 } 4536 4537 static tree 4538 gfc_trans_omp_parallel_workshare (gfc_code *code) 4539 { 4540 stmtblock_t block; 4541 gfc_omp_clauses workshare_clauses; 4542 tree stmt, omp_clauses; 4543 4544 memset (&workshare_clauses, 0, sizeof (workshare_clauses)); 4545 workshare_clauses.nowait = true; 4546 4547 gfc_start_block (&block); 4548 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4549 code->loc); 4550 pushlevel (); 4551 stmt = gfc_trans_omp_workshare (code, &workshare_clauses); 4552 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4553 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 4554 omp_clauses); 4555 OMP_PARALLEL_COMBINED (stmt) = 1; 4556 gfc_add_expr_to_block (&block, stmt); 4557 return gfc_finish_block (&block); 4558 } 4559 4560 static tree 4561 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) 4562 { 4563 stmtblock_t block, body; 4564 tree omp_clauses, stmt; 4565 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL; 4566 4567 gfc_start_block (&block); 4568 4569 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); 4570 4571 gfc_init_block (&body); 4572 for (code = code->block; code; code = code->block) 4573 { 4574 /* Last section is special because of lastprivate, so even if it 4575 is empty, chain it in. */ 4576 stmt = gfc_trans_omp_code (code->next, 4577 has_lastprivate && code->block == NULL); 4578 if (! IS_EMPTY_STMT (stmt)) 4579 { 4580 stmt = build1_v (OMP_SECTION, stmt); 4581 gfc_add_expr_to_block (&body, stmt); 4582 } 4583 } 4584 stmt = gfc_finish_block (&body); 4585 4586 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt, 4587 omp_clauses); 4588 gfc_add_expr_to_block (&block, stmt); 4589 4590 return gfc_finish_block (&block); 4591 } 4592 4593 static tree 4594 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) 4595 { 4596 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc); 4597 tree stmt = gfc_trans_omp_code (code->block->next, true); 4598 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt, 4599 omp_clauses); 4600 return stmt; 4601 } 4602 4603 static tree 4604 gfc_trans_omp_task (gfc_code *code) 4605 { 4606 stmtblock_t block; 4607 tree stmt, omp_clauses; 4608 4609 gfc_start_block (&block); 4610 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4611 code->loc); 4612 pushlevel (); 4613 stmt = gfc_trans_omp_code (code->block->next, true); 4614 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4615 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt, 4616 omp_clauses); 4617 gfc_add_expr_to_block (&block, stmt); 4618 return gfc_finish_block (&block); 4619 } 4620 4621 static tree 4622 gfc_trans_omp_taskgroup (gfc_code *code) 4623 { 4624 tree body = gfc_trans_code (code->block->next); 4625 tree stmt = make_node (OMP_TASKGROUP); 4626 TREE_TYPE (stmt) = void_type_node; 4627 OMP_TASKGROUP_BODY (stmt) = body; 4628 OMP_TASKGROUP_CLAUSES (stmt) = NULL_TREE; 4629 return stmt; 4630 } 4631 4632 static tree 4633 gfc_trans_omp_taskwait (void) 4634 { 4635 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); 4636 return build_call_expr_loc (input_location, decl, 0); 4637 } 4638 4639 static tree 4640 gfc_trans_omp_taskyield (void) 4641 { 4642 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD); 4643 return build_call_expr_loc (input_location, decl, 0); 4644 } 4645 4646 static tree 4647 gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) 4648 { 4649 stmtblock_t block; 4650 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 4651 tree stmt, omp_clauses = NULL_TREE; 4652 4653 gfc_start_block (&block); 4654 if (clausesa == NULL) 4655 { 4656 clausesa = clausesa_buf; 4657 gfc_split_omp_clauses (code, clausesa); 4658 } 4659 if (flag_openmp) 4660 omp_clauses 4661 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], 4662 code->loc); 4663 switch (code->op) 4664 { 4665 case EXEC_OMP_DISTRIBUTE: 4666 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 4667 case EXEC_OMP_TEAMS_DISTRIBUTE: 4668 /* This is handled in gfc_trans_omp_do. */ 4669 gcc_unreachable (); 4670 break; 4671 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 4672 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 4673 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 4674 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa); 4675 if (TREE_CODE (stmt) != BIND_EXPR) 4676 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4677 else 4678 poplevel (0, 0); 4679 break; 4680 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 4681 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4682 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4683 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); 4684 if (TREE_CODE (stmt) != BIND_EXPR) 4685 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4686 else 4687 poplevel (0, 0); 4688 break; 4689 case EXEC_OMP_DISTRIBUTE_SIMD: 4690 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 4691 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 4692 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, 4693 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); 4694 if (TREE_CODE (stmt) != BIND_EXPR) 4695 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4696 else 4697 poplevel (0, 0); 4698 break; 4699 default: 4700 gcc_unreachable (); 4701 } 4702 if (flag_openmp) 4703 { 4704 tree distribute = make_node (OMP_DISTRIBUTE); 4705 TREE_TYPE (distribute) = void_type_node; 4706 OMP_FOR_BODY (distribute) = stmt; 4707 OMP_FOR_CLAUSES (distribute) = omp_clauses; 4708 stmt = distribute; 4709 } 4710 gfc_add_expr_to_block (&block, stmt); 4711 return gfc_finish_block (&block); 4712 } 4713 4714 static tree 4715 gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, 4716 tree omp_clauses) 4717 { 4718 stmtblock_t block; 4719 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; 4720 tree stmt; 4721 bool combined = true; 4722 4723 gfc_start_block (&block); 4724 if (clausesa == NULL) 4725 { 4726 clausesa = clausesa_buf; 4727 gfc_split_omp_clauses (code, clausesa); 4728 } 4729 if (flag_openmp) 4730 omp_clauses 4731 = chainon (omp_clauses, 4732 gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS], 4733 code->loc)); 4734 switch (code->op) 4735 { 4736 case EXEC_OMP_TARGET_TEAMS: 4737 case EXEC_OMP_TEAMS: 4738 stmt = gfc_trans_omp_code (code->block->next, true); 4739 combined = false; 4740 break; 4741 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 4742 case EXEC_OMP_TEAMS_DISTRIBUTE: 4743 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL, 4744 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], 4745 NULL); 4746 break; 4747 default: 4748 stmt = gfc_trans_omp_distribute (code, clausesa); 4749 break; 4750 } 4751 if (flag_openmp) 4752 { 4753 stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt, 4754 omp_clauses); 4755 if (combined) 4756 OMP_TEAMS_COMBINED (stmt) = 1; 4757 } 4758 gfc_add_expr_to_block (&block, stmt); 4759 return gfc_finish_block (&block); 4760 } 4761 4762 static tree 4763 gfc_trans_omp_target (gfc_code *code) 4764 { 4765 stmtblock_t block; 4766 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; 4767 tree stmt, omp_clauses = NULL_TREE; 4768 4769 gfc_start_block (&block); 4770 gfc_split_omp_clauses (code, clausesa); 4771 if (flag_openmp) 4772 omp_clauses 4773 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], 4774 code->loc); 4775 switch (code->op) 4776 { 4777 case EXEC_OMP_TARGET: 4778 pushlevel (); 4779 stmt = gfc_trans_omp_code (code->block->next, true); 4780 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4781 break; 4782 case EXEC_OMP_TARGET_PARALLEL: 4783 { 4784 stmtblock_t iblock; 4785 4786 pushlevel (); 4787 gfc_start_block (&iblock); 4788 tree inner_clauses 4789 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], 4790 code->loc); 4791 stmt = gfc_trans_omp_code (code->block->next, true); 4792 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, 4793 inner_clauses); 4794 gfc_add_expr_to_block (&iblock, stmt); 4795 stmt = gfc_finish_block (&iblock); 4796 if (TREE_CODE (stmt) != BIND_EXPR) 4797 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4798 else 4799 poplevel (0, 0); 4800 } 4801 break; 4802 case EXEC_OMP_TARGET_PARALLEL_DO: 4803 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 4804 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa); 4805 if (TREE_CODE (stmt) != BIND_EXPR) 4806 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4807 else 4808 poplevel (0, 0); 4809 break; 4810 case EXEC_OMP_TARGET_SIMD: 4811 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, 4812 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); 4813 if (TREE_CODE (stmt) != BIND_EXPR) 4814 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4815 else 4816 poplevel (0, 0); 4817 break; 4818 default: 4819 if (flag_openmp 4820 && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams 4821 || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit)) 4822 { 4823 gfc_omp_clauses clausesb; 4824 tree teams_clauses; 4825 /* For combined !$omp target teams, the num_teams and 4826 thread_limit clauses are evaluated before entering the 4827 target construct. */ 4828 memset (&clausesb, '\0', sizeof (clausesb)); 4829 clausesb.num_teams = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams; 4830 clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit; 4831 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams = NULL; 4832 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL; 4833 teams_clauses 4834 = gfc_trans_omp_clauses (&block, &clausesb, code->loc); 4835 pushlevel (); 4836 stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses); 4837 } 4838 else 4839 { 4840 pushlevel (); 4841 stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE); 4842 } 4843 if (TREE_CODE (stmt) != BIND_EXPR) 4844 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4845 else 4846 poplevel (0, 0); 4847 break; 4848 } 4849 if (flag_openmp) 4850 { 4851 stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt, 4852 omp_clauses); 4853 if (code->op != EXEC_OMP_TARGET) 4854 OMP_TARGET_COMBINED (stmt) = 1; 4855 } 4856 gfc_add_expr_to_block (&block, stmt); 4857 return gfc_finish_block (&block); 4858 } 4859 4860 static tree 4861 gfc_trans_omp_taskloop (gfc_code *code) 4862 { 4863 stmtblock_t block; 4864 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; 4865 tree stmt, omp_clauses = NULL_TREE; 4866 4867 gfc_start_block (&block); 4868 gfc_split_omp_clauses (code, clausesa); 4869 if (flag_openmp) 4870 omp_clauses 4871 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP], 4872 code->loc); 4873 switch (code->op) 4874 { 4875 case EXEC_OMP_TASKLOOP: 4876 /* This is handled in gfc_trans_omp_do. */ 4877 gcc_unreachable (); 4878 break; 4879 case EXEC_OMP_TASKLOOP_SIMD: 4880 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, 4881 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); 4882 if (TREE_CODE (stmt) != BIND_EXPR) 4883 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); 4884 else 4885 poplevel (0, 0); 4886 break; 4887 default: 4888 gcc_unreachable (); 4889 } 4890 if (flag_openmp) 4891 { 4892 tree taskloop = make_node (OMP_TASKLOOP); 4893 TREE_TYPE (taskloop) = void_type_node; 4894 OMP_FOR_BODY (taskloop) = stmt; 4895 OMP_FOR_CLAUSES (taskloop) = omp_clauses; 4896 stmt = taskloop; 4897 } 4898 gfc_add_expr_to_block (&block, stmt); 4899 return gfc_finish_block (&block); 4900 } 4901 4902 static tree 4903 gfc_trans_omp_target_data (gfc_code *code) 4904 { 4905 stmtblock_t block; 4906 tree stmt, omp_clauses; 4907 4908 gfc_start_block (&block); 4909 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4910 code->loc); 4911 stmt = gfc_trans_omp_code (code->block->next, true); 4912 stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt, 4913 omp_clauses); 4914 gfc_add_expr_to_block (&block, stmt); 4915 return gfc_finish_block (&block); 4916 } 4917 4918 static tree 4919 gfc_trans_omp_target_enter_data (gfc_code *code) 4920 { 4921 stmtblock_t block; 4922 tree stmt, omp_clauses; 4923 4924 gfc_start_block (&block); 4925 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4926 code->loc); 4927 stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node, 4928 omp_clauses); 4929 gfc_add_expr_to_block (&block, stmt); 4930 return gfc_finish_block (&block); 4931 } 4932 4933 static tree 4934 gfc_trans_omp_target_exit_data (gfc_code *code) 4935 { 4936 stmtblock_t block; 4937 tree stmt, omp_clauses; 4938 4939 gfc_start_block (&block); 4940 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4941 code->loc); 4942 stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node, 4943 omp_clauses); 4944 gfc_add_expr_to_block (&block, stmt); 4945 return gfc_finish_block (&block); 4946 } 4947 4948 static tree 4949 gfc_trans_omp_target_update (gfc_code *code) 4950 { 4951 stmtblock_t block; 4952 tree stmt, omp_clauses; 4953 4954 gfc_start_block (&block); 4955 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, 4956 code->loc); 4957 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node, 4958 omp_clauses); 4959 gfc_add_expr_to_block (&block, stmt); 4960 return gfc_finish_block (&block); 4961 } 4962 4963 static tree 4964 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) 4965 { 4966 tree res, tmp, stmt; 4967 stmtblock_t block, *pblock = NULL; 4968 stmtblock_t singleblock; 4969 int saved_ompws_flags; 4970 bool singleblock_in_progress = false; 4971 /* True if previous gfc_code in workshare construct is not workshared. */ 4972 bool prev_singleunit; 4973 4974 code = code->block->next; 4975 4976 pushlevel (); 4977 4978 gfc_start_block (&block); 4979 pblock = █ 4980 4981 ompws_flags = OMPWS_WORKSHARE_FLAG; 4982 prev_singleunit = false; 4983 4984 /* Translate statements one by one to trees until we reach 4985 the end of the workshare construct. Adjacent gfc_codes that 4986 are a single unit of work are clustered and encapsulated in a 4987 single OMP_SINGLE construct. */ 4988 for (; code; code = code->next) 4989 { 4990 if (code->here != 0) 4991 { 4992 res = gfc_trans_label_here (code); 4993 gfc_add_expr_to_block (pblock, res); 4994 } 4995 4996 /* No dependence analysis, use for clauses with wait. 4997 If this is the last gfc_code, use default omp_clauses. */ 4998 if (code->next == NULL && clauses->nowait) 4999 ompws_flags |= OMPWS_NOWAIT; 5000 5001 /* By default, every gfc_code is a single unit of work. */ 5002 ompws_flags |= OMPWS_CURR_SINGLEUNIT; 5003 ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY); 5004 5005 switch (code->op) 5006 { 5007 case EXEC_NOP: 5008 res = NULL_TREE; 5009 break; 5010 5011 case EXEC_ASSIGN: 5012 res = gfc_trans_assign (code); 5013 break; 5014 5015 case EXEC_POINTER_ASSIGN: 5016 res = gfc_trans_pointer_assign (code); 5017 break; 5018 5019 case EXEC_INIT_ASSIGN: 5020 res = gfc_trans_init_assign (code); 5021 break; 5022 5023 case EXEC_FORALL: 5024 res = gfc_trans_forall (code); 5025 break; 5026 5027 case EXEC_WHERE: 5028 res = gfc_trans_where (code); 5029 break; 5030 5031 case EXEC_OMP_ATOMIC: 5032 res = gfc_trans_omp_directive (code); 5033 break; 5034 5035 case EXEC_OMP_PARALLEL: 5036 case EXEC_OMP_PARALLEL_DO: 5037 case EXEC_OMP_PARALLEL_SECTIONS: 5038 case EXEC_OMP_PARALLEL_WORKSHARE: 5039 case EXEC_OMP_CRITICAL: 5040 saved_ompws_flags = ompws_flags; 5041 ompws_flags = 0; 5042 res = gfc_trans_omp_directive (code); 5043 ompws_flags = saved_ompws_flags; 5044 break; 5045 5046 default: 5047 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code"); 5048 } 5049 5050 gfc_set_backend_locus (&code->loc); 5051 5052 if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) 5053 { 5054 if (prev_singleunit) 5055 { 5056 if (ompws_flags & OMPWS_CURR_SINGLEUNIT) 5057 /* Add current gfc_code to single block. */ 5058 gfc_add_expr_to_block (&singleblock, res); 5059 else 5060 { 5061 /* Finish single block and add it to pblock. */ 5062 tmp = gfc_finish_block (&singleblock); 5063 tmp = build2_loc (input_location, OMP_SINGLE, 5064 void_type_node, tmp, NULL_TREE); 5065 gfc_add_expr_to_block (pblock, tmp); 5066 /* Add current gfc_code to pblock. */ 5067 gfc_add_expr_to_block (pblock, res); 5068 singleblock_in_progress = false; 5069 } 5070 } 5071 else 5072 { 5073 if (ompws_flags & OMPWS_CURR_SINGLEUNIT) 5074 { 5075 /* Start single block. */ 5076 gfc_init_block (&singleblock); 5077 gfc_add_expr_to_block (&singleblock, res); 5078 singleblock_in_progress = true; 5079 } 5080 else 5081 /* Add the new statement to the block. */ 5082 gfc_add_expr_to_block (pblock, res); 5083 } 5084 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0; 5085 } 5086 } 5087 5088 /* Finish remaining SINGLE block, if we were in the middle of one. */ 5089 if (singleblock_in_progress) 5090 { 5091 /* Finish single block and add it to pblock. */ 5092 tmp = gfc_finish_block (&singleblock); 5093 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp, 5094 clauses->nowait 5095 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT) 5096 : NULL_TREE); 5097 gfc_add_expr_to_block (pblock, tmp); 5098 } 5099 5100 stmt = gfc_finish_block (pblock); 5101 if (TREE_CODE (stmt) != BIND_EXPR) 5102 { 5103 if (!IS_EMPTY_STMT (stmt)) 5104 { 5105 tree bindblock = poplevel (1, 0); 5106 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock); 5107 } 5108 else 5109 poplevel (0, 0); 5110 } 5111 else 5112 poplevel (0, 0); 5113 5114 if (IS_EMPTY_STMT (stmt) && !clauses->nowait) 5115 stmt = gfc_trans_omp_barrier (); 5116 5117 ompws_flags = 0; 5118 return stmt; 5119 } 5120 5121 tree 5122 gfc_trans_oacc_declare (gfc_code *code) 5123 { 5124 stmtblock_t block; 5125 tree stmt, oacc_clauses; 5126 enum tree_code construct_code; 5127 5128 construct_code = OACC_DATA; 5129 5130 gfc_start_block (&block); 5131 5132 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses, 5133 code->loc); 5134 stmt = gfc_trans_omp_code (code->block->next, true); 5135 stmt = build2_loc (input_location, construct_code, void_type_node, stmt, 5136 oacc_clauses); 5137 gfc_add_expr_to_block (&block, stmt); 5138 5139 return gfc_finish_block (&block); 5140 } 5141 5142 tree 5143 gfc_trans_oacc_directive (gfc_code *code) 5144 { 5145 switch (code->op) 5146 { 5147 case EXEC_OACC_PARALLEL_LOOP: 5148 case EXEC_OACC_KERNELS_LOOP: 5149 return gfc_trans_oacc_combined_directive (code); 5150 case EXEC_OACC_PARALLEL: 5151 case EXEC_OACC_KERNELS: 5152 case EXEC_OACC_DATA: 5153 case EXEC_OACC_HOST_DATA: 5154 return gfc_trans_oacc_construct (code); 5155 case EXEC_OACC_LOOP: 5156 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, 5157 NULL); 5158 case EXEC_OACC_UPDATE: 5159 case EXEC_OACC_CACHE: 5160 case EXEC_OACC_ENTER_DATA: 5161 case EXEC_OACC_EXIT_DATA: 5162 return gfc_trans_oacc_executable_directive (code); 5163 case EXEC_OACC_WAIT: 5164 return gfc_trans_oacc_wait_directive (code); 5165 case EXEC_OACC_ATOMIC: 5166 return gfc_trans_omp_atomic (code); 5167 case EXEC_OACC_DECLARE: 5168 return gfc_trans_oacc_declare (code); 5169 default: 5170 gcc_unreachable (); 5171 } 5172 } 5173 5174 tree 5175 gfc_trans_omp_directive (gfc_code *code) 5176 { 5177 switch (code->op) 5178 { 5179 case EXEC_OMP_ATOMIC: 5180 return gfc_trans_omp_atomic (code); 5181 case EXEC_OMP_BARRIER: 5182 return gfc_trans_omp_barrier (); 5183 case EXEC_OMP_CANCEL: 5184 return gfc_trans_omp_cancel (code); 5185 case EXEC_OMP_CANCELLATION_POINT: 5186 return gfc_trans_omp_cancellation_point (code); 5187 case EXEC_OMP_CRITICAL: 5188 return gfc_trans_omp_critical (code); 5189 case EXEC_OMP_DISTRIBUTE: 5190 case EXEC_OMP_DO: 5191 case EXEC_OMP_SIMD: 5192 case EXEC_OMP_TASKLOOP: 5193 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, 5194 NULL); 5195 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 5196 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5197 case EXEC_OMP_DISTRIBUTE_SIMD: 5198 return gfc_trans_omp_distribute (code, NULL); 5199 case EXEC_OMP_DO_SIMD: 5200 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); 5201 case EXEC_OMP_FLUSH: 5202 return gfc_trans_omp_flush (); 5203 case EXEC_OMP_MASTER: 5204 return gfc_trans_omp_master (code); 5205 case EXEC_OMP_ORDERED: 5206 return gfc_trans_omp_ordered (code); 5207 case EXEC_OMP_PARALLEL: 5208 return gfc_trans_omp_parallel (code); 5209 case EXEC_OMP_PARALLEL_DO: 5210 return gfc_trans_omp_parallel_do (code, NULL, NULL); 5211 case EXEC_OMP_PARALLEL_DO_SIMD: 5212 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); 5213 case EXEC_OMP_PARALLEL_SECTIONS: 5214 return gfc_trans_omp_parallel_sections (code); 5215 case EXEC_OMP_PARALLEL_WORKSHARE: 5216 return gfc_trans_omp_parallel_workshare (code); 5217 case EXEC_OMP_SECTIONS: 5218 return gfc_trans_omp_sections (code, code->ext.omp_clauses); 5219 case EXEC_OMP_SINGLE: 5220 return gfc_trans_omp_single (code, code->ext.omp_clauses); 5221 case EXEC_OMP_TARGET: 5222 case EXEC_OMP_TARGET_PARALLEL: 5223 case EXEC_OMP_TARGET_PARALLEL_DO: 5224 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 5225 case EXEC_OMP_TARGET_SIMD: 5226 case EXEC_OMP_TARGET_TEAMS: 5227 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 5228 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5229 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5230 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5231 return gfc_trans_omp_target (code); 5232 case EXEC_OMP_TARGET_DATA: 5233 return gfc_trans_omp_target_data (code); 5234 case EXEC_OMP_TARGET_ENTER_DATA: 5235 return gfc_trans_omp_target_enter_data (code); 5236 case EXEC_OMP_TARGET_EXIT_DATA: 5237 return gfc_trans_omp_target_exit_data (code); 5238 case EXEC_OMP_TARGET_UPDATE: 5239 return gfc_trans_omp_target_update (code); 5240 case EXEC_OMP_TASK: 5241 return gfc_trans_omp_task (code); 5242 case EXEC_OMP_TASKGROUP: 5243 return gfc_trans_omp_taskgroup (code); 5244 case EXEC_OMP_TASKLOOP_SIMD: 5245 return gfc_trans_omp_taskloop (code); 5246 case EXEC_OMP_TASKWAIT: 5247 return gfc_trans_omp_taskwait (); 5248 case EXEC_OMP_TASKYIELD: 5249 return gfc_trans_omp_taskyield (); 5250 case EXEC_OMP_TEAMS: 5251 case EXEC_OMP_TEAMS_DISTRIBUTE: 5252 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5253 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5254 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 5255 return gfc_trans_omp_teams (code, NULL, NULL_TREE); 5256 case EXEC_OMP_WORKSHARE: 5257 return gfc_trans_omp_workshare (code, code->ext.omp_clauses); 5258 default: 5259 gcc_unreachable (); 5260 } 5261 } 5262 5263 void 5264 gfc_trans_omp_declare_simd (gfc_namespace *ns) 5265 { 5266 if (ns->entries) 5267 return; 5268 5269 gfc_omp_declare_simd *ods; 5270 for (ods = ns->omp_declare_simd; ods; ods = ods->next) 5271 { 5272 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true); 5273 tree fndecl = ns->proc_name->backend_decl; 5274 if (c != NULL_TREE) 5275 c = tree_cons (NULL_TREE, c, NULL_TREE); 5276 c = build_tree_list (get_identifier ("omp declare simd"), c); 5277 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl); 5278 DECL_ATTRIBUTES (fndecl) = c; 5279 } 5280 } 5281