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