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