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