gcc/fortran/trans-openmp.c

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