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