gcc/fortran/trans-openmp.c

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