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