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