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