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       tree dovar_decl;
1164
1165       if (clauses)
1166         {
1167           gfc_namelist *n;
1168           for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
1169                n = n->next)
1170             if (code->ext.iterator->var->symtree->n.sym == n->sym)
1171               break;
1172           if (n != NULL)
1173             dovar_found = 1;
1174           else if (n == NULL)
1175             for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
1176               if (code->ext.iterator->var->symtree->n.sym == n->sym)
1177                 break;
1178           if (n != NULL)
1179             dovar_found++;
1180         }
1181
1182       /* Evaluate all the expressions in the iterator.  */
1183       gfc_init_se (&se, NULL);
1184       gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1185       gfc_add_block_to_block (pblock, &se.pre);
1186       dovar = se.expr;
1187       type = TREE_TYPE (dovar);
1188       gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
1189
1190       gfc_init_se (&se, NULL);
1191       gfc_conv_expr_val (&se, code->ext.iterator->start);
1192       gfc_add_block_to_block (pblock, &se.pre);
1193       from = gfc_evaluate_now (se.expr, pblock);
1194
1195       gfc_init_se (&se, NULL);
1196       gfc_conv_expr_val (&se, code->ext.iterator->end);
1197       gfc_add_block_to_block (pblock, &se.pre);
1198       to = gfc_evaluate_now (se.expr, pblock);
1199
1200       gfc_init_se (&se, NULL);
1201       gfc_conv_expr_val (&se, code->ext.iterator->step);
1202       gfc_add_block_to_block (pblock, &se.pre);
1203       step = gfc_evaluate_now (se.expr, pblock);
1204       dovar_decl = dovar;
1205
1206       /* Special case simple loops.  */
1207       if (TREE_CODE (dovar) == VAR_DECL)
1208         {
1209           if (integer_onep (step))
1210             simple = 1;
1211           else if (tree_int_cst_equal (step, integer_minus_one_node))
1212             simple = -1;
1213         }
1214       else
1215         dovar_decl
1216           = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
1217
1218       /* Loop body.  */
1219       if (simple)
1220         {
1221           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
1222           TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR,
1223                                                 boolean_type_node, dovar, to);
1224           TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step);
1225           TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar,
1226                                                 TREE_VEC_ELT (incr, i));
1227         }
1228       else
1229         {
1230           /* STEP is not 1 or -1.  Use:
1231              for (count = 0; count < (to + step - from) / step; count++)
1232                {
1233                  dovar = from + count * step;
1234                  body;
1235                cycle_label:;
1236                }  */
1237           tmp = fold_build2 (MINUS_EXPR, type, step, from);
1238           tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
1239           tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
1240           tmp = gfc_evaluate_now (tmp, pblock);
1241           count = gfc_create_var (type, "count");
1242           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
1243                                              build_int_cst (type, 0));
1244           TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node,
1245                                                 count, tmp);
1246           TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count,
1247                                                 build_int_cst (type, 1));
1248           TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type,
1249                                                 count, TREE_VEC_ELT (incr, i));
1250
1251           /* Initialize DOVAR.  */
1252           tmp = fold_build2 (MULT_EXPR, type, count, step);
1253           tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
1254           dovar_init = tree_cons (dovar, tmp, dovar_init);
1255         }
1256
1257       if (!dovar_found)
1258         {
1259           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1260           OMP_CLAUSE_DECL (tmp) = dovar_decl;
1261           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1262         }
1263       else if (dovar_found == 2)
1264         {
1265           tree c = NULL;
1266
1267           tmp = NULL;
1268           if (!simple)
1269             {
1270               /* If dovar is lastprivate, but different counter is used,
1271                  dovar += step needs to be added to
1272                  OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
1273                  will have the value on entry of the last loop, rather
1274                  than value after iterator increment.  */
1275               tmp = gfc_evaluate_now (step, pblock);
1276               tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp);
1277               tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp);
1278               for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1279                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1280                     && OMP_CLAUSE_DECL (c) == dovar_decl)
1281                   {
1282                     OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
1283                     break;
1284                   }
1285             }
1286           if (c == NULL && par_clauses != NULL)
1287             {
1288               for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1289                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1290                     && OMP_CLAUSE_DECL (c) == dovar_decl)
1291                   {
1292                     tree l = build_omp_clause (input_location,
1293                                                OMP_CLAUSE_LASTPRIVATE);
1294                     OMP_CLAUSE_DECL (l) = dovar_decl;
1295                     OMP_CLAUSE_CHAIN (l) = omp_clauses;
1296                     OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
1297                     omp_clauses = l;
1298                     OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
1299                     break;
1300                   }
1301             }
1302           gcc_assert (simple || c != NULL);
1303         }
1304       if (!simple)
1305         {
1306           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1307           OMP_CLAUSE_DECL (tmp) = count;
1308           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1309         }
1310
1311       if (i + 1 < collapse)
1312         code = code->block->next;
1313     }
1314
1315   if (pblock != &block)
1316     {
1317       pushlevel (0);
1318       gfc_start_block (&block);
1319     }
1320
1321   gfc_start_block (&body);
1322
1323   dovar_init = nreverse (dovar_init);
1324   while (dovar_init)
1325     {
1326       gfc_add_modify (&body, TREE_PURPOSE (dovar_init),
1327                            TREE_VALUE (dovar_init));
1328       dovar_init = TREE_CHAIN (dovar_init);
1329     }
1330
1331   /* Cycle statement is implemented with a goto.  Exit statement must not be
1332      present for this loop.  */
1333   cycle_label = gfc_build_label_decl (NULL_TREE);
1334
1335   /* Put these labels where they can be found later. We put the
1336      labels in a TREE_LIST node (because TREE_CHAIN is already
1337      used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
1338      label in TREE_VALUE (backend_decl).  */
1339
1340   code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
1341
1342   /* Main loop body.  */
1343   tmp = gfc_trans_omp_code (code->block->next, true);
1344   gfc_add_expr_to_block (&body, tmp);
1345
1346   /* Label for cycle statements (if needed).  */
1347   if (TREE_USED (cycle_label))
1348     {
1349       tmp = build1_v (LABEL_EXPR, cycle_label);
1350       gfc_add_expr_to_block (&body, tmp);
1351     }
1352
1353   /* End of loop body.  */
1354   stmt = make_node (OMP_FOR);
1355
1356   TREE_TYPE (stmt) = void_type_node;
1357   OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1358   OMP_FOR_CLAUSES (stmt) = omp_clauses;
1359   OMP_FOR_INIT (stmt) = init;
1360   OMP_FOR_COND (stmt) = cond;
1361   OMP_FOR_INCR (stmt) = incr;
1362   gfc_add_expr_to_block (&block, stmt);
1363
1364   return gfc_finish_block (&block);
1365 }
1366
1367 static tree
1368 gfc_trans_omp_flush (void)
1369 {
1370   tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
1371   return build_call_expr_loc (input_location, decl, 0);
1372 }
1373
1374 static tree
1375 gfc_trans_omp_master (gfc_code *code)
1376 {
1377   tree stmt = gfc_trans_code (code->block->next);
1378   if (IS_EMPTY_STMT (stmt))
1379     return stmt;
1380   return build1_v (OMP_MASTER, stmt);
1381 }
1382
1383 static tree
1384 gfc_trans_omp_ordered (gfc_code *code)
1385 {
1386   return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1387 }
1388
1389 static tree
1390 gfc_trans_omp_parallel (gfc_code *code)
1391 {
1392   stmtblock_t block;
1393   tree stmt, omp_clauses;
1394
1395   gfc_start_block (&block);
1396   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1397                                        code->loc);
1398   stmt = gfc_trans_omp_code (code->block->next, true);
1399   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1400   gfc_add_expr_to_block (&block, stmt);
1401   return gfc_finish_block (&block);
1402 }
1403
1404 static tree
1405 gfc_trans_omp_parallel_do (gfc_code *code)
1406 {
1407   stmtblock_t block, *pblock = NULL;
1408   gfc_omp_clauses parallel_clauses, do_clauses;
1409   tree stmt, omp_clauses = NULL_TREE;
1410
1411   gfc_start_block (&block);
1412
1413   memset (&do_clauses, 0, sizeof (do_clauses));
1414   if (code->ext.omp_clauses != NULL)
1415     {
1416       memcpy (&parallel_clauses, code->ext.omp_clauses,
1417               sizeof (parallel_clauses));
1418       do_clauses.sched_kind = parallel_clauses.sched_kind;
1419       do_clauses.chunk_size = parallel_clauses.chunk_size;
1420       do_clauses.ordered = parallel_clauses.ordered;
1421       do_clauses.collapse = parallel_clauses.collapse;
1422       parallel_clauses.sched_kind = OMP_SCHED_NONE;
1423       parallel_clauses.chunk_size = NULL;
1424       parallel_clauses.ordered = false;
1425       parallel_clauses.collapse = 0;
1426       omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
1427                                            code->loc);
1428     }
1429   do_clauses.nowait = true;
1430   if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1431     pblock = &block;
1432   else
1433     pushlevel (0);
1434   stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
1435   if (TREE_CODE (stmt) != BIND_EXPR)
1436     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1437   else
1438     poplevel (0, 0, 0);
1439   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1440   OMP_PARALLEL_COMBINED (stmt) = 1;
1441   gfc_add_expr_to_block (&block, stmt);
1442   return gfc_finish_block (&block);
1443 }
1444
1445 static tree
1446 gfc_trans_omp_parallel_sections (gfc_code *code)
1447 {
1448   stmtblock_t block;
1449   gfc_omp_clauses section_clauses;
1450   tree stmt, omp_clauses;
1451
1452   memset (&section_clauses, 0, sizeof (section_clauses));
1453   section_clauses.nowait = true;
1454
1455   gfc_start_block (&block);
1456   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1457                                        code->loc);
1458   pushlevel (0);
1459   stmt = gfc_trans_omp_sections (code, &section_clauses);
1460   if (TREE_CODE (stmt) != BIND_EXPR)
1461     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1462   else
1463     poplevel (0, 0, 0);
1464   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1465   OMP_PARALLEL_COMBINED (stmt) = 1;
1466   gfc_add_expr_to_block (&block, stmt);
1467   return gfc_finish_block (&block);
1468 }
1469
1470 static tree
1471 gfc_trans_omp_parallel_workshare (gfc_code *code)
1472 {
1473   stmtblock_t block;
1474   gfc_omp_clauses workshare_clauses;
1475   tree stmt, omp_clauses;
1476
1477   memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1478   workshare_clauses.nowait = true;
1479
1480   gfc_start_block (&block);
1481   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1482                                        code->loc);
1483   pushlevel (0);
1484   stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1485   if (TREE_CODE (stmt) != BIND_EXPR)
1486     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1487   else
1488     poplevel (0, 0, 0);
1489   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1490   OMP_PARALLEL_COMBINED (stmt) = 1;
1491   gfc_add_expr_to_block (&block, stmt);
1492   return gfc_finish_block (&block);
1493 }
1494
1495 static tree
1496 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1497 {
1498   stmtblock_t block, body;
1499   tree omp_clauses, stmt;
1500   bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1501
1502   gfc_start_block (&block);
1503
1504   omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1505
1506   gfc_init_block (&body);
1507   for (code = code->block; code; code = code->block)
1508     {
1509       /* Last section is special because of lastprivate, so even if it
1510          is empty, chain it in.  */
1511       stmt = gfc_trans_omp_code (code->next,
1512                                  has_lastprivate && code->block == NULL);
1513       if (! IS_EMPTY_STMT (stmt))
1514         {
1515           stmt = build1_v (OMP_SECTION, stmt);
1516           gfc_add_expr_to_block (&body, stmt);
1517         }
1518     }
1519   stmt = gfc_finish_block (&body);
1520
1521   stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
1522   gfc_add_expr_to_block (&block, stmt);
1523
1524   return gfc_finish_block (&block);
1525 }
1526
1527 static tree
1528 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1529 {
1530   tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1531   tree stmt = gfc_trans_omp_code (code->block->next, true);
1532   stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses);
1533   return stmt;
1534 }
1535
1536 static tree
1537 gfc_trans_omp_task (gfc_code *code)
1538 {
1539   stmtblock_t block;
1540   tree stmt, omp_clauses;
1541
1542   gfc_start_block (&block);
1543   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1544                                        code->loc);
1545   stmt = gfc_trans_omp_code (code->block->next, true);
1546   stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
1547   gfc_add_expr_to_block (&block, stmt);
1548   return gfc_finish_block (&block);
1549 }
1550
1551 static tree
1552 gfc_trans_omp_taskwait (void)
1553 {
1554   tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
1555   return build_call_expr_loc (input_location, decl, 0);
1556 }
1557
1558 static tree
1559 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1560 {
1561   tree res, tmp, stmt;
1562   stmtblock_t block, *pblock = NULL;
1563   stmtblock_t singleblock;
1564   int saved_ompws_flags;
1565   bool singleblock_in_progress = false;
1566   /* True if previous gfc_code in workshare construct is not workshared.  */
1567   bool prev_singleunit;
1568
1569   code = code->block->next;
1570
1571   pushlevel (0);
1572
1573   if (!code)
1574     return build_empty_stmt (input_location);
1575
1576   gfc_start_block (&block);
1577   pblock = &block;
1578
1579   ompws_flags = OMPWS_WORKSHARE_FLAG;
1580   prev_singleunit = false;
1581
1582   /* Translate statements one by one to trees until we reach
1583      the end of the workshare construct.  Adjacent gfc_codes that
1584      are a single unit of work are clustered and encapsulated in a
1585      single OMP_SINGLE construct.  */
1586   for (; code; code = code->next)
1587     {
1588       if (code->here != 0)
1589         {
1590           res = gfc_trans_label_here (code);
1591           gfc_add_expr_to_block (pblock, res);
1592         }
1593
1594       /* No dependence analysis, use for clauses with wait.
1595          If this is the last gfc_code, use default omp_clauses.  */
1596       if (code->next == NULL && clauses->nowait)
1597         ompws_flags |= OMPWS_NOWAIT;
1598
1599       /* By default, every gfc_code is a single unit of work.  */
1600       ompws_flags |= OMPWS_CURR_SINGLEUNIT;
1601       ompws_flags &= ~OMPWS_SCALARIZER_WS;
1602
1603       switch (code->op)
1604         {
1605         case EXEC_NOP:
1606           res = NULL_TREE;
1607           break;
1608
1609         case EXEC_ASSIGN:
1610           res = gfc_trans_assign (code);
1611           break;
1612
1613         case EXEC_POINTER_ASSIGN:
1614           res = gfc_trans_pointer_assign (code);
1615           break;
1616
1617         case EXEC_INIT_ASSIGN:
1618           res = gfc_trans_init_assign (code);
1619           break;
1620
1621         case EXEC_FORALL:
1622           res = gfc_trans_forall (code);
1623           break;
1624
1625         case EXEC_WHERE:
1626           res = gfc_trans_where (code);
1627           break;
1628
1629         case EXEC_OMP_ATOMIC:
1630           res = gfc_trans_omp_directive (code);
1631           break;
1632
1633         case EXEC_OMP_PARALLEL:
1634         case EXEC_OMP_PARALLEL_DO:
1635         case EXEC_OMP_PARALLEL_SECTIONS:
1636         case EXEC_OMP_PARALLEL_WORKSHARE:
1637         case EXEC_OMP_CRITICAL:
1638           saved_ompws_flags = ompws_flags;
1639           ompws_flags = 0;
1640           res = gfc_trans_omp_directive (code);
1641           ompws_flags = saved_ompws_flags;
1642           break;
1643
1644         default:
1645           internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1646         }
1647
1648       gfc_set_backend_locus (&code->loc);
1649
1650       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1651         {
1652           if (prev_singleunit)
1653             {
1654               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1655                 /* Add current gfc_code to single block.  */
1656                 gfc_add_expr_to_block (&singleblock, res);
1657               else
1658                 {
1659                   /* Finish single block and add it to pblock.  */
1660                   tmp = gfc_finish_block (&singleblock);
1661                   tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
1662                   gfc_add_expr_to_block (pblock, tmp);
1663                   /* Add current gfc_code to pblock.  */
1664                   gfc_add_expr_to_block (pblock, res);
1665                   singleblock_in_progress = false;
1666                 }
1667             }
1668           else
1669             {
1670               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1671                 {
1672                   /* Start single block.  */
1673                   gfc_init_block (&singleblock);
1674                   gfc_add_expr_to_block (&singleblock, res);
1675                   singleblock_in_progress = true;
1676                 }
1677               else
1678                 /* Add the new statement to the block.  */
1679                 gfc_add_expr_to_block (pblock, res);
1680             }
1681           prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
1682         }
1683     }
1684
1685   /* Finish remaining SINGLE block, if we were in the middle of one.  */
1686   if (singleblock_in_progress)
1687     {
1688       /* Finish single block and add it to pblock.  */
1689       tmp = gfc_finish_block (&singleblock);
1690       tmp = build2 (OMP_SINGLE, void_type_node, tmp,
1691                     clauses->nowait
1692                     ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
1693                     : NULL_TREE);
1694       gfc_add_expr_to_block (pblock, tmp);
1695     }
1696
1697   stmt = gfc_finish_block (pblock);
1698   if (TREE_CODE (stmt) != BIND_EXPR)
1699     {
1700       if (!IS_EMPTY_STMT (stmt))
1701         {
1702           tree bindblock = poplevel (1, 0, 0);
1703           stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
1704         }
1705       else
1706         poplevel (0, 0, 0);
1707     }
1708   else
1709     poplevel (0, 0, 0);
1710
1711   ompws_flags = 0;
1712   return stmt;
1713 }
1714
1715 tree
1716 gfc_trans_omp_directive (gfc_code *code)
1717 {
1718   switch (code->op)
1719     {
1720     case EXEC_OMP_ATOMIC:
1721       return gfc_trans_omp_atomic (code);
1722     case EXEC_OMP_BARRIER:
1723       return gfc_trans_omp_barrier ();
1724     case EXEC_OMP_CRITICAL:
1725       return gfc_trans_omp_critical (code);
1726     case EXEC_OMP_DO:
1727       return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
1728     case EXEC_OMP_FLUSH:
1729       return gfc_trans_omp_flush ();
1730     case EXEC_OMP_MASTER:
1731       return gfc_trans_omp_master (code);
1732     case EXEC_OMP_ORDERED:
1733       return gfc_trans_omp_ordered (code);
1734     case EXEC_OMP_PARALLEL:
1735       return gfc_trans_omp_parallel (code);
1736     case EXEC_OMP_PARALLEL_DO:
1737       return gfc_trans_omp_parallel_do (code);
1738     case EXEC_OMP_PARALLEL_SECTIONS:
1739       return gfc_trans_omp_parallel_sections (code);
1740     case EXEC_OMP_PARALLEL_WORKSHARE:
1741       return gfc_trans_omp_parallel_workshare (code);
1742     case EXEC_OMP_SECTIONS:
1743       return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1744     case EXEC_OMP_SINGLE:
1745       return gfc_trans_omp_single (code, code->ext.omp_clauses);
1746     case EXEC_OMP_TASK:
1747       return gfc_trans_omp_task (code);
1748     case EXEC_OMP_TASKWAIT:
1749       return gfc_trans_omp_taskwait ();
1750     case EXEC_OMP_WORKSHARE:
1751       return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
1752     default:
1753       gcc_unreachable ();
1754     }
1755 }