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