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;
 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           omp_clauses
 763             = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
 764                                             where);
 765           continue;
 766         }
 767       switch (list)
 768         {
 769         case OMP_LIST_PRIVATE:
 770           clause_code = OMP_CLAUSE_PRIVATE;
 771           goto add_clause;
 772         case OMP_LIST_SHARED:
 773           clause_code = OMP_CLAUSE_SHARED;
 774           goto add_clause;
 775         case OMP_LIST_FIRSTPRIVATE:
 776           clause_code = OMP_CLAUSE_FIRSTPRIVATE;
 777           goto add_clause;
 778         case OMP_LIST_LASTPRIVATE:
 779           clause_code = OMP_CLAUSE_LASTPRIVATE;
 780           goto add_clause;
 781         case OMP_LIST_COPYIN:
 782           clause_code = OMP_CLAUSE_COPYIN;
 783           goto add_clause;
 784         case OMP_LIST_COPYPRIVATE:
 785           clause_code = OMP_CLAUSE_COPYPRIVATE;
 786           /* FALLTHROUGH */
 787         add_clause:
 788           omp_clauses
 789             = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
 790           break;
 791         default:
 792           break;
 793         }
 794     }
 795
 796   if (clauses->if_expr)
 797     {
 798       tree if_var;
 799
 800       gfc_init_se (&se, NULL);
 801       gfc_conv_expr (&se, clauses->if_expr);
 802       gfc_add_block_to_block (block, &se.pre);
 803       if_var = gfc_evaluate_now (se.expr, block);
 804       gfc_add_block_to_block (block, &se.post);
 805
 806       c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
 807       OMP_CLAUSE_IF_EXPR (c) = if_var;
 808       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 809     }
 810
 811   if (clauses->num_threads)
 812     {
 813       tree num_threads;
 814
 815       gfc_init_se (&se, NULL);
 816       gfc_conv_expr (&se, clauses->num_threads);
 817       gfc_add_block_to_block (block, &se.pre);
 818       num_threads = gfc_evaluate_now (se.expr, block);
 819       gfc_add_block_to_block (block, &se.post);
 820
 821       c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
 822       OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
 823       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 824     }
 825
 826   chunk_size = NULL_TREE;
 827   if (clauses->chunk_size)
 828     {
 829       gfc_init_se (&se, NULL);
 830       gfc_conv_expr (&se, clauses->chunk_size);
 831       gfc_add_block_to_block (block, &se.pre);
 832       chunk_size = gfc_evaluate_now (se.expr, block);
 833       gfc_add_block_to_block (block, &se.post);
 834     }
 835
 836   if (clauses->sched_kind != OMP_SCHED_NONE)
 837     {
 838       c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
 839       OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
 840       switch (clauses->sched_kind)
 841         {
 842         case OMP_SCHED_STATIC:
 843           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
 844           break;
 845         case OMP_SCHED_DYNAMIC:
 846           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
 847           break;
 848         case OMP_SCHED_GUIDED:
 849           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
 850           break;
 851         case OMP_SCHED_RUNTIME:
 852           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
 853           break;
 854         case OMP_SCHED_AUTO:
 855           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
 856           break;
 857         default:
 858           gcc_unreachable ();
 859         }
 860       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 861     }
 862
 863   if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
 864     {
 865       c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
 866       switch (clauses->default_sharing)
 867         {
 868         case OMP_DEFAULT_NONE:
 869           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
 870           break;
 871         case OMP_DEFAULT_SHARED:
 872           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
 873           break;
 874         case OMP_DEFAULT_PRIVATE:
 875           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
 876           break;
 877         case OMP_DEFAULT_FIRSTPRIVATE:
 878           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
 879           break;
 880         default:
 881           gcc_unreachable ();
 882         }
 883       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 884     }
 885
 886   if (clauses->nowait)
 887     {
 888       c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
 889       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 890     }
 891
 892   if (clauses->ordered)
 893     {
 894       c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
 895       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 896     }
 897
 898   if (clauses->untied)
 899     {
 900       c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
 901       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 902     }
 903
 904   if (clauses->collapse)
 905     {
 906       c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
 907       OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse);
 908       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 909     }
 910
 911   return omp_clauses;
 912 }
 913
 914 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it.  */
 915
 916 static tree
 917 gfc_trans_omp_code (gfc_code *code, bool force_empty)
 918 {
 919   tree stmt;
 920
 921   pushlevel (0);
 922   stmt = gfc_trans_code (code);
 923   if (TREE_CODE (stmt) != BIND_EXPR)
 924     {
 925       if (!IS_EMPTY_STMT (stmt) || force_empty)
 926         {
 927           tree block = poplevel (1, 0, 0);
 928           stmt = build3_v (BIND_EXPR, NULL, stmt, block);
 929         }
 930       else
 931         poplevel (0, 0, 0);
 932     }
 933   else
 934     poplevel (0, 0, 0);
 935   return stmt;
 936 }
 937
 938
 939 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
 940 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
 941
 942 static tree
 943 gfc_trans_omp_atomic (gfc_code *code)
 944 {
 945   gfc_se lse;
 946   gfc_se rse;
 947   gfc_expr *expr2, *e;
 948   gfc_symbol *var;
 949   stmtblock_t block;
 950   tree lhsaddr, type, rhs, x;
 951   enum tree_code op = ERROR_MARK;
 952   bool var_on_left = false;
 953
 954   code = code->block->next;
 955   gcc_assert (code->op == EXEC_ASSIGN);
 956   gcc_assert (code->next == NULL);
 957   var = code->expr1->symtree->n.sym;
 958
 959   gfc_init_se (&lse, NULL);
 960   gfc_init_se (&rse, NULL);
 961   gfc_start_block (&block);
 962
 963   gfc_conv_expr (&lse, code->expr1);
 964   gfc_add_block_to_block (&block, &lse.pre);
 965   type = TREE_TYPE (lse.expr);
 966   lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
 967
 968   expr2 = code->expr2;
 969   if (expr2->expr_type == EXPR_FUNCTION
 970       && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
 971     expr2 = expr2->value.function.actual->expr;
 972
 973   if (expr2->expr_type == EXPR_OP)
 974     {
 975       gfc_expr *e;
 976       switch (expr2->value.op.op)
 977         {
 978         case INTRINSIC_PLUS:
 979           op = PLUS_EXPR;
 980           break;
 981         case INTRINSIC_TIMES:
 982           op = MULT_EXPR;
 983           break;
 984         case INTRINSIC_MINUS:
 985           op = MINUS_EXPR;
 986           break;
 987         case INTRINSIC_DIVIDE:
 988           if (expr2->ts.type == BT_INTEGER)
 989             op = TRUNC_DIV_EXPR;
 990           else
 991             op = RDIV_EXPR;
 992           break;
 993         case INTRINSIC_AND:
 994           op = TRUTH_ANDIF_EXPR;
 995           break;
 996         case INTRINSIC_OR:
 997           op = TRUTH_ORIF_EXPR;
 998           break;
 999         case INTRINSIC_EQV:
1000           op = EQ_EXPR;
1001           break;
1002         case INTRINSIC_NEQV:
1003           op = NE_EXPR;
1004           break;
1005         default:
1006           gcc_unreachable ();
1007         }
1008       e = expr2->value.op.op1;
1009       if (e->expr_type == EXPR_FUNCTION
1010           && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1011         e = e->value.function.actual->expr;
1012       if (e->expr_type == EXPR_VARIABLE
1013           && e->symtree != NULL
1014           && e->symtree->n.sym == var)
1015         {
1016           expr2 = expr2->value.op.op2;
1017           var_on_left = true;
1018         }
1019       else
1020         {
1021           e = expr2->value.op.op2;
1022           if (e->expr_type == EXPR_FUNCTION
1023               && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1024             e = e->value.function.actual->expr;
1025           gcc_assert (e->expr_type == EXPR_VARIABLE
1026                       && e->symtree != NULL
1027                       && e->symtree->n.sym == var);
1028           expr2 = expr2->value.op.op1;
1029           var_on_left = false;
1030         }
1031       gfc_conv_expr (&rse, expr2);
1032       gfc_add_block_to_block (&block, &rse.pre);
1033     }
1034   else
1035     {
1036       gcc_assert (expr2->expr_type == EXPR_FUNCTION);
1037       switch (expr2->value.function.isym->id)
1038         {
1039         case GFC_ISYM_MIN:
1040           op = MIN_EXPR;
1041           break;
1042         case GFC_ISYM_MAX:
1043           op = MAX_EXPR;
1044           break;
1045         case GFC_ISYM_IAND:
1046           op = BIT_AND_EXPR;
1047           break;
1048         case GFC_ISYM_IOR:
1049           op = BIT_IOR_EXPR;
1050           break;
1051         case GFC_ISYM_IEOR:
1052           op = BIT_XOR_EXPR;
1053           break;
1054         default:
1055           gcc_unreachable ();
1056         }
1057       e = expr2->value.function.actual->expr;
1058       gcc_assert (e->expr_type == EXPR_VARIABLE
1059                   && e->symtree != NULL
1060                   && e->symtree->n.sym == var);
1061
1062       gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
1063       gfc_add_block_to_block (&block, &rse.pre);
1064       if (expr2->value.function.actual->next->next != NULL)
1065         {
1066           tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
1067           gfc_actual_arglist *arg;
1068
1069           gfc_add_modify (&block, accum, rse.expr);
1070           for (arg = expr2->value.function.actual->next->next; arg;
1071                arg = arg->next)
1072             {
1073               gfc_init_block (&rse.pre);
1074               gfc_conv_expr (&rse, arg->expr);
1075               gfc_add_block_to_block (&block, &rse.pre);
1076               x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
1077               gfc_add_modify (&block, accum, x);
1078             }
1079
1080           rse.expr = accum;
1081         }
1082
1083       expr2 = expr2->value.function.actual->next->expr;
1084     }
1085
1086   lhsaddr = save_expr (lhsaddr);
1087   rhs = gfc_evaluate_now (rse.expr, &block);
1088   x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
1089                                                          lhsaddr));
1090
1091   if (var_on_left)
1092     x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
1093   else
1094     x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
1095
1096   if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
1097       && TREE_CODE (type) != COMPLEX_TYPE)
1098     x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
1099
1100   x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
1101   gfc_add_expr_to_block (&block, x);
1102
1103   gfc_add_block_to_block (&block, &lse.pre);
1104   gfc_add_block_to_block (&block, &rse.pre);
1105
1106   return gfc_finish_block (&block);
1107 }
1108
1109 static tree
1110 gfc_trans_omp_barrier (void)
1111 {
1112   tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
1113   return build_call_expr_loc (input_location, decl, 0);
1114 }
1115
1116 static tree
1117 gfc_trans_omp_critical (gfc_code *code)
1118 {
1119   tree name = NULL_TREE, stmt;
1120   if (code->ext.omp_name != NULL)
1121     name = get_identifier (code->ext.omp_name);
1122   stmt = gfc_trans_code (code->block->next);
1123   return build2 (OMP_CRITICAL, void_type_node, stmt, name);
1124 }
1125
1126 static tree
1127 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
1128                   gfc_omp_clauses *do_clauses, tree par_clauses)
1129 {
1130   gfc_se se;
1131   tree dovar, stmt, from, to, step, type, init, cond, incr;
1132   tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
1133   stmtblock_t block;
1134   stmtblock_t body;
1135   gfc_omp_clauses *clauses = code->ext.omp_clauses;
1136   int i, collapse = clauses->collapse;
1137   tree dovar_init = NULL_TREE;
1138
1139   if (collapse <= 0)
1140     collapse = 1;
1141
1142   code = code->block->next;
1143   gcc_assert (code->op == EXEC_DO);
1144
1145   init = make_tree_vec (collapse);
1146   cond = make_tree_vec (collapse);
1147   incr = make_tree_vec (collapse);
1148
1149   if (pblock == NULL)
1150     {
1151       gfc_start_block (&block);
1152       pblock = &block;
1153     }
1154
1155   omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
1156
1157   for (i = 0; i < collapse; i++)
1158     {
1159       int simple = 0;
1160       int dovar_found = 0;
1161       tree dovar_decl;
1162
1163       if (clauses)
1164         {
1165           gfc_namelist *n;
1166           for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
1167                n = n->next)
1168             if (code->ext.iterator->var->symtree->n.sym == n->sym)
1169               break;
1170           if (n != NULL)
1171             dovar_found = 1;
1172           else if (n == NULL)
1173             for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
1174               if (code->ext.iterator->var->symtree->n.sym == n->sym)
1175                 break;
1176           if (n != NULL)
1177             dovar_found++;
1178         }
1179
1180       /* Evaluate all the expressions in the iterator.  */
1181       gfc_init_se (&se, NULL);
1182       gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1183       gfc_add_block_to_block (pblock, &se.pre);
1184       dovar = se.expr;
1185       type = TREE_TYPE (dovar);
1186       gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
1187
1188       gfc_init_se (&se, NULL);
1189       gfc_conv_expr_val (&se, code->ext.iterator->start);
1190       gfc_add_block_to_block (pblock, &se.pre);
1191       from = gfc_evaluate_now (se.expr, pblock);
1192
1193       gfc_init_se (&se, NULL);
1194       gfc_conv_expr_val (&se, code->ext.iterator->end);
1195       gfc_add_block_to_block (pblock, &se.pre);
1196       to = gfc_evaluate_now (se.expr, pblock);
1197
1198       gfc_init_se (&se, NULL);
1199       gfc_conv_expr_val (&se, code->ext.iterator->step);
1200       gfc_add_block_to_block (pblock, &se.pre);
1201       step = gfc_evaluate_now (se.expr, pblock);
1202       dovar_decl = dovar;
1203
1204       /* Special case simple loops.  */
1205       if (TREE_CODE (dovar) == VAR_DECL)
1206         {
1207           if (integer_onep (step))
1208             simple = 1;
1209           else if (tree_int_cst_equal (step, integer_minus_one_node))
1210             simple = -1;
1211         }
1212       else
1213         dovar_decl
1214           = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
1215
1216       /* Loop body.  */
1217       if (simple)
1218         {
1219           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
1220           TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR,
1221                                                 boolean_type_node, dovar, to);
1222           TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step);
1223           TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar,
1224                                                 TREE_VEC_ELT (incr, i));
1225         }
1226       else
1227         {
1228           /* STEP is not 1 or -1.  Use:
1229              for (count = 0; count < (to + step - from) / step; count++)
1230                {
1231                  dovar = from + count * step;
1232                  body;
1233                cycle_label:;
1234                }  */
1235           tmp = fold_build2 (MINUS_EXPR, type, step, from);
1236           tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
1237           tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
1238           tmp = gfc_evaluate_now (tmp, pblock);
1239           count = gfc_create_var (type, "count");
1240           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
1241                                              build_int_cst (type, 0));
1242           TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node,
1243                                                 count, tmp);
1244           TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count,
1245                                                 build_int_cst (type, 1));
1246           TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type,
1247                                                 count, TREE_VEC_ELT (incr, i));
1248
1249           /* Initialize DOVAR.  */
1250           tmp = fold_build2 (MULT_EXPR, type, count, step);
1251           tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
1252           dovar_init = tree_cons (dovar, tmp, dovar_init);
1253         }
1254
1255       if (!dovar_found)
1256         {
1257           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1258           OMP_CLAUSE_DECL (tmp) = dovar_decl;
1259           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1260         }
1261       else if (dovar_found == 2)
1262         {
1263           tree c = NULL;
1264
1265           tmp = NULL;
1266           if (!simple)
1267             {
1268               /* If dovar is lastprivate, but different counter is used,
1269                  dovar += step needs to be added to
1270                  OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
1271                  will have the value on entry of the last loop, rather
1272                  than value after iterator increment.  */
1273               tmp = gfc_evaluate_now (step, pblock);
1274               tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp);
1275               tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp);
1276               for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1277                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1278                     && OMP_CLAUSE_DECL (c) == dovar_decl)
1279                   {
1280                     OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
1281                     break;
1282                   }
1283             }
1284           if (c == NULL && par_clauses != NULL)
1285             {
1286               for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1287                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1288                     && OMP_CLAUSE_DECL (c) == dovar_decl)
1289                   {
1290                     tree l = build_omp_clause (input_location,
1291                                                OMP_CLAUSE_LASTPRIVATE);
1292                     OMP_CLAUSE_DECL (l) = dovar_decl;
1293                     OMP_CLAUSE_CHAIN (l) = omp_clauses;
1294                     OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
1295                     omp_clauses = l;
1296                     OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
1297                     break;
1298                   }
1299             }
1300           gcc_assert (simple || c != NULL);
1301         }
1302       if (!simple)
1303         {
1304           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1305           OMP_CLAUSE_DECL (tmp) = count;
1306           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1307         }
1308
1309       if (i + 1 < collapse)
1310         code = code->block->next;
1311     }
1312
1313   if (pblock != &block)
1314     {
1315       pushlevel (0);
1316       gfc_start_block (&block);
1317     }
1318
1319   gfc_start_block (&body);
1320
1321   dovar_init = nreverse (dovar_init);
1322   while (dovar_init)
1323     {
1324       gfc_add_modify (&body, TREE_PURPOSE (dovar_init),
1325                            TREE_VALUE (dovar_init));
1326       dovar_init = TREE_CHAIN (dovar_init);
1327     }
1328
1329   /* Cycle statement is implemented with a goto.  Exit statement must not be
1330      present for this loop.  */
1331   cycle_label = gfc_build_label_decl (NULL_TREE);
1332
1333   /* Put these labels where they can be found later. We put the
1334      labels in a TREE_LIST node (because TREE_CHAIN is already
1335      used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
1336      label in TREE_VALUE (backend_decl).  */
1337
1338   code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
1339
1340   /* Main loop body.  */
1341   tmp = gfc_trans_omp_code (code->block->next, true);
1342   gfc_add_expr_to_block (&body, tmp);
1343
1344   /* Label for cycle statements (if needed).  */
1345   if (TREE_USED (cycle_label))
1346     {
1347       tmp = build1_v (LABEL_EXPR, cycle_label);
1348       gfc_add_expr_to_block (&body, tmp);
1349     }
1350
1351   /* End of loop body.  */
1352   stmt = make_node (OMP_FOR);
1353
1354   TREE_TYPE (stmt) = void_type_node;
1355   OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1356   OMP_FOR_CLAUSES (stmt) = omp_clauses;
1357   OMP_FOR_INIT (stmt) = init;
1358   OMP_FOR_COND (stmt) = cond;
1359   OMP_FOR_INCR (stmt) = incr;
1360   gfc_add_expr_to_block (&block, stmt);
1361
1362   return gfc_finish_block (&block);
1363 }
1364
1365 static tree
1366 gfc_trans_omp_flush (void)
1367 {
1368   tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
1369   return build_call_expr_loc (input_location, decl, 0);
1370 }
1371
1372 static tree
1373 gfc_trans_omp_master (gfc_code *code)
1374 {
1375   tree stmt = gfc_trans_code (code->block->next);
1376   if (IS_EMPTY_STMT (stmt))
1377     return stmt;
1378   return build1_v (OMP_MASTER, stmt);
1379 }
1380
1381 static tree
1382 gfc_trans_omp_ordered (gfc_code *code)
1383 {
1384   return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1385 }
1386
1387 static tree
1388 gfc_trans_omp_parallel (gfc_code *code)
1389 {
1390   stmtblock_t block;
1391   tree stmt, omp_clauses;
1392
1393   gfc_start_block (&block);
1394   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1395                                        code->loc);
1396   stmt = gfc_trans_omp_code (code->block->next, true);
1397   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1398   gfc_add_expr_to_block (&block, stmt);
1399   return gfc_finish_block (&block);
1400 }
1401
1402 static tree
1403 gfc_trans_omp_parallel_do (gfc_code *code)
1404 {
1405   stmtblock_t block, *pblock = NULL;
1406   gfc_omp_clauses parallel_clauses, do_clauses;
1407   tree stmt, omp_clauses = NULL_TREE;
1408
1409   gfc_start_block (&block);
1410
1411   memset (&do_clauses, 0, sizeof (do_clauses));
1412   if (code->ext.omp_clauses != NULL)
1413     {
1414       memcpy (&parallel_clauses, code->ext.omp_clauses,
1415               sizeof (parallel_clauses));
1416       do_clauses.sched_kind = parallel_clauses.sched_kind;
1417       do_clauses.chunk_size = parallel_clauses.chunk_size;
1418       do_clauses.ordered = parallel_clauses.ordered;
1419       do_clauses.collapse = parallel_clauses.collapse;
1420       parallel_clauses.sched_kind = OMP_SCHED_NONE;
1421       parallel_clauses.chunk_size = NULL;
1422       parallel_clauses.ordered = false;
1423       parallel_clauses.collapse = 0;
1424       omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
1425                                            code->loc);
1426     }
1427   do_clauses.nowait = true;
1428   if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1429     pblock = &block;
1430   else
1431     pushlevel (0);
1432   stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
1433   if (TREE_CODE (stmt) != BIND_EXPR)
1434     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1435   else
1436     poplevel (0, 0, 0);
1437   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1438   OMP_PARALLEL_COMBINED (stmt) = 1;
1439   gfc_add_expr_to_block (&block, stmt);
1440   return gfc_finish_block (&block);
1441 }
1442
1443 static tree
1444 gfc_trans_omp_parallel_sections (gfc_code *code)
1445 {
1446   stmtblock_t block;
1447   gfc_omp_clauses section_clauses;
1448   tree stmt, omp_clauses;
1449
1450   memset (&section_clauses, 0, sizeof (section_clauses));
1451   section_clauses.nowait = true;
1452
1453   gfc_start_block (&block);
1454   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1455                                        code->loc);
1456   pushlevel (0);
1457   stmt = gfc_trans_omp_sections (code, &section_clauses);
1458   if (TREE_CODE (stmt) != BIND_EXPR)
1459     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1460   else
1461     poplevel (0, 0, 0);
1462   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1463   OMP_PARALLEL_COMBINED (stmt) = 1;
1464   gfc_add_expr_to_block (&block, stmt);
1465   return gfc_finish_block (&block);
1466 }
1467
1468 static tree
1469 gfc_trans_omp_parallel_workshare (gfc_code *code)
1470 {
1471   stmtblock_t block;
1472   gfc_omp_clauses workshare_clauses;
1473   tree stmt, omp_clauses;
1474
1475   memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1476   workshare_clauses.nowait = true;
1477
1478   gfc_start_block (&block);
1479   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1480                                        code->loc);
1481   pushlevel (0);
1482   stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1483   if (TREE_CODE (stmt) != BIND_EXPR)
1484     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1485   else
1486     poplevel (0, 0, 0);
1487   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1488   OMP_PARALLEL_COMBINED (stmt) = 1;
1489   gfc_add_expr_to_block (&block, stmt);
1490   return gfc_finish_block (&block);
1491 }
1492
1493 static tree
1494 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1495 {
1496   stmtblock_t block, body;
1497   tree omp_clauses, stmt;
1498   bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1499
1500   gfc_start_block (&block);
1501
1502   omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1503
1504   gfc_init_block (&body);
1505   for (code = code->block; code; code = code->block)
1506     {
1507       /* Last section is special because of lastprivate, so even if it
1508          is empty, chain it in.  */
1509       stmt = gfc_trans_omp_code (code->next,
1510                                  has_lastprivate && code->block == NULL);
1511       if (! IS_EMPTY_STMT (stmt))
1512         {
1513           stmt = build1_v (OMP_SECTION, stmt);
1514           gfc_add_expr_to_block (&body, stmt);
1515         }
1516     }
1517   stmt = gfc_finish_block (&body);
1518
1519   stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
1520   gfc_add_expr_to_block (&block, stmt);
1521
1522   return gfc_finish_block (&block);
1523 }
1524
1525 static tree
1526 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1527 {
1528   tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1529   tree stmt = gfc_trans_omp_code (code->block->next, true);
1530   stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses);
1531   return stmt;
1532 }
1533
1534 static tree
1535 gfc_trans_omp_task (gfc_code *code)
1536 {
1537   stmtblock_t block;
1538   tree stmt, omp_clauses;
1539
1540   gfc_start_block (&block);
1541   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1542                                        code->loc);
1543   stmt = gfc_trans_omp_code (code->block->next, true);
1544   stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
1545   gfc_add_expr_to_block (&block, stmt);
1546   return gfc_finish_block (&block);
1547 }
1548
1549 static tree
1550 gfc_trans_omp_taskwait (void)
1551 {
1552   tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
1553   return build_call_expr_loc (input_location, decl, 0);
1554 }
1555
1556 static tree
1557 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1558 {
1559   tree res, tmp, stmt;
1560   stmtblock_t block, *pblock = NULL;
1561   stmtblock_t singleblock;
1562   int saved_ompws_flags;
1563   bool singleblock_in_progress = false;
1564   /* True if previous gfc_code in workshare construct is not workshared.  */
1565   bool prev_singleunit;
1566
1567   code = code->block->next;
1568
1569   pushlevel (0);
1570
1571   if (!code)
1572     return build_empty_stmt (input_location);
1573
1574   gfc_start_block (&block);
1575   pblock = &block;
1576
1577   ompws_flags = OMPWS_WORKSHARE_FLAG;
1578   prev_singleunit = false;
1579
1580   /* Translate statements one by one to trees until we reach
1581      the end of the workshare construct.  Adjacent gfc_codes that
1582      are a single unit of work are clustered and encapsulated in a
1583      single OMP_SINGLE construct.  */
1584   for (; code; code = code->next)
1585     {
1586       if (code->here != 0)
1587         {
1588           res = gfc_trans_label_here (code);
1589           gfc_add_expr_to_block (pblock, res);
1590         }
1591
1592       /* No dependence analysis, use for clauses with wait.
1593          If this is the last gfc_code, use default omp_clauses.  */
1594       if (code->next == NULL && clauses->nowait)
1595         ompws_flags |= OMPWS_NOWAIT;
1596
1597       /* By default, every gfc_code is a single unit of work.  */
1598       ompws_flags |= OMPWS_CURR_SINGLEUNIT;
1599       ompws_flags &= ~OMPWS_SCALARIZER_WS;
1600
1601       switch (code->op)
1602         {
1603         case EXEC_NOP:
1604           res = NULL_TREE;
1605           break;
1606
1607         case EXEC_ASSIGN:
1608           res = gfc_trans_assign (code);
1609           break;
1610
1611         case EXEC_POINTER_ASSIGN:
1612           res = gfc_trans_pointer_assign (code);
1613           break;
1614
1615         case EXEC_INIT_ASSIGN:
1616           res = gfc_trans_init_assign (code);
1617           break;
1618
1619         case EXEC_FORALL:
1620           res = gfc_trans_forall (code);
1621           break;
1622
1623         case EXEC_WHERE:
1624           res = gfc_trans_where (code);
1625           break;
1626
1627         case EXEC_OMP_ATOMIC:
1628           res = gfc_trans_omp_directive (code);
1629           break;
1630
1631         case EXEC_OMP_PARALLEL:
1632         case EXEC_OMP_PARALLEL_DO:
1633         case EXEC_OMP_PARALLEL_SECTIONS:
1634         case EXEC_OMP_PARALLEL_WORKSHARE:
1635         case EXEC_OMP_CRITICAL:
1636           saved_ompws_flags = ompws_flags;
1637           ompws_flags = 0;
1638           res = gfc_trans_omp_directive (code);
1639           ompws_flags = saved_ompws_flags;
1640           break;
1641
1642         default:
1643           internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1644         }
1645
1646       gfc_set_backend_locus (&code->loc);
1647
1648       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1649         {
1650           if (prev_singleunit)
1651             {
1652               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1653                 /* Add current gfc_code to single block.  */
1654                 gfc_add_expr_to_block (&singleblock, res);
1655               else
1656                 {
1657                   /* Finish single block and add it to pblock.  */
1658                   tmp = gfc_finish_block (&singleblock);
1659                   tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
1660                   gfc_add_expr_to_block (pblock, tmp);
1661                   /* Add current gfc_code to pblock.  */
1662                   gfc_add_expr_to_block (pblock, res);
1663                   singleblock_in_progress = false;
1664                 }
1665             }
1666           else
1667             {
1668               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1669                 {
1670                   /* Start single block.  */
1671                   gfc_init_block (&singleblock);
1672                   gfc_add_expr_to_block (&singleblock, res);
1673                   singleblock_in_progress = true;
1674                 }
1675               else
1676                 /* Add the new statement to the block.  */
1677                 gfc_add_expr_to_block (pblock, res);
1678             }
1679           prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
1680         }
1681     }
1682
1683   /* Finish remaining SINGLE block, if we were in the middle of one.  */
1684   if (singleblock_in_progress)
1685     {
1686       /* Finish single block and add it to pblock.  */
1687       tmp = gfc_finish_block (&singleblock);
1688       tmp = build2 (OMP_SINGLE, void_type_node, tmp,
1689                     clauses->nowait
1690                     ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
1691                     : NULL_TREE);
1692       gfc_add_expr_to_block (pblock, tmp);
1693     }
1694
1695   stmt = gfc_finish_block (pblock);
1696   if (TREE_CODE (stmt) != BIND_EXPR)
1697     {
1698       if (!IS_EMPTY_STMT (stmt))
1699         {
1700           tree bindblock = poplevel (1, 0, 0);
1701           stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
1702         }
1703       else
1704         poplevel (0, 0, 0);
1705     }
1706   else
1707     poplevel (0, 0, 0);
1708
1709   ompws_flags = 0;
1710   return stmt;
1711 }
1712
1713 tree
1714 gfc_trans_omp_directive (gfc_code *code)
1715 {
1716   switch (code->op)
1717     {
1718     case EXEC_OMP_ATOMIC:
1719       return gfc_trans_omp_atomic (code);
1720     case EXEC_OMP_BARRIER:
1721       return gfc_trans_omp_barrier ();
1722     case EXEC_OMP_CRITICAL:
1723       return gfc_trans_omp_critical (code);
1724     case EXEC_OMP_DO:
1725       return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
1726     case EXEC_OMP_FLUSH:
1727       return gfc_trans_omp_flush ();
1728     case EXEC_OMP_MASTER:
1729       return gfc_trans_omp_master (code);
1730     case EXEC_OMP_ORDERED:
1731       return gfc_trans_omp_ordered (code);
1732     case EXEC_OMP_PARALLEL:
1733       return gfc_trans_omp_parallel (code);
1734     case EXEC_OMP_PARALLEL_DO:
1735       return gfc_trans_omp_parallel_do (code);
1736     case EXEC_OMP_PARALLEL_SECTIONS:
1737       return gfc_trans_omp_parallel_sections (code);
1738     case EXEC_OMP_PARALLEL_WORKSHARE:
1739       return gfc_trans_omp_parallel_workshare (code);
1740     case EXEC_OMP_SECTIONS:
1741       return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1742     case EXEC_OMP_SINGLE:
1743       return gfc_trans_omp_single (code, code->ext.omp_clauses);
1744     case EXEC_OMP_TASK:
1745       return gfc_trans_omp_task (code);
1746     case EXEC_OMP_TASKWAIT:
1747       return gfc_trans_omp_taskwait ();
1748     case EXEC_OMP_WORKSHARE:
1749       return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
1750     default:
1751       gcc_unreachable ();
1752     }
1753 }