gcc/fortran/trans-openmp.c

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