gcc/fortran/trans-openmp.c

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