gcc/fortran/trans-openmp.c

   1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   3    Contributed by Jakub Jelinek <jakub@redhat.com>
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "tree.h"
  26 #include "gimple.h"
  27 #include "ggc.h"
  28 #include "toplev.h"
  29 #include "real.h"
  30 #include "gfortran.h"
  31 #include "trans.h"
  32 #include "trans-stmt.h"
  33 #include "trans-types.h"
  34 #include "trans-array.h"
  35 #include "trans-const.h"
  36 #include "arith.h"
  37
  38 int ompws_flags;
  39
  40 /* True if OpenMP should privatize what this DECL points to rather
  41    than the DECL itself.  */
  42
  43 bool
  44 gfc_omp_privatize_by_reference (const_tree decl)
  45 {
  46   tree type = TREE_TYPE (decl);
  47
  48   if (TREE_CODE (type) == REFERENCE_TYPE
  49       && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
  50     return true;
  51
  52   if (TREE_CODE (type) == POINTER_TYPE)
  53     {
  54       /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
  55          that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
  56          set are supposed to be privatized by reference.  */
  57       if (GFC_POINTER_TYPE_P (type))
  58         return false;
  59
  60       if (!DECL_ARTIFICIAL (decl))
  61         return true;
  62
  63       /* Some arrays are expanded as DECL_ARTIFICIAL pointers
  64          by the frontend.  */
  65       if (DECL_LANG_SPECIFIC (decl)
  66           && GFC_DECL_SAVED_DESCRIPTOR (decl))
  67         return true;
  68     }
  69
  70   return false;
  71 }
  72
  73 /* True if OpenMP sharing attribute of DECL is predetermined.  */
  74
  75 enum omp_clause_default_kind
  76 gfc_omp_predetermined_sharing (tree decl)
  77 {
  78   if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
  79     return OMP_CLAUSE_DEFAULT_SHARED;
  80
  81   /* Cray pointees shouldn't be listed in any clauses and should be
  82      gimplified to dereference of the corresponding Cray pointer.
  83      Make them all private, so that they are emitted in the debug
  84      information.  */
  85   if (GFC_DECL_CRAY_POINTEE (decl))
  86     return OMP_CLAUSE_DEFAULT_PRIVATE;
  87
  88   /* Assumed-size arrays are predetermined to inherit sharing
  89      attributes of the associated actual argument, which is shared
  90      for all we care.  */
  91   if (TREE_CODE (decl) == PARM_DECL
  92       && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
  93       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
  94       && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
  95                                 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
  96          == NULL)
  97     return OMP_CLAUSE_DEFAULT_SHARED;
  98
  99   /* COMMON and EQUIVALENCE decls are shared.  They
 100      are only referenced through DECL_VALUE_EXPR of the variables
 101      contained in them.  If those are privatized, they will not be
 102      gimplified to the COMMON or EQUIVALENCE decls.  */
 103   if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
 104     return OMP_CLAUSE_DEFAULT_SHARED;
 105
 106   if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
 107     return OMP_CLAUSE_DEFAULT_SHARED;
 108
 109   return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
 110 }
 111
 112
 113 /* Return true if DECL in private clause needs
 114    OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause.  */
 115 bool
 116 gfc_omp_private_outer_ref (tree decl)
 117 {
 118   tree type = TREE_TYPE (decl);
 119
 120   if (GFC_DESCRIPTOR_TYPE_P (type)
 121       && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
 122     return true;
 123
 124   return false;
 125 }
 126
 127 /* Return code to initialize DECL with its default constructor, or
 128    NULL if there's nothing to do.  */
 129
 130 tree
 131 gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
 132 {
 133   tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
 134   stmtblock_t block, cond_block;
 135
 136   if (! GFC_DESCRIPTOR_TYPE_P (type)
 137       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 138     return NULL;
 139
 140   gcc_assert (outer != NULL);
 141   gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
 142               || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
 143
 144   /* Allocatable arrays in PRIVATE clauses need to be set to
 145      "not currently allocated" allocation status if outer
 146      array is "not currently allocated", otherwise should be allocated.  */
 147   gfc_start_block (&block);
 148
 149   gfc_init_block (&cond_block);
 150
 151   gfc_add_modify (&cond_block, decl, outer);
 152   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 153   size = gfc_conv_descriptor_ubound_get (decl, rank);
 154   size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
 155                       gfc_conv_descriptor_lbound_get (decl, rank));
 156   size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 157                       gfc_index_one_node);
 158   if (GFC_TYPE_ARRAY_RANK (type) > 1)
 159     size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
 160                         gfc_conv_descriptor_stride_get (decl, rank));
 161   esize = fold_convert (gfc_array_index_type,
 162                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 163   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
 164   size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
 165   ptr = gfc_allocate_array_with_status (&cond_block,
 166                                         build_int_cst (pvoid_type_node, 0),
 167                                         size, NULL, NULL);
 168   gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
 169   then_b = gfc_finish_block (&cond_block);
 170
 171   gfc_init_block (&cond_block);
 172   gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
 173   else_b = gfc_finish_block (&cond_block);
 174
 175   cond = fold_build2 (NE_EXPR, boolean_type_node,
 176                       fold_convert (pvoid_type_node,
 177                                     gfc_conv_descriptor_data_get (outer)),
 178                       null_pointer_node);
 179   gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
 180                          cond, then_b, else_b));
 181
 182   return gfc_finish_block (&block);
 183 }
 184
 185 /* Build and return code for a copy constructor from SRC to DEST.  */
 186
 187 tree
 188 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
 189 {
 190   tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
 191   stmtblock_t block;
 192
 193   if (! GFC_DESCRIPTOR_TYPE_P (type)
 194       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 195     return build2_v (MODIFY_EXPR, dest, src);
 196
 197   gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
 198
 199   /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
 200      and copied from SRC.  */
 201   gfc_start_block (&block);
 202
 203   gfc_add_modify (&block, dest, src);
 204   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 205   size = gfc_conv_descriptor_ubound_get (dest, rank);
 206   size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
 207                       gfc_conv_descriptor_lbound_get (dest, rank));
 208   size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 209                       gfc_index_one_node);
 210   if (GFC_TYPE_ARRAY_RANK (type) > 1)
 211     size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
 212                         gfc_conv_descriptor_stride_get (dest, rank));
 213   esize = fold_convert (gfc_array_index_type,
 214                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 215   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
 216   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
 217   ptr = gfc_allocate_array_with_status (&block,
 218                                         build_int_cst (pvoid_type_node, 0),
 219                                         size, NULL, NULL);
 220   gfc_conv_descriptor_data_set (&block, dest, ptr);
 221   call = build_call_expr_loc (input_location,
 222                           built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
 223                           fold_convert (pvoid_type_node,
 224                                         gfc_conv_descriptor_data_get (src)),
 225                           size);
 226   gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
 227
 228   return gfc_finish_block (&block);
 229 }
 230
 231 /* Similarly, except use an assignment operator instead.  */
 232
 233 tree
 234 gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
 235 {
 236   tree type = TREE_TYPE (dest), rank, size, esize, call;
 237   stmtblock_t block;
 238
 239   if (! GFC_DESCRIPTOR_TYPE_P (type)
 240       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 241     return build2_v (MODIFY_EXPR, dest, src);
 242
 243   /* Handle copying allocatable arrays.  */
 244   gfc_start_block (&block);
 245
 246   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 247   size = gfc_conv_descriptor_ubound_get (dest, rank);
 248   size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
 249                       gfc_conv_descriptor_lbound_get (dest, rank));
 250   size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 251                       gfc_index_one_node);
 252   if (GFC_TYPE_ARRAY_RANK (type) > 1)
 253     size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
 254                         gfc_conv_descriptor_stride_get (dest, rank));
 255   esize = fold_convert (gfc_array_index_type,
 256                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 257   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
 258   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
 259   call = build_call_expr_loc (input_location,
 260                           built_in_decls[BUILT_IN_MEMCPY], 3,
 261                           fold_convert (pvoid_type_node,
 262                                         gfc_conv_descriptor_data_get (dest)),
 263                           fold_convert (pvoid_type_node,
 264                                         gfc_conv_descriptor_data_get (src)),
 265                           size);
 266   gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
 267
 268   return gfc_finish_block (&block);
 269 }
 270
 271 /* Build and return code destructing DECL.  Return NULL if nothing
 272    to be done.  */
 273
 274 tree
 275 gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
 276 {
 277   tree type = TREE_TYPE (decl);
 278
 279   if (! GFC_DESCRIPTOR_TYPE_P (type)
 280       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 281     return NULL;
 282
 283   /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
 284      to be deallocated if they were allocated.  */
 285   return gfc_trans_dealloc_allocated (decl);
 286 }
 287
 288
 289 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
 290    disregarded in OpenMP construct, because it is going to be
 291    remapped during OpenMP lowering.  SHARED is true if DECL
 292    is going to be shared, false if it is going to be privatized.  */
 293
 294 bool
 295 gfc_omp_disregard_value_expr (tree decl, bool shared)
 296 {
 297   if (GFC_DECL_COMMON_OR_EQUIV (decl)
 298       && DECL_HAS_VALUE_EXPR_P (decl))
 299     {
 300       tree value = DECL_VALUE_EXPR (decl);
 301
 302       if (TREE_CODE (value) == COMPONENT_REF
 303           && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
 304           && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
 305         {
 306           /* If variable in COMMON or EQUIVALENCE is privatized, return
 307              true, as just that variable is supposed to be privatized,
 308              not the whole COMMON or whole EQUIVALENCE.
 309              For shared variables in COMMON or EQUIVALENCE, let them be
 310              gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
 311              from the same COMMON or EQUIVALENCE just one sharing of the
 312              whole COMMON or EQUIVALENCE is enough.  */
 313           return ! shared;
 314         }
 315     }
 316
 317   if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
 318     return ! shared;
 319
 320   return false;
 321 }
 322
 323 /* Return true if DECL that is shared iff SHARED is true should
 324    be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
 325    flag set.  */
 326
 327 bool
 328 gfc_omp_private_debug_clause (tree decl, bool shared)
 329 {
 330   if (GFC_DECL_CRAY_POINTEE (decl))
 331     return true;
 332
 333   if (GFC_DECL_COMMON_OR_EQUIV (decl)
 334       && DECL_HAS_VALUE_EXPR_P (decl))
 335     {
 336       tree value = DECL_VALUE_EXPR (decl);
 337
 338       if (TREE_CODE (value) == COMPONENT_REF
 339           && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
 340           && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
 341         return shared;
 342     }
 343
 344   return false;
 345 }
 346
 347 /* Register language specific type size variables as potentially OpenMP
 348    firstprivate variables.  */
 349
 350 void
 351 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
 352 {
 353   if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
 354     {
 355       int r;
 356
 357       gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
 358       for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
 359         {
 360           omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
 361           omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
 362           omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
 363         }
 364       omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
 365       omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
 366     }
 367 }
 368
 369
 370 static inline tree
 371 gfc_trans_add_clause (tree node, tree tail)
 372 {
 373   OMP_CLAUSE_CHAIN (node) = tail;
 374   return node;
 375 }
 376
 377 static tree
 378 gfc_trans_omp_variable (gfc_symbol *sym)
 379 {
 380   tree t = gfc_get_symbol_decl (sym);
 381   tree parent_decl;
 382   int parent_flag;
 383   bool return_value;
 384   bool alternate_entry;
 385   bool entry_master;
 386
 387   return_value = sym->attr.function && sym->result == sym;
 388   alternate_entry = sym->attr.function && sym->attr.entry
 389                     && sym->result == sym;
 390   entry_master = sym->attr.result
 391                  && sym->ns->proc_name->attr.entry_master
 392                  && !gfc_return_by_reference (sym->ns->proc_name);
 393   parent_decl = DECL_CONTEXT (current_function_decl);
 394
 395   if ((t == parent_decl && return_value)
 396        || (sym->ns && sym->ns->proc_name
 397            && sym->ns->proc_name->backend_decl == parent_decl
 398            && (alternate_entry || entry_master)))
 399     parent_flag = 1;
 400   else
 401     parent_flag = 0;
 402
 403   /* Special case for assigning the return value of a function.
 404      Self recursive functions must have an explicit return value.  */
 405   if (return_value && (t == current_function_decl || parent_flag))
 406     t = gfc_get_fake_result_decl (sym, parent_flag);
 407
 408   /* Similarly for alternate entry points.  */
 409   else if (alternate_entry
 410            && (sym->ns->proc_name->backend_decl == current_function_decl
 411                || parent_flag))
 412     {
 413       gfc_entry_list *el = NULL;
 414
 415       for (el = sym->ns->entries; el; el = el->next)
 416         if (sym == el->sym)
 417           {
 418             t = gfc_get_fake_result_decl (sym, parent_flag);
 419             break;
 420           }
 421     }
 422
 423   else if (entry_master
 424            && (sym->ns->proc_name->backend_decl == current_function_decl
 425                || parent_flag))
 426     t = gfc_get_fake_result_decl (sym, parent_flag);
 427
 428   return t;
 429 }
 430
 431 static tree
 432 gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
 433                              tree list)
 434 {
 435   for (; namelist != NULL; namelist = namelist->next)
 436     if (namelist->sym->attr.referenced)
 437       {
 438         tree t = gfc_trans_omp_variable (namelist->sym);
 439         if (t != error_mark_node)
 440           {
 441             tree node = build_omp_clause (input_location, code);
 442             OMP_CLAUSE_DECL (node) = t;
 443             list = gfc_trans_add_clause (node, list);
 444           }
 445       }
 446   return list;
 447 }
 448
 449 static void
 450 gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
 451 {
 452   gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
 453   gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
 454   gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
 455   gfc_expr *e1, *e2, *e3, *e4;
 456   gfc_ref *ref;
 457   tree decl, backend_decl, stmt;
 458   locus old_loc = gfc_current_locus;
 459   const char *iname;
 460   gfc_try t;
 461
 462   decl = OMP_CLAUSE_DECL (c);
 463   gfc_current_locus = where;
 464
 465   /* Create a fake symbol for init value.  */
 466   memset (&init_val_sym, 0, sizeof (init_val_sym));
 467   init_val_sym.ns = sym->ns;
 468   init_val_sym.name = sym->name;
 469   init_val_sym.ts = sym->ts;
 470   init_val_sym.attr.referenced = 1;
 471   init_val_sym.declared_at = where;
 472   init_val_sym.attr.flavor = FL_VARIABLE;
 473   backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
 474   init_val_sym.backend_decl = backend_decl;
 475
 476   /* Create a fake symbol for the outer array reference.  */
 477   outer_sym = *sym;
 478   outer_sym.as = gfc_copy_array_spec (sym->as);
 479   outer_sym.attr.dummy = 0;
 480   outer_sym.attr.result = 0;
 481   outer_sym.attr.flavor = FL_VARIABLE;
 482   outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
 483
 484   /* Create fake symtrees for it.  */
 485   symtree1 = gfc_new_symtree (&root1, sym->name);
 486   symtree1->n.sym = sym;
 487   gcc_assert (symtree1 == root1);
 488
 489   symtree2 = gfc_new_symtree (&root2, sym->name);
 490   symtree2->n.sym = &init_val_sym;
 491   gcc_assert (symtree2 == root2);
 492
 493   symtree3 = gfc_new_symtree (&root3, sym->name);
 494   symtree3->n.sym = &outer_sym;
 495   gcc_assert (symtree3 == root3);
 496
 497   /* Create expressions.  */
 498   e1 = gfc_get_expr ();
 499   e1->expr_type = EXPR_VARIABLE;
 500   e1->where = where;
 501   e1->symtree = symtree1;
 502   e1->ts = sym->ts;
 503   e1->ref = ref = gfc_get_ref ();
 504   ref->type = REF_ARRAY;
 505   ref->u.ar.where = where;
 506   ref->u.ar.as = sym->as;
 507   ref->u.ar.type = AR_FULL;
 508   ref->u.ar.dimen = 0;
 509   t = gfc_resolve_expr (e1);
 510   gcc_assert (t == SUCCESS);
 511
 512   e2 = gfc_get_expr ();
 513   e2->expr_type = EXPR_VARIABLE;
 514   e2->where = where;
 515   e2->symtree = symtree2;
 516   e2->ts = sym->ts;
 517   t = gfc_resolve_expr (e2);
 518   gcc_assert (t == SUCCESS);
 519
 520   e3 = gfc_copy_expr (e1);
 521   e3->symtree = symtree3;
 522   t = gfc_resolve_expr (e3);
 523   gcc_assert (t == SUCCESS);
 524
 525   iname = NULL;
 526   switch (OMP_CLAUSE_REDUCTION_CODE (c))
 527     {
 528     case PLUS_EXPR:
 529     case MINUS_EXPR:
 530       e4 = gfc_add (e3, e1);
 531       break;
 532     case MULT_EXPR:
 533       e4 = gfc_multiply (e3, e1);
 534       break;
 535     case TRUTH_ANDIF_EXPR:
 536       e4 = gfc_and (e3, e1);
 537       break;
 538     case TRUTH_ORIF_EXPR:
 539       e4 = gfc_or (e3, e1);
 540       break;
 541     case EQ_EXPR:
 542       e4 = gfc_eqv (e3, e1);
 543       break;
 544     case NE_EXPR:
 545       e4 = gfc_neqv (e3, e1);
 546       break;
 547     case MIN_EXPR:
 548       iname = "min";
 549       break;
 550     case MAX_EXPR:
 551       iname = "max";
 552       break;
 553     case BIT_AND_EXPR:
 554       iname = "iand";
 555       break;
 556     case BIT_IOR_EXPR:
 557       iname = "ior";
 558       break;
 559     case BIT_XOR_EXPR:
 560       iname = "ieor";
 561       break;
 562     default:
 563       gcc_unreachable ();
 564     }
 565   if (iname != NULL)
 566     {
 567       memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
 568       intrinsic_sym.ns = sym->ns;
 569       intrinsic_sym.name = iname;
 570       intrinsic_sym.ts = sym->ts;
 571       intrinsic_sym.attr.referenced = 1;
 572       intrinsic_sym.attr.intrinsic = 1;
 573       intrinsic_sym.attr.function = 1;
 574       intrinsic_sym.result = &intrinsic_sym;
 575       intrinsic_sym.declared_at = where;
 576
 577       symtree4 = gfc_new_symtree (&root4, iname);
 578       symtree4->n.sym = &intrinsic_sym;
 579       gcc_assert (symtree4 == root4);
 580
 581       e4 = gfc_get_expr ();
 582       e4->expr_type = EXPR_FUNCTION;
 583       e4->where = where;
 584       e4->symtree = symtree4;
 585       e4->value.function.isym = gfc_find_function (iname);
 586       e4->value.function.actual = gfc_get_actual_arglist ();
 587       e4->value.function.actual->expr = e3;
 588       e4->value.function.actual->next = gfc_get_actual_arglist ();
 589       e4->value.function.actual->next->expr = e1;
 590     }
 591   /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
 592   e1 = gfc_copy_expr (e1);
 593   e3 = gfc_copy_expr (e3);
 594   t = gfc_resolve_expr (e4);
 595   gcc_assert (t == SUCCESS);
 596
 597   /* Create the init statement list.  */
 598   pushlevel (0);
 599   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
 600       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
 601     {
 602       /* If decl is an allocatable array, it needs to be allocated
 603          with the same bounds as the outer var.  */
 604       tree type = TREE_TYPE (decl), rank, size, esize, ptr;
 605       stmtblock_t block;
 606
 607       gfc_start_block (&block);
 608
 609       gfc_add_modify (&block, decl, outer_sym.backend_decl);
 610       rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 611       size = gfc_conv_descriptor_ubound_get (decl, rank);
 612       size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
 613                           gfc_conv_descriptor_lbound_get (decl, rank));
 614       size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 615                           gfc_index_one_node);
 616       if (GFC_TYPE_ARRAY_RANK (type) > 1)
 617         size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
 618                             gfc_conv_descriptor_stride_get (decl, rank));
 619       esize = fold_convert (gfc_array_index_type,
 620                             TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 621       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
 622       size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
 623       ptr = gfc_allocate_array_with_status (&block,
 624                                             build_int_cst (pvoid_type_node, 0),
 625                                             size, NULL, NULL);
 626       gfc_conv_descriptor_data_set (&block, decl, ptr);
 627       gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
 628       stmt = gfc_finish_block (&block);
 629     }
 630   else
 631     stmt = gfc_trans_assignment (e1, e2, false);
 632   if (TREE_CODE (stmt) != BIND_EXPR)
 633     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
 634   else
 635     poplevel (0, 0, 0);
 636   OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
 637
 638   /* Create the merge statement list.  */
 639   pushlevel (0);
 640   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
 641       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
 642     {
 643       /* If decl is an allocatable array, it needs to be deallocated
 644          afterwards.  */
 645       stmtblock_t block;
 646
 647       gfc_start_block (&block);
 648       gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
 649       gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
 650       stmt = gfc_finish_block (&block);
 651     }
 652   else
 653     stmt = gfc_trans_assignment (e3, e4, false);
 654   if (TREE_CODE (stmt) != BIND_EXPR)
 655     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
 656   else
 657     poplevel (0, 0, 0);
 658   OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
 659
 660   /* And stick the placeholder VAR_DECL into the clause as well.  */
 661   OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
 662
 663   gfc_current_locus = old_loc;
 664
 665   gfc_free_expr (e1);
 666   gfc_free_expr (e2);
 667   gfc_free_expr (e3);
 668   gfc_free_expr (e4);
 669   gfc_free (symtree1);
 670   gfc_free (symtree2);
 671   gfc_free (symtree3);
 672   if (symtree4)
 673     gfc_free (symtree4);
 674   gfc_free_array_spec (outer_sym.as);
 675 }
 676
 677 static tree
 678 gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
 679                               enum tree_code reduction_code, locus where)
 680 {
 681   for (; namelist != NULL; namelist = namelist->next)
 682     if (namelist->sym->attr.referenced)
 683       {
 684         tree t = gfc_trans_omp_variable (namelist->sym);
 685         if (t != error_mark_node)
 686           {
 687             tree node = build_omp_clause (where.lb->location,
 688                                           OMP_CLAUSE_REDUCTION);
 689             OMP_CLAUSE_DECL (node) = t;
 690             OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
 691             if (namelist->sym->attr.dimension)
 692               gfc_trans_omp_array_reduction (node, namelist->sym, where);
 693             list = gfc_trans_add_clause (node, list);
 694           }
 695       }
 696   return list;
 697 }
 698
 699 static tree
 700 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 701                        locus where)
 702 {
 703   tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
 704   int list;
 705   enum omp_clause_code clause_code;
 706   gfc_se se;
 707
 708   if (clauses == NULL)
 709     return NULL_TREE;
 710
 711   for (list = 0; list < OMP_LIST_NUM; list++)
 712     {
 713       gfc_namelist *n = clauses->lists[list];
 714
 715       if (n == NULL)
 716         continue;
 717       if (list >= OMP_LIST_REDUCTION_FIRST
 718           && list <= OMP_LIST_REDUCTION_LAST)
 719         {
 720           enum tree_code reduction_code;
 721           switch (list)
 722             {
 723             case OMP_LIST_PLUS:
 724               reduction_code = PLUS_EXPR;
 725               break;
 726             case OMP_LIST_MULT:
 727               reduction_code = MULT_EXPR;
 728               break;
 729             case OMP_LIST_SUB:
 730               reduction_code = MINUS_EXPR;
 731               break;
 732             case OMP_LIST_AND:
 733               reduction_code = TRUTH_ANDIF_EXPR;
 734               break;
 735             case OMP_LIST_OR:
 736               reduction_code = TRUTH_ORIF_EXPR;
 737               break;
 738             case OMP_LIST_EQV:
 739               reduction_code = EQ_EXPR;
 740               break;
 741             case OMP_LIST_NEQV:
 742               reduction_code = NE_EXPR;
 743               break;
 744             case OMP_LIST_MAX:
 745               reduction_code = MAX_EXPR;
 746               break;
 747             case OMP_LIST_MIN:
 748               reduction_code = MIN_EXPR;
 749               break;
 750             case OMP_LIST_IAND:
 751               reduction_code = BIT_AND_EXPR;
 752               break;
 753             case OMP_LIST_IOR:
 754               reduction_code = BIT_IOR_EXPR;
 755               break;
 756             case OMP_LIST_IEOR:
 757               reduction_code = BIT_XOR_EXPR;
 758               break;
 759             default:
 760               gcc_unreachable ();
 761             }
 762           old_clauses = omp_clauses;
 763           omp_clauses
 764             = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
 765                                             where);
 766           continue;
 767         }
 768       switch (list)
 769         {
 770         case OMP_LIST_PRIVATE:
 771           clause_code = OMP_CLAUSE_PRIVATE;
 772           goto add_clause;
 773         case OMP_LIST_SHARED:
 774           clause_code = OMP_CLAUSE_SHARED;
 775           goto add_clause;
 776         case OMP_LIST_FIRSTPRIVATE:
 777           clause_code = OMP_CLAUSE_FIRSTPRIVATE;
 778           goto add_clause;
 779         case OMP_LIST_LASTPRIVATE:
 780           clause_code = OMP_CLAUSE_LASTPRIVATE;
 781           goto add_clause;
 782         case OMP_LIST_COPYIN:
 783           clause_code = OMP_CLAUSE_COPYIN;
 784           goto add_clause;
 785         case OMP_LIST_COPYPRIVATE:
 786           clause_code = OMP_CLAUSE_COPYPRIVATE;
 787           /* FALLTHROUGH */
 788         add_clause:
 789           omp_clauses
 790             = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
 791           break;
 792         default:
 793           break;
 794         }
 795     }
 796
 797   if (clauses->if_expr)
 798     {
 799       tree if_var;
 800
 801       gfc_init_se (&se, NULL);
 802       gfc_conv_expr (&se, clauses->if_expr);
 803       gfc_add_block_to_block (block, &se.pre);
 804       if_var = gfc_evaluate_now (se.expr, block);
 805       gfc_add_block_to_block (block, &se.post);
 806
 807       c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
 808       OMP_CLAUSE_IF_EXPR (c) = if_var;
 809       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 810     }
 811
 812   if (clauses->num_threads)
 813     {
 814       tree num_threads;
 815
 816       gfc_init_se (&se, NULL);
 817       gfc_conv_expr (&se, clauses->num_threads);
 818       gfc_add_block_to_block (block, &se.pre);
 819       num_threads = gfc_evaluate_now (se.expr, block);
 820       gfc_add_block_to_block (block, &se.post);
 821
 822       c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
 823       OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
 824       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 825     }
 826
 827   chunk_size = NULL_TREE;
 828   if (clauses->chunk_size)
 829     {
 830       gfc_init_se (&se, NULL);
 831       gfc_conv_expr (&se, clauses->chunk_size);
 832       gfc_add_block_to_block (block, &se.pre);
 833       chunk_size = gfc_evaluate_now (se.expr, block);
 834       gfc_add_block_to_block (block, &se.post);
 835     }
 836
 837   if (clauses->sched_kind != OMP_SCHED_NONE)
 838     {
 839       c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
 840       OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
 841       switch (clauses->sched_kind)
 842         {
 843         case OMP_SCHED_STATIC:
 844           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
 845           break;
 846         case OMP_SCHED_DYNAMIC:
 847           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
 848           break;
 849         case OMP_SCHED_GUIDED:
 850           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
 851           break;
 852         case OMP_SCHED_RUNTIME:
 853           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
 854           break;
 855         case OMP_SCHED_AUTO:
 856           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
 857           break;
 858         default:
 859           gcc_unreachable ();
 860         }
 861       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 862     }
 863
 864   if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
 865     {
 866       c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
 867       switch (clauses->default_sharing)
 868         {
 869         case OMP_DEFAULT_NONE:
 870           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
 871           break;
 872         case OMP_DEFAULT_SHARED:
 873           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
 874           break;
 875         case OMP_DEFAULT_PRIVATE:
 876           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
 877           break;
 878         case OMP_DEFAULT_FIRSTPRIVATE:
 879           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
 880           break;
 881         default:
 882           gcc_unreachable ();
 883         }
 884       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 885     }
 886
 887   if (clauses->nowait)
 888     {
 889       c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
 890       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 891     }
 892
 893   if (clauses->ordered)
 894     {
 895       c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
 896       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 897     }
 898
 899   if (clauses->untied)
 900     {
 901       c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
 902       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 903     }
 904
 905   if (clauses->collapse)
 906     {
 907       c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
 908       OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse);
 909       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 910     }
 911
 912   return omp_clauses;
 913 }
 914
 915 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it.  */
 916
 917 static tree
 918 gfc_trans_omp_code (gfc_code *code, bool force_empty)
 919 {
 920   tree stmt;
 921
 922   pushlevel (0);
 923   stmt = gfc_trans_code (code);
 924   if (TREE_CODE (stmt) != BIND_EXPR)
 925     {
 926       if (!IS_EMPTY_STMT (stmt) || force_empty)
 927         {
 928           tree block = poplevel (1, 0, 0);
 929           stmt = build3_v (BIND_EXPR, NULL, stmt, block);
 930         }
 931       else
 932         poplevel (0, 0, 0);
 933     }
 934   else
 935     poplevel (0, 0, 0);
 936   return stmt;
 937 }
 938
 939
 940 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
 941 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
 942
 943 static tree
 944 gfc_trans_omp_atomic (gfc_code *code)
 945 {
 946   gfc_se lse;
 947   gfc_se rse;
 948   gfc_expr *expr2, *e;
 949   gfc_symbol *var;
 950   stmtblock_t block;
 951   tree lhsaddr, type, rhs, x;
 952   enum tree_code op = ERROR_MARK;
 953   bool var_on_left = false;
 954
 955   code = code->block->next;
 956   gcc_assert (code->op == EXEC_ASSIGN);
 957   gcc_assert (code->next == NULL);
 958   var = code->expr1->symtree->n.sym;
 959
 960   gfc_init_se (&lse, NULL);
 961   gfc_init_se (&rse, NULL);
 962   gfc_start_block (&block);
 963
 964   gfc_conv_expr (&lse, code->expr1);
 965   gfc_add_block_to_block (&block, &lse.pre);
 966   type = TREE_TYPE (lse.expr);
 967   lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
 968
 969   expr2 = code->expr2;
 970   if (expr2->expr_type == EXPR_FUNCTION
 971       && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
 972     expr2 = expr2->value.function.actual->expr;
 973
 974   if (expr2->expr_type == EXPR_OP)
 975     {
 976       gfc_expr *e;
 977       switch (expr2->value.op.op)
 978         {
 979         case INTRINSIC_PLUS:
 980           op = PLUS_EXPR;
 981           break;
 982         case INTRINSIC_TIMES:
 983           op = MULT_EXPR;
 984           break;
 985         case INTRINSIC_MINUS:
 986           op = MINUS_EXPR;
 987           break;
 988         case INTRINSIC_DIVIDE:
 989           if (expr2->ts.type == BT_INTEGER)
 990             op = TRUNC_DIV_EXPR;
 991           else
 992             op = RDIV_EXPR;
 993           break;
 994         case INTRINSIC_AND:
 995           op = TRUTH_ANDIF_EXPR;
 996           break;
 997         case INTRINSIC_OR:
 998           op = TRUTH_ORIF_EXPR;
 999           break;
1000         case INTRINSIC_EQV:
1001           op = EQ_EXPR;
1002           break;
1003         case INTRINSIC_NEQV:
1004           op = NE_EXPR;
1005           break;
1006         default:
1007           gcc_unreachable ();
1008         }
1009       e = expr2->value.op.op1;
1010       if (e->expr_type == EXPR_FUNCTION
1011           && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1012         e = e->value.function.actual->expr;
1013       if (e->expr_type == EXPR_VARIABLE
1014           && e->symtree != NULL
1015           && e->symtree->n.sym == var)
1016         {
1017           expr2 = expr2->value.op.op2;
1018           var_on_left = true;
1019         }
1020       else
1021         {
1022           e = expr2->value.op.op2;
1023           if (e->expr_type == EXPR_FUNCTION
1024               && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1025             e = e->value.function.actual->expr;
1026           gcc_assert (e->expr_type == EXPR_VARIABLE
1027                       && e->symtree != NULL
1028                       && e->symtree->n.sym == var);
1029           expr2 = expr2->value.op.op1;
1030           var_on_left = false;
1031         }
1032       gfc_conv_expr (&rse, expr2);
1033       gfc_add_block_to_block (&block, &rse.pre);
1034     }
1035   else
1036     {
1037       gcc_assert (expr2->expr_type == EXPR_FUNCTION);
1038       switch (expr2->value.function.isym->id)
1039         {
1040         case GFC_ISYM_MIN:
1041           op = MIN_EXPR;
1042           break;
1043         case GFC_ISYM_MAX:
1044           op = MAX_EXPR;
1045           break;
1046         case GFC_ISYM_IAND:
1047           op = BIT_AND_EXPR;
1048           break;
1049         case GFC_ISYM_IOR:
1050           op = BIT_IOR_EXPR;
1051           break;
1052         case GFC_ISYM_IEOR:
1053           op = BIT_XOR_EXPR;
1054           break;
1055         default:
1056           gcc_unreachable ();
1057         }
1058       e = expr2->value.function.actual->expr;
1059       gcc_assert (e->expr_type == EXPR_VARIABLE
1060                   && e->symtree != NULL
1061                   && e->symtree->n.sym == var);
1062
1063       gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
1064       gfc_add_block_to_block (&block, &rse.pre);
1065       if (expr2->value.function.actual->next->next != NULL)
1066         {
1067           tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
1068           gfc_actual_arglist *arg;
1069
1070           gfc_add_modify (&block, accum, rse.expr);
1071           for (arg = expr2->value.function.actual->next->next; arg;
1072                arg = arg->next)
1073             {
1074               gfc_init_block (&rse.pre);
1075               gfc_conv_expr (&rse, arg->expr);
1076               gfc_add_block_to_block (&block, &rse.pre);
1077               x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
1078               gfc_add_modify (&block, accum, x);
1079             }
1080
1081           rse.expr = accum;
1082         }
1083
1084       expr2 = expr2->value.function.actual->next->expr;
1085     }
1086
1087   lhsaddr = save_expr (lhsaddr);
1088   rhs = gfc_evaluate_now (rse.expr, &block);
1089   x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
1090                                                          lhsaddr));
1091
1092   if (var_on_left)
1093     x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
1094   else
1095     x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
1096
1097   if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
1098       && TREE_CODE (type) != COMPLEX_TYPE)
1099     x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
1100
1101   x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
1102   gfc_add_expr_to_block (&block, x);
1103
1104   gfc_add_block_to_block (&block, &lse.pre);
1105   gfc_add_block_to_block (&block, &rse.pre);
1106
1107   return gfc_finish_block (&block);
1108 }
1109
1110 static tree
1111 gfc_trans_omp_barrier (void)
1112 {
1113   tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
1114   return build_call_expr_loc (input_location, decl, 0);
1115 }
1116
1117 static tree
1118 gfc_trans_omp_critical (gfc_code *code)
1119 {
1120   tree name = NULL_TREE, stmt;
1121   if (code->ext.omp_name != NULL)
1122     name = get_identifier (code->ext.omp_name);
1123   stmt = gfc_trans_code (code->block->next);
1124   return build2 (OMP_CRITICAL, void_type_node, stmt, name);
1125 }
1126
1127 static tree
1128 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
1129                   gfc_omp_clauses *do_clauses, tree par_clauses)
1130 {
1131   gfc_se se;
1132   tree dovar, stmt, from, to, step, type, init, cond, incr;
1133   tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
1134   stmtblock_t block;
1135   stmtblock_t body;
1136   gfc_omp_clauses *clauses = code->ext.omp_clauses;
1137   gfc_code *outermost;
1138   int i, collapse = clauses->collapse;
1139   tree dovar_init = NULL_TREE;
1140
1141   if (collapse <= 0)
1142     collapse = 1;
1143
1144   outermost = code = code->block->next;
1145   gcc_assert (code->op == EXEC_DO);
1146
1147   init = make_tree_vec (collapse);
1148   cond = make_tree_vec (collapse);
1149   incr = make_tree_vec (collapse);
1150
1151   if (pblock == NULL)
1152     {
1153       gfc_start_block (&block);
1154       pblock = &block;
1155     }
1156
1157   omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
1158
1159   for (i = 0; i < collapse; i++)
1160     {
1161       int simple = 0;
1162       int dovar_found = 0;
1163
1164       if (clauses)
1165         {
1166           gfc_namelist *n;
1167           for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
1168                n = n->next)
1169             if (code->ext.iterator->var->symtree->n.sym == n->sym)
1170               break;
1171           if (n != NULL)
1172             dovar_found = 1;
1173           else if (n == NULL)
1174             for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
1175               if (code->ext.iterator->var->symtree->n.sym == n->sym)
1176                 break;
1177           if (n != NULL)
1178             dovar_found++;
1179         }
1180
1181       /* Evaluate all the expressions in the iterator.  */
1182       gfc_init_se (&se, NULL);
1183       gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1184       gfc_add_block_to_block (pblock, &se.pre);
1185       dovar = se.expr;
1186       type = TREE_TYPE (dovar);
1187       gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
1188
1189       gfc_init_se (&se, NULL);
1190       gfc_conv_expr_val (&se, code->ext.iterator->start);
1191       gfc_add_block_to_block (pblock, &se.pre);
1192       from = gfc_evaluate_now (se.expr, pblock);
1193
1194       gfc_init_se (&se, NULL);
1195       gfc_conv_expr_val (&se, code->ext.iterator->end);
1196       gfc_add_block_to_block (pblock, &se.pre);
1197       to = gfc_evaluate_now (se.expr, pblock);
1198
1199       gfc_init_se (&se, NULL);
1200       gfc_conv_expr_val (&se, code->ext.iterator->step);
1201       gfc_add_block_to_block (pblock, &se.pre);
1202       step = gfc_evaluate_now (se.expr, pblock);
1203
1204       /* Special case simple loops.  */
1205       if (integer_onep (step))
1206         simple = 1;
1207       else if (tree_int_cst_equal (step, integer_minus_one_node))
1208         simple = -1;
1209
1210       /* Loop body.  */
1211       if (simple)
1212         {
1213           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
1214           TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR,
1215                                                 boolean_type_node, dovar, to);
1216           TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step);
1217           TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar,
1218                                                 TREE_VEC_ELT (incr, i));
1219         }
1220       else
1221         {
1222           /* STEP is not 1 or -1.  Use:
1223              for (count = 0; count < (to + step - from) / step; count++)
1224                {
1225                  dovar = from + count * step;
1226                  body;
1227                cycle_label:;
1228                }  */
1229           tmp = fold_build2 (MINUS_EXPR, type, step, from);
1230           tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
1231           tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
1232           tmp = gfc_evaluate_now (tmp, pblock);
1233           count = gfc_create_var (type, "count");
1234           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
1235                                              build_int_cst (type, 0));
1236           TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node,
1237                                                 count, tmp);
1238           TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count,
1239                                                 build_int_cst (type, 1));
1240           TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type,
1241                                                 count, TREE_VEC_ELT (incr, i));
1242
1243           /* Initialize DOVAR.  */
1244           tmp = fold_build2 (MULT_EXPR, type, count, step);
1245           tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
1246           dovar_init = tree_cons (dovar, tmp, dovar_init);
1247         }
1248
1249       if (!dovar_found)
1250         {
1251           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1252           OMP_CLAUSE_DECL (tmp) = dovar;
1253           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1254         }
1255       else if (dovar_found == 2)
1256         {
1257           tree c = NULL;
1258
1259           tmp = NULL;
1260           if (!simple)
1261             {
1262               /* If dovar is lastprivate, but different counter is used,
1263                  dovar += step needs to be added to
1264                  OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
1265                  will have the value on entry of the last loop, rather
1266                  than value after iterator increment.  */
1267               tmp = gfc_evaluate_now (step, pblock);
1268               tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp);
1269               tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp);
1270               for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1271                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1272                     && OMP_CLAUSE_DECL (c) == dovar)
1273                   {
1274                     OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
1275                     break;
1276                   }
1277             }
1278           if (c == NULL && par_clauses != NULL)
1279             {
1280               for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1281                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1282                     && OMP_CLAUSE_DECL (c) == dovar)
1283                   {
1284                     tree l = build_omp_clause (input_location,
1285                                                OMP_CLAUSE_LASTPRIVATE);
1286                     OMP_CLAUSE_DECL (l) = dovar;
1287                     OMP_CLAUSE_CHAIN (l) = omp_clauses;
1288                     OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
1289                     omp_clauses = l;
1290                     OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
1291                     break;
1292                   }
1293             }
1294           gcc_assert (simple || c != NULL);
1295         }
1296       if (!simple)
1297         {
1298           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1299           OMP_CLAUSE_DECL (tmp) = count;
1300           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1301         }
1302
1303       if (i + 1 < collapse)
1304         code = code->block->next;
1305     }
1306
1307   if (pblock != &block)
1308     {
1309       pushlevel (0);
1310       gfc_start_block (&block);
1311     }
1312
1313   gfc_start_block (&body);
1314
1315   dovar_init = nreverse (dovar_init);
1316   while (dovar_init)
1317     {
1318       gfc_add_modify (&body, TREE_PURPOSE (dovar_init),
1319                            TREE_VALUE (dovar_init));
1320       dovar_init = TREE_CHAIN (dovar_init);
1321     }
1322
1323   /* Cycle statement is implemented with a goto.  Exit statement must not be
1324      present for this loop.  */
1325   cycle_label = gfc_build_label_decl (NULL_TREE);
1326
1327   /* Put these labels where they can be found later. We put the
1328      labels in a TREE_LIST node (because TREE_CHAIN is already
1329      used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
1330      label in TREE_VALUE (backend_decl).  */
1331
1332   code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
1333
1334   /* Main loop body.  */
1335   tmp = gfc_trans_omp_code (code->block->next, true);
1336   gfc_add_expr_to_block (&body, tmp);
1337
1338   /* Label for cycle statements (if needed).  */
1339   if (TREE_USED (cycle_label))
1340     {
1341       tmp = build1_v (LABEL_EXPR, cycle_label);
1342       gfc_add_expr_to_block (&body, tmp);
1343     }
1344
1345   /* End of loop body.  */
1346   stmt = make_node (OMP_FOR);
1347
1348   TREE_TYPE (stmt) = void_type_node;
1349   OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1350   OMP_FOR_CLAUSES (stmt) = omp_clauses;
1351   OMP_FOR_INIT (stmt) = init;
1352   OMP_FOR_COND (stmt) = cond;
1353   OMP_FOR_INCR (stmt) = incr;
1354   gfc_add_expr_to_block (&block, stmt);
1355
1356   return gfc_finish_block (&block);
1357 }
1358
1359 static tree
1360 gfc_trans_omp_flush (void)
1361 {
1362   tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
1363   return build_call_expr_loc (input_location, decl, 0);
1364 }
1365
1366 static tree
1367 gfc_trans_omp_master (gfc_code *code)
1368 {
1369   tree stmt = gfc_trans_code (code->block->next);
1370   if (IS_EMPTY_STMT (stmt))
1371     return stmt;
1372   return build1_v (OMP_MASTER, stmt);
1373 }
1374
1375 static tree
1376 gfc_trans_omp_ordered (gfc_code *code)
1377 {
1378   return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1379 }
1380
1381 static tree
1382 gfc_trans_omp_parallel (gfc_code *code)
1383 {
1384   stmtblock_t block;
1385   tree stmt, omp_clauses;
1386
1387   gfc_start_block (&block);
1388   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1389                                        code->loc);
1390   stmt = gfc_trans_omp_code (code->block->next, true);
1391   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1392   gfc_add_expr_to_block (&block, stmt);
1393   return gfc_finish_block (&block);
1394 }
1395
1396 static tree
1397 gfc_trans_omp_parallel_do (gfc_code *code)
1398 {
1399   stmtblock_t block, *pblock = NULL;
1400   gfc_omp_clauses parallel_clauses, do_clauses;
1401   tree stmt, omp_clauses = NULL_TREE;
1402
1403   gfc_start_block (&block);
1404
1405   memset (&do_clauses, 0, sizeof (do_clauses));
1406   if (code->ext.omp_clauses != NULL)
1407     {
1408       memcpy (&parallel_clauses, code->ext.omp_clauses,
1409               sizeof (parallel_clauses));
1410       do_clauses.sched_kind = parallel_clauses.sched_kind;
1411       do_clauses.chunk_size = parallel_clauses.chunk_size;
1412       do_clauses.ordered = parallel_clauses.ordered;
1413       do_clauses.collapse = parallel_clauses.collapse;
1414       parallel_clauses.sched_kind = OMP_SCHED_NONE;
1415       parallel_clauses.chunk_size = NULL;
1416       parallel_clauses.ordered = false;
1417       parallel_clauses.collapse = 0;
1418       omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
1419                                            code->loc);
1420     }
1421   do_clauses.nowait = true;
1422   if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1423     pblock = &block;
1424   else
1425     pushlevel (0);
1426   stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
1427   if (TREE_CODE (stmt) != BIND_EXPR)
1428     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1429   else
1430     poplevel (0, 0, 0);
1431   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1432   OMP_PARALLEL_COMBINED (stmt) = 1;
1433   gfc_add_expr_to_block (&block, stmt);
1434   return gfc_finish_block (&block);
1435 }
1436
1437 static tree
1438 gfc_trans_omp_parallel_sections (gfc_code *code)
1439 {
1440   stmtblock_t block;
1441   gfc_omp_clauses section_clauses;
1442   tree stmt, omp_clauses;
1443
1444   memset (&section_clauses, 0, sizeof (section_clauses));
1445   section_clauses.nowait = true;
1446
1447   gfc_start_block (&block);
1448   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1449                                        code->loc);
1450   pushlevel (0);
1451   stmt = gfc_trans_omp_sections (code, &section_clauses);
1452   if (TREE_CODE (stmt) != BIND_EXPR)
1453     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1454   else
1455     poplevel (0, 0, 0);
1456   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1457   OMP_PARALLEL_COMBINED (stmt) = 1;
1458   gfc_add_expr_to_block (&block, stmt);
1459   return gfc_finish_block (&block);
1460 }
1461
1462 static tree
1463 gfc_trans_omp_parallel_workshare (gfc_code *code)
1464 {
1465   stmtblock_t block;
1466   gfc_omp_clauses workshare_clauses;
1467   tree stmt, omp_clauses;
1468
1469   memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1470   workshare_clauses.nowait = true;
1471
1472   gfc_start_block (&block);
1473   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1474                                        code->loc);
1475   pushlevel (0);
1476   stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1477   if (TREE_CODE (stmt) != BIND_EXPR)
1478     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1479   else
1480     poplevel (0, 0, 0);
1481   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1482   OMP_PARALLEL_COMBINED (stmt) = 1;
1483   gfc_add_expr_to_block (&block, stmt);
1484   return gfc_finish_block (&block);
1485 }
1486
1487 static tree
1488 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1489 {
1490   stmtblock_t block, body;
1491   tree omp_clauses, stmt;
1492   bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1493
1494   gfc_start_block (&block);
1495
1496   omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1497
1498   gfc_init_block (&body);
1499   for (code = code->block; code; code = code->block)
1500     {
1501       /* Last section is special because of lastprivate, so even if it
1502          is empty, chain it in.  */
1503       stmt = gfc_trans_omp_code (code->next,
1504                                  has_lastprivate && code->block == NULL);
1505       if (! IS_EMPTY_STMT (stmt))
1506         {
1507           stmt = build1_v (OMP_SECTION, stmt);
1508           gfc_add_expr_to_block (&body, stmt);
1509         }
1510     }
1511   stmt = gfc_finish_block (&body);
1512
1513   stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
1514   gfc_add_expr_to_block (&block, stmt);
1515
1516   return gfc_finish_block (&block);
1517 }
1518
1519 static tree
1520 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1521 {
1522   tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1523   tree stmt = gfc_trans_omp_code (code->block->next, true);
1524   stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses);
1525   return stmt;
1526 }
1527
1528 static tree
1529 gfc_trans_omp_task (gfc_code *code)
1530 {
1531   stmtblock_t block;
1532   tree stmt, omp_clauses;
1533
1534   gfc_start_block (&block);
1535   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1536                                        code->loc);
1537   stmt = gfc_trans_omp_code (code->block->next, true);
1538   stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
1539   gfc_add_expr_to_block (&block, stmt);
1540   return gfc_finish_block (&block);
1541 }
1542
1543 static tree
1544 gfc_trans_omp_taskwait (void)
1545 {
1546   tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
1547   return build_call_expr_loc (input_location, decl, 0);
1548 }
1549
1550 static tree
1551 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1552 {
1553   tree res, tmp, stmt;
1554   stmtblock_t block, *pblock = NULL;
1555   stmtblock_t singleblock;
1556   int saved_ompws_flags;
1557   bool singleblock_in_progress = false;
1558   /* True if previous gfc_code in workshare construct is not workshared.  */
1559   bool prev_singleunit;
1560
1561   code = code->block->next;
1562
1563   pushlevel (0);
1564
1565   if (!code)
1566     return build_empty_stmt (input_location);
1567
1568   gfc_start_block (&block);
1569   pblock = &block;
1570
1571   ompws_flags = OMPWS_WORKSHARE_FLAG;
1572   prev_singleunit = false;
1573
1574   /* Translate statements one by one to trees until we reach
1575      the end of the workshare construct.  Adjacent gfc_codes that
1576      are a single unit of work are clustered and encapsulated in a
1577      single OMP_SINGLE construct.  */
1578   for (; code; code = code->next)
1579     {
1580       if (code->here != 0)
1581         {
1582           res = gfc_trans_label_here (code);
1583           gfc_add_expr_to_block (pblock, res);
1584         }
1585
1586       /* No dependence analysis, use for clauses with wait.
1587          If this is the last gfc_code, use default omp_clauses.  */
1588       if (code->next == NULL && clauses->nowait)
1589         ompws_flags |= OMPWS_NOWAIT;
1590
1591       /* By default, every gfc_code is a single unit of work.  */
1592       ompws_flags |= OMPWS_CURR_SINGLEUNIT;
1593       ompws_flags &= ~OMPWS_SCALARIZER_WS;
1594
1595       switch (code->op)
1596         {
1597         case EXEC_NOP:
1598           res = NULL_TREE;
1599           break;
1600
1601         case EXEC_ASSIGN:
1602           res = gfc_trans_assign (code);
1603           break;
1604
1605         case EXEC_POINTER_ASSIGN:
1606           res = gfc_trans_pointer_assign (code);
1607           break;
1608
1609         case EXEC_INIT_ASSIGN:
1610           res = gfc_trans_init_assign (code);
1611           break;
1612
1613         case EXEC_FORALL:
1614           res = gfc_trans_forall (code);
1615           break;
1616
1617         case EXEC_WHERE:
1618           res = gfc_trans_where (code);
1619           break;
1620
1621         case EXEC_OMP_ATOMIC:
1622           res = gfc_trans_omp_directive (code);
1623           break;
1624
1625         case EXEC_OMP_PARALLEL:
1626         case EXEC_OMP_PARALLEL_DO:
1627         case EXEC_OMP_PARALLEL_SECTIONS:
1628         case EXEC_OMP_PARALLEL_WORKSHARE:
1629         case EXEC_OMP_CRITICAL:
1630           saved_ompws_flags = ompws_flags;
1631           ompws_flags = 0;
1632           res = gfc_trans_omp_directive (code);
1633           ompws_flags = saved_ompws_flags;
1634           break;
1635
1636         default:
1637           internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1638         }
1639
1640       gfc_set_backend_locus (&code->loc);
1641
1642       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1643         {
1644           if (prev_singleunit)
1645             {
1646               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1647                 /* Add current gfc_code to single block.  */
1648                 gfc_add_expr_to_block (&singleblock, res);
1649               else
1650                 {
1651                   /* Finish single block and add it to pblock.  */
1652                   tmp = gfc_finish_block (&singleblock);
1653                   tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
1654                   gfc_add_expr_to_block (pblock, tmp);
1655                   /* Add current gfc_code to pblock.  */
1656                   gfc_add_expr_to_block (pblock, res);
1657                   singleblock_in_progress = false;
1658                 }
1659             }
1660           else
1661             {
1662               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1663                 {
1664                   /* Start single block.  */
1665                   gfc_init_block (&singleblock);
1666                   gfc_add_expr_to_block (&singleblock, res);
1667                   singleblock_in_progress = true;
1668                 }
1669               else
1670                 /* Add the new statement to the block.  */
1671                 gfc_add_expr_to_block (pblock, res);
1672             }
1673           prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
1674         }
1675     }
1676
1677   /* Finish remaining SINGLE block, if we were in the middle of one.  */
1678   if (singleblock_in_progress)
1679     {
1680       /* Finish single block and add it to pblock.  */
1681       tmp = gfc_finish_block (&singleblock);
1682       tmp = build2 (OMP_SINGLE, void_type_node, tmp,
1683                     clauses->nowait
1684                     ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
1685                     : NULL_TREE);
1686       gfc_add_expr_to_block (pblock, tmp);
1687     }
1688
1689   stmt = gfc_finish_block (pblock);
1690   if (TREE_CODE (stmt) != BIND_EXPR)
1691     {
1692       if (!IS_EMPTY_STMT (stmt))
1693         {
1694           tree bindblock = poplevel (1, 0, 0);
1695           stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
1696         }
1697       else
1698         poplevel (0, 0, 0);
1699     }
1700   else
1701     poplevel (0, 0, 0);
1702
1703   ompws_flags = 0;
1704   return stmt;
1705 }
1706
1707 tree
1708 gfc_trans_omp_directive (gfc_code *code)
1709 {
1710   switch (code->op)
1711     {
1712     case EXEC_OMP_ATOMIC:
1713       return gfc_trans_omp_atomic (code);
1714     case EXEC_OMP_BARRIER:
1715       return gfc_trans_omp_barrier ();
1716     case EXEC_OMP_CRITICAL:
1717       return gfc_trans_omp_critical (code);
1718     case EXEC_OMP_DO:
1719       return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
1720     case EXEC_OMP_FLUSH:
1721       return gfc_trans_omp_flush ();
1722     case EXEC_OMP_MASTER:
1723       return gfc_trans_omp_master (code);
1724     case EXEC_OMP_ORDERED:
1725       return gfc_trans_omp_ordered (code);
1726     case EXEC_OMP_PARALLEL:
1727       return gfc_trans_omp_parallel (code);
1728     case EXEC_OMP_PARALLEL_DO:
1729       return gfc_trans_omp_parallel_do (code);
1730     case EXEC_OMP_PARALLEL_SECTIONS:
1731       return gfc_trans_omp_parallel_sections (code);
1732     case EXEC_OMP_PARALLEL_WORKSHARE:
1733       return gfc_trans_omp_parallel_workshare (code);
1734     case EXEC_OMP_SECTIONS:
1735       return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1736     case EXEC_OMP_SINGLE:
1737       return gfc_trans_omp_single (code, code->ext.omp_clauses);
1738     case EXEC_OMP_TASK:
1739       return gfc_trans_omp_task (code);
1740     case EXEC_OMP_TASKWAIT:
1741       return gfc_trans_omp_taskwait ();
1742     case EXEC_OMP_WORKSHARE:
1743       return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
1744     default:
1745       gcc_unreachable ();
1746     }
1747 }