]> 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
trans-intrinsic.c (gfc_conv_intrinsic_minmax): Use VAR_P (x) instead of TREE_CODE...
[thirdparty/gcc.git] / gcc / fortran / trans-openmp.c
CommitLineData
6c7a4dfd 1/* OpenMP directive translation -- generate GCC trees from gfc_code.
818ab71a 2 Copyright (C) 2005-2016 Free Software Foundation, Inc.
6c7a4dfd
JJ		 3 Contributed by Jakub Jelinek <jakub@redhat.com>
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
d234d788 9Software Foundation; either version 3, or (at your option) any later
6c7a4dfd
JJ		 10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
d234d788
NC		 18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
6c7a4dfd
JJ		 20
21
22#include "config.h"
23#include "system.h"
24#include "coretypes.h"
c7131fb2 25#include "options.h"
2adfab87
AM		 26#include "tree.h"
27#include "gfortran.h"
2fb9a547 28#include "gimple-expr.h"
2adfab87 29#include "trans.h"
d8a2d370 30#include "stringpool.h"
2adfab87
AM		 31#include "fold-const.h"
32#include "gimplify.h" /* For create_tmp_var_raw. */
6c7a4dfd
JJ		 33#include "trans-stmt.h"
34#include "trans-types.h"
35#include "trans-array.h"
36#include "trans-const.h"
37#include "arith.h"
0645c1a2 38#include "omp-low.h"
41dbbb37 39#include "gomp-constants.h"
6c7a4dfd 40
34d01e1d 41int ompws_flags;
6c7a4dfd
JJ		 42
43/* True if OpenMP should privatize what this DECL points to rather
44 than the DECL itself. */
45
46bool
58f9752a 47gfc_omp_privatize_by_reference (const_tree decl)
6c7a4dfd
JJ		 48{
49 tree type = TREE_TYPE (decl);
50
36cefd39
JJ		 51 if (TREE_CODE (type) == REFERENCE_TYPE
52 && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
6c7a4dfd
JJ		 53 return true;
54
55 if (TREE_CODE (type) == POINTER_TYPE)
56 {
e1c82219 57 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
b46ebd6c
JJ		 58 that have POINTER_TYPE type and aren't scalar pointers, scalar
59 allocatables, Cray pointees or C pointers are supposed to be
60 privatized by reference. */
92d28cbb
JJ		 61 if (GFC_DECL_GET_SCALAR_POINTER (decl)
62 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
b46ebd6c 63 || GFC_DECL_CRAY_POINTEE (decl)
a8dbab92 64 || GFC_DECL_ASSOCIATE_VAR_P (decl)
b46ebd6c 65 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
e1c82219
JJ		 66 return false;
67
2b45bf21
JJ		 68 if (!DECL_ARTIFICIAL (decl)
69 && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
6c7a4dfd
JJ		 70 return true;
71
72 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
73 by the frontend. */
74 if (DECL_LANG_SPECIFIC (decl)
75 && GFC_DECL_SAVED_DESCRIPTOR (decl))
76 return true;
77 }
78
79 return false;
80}
81
82/* True if OpenMP sharing attribute of DECL is predetermined. */
83
84enum omp_clause_default_kind
85gfc_omp_predetermined_sharing (tree decl)
86{
92d28cbb
JJ		 87 /* Associate names preserve the association established during ASSOCIATE.
88 As they are implemented either as pointers to the selector or array
89 descriptor and shouldn't really change in the ASSOCIATE region,
90 this decl can be either shared or firstprivate. If it is a pointer,
91 use firstprivate, as it is cheaper that way, otherwise make it shared. */
92 if (GFC_DECL_ASSOCIATE_VAR_P (decl))
93 {
94 if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
95 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
96 else
97 return OMP_CLAUSE_DEFAULT_SHARED;
98 }
99
79943d19
JJ		 100 if (DECL_ARTIFICIAL (decl)
101 && ! GFC_DECL_RESULT (decl)
102 && ! (DECL_LANG_SPECIFIC (decl)
103 && GFC_DECL_SAVED_DESCRIPTOR (decl)))
6c7a4dfd
JJ		 104 return OMP_CLAUSE_DEFAULT_SHARED;
105
106 /* Cray pointees shouldn't be listed in any clauses and should be
107 gimplified to dereference of the corresponding Cray pointer.
108 Make them all private, so that they are emitted in the debug
109 information. */
110 if (GFC_DECL_CRAY_POINTEE (decl))
111 return OMP_CLAUSE_DEFAULT_PRIVATE;
112
20906c66 113 /* Assumed-size arrays are predetermined shared. */
a68ab351
JJ		 114 if (TREE_CODE (decl) == PARM_DECL
115 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
116 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
117 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
118 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
119 == NULL)
120 return OMP_CLAUSE_DEFAULT_SHARED;
121
2b45bf21
JJ		 122 /* Dummy procedures aren't considered variables by OpenMP, thus are
123 disallowed in OpenMP clauses. They are represented as PARM_DECLs
124 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
125 to avoid complaining about their uses with default(none). */
126 if (TREE_CODE (decl) == PARM_DECL
127 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
128 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
129 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
130
6c7a4dfd
JJ		 131 /* COMMON and EQUIVALENCE decls are shared. They
132 are only referenced through DECL_VALUE_EXPR of the variables
133 contained in them. If those are privatized, they will not be
134 gimplified to the COMMON or EQUIVALENCE decls. */
135 if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
136 return OMP_CLAUSE_DEFAULT_SHARED;
137
138 if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
139 return OMP_CLAUSE_DEFAULT_SHARED;
140
18cda88d
JJ		 141 /* These are either array or derived parameters, or vtables.
142 In the former cases, the OpenMP standard doesn't consider them to be
143 variables at all (they can't be redefined), but they can nevertheless appear
144 in parallel/task regions and for default(none) purposes treat them as shared.
145 For vtables likely the same handling is desirable. */
d168c883 146 if (VAR_P (decl) && TREE_READONLY (decl) && TREE_STATIC (decl))
18cda88d
JJ		 147 return OMP_CLAUSE_DEFAULT_SHARED;
148
6c7a4dfd
JJ		 149 return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
150}
151
79943d19
JJ		 152/* Return decl that should be used when reporting DEFAULT(NONE)
153 diagnostics. */
154
155tree
156gfc_omp_report_decl (tree decl)
157{
158 if (DECL_ARTIFICIAL (decl)
159 && DECL_LANG_SPECIFIC (decl)
160 && GFC_DECL_SAVED_DESCRIPTOR (decl))
161 return GFC_DECL_SAVED_DESCRIPTOR (decl);
162
163 return decl;
164}
cd75853e 165
92d28cbb
JJ		 166/* Return true if TYPE has any allocatable components. */
167
168static bool
169gfc_has_alloc_comps (tree type, tree decl)
170{
171 tree field, ftype;
172
173 if (POINTER_TYPE_P (type))
174 {
175 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
176 type = TREE_TYPE (type);
177 else if (GFC_DECL_GET_SCALAR_POINTER (decl))
178 return false;
179 }
180
710700ab 181 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
92d28cbb
JJ		 182 type = gfc_get_element_type (type);
183
184 if (TREE_CODE (type) != RECORD_TYPE)
185 return false;
186
187 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
188 {
189 ftype = TREE_TYPE (field);
190 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
191 return true;
192 if (GFC_DESCRIPTOR_TYPE_P (ftype)
193 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
194 return true;
195 if (gfc_has_alloc_comps (ftype, field))
196 return true;
197 }
198 return false;
199}
200
a68ab351
JJ		 201/* Return true if DECL in private clause needs
202 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
203bool
204gfc_omp_private_outer_ref (tree decl)
205{
206 tree type = TREE_TYPE (decl);
207
f2e0c4e1
JJ		 208 if (gfc_omp_privatize_by_reference (decl))
209 type = TREE_TYPE (type);
210
a68ab351
JJ		 211 if (GFC_DESCRIPTOR_TYPE_P (type)
212 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
213 return true;
214
92d28cbb
JJ		 215 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
216 return true;
217
92d28cbb
JJ		 218 if (gfc_has_alloc_comps (type, decl))
219 return true;
220
a68ab351
JJ		 221 return false;
222}
223
92d28cbb
JJ		 224/* Callback for gfc_omp_unshare_expr. */
225
226static tree
227gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
228{
229 tree t = *tp;
230 enum tree_code code = TREE_CODE (t);
231
232 /* Stop at types, decls, constants like copy_tree_r. */
233 if (TREE_CODE_CLASS (code) == tcc_type
234 || TREE_CODE_CLASS (code) == tcc_declaration
235 || TREE_CODE_CLASS (code) == tcc_constant
236 || code == BLOCK)
237 *walk_subtrees = 0;
238 else if (handled_component_p (t)
239 || TREE_CODE (t) == MEM_REF)
240 {
241 *tp = unshare_expr (t);
242 *walk_subtrees = 0;
243 }
244
245 return NULL_TREE;
246}
247
248/* Unshare in expr anything that the FE which normally doesn't
249 care much about tree sharing (because during gimplification
250 everything is unshared) could cause problems with tree sharing
251 at omp-low.c time. */
252
253static tree
254gfc_omp_unshare_expr (tree expr)
255{
256 walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
257 return expr;
258}
259
260enum walk_alloc_comps
261{
262 WALK_ALLOC_COMPS_DTOR,
263 WALK_ALLOC_COMPS_DEFAULT_CTOR,
264 WALK_ALLOC_COMPS_COPY_CTOR
265};
266
267/* Handle allocatable components in OpenMP clauses. */
268
269static tree
270gfc_walk_alloc_comps (tree decl, tree dest, tree var,
271 enum walk_alloc_comps kind)
272{
273 stmtblock_t block, tmpblock;
274 tree type = TREE_TYPE (decl), then_b, tem, field;
275 gfc_init_block (&block);
276
277 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
278 {
279 if (GFC_DESCRIPTOR_TYPE_P (type))
280 {
281 gfc_init_block (&tmpblock);
282 tem = gfc_full_array_size (&tmpblock, decl,
283 GFC_TYPE_ARRAY_RANK (type));
284 then_b = gfc_finish_block (&tmpblock);
285 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b));
286 tem = gfc_omp_unshare_expr (tem);
287 tem = fold_build2_loc (input_location, MINUS_EXPR,
288 gfc_array_index_type, tem,
289 gfc_index_one_node);
290 }
291 else
292 {
293 if (!TYPE_DOMAIN (type)
294 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
295 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
296 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
297 {
298 tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
299 TYPE_SIZE_UNIT (type),
300 TYPE_SIZE_UNIT (TREE_TYPE (type)));
301 tem = size_binop (MINUS_EXPR, tem, size_one_node);
302 }
303 else
304 tem = array_type_nelts (type);
305 tem = fold_convert (gfc_array_index_type, tem);
306 }
307
308 tree nelems = gfc_evaluate_now (tem, &block);
309 tree index = gfc_create_var (gfc_array_index_type, "S");
310
311 gfc_init_block (&tmpblock);
312 tem = gfc_conv_array_data (decl);
313 tree declvar = build_fold_indirect_ref_loc (input_location, tem);
314 tree declvref = gfc_build_array_ref (declvar, index, NULL);
315 tree destvar, destvref = NULL_TREE;
316 if (dest)
317 {
318 tem = gfc_conv_array_data (dest);
319 destvar = build_fold_indirect_ref_loc (input_location, tem);
320 destvref = gfc_build_array_ref (destvar, index, NULL);
321 }
322 gfc_add_expr_to_block (&tmpblock,
323 gfc_walk_alloc_comps (declvref, destvref,
324 var, kind));
325
326 gfc_loopinfo loop;
327 gfc_init_loopinfo (&loop);
328 loop.dimen = 1;
329 loop.from[0] = gfc_index_zero_node;
330 loop.loopvar[0] = index;
331 loop.to[0] = nelems;
332 gfc_trans_scalarizing_loops (&loop, &tmpblock);
333 gfc_add_block_to_block (&block, &loop.pre);
334 return gfc_finish_block (&block);
335 }
336 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
337 {
338 decl = build_fold_indirect_ref_loc (input_location, decl);
339 if (dest)
340 dest = build_fold_indirect_ref_loc (input_location, dest);
341 type = TREE_TYPE (decl);
342 }
343
344 gcc_assert (TREE_CODE (type) == RECORD_TYPE);
345 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
346 {
347 tree ftype = TREE_TYPE (field);
348 tree declf, destf = NULL_TREE;
349 bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
350 if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
351 || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
352 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
353 && !has_alloc_comps)
354 continue;
355 declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
356 decl, field, NULL_TREE);
357 if (dest)
358 destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
359 dest, field, NULL_TREE);
360
361 tem = NULL_TREE;
362 switch (kind)
363 {
364 case WALK_ALLOC_COMPS_DTOR:
365 break;
366 case WALK_ALLOC_COMPS_DEFAULT_CTOR:
367 if (GFC_DESCRIPTOR_TYPE_P (ftype)
368 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
369 {
370 gfc_add_modify (&block, unshare_expr (destf),
371 unshare_expr (declf));
372 tem = gfc_duplicate_allocatable_nocopy
373 (destf, declf, ftype,
374 GFC_TYPE_ARRAY_RANK (ftype));
375 }
376 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
377 tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
378 break;
379 case WALK_ALLOC_COMPS_COPY_CTOR:
380 if (GFC_DESCRIPTOR_TYPE_P (ftype)
381 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
382 tem = gfc_duplicate_allocatable (destf, declf, ftype,
fc7d0afb
AV		 383 GFC_TYPE_ARRAY_RANK (ftype),
384 NULL_TREE);
92d28cbb 385 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
fc7d0afb
AV		 386 tem = gfc_duplicate_allocatable (destf, declf, ftype, 0,
387 NULL_TREE);
92d28cbb
JJ		 388 break;
389 }
390 if (tem)
391 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
392 if (has_alloc_comps)
393 {
394 gfc_init_block (&tmpblock);
395 gfc_add_expr_to_block (&tmpblock,
396 gfc_walk_alloc_comps (declf, destf,
397 field, kind));
398 then_b = gfc_finish_block (&tmpblock);
399 if (GFC_DESCRIPTOR_TYPE_P (ftype)
400 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
401 tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
402 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
403 tem = unshare_expr (declf);
404 else
405 tem = NULL_TREE;
406 if (tem)
407 {
408 tem = fold_convert (pvoid_type_node, tem);
409 tem = fold_build2_loc (input_location, NE_EXPR,
410 boolean_type_node, tem,
411 null_pointer_node);
412 then_b = build3_loc (input_location, COND_EXPR, void_type_node,
413 tem, then_b,
414 build_empty_stmt (input_location));
415 }
416 gfc_add_expr_to_block (&block, then_b);
417 }
418 if (kind == WALK_ALLOC_COMPS_DTOR)
419 {
420 if (GFC_DESCRIPTOR_TYPE_P (ftype)
421 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
422 {
423 tem = gfc_trans_dealloc_allocated (unshare_expr (declf),
424 false, NULL);
425 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
426 }
427 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
428 {
429 tem = gfc_call_free (unshare_expr (declf));
430 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
431 }
432 }
433 }
434
435 return gfc_finish_block (&block);
436}
437
cd75853e
JJ		 438/* Return code to initialize DECL with its default constructor, or
439 NULL if there's nothing to do. */
440
441tree
a68ab351 442gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
cd75853e 443{
92d28cbb 444 tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
a68ab351 445 stmtblock_t block, cond_block;
cd75853e 446
92d28cbb
JJ		 447 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
448 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE
449 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR
450 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION);
cd75853e 451
92d28cbb
JJ		 452 if ((! GFC_DESCRIPTOR_TYPE_P (type)
453 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
454 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
455 {
456 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
457 {
458 gcc_assert (outer);
459 gfc_start_block (&block);
460 tree tem = gfc_walk_alloc_comps (outer, decl,
461 OMP_CLAUSE_DECL (clause),
462 WALK_ALLOC_COMPS_DEFAULT_CTOR);
463 gfc_add_expr_to_block (&block, tem);
464 return gfc_finish_block (&block);
465 }
466 return NULL_TREE;
467 }
acf0174b 468
92d28cbb 469 gcc_assert (outer != NULL_TREE);
a68ab351 470
92d28cbb 471 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
a68ab351
JJ		 472 "not currently allocated" allocation status if outer
473 array is "not currently allocated", otherwise should be allocated. */
474 gfc_start_block (&block);
475
476 gfc_init_block (&cond_block);
477
92d28cbb
JJ		 478 if (GFC_DESCRIPTOR_TYPE_P (type))
479 {
480 gfc_add_modify (&cond_block, decl, outer);
481 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
482 size = gfc_conv_descriptor_ubound_get (decl, rank);
483 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
484 size,
485 gfc_conv_descriptor_lbound_get (decl, rank));
486 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
487 size, gfc_index_one_node);
488 if (GFC_TYPE_ARRAY_RANK (type) > 1)
489 size = fold_build2_loc (input_location, MULT_EXPR,
490 gfc_array_index_type, size,
491 gfc_conv_descriptor_stride_get (decl, rank));
492 tree esize = fold_convert (gfc_array_index_type,
493 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
494 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
495 size, esize);
496 size = unshare_expr (size);
497 size = gfc_evaluate_now (fold_convert (size_type_node, size),
498 &cond_block);
499 }
500 else
501 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
4f13e17f
DC		 502 ptr = gfc_create_var (pvoid_type_node, NULL);
503 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
92d28cbb
JJ		 504 if (GFC_DESCRIPTOR_TYPE_P (type))
505 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
506 else
507 gfc_add_modify (&cond_block, unshare_expr (decl),
508 fold_convert (TREE_TYPE (decl), ptr));
509 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
510 {
511 tree tem = gfc_walk_alloc_comps (outer, decl,
512 OMP_CLAUSE_DECL (clause),
513 WALK_ALLOC_COMPS_DEFAULT_CTOR);
514 gfc_add_expr_to_block (&cond_block, tem);
515 }
a68ab351
JJ		 516 then_b = gfc_finish_block (&cond_block);
517
92d28cbb
JJ		 518 /* Reduction clause requires allocated ALLOCATABLE. */
519 if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION)
520 {
521 gfc_init_block (&cond_block);
522 if (GFC_DESCRIPTOR_TYPE_P (type))
523 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
524 null_pointer_node);
525 else
526 gfc_add_modify (&cond_block, unshare_expr (decl),
527 build_zero_cst (TREE_TYPE (decl)));
528 else_b = gfc_finish_block (&cond_block);
529
530 tree tem = fold_convert (pvoid_type_node,
531 GFC_DESCRIPTOR_TYPE_P (type)
532 ? gfc_conv_descriptor_data_get (outer) : outer);
533 tem = unshare_expr (tem);
534 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
535 tem, null_pointer_node);
536 gfc_add_expr_to_block (&block,
537 build3_loc (input_location, COND_EXPR,
538 void_type_node, cond, then_b,
539 else_b));
540 }
541 else
542 gfc_add_expr_to_block (&block, then_b);
cd75853e 543
a68ab351
JJ		 544 return gfc_finish_block (&block);
545}
546
547/* Build and return code for a copy constructor from SRC to DEST. */
548
549tree
550gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
551{
92d28cbb 552 tree type = TREE_TYPE (dest), ptr, size, call;
20906c66
JJ		 553 tree cond, then_b, else_b;
554 stmtblock_t block, cond_block;
a68ab351 555
92d28cbb
JJ		 556 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
557 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
a68ab351 558
92d28cbb
JJ		 559 if ((! GFC_DESCRIPTOR_TYPE_P (type)
560 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
561 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
562 {
563 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
564 {
565 gfc_start_block (&block);
566 gfc_add_modify (&block, dest, src);
567 tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
568 WALK_ALLOC_COMPS_COPY_CTOR);
569 gfc_add_expr_to_block (&block, tem);
570 return gfc_finish_block (&block);
571 }
572 else
573 return build2_v (MODIFY_EXPR, dest, src);
574 }
a68ab351
JJ		 575
576 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
577 and copied from SRC. */
578 gfc_start_block (&block);
579
20906c66
JJ		 580 gfc_init_block (&cond_block);
581
582 gfc_add_modify (&cond_block, dest, src);
92d28cbb
JJ		 583 if (GFC_DESCRIPTOR_TYPE_P (type))
584 {
585 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
586 size = gfc_conv_descriptor_ubound_get (dest, rank);
587 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
588 size,
589 gfc_conv_descriptor_lbound_get (dest, rank));
590 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
591 size, gfc_index_one_node);
592 if (GFC_TYPE_ARRAY_RANK (type) > 1)
593 size = fold_build2_loc (input_location, MULT_EXPR,
594 gfc_array_index_type, size,
595 gfc_conv_descriptor_stride_get (dest, rank));
596 tree esize = fold_convert (gfc_array_index_type,
597 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
598 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
599 size, esize);
600 size = unshare_expr (size);
601 size = gfc_evaluate_now (fold_convert (size_type_node, size),
602 &cond_block);
603 }
604 else
605 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
4f13e17f 606 ptr = gfc_create_var (pvoid_type_node, NULL);
20906c66 607 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
92d28cbb
JJ		 608 if (GFC_DESCRIPTOR_TYPE_P (type))
609 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
610 else
611 gfc_add_modify (&cond_block, unshare_expr (dest),
612 fold_convert (TREE_TYPE (dest), ptr));
4f13e17f 613
92d28cbb
JJ		 614 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
615 ? gfc_conv_descriptor_data_get (src) : src;
616 srcptr = unshare_expr (srcptr);
617 srcptr = fold_convert (pvoid_type_node, srcptr);
db3927fb 618 call = build_call_expr_loc (input_location,
92d28cbb
JJ		 619 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
620 srcptr, size);
20906c66 621 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
92d28cbb
JJ		 622 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
623 {
624 tree tem = gfc_walk_alloc_comps (src, dest,
625 OMP_CLAUSE_DECL (clause),
626 WALK_ALLOC_COMPS_COPY_CTOR);
627 gfc_add_expr_to_block (&cond_block, tem);
628 }
20906c66
JJ		 629 then_b = gfc_finish_block (&cond_block);
630
631 gfc_init_block (&cond_block);
92d28cbb
JJ		 632 if (GFC_DESCRIPTOR_TYPE_P (type))
633 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
634 null_pointer_node);
635 else
636 gfc_add_modify (&cond_block, unshare_expr (dest),
637 build_zero_cst (TREE_TYPE (dest)));
20906c66
JJ		 638 else_b = gfc_finish_block (&cond_block);
639
640 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
92d28cbb
JJ		 641 unshare_expr (srcptr), null_pointer_node);
642 gfc_add_expr_to_block (&block,
643 build3_loc (input_location, COND_EXPR,
644 void_type_node, cond, then_b, else_b));
cd75853e
JJ		 645
646 return gfc_finish_block (&block);
647}
648
92d28cbb
JJ		 649/* Similarly, except use an intrinsic or pointer assignment operator
650 instead. */
a68ab351
JJ		 651
652tree
92d28cbb 653gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
a68ab351 654{
92d28cbb
JJ		 655 tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
656 tree cond, then_b, else_b;
657 stmtblock_t block, cond_block, cond_block2, inner_block;
a68ab351 658
92d28cbb
JJ		 659 if ((! GFC_DESCRIPTOR_TYPE_P (type)
660 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
661 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
662 {
663 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
664 {
665 gfc_start_block (&block);
666 /* First dealloc any allocatable components in DEST. */
667 tree tem = gfc_walk_alloc_comps (dest, NULL_TREE,
668 OMP_CLAUSE_DECL (clause),
669 WALK_ALLOC_COMPS_DTOR);
670 gfc_add_expr_to_block (&block, tem);
671 /* Then copy over toplevel data. */
672 gfc_add_modify (&block, dest, src);
673 /* Finally allocate any allocatable components and copy. */
674 tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
675 WALK_ALLOC_COMPS_COPY_CTOR);
676 gfc_add_expr_to_block (&block, tem);
677 return gfc_finish_block (&block);
678 }
679 else
680 return build2_v (MODIFY_EXPR, dest, src);
681 }
a68ab351 682
a68ab351
JJ		 683 gfc_start_block (&block);
684
92d28cbb
JJ		 685 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
686 {
687 then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
688 WALK_ALLOC_COMPS_DTOR);
689 tree tem = fold_convert (pvoid_type_node,
690 GFC_DESCRIPTOR_TYPE_P (type)
691 ? gfc_conv_descriptor_data_get (dest) : dest);
692 tem = unshare_expr (tem);
693 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
694 tem, null_pointer_node);
695 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
696 then_b, build_empty_stmt (input_location));
697 gfc_add_expr_to_block (&block, tem);
698 }
699
700 gfc_init_block (&cond_block);
701
702 if (GFC_DESCRIPTOR_TYPE_P (type))
703 {
704 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
705 size = gfc_conv_descriptor_ubound_get (src, rank);
706 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
707 size,
708 gfc_conv_descriptor_lbound_get (src, rank));
709 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
710 size, gfc_index_one_node);
711 if (GFC_TYPE_ARRAY_RANK (type) > 1)
712 size = fold_build2_loc (input_location, MULT_EXPR,
713 gfc_array_index_type, size,
714 gfc_conv_descriptor_stride_get (src, rank));
715 tree esize = fold_convert (gfc_array_index_type,
716 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
717 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
718 size, esize);
719 size = unshare_expr (size);
720 size = gfc_evaluate_now (fold_convert (size_type_node, size),
721 &cond_block);
722 }
723 else
724 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
725 ptr = gfc_create_var (pvoid_type_node, NULL);
726
727 tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
728 ? gfc_conv_descriptor_data_get (dest) : dest;
729 destptr = unshare_expr (destptr);
730 destptr = fold_convert (pvoid_type_node, destptr);
731 gfc_add_modify (&cond_block, ptr, destptr);
732
733 nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
734 destptr, null_pointer_node);
735 cond = nonalloc;
736 if (GFC_DESCRIPTOR_TYPE_P (type))
737 {
738 int i;
739 for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
740 {
741 tree rank = gfc_rank_cst[i];
742 tree tem = gfc_conv_descriptor_ubound_get (src, rank);
743 tem = fold_build2_loc (input_location, MINUS_EXPR,
744 gfc_array_index_type, tem,
745 gfc_conv_descriptor_lbound_get (src, rank));
746 tem = fold_build2_loc (input_location, PLUS_EXPR,
747 gfc_array_index_type, tem,
748 gfc_conv_descriptor_lbound_get (dest, rank));
749 tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
750 tem, gfc_conv_descriptor_ubound_get (dest,
751 rank));
752 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
753 boolean_type_node, cond, tem);
754 }
755 }
756
757 gfc_init_block (&cond_block2);
758
759 if (GFC_DESCRIPTOR_TYPE_P (type))
760 {
761 gfc_init_block (&inner_block);
762 gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
763 then_b = gfc_finish_block (&inner_block);
764
765 gfc_init_block (&inner_block);
766 gfc_add_modify (&inner_block, ptr,
767 gfc_call_realloc (&inner_block, ptr, size));
768 else_b = gfc_finish_block (&inner_block);
769
770 gfc_add_expr_to_block (&cond_block2,
771 build3_loc (input_location, COND_EXPR,
772 void_type_node,
773 unshare_expr (nonalloc),
774 then_b, else_b));
775 gfc_add_modify (&cond_block2, dest, src);
776 gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
777 }
778 else
779 {
780 gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
781 gfc_add_modify (&cond_block2, unshare_expr (dest),
782 fold_convert (type, ptr));
783 }
784 then_b = gfc_finish_block (&cond_block2);
785 else_b = build_empty_stmt (input_location);
786
787 gfc_add_expr_to_block (&cond_block,
788 build3_loc (input_location, COND_EXPR,
789 void_type_node, unshare_expr (cond),
790 then_b, else_b));
791
792 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
793 ? gfc_conv_descriptor_data_get (src) : src;
794 srcptr = unshare_expr (srcptr);
795 srcptr = fold_convert (pvoid_type_node, srcptr);
db3927fb 796 call = build_call_expr_loc (input_location,
92d28cbb
JJ		 797 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
798 srcptr, size);
799 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
800 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
801 {
802 tree tem = gfc_walk_alloc_comps (src, dest,
803 OMP_CLAUSE_DECL (clause),
804 WALK_ALLOC_COMPS_COPY_CTOR);
805 gfc_add_expr_to_block (&cond_block, tem);
806 }
807 then_b = gfc_finish_block (&cond_block);
808
809 if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
810 {
811 gfc_init_block (&cond_block);
812 if (GFC_DESCRIPTOR_TYPE_P (type))
813 gfc_add_expr_to_block (&cond_block,
814 gfc_trans_dealloc_allocated (unshare_expr (dest),
815 false, NULL));
816 else
817 {
818 destptr = gfc_evaluate_now (destptr, &cond_block);
819 gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
820 gfc_add_modify (&cond_block, unshare_expr (dest),
821 build_zero_cst (TREE_TYPE (dest)));
822 }
823 else_b = gfc_finish_block (&cond_block);
824
825 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
826 unshare_expr (srcptr), null_pointer_node);
827 gfc_add_expr_to_block (&block,
828 build3_loc (input_location, COND_EXPR,
829 void_type_node, cond,
830 then_b, else_b));
831 }
832 else
833 gfc_add_expr_to_block (&block, then_b);
a68ab351
JJ		 834
835 return gfc_finish_block (&block);
836}
837
da6f124d
JJ		 838static void
839gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src,
840 tree add, tree nelems)
841{
842 stmtblock_t tmpblock;
843 tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S");
844 nelems = gfc_evaluate_now (nelems, block);
845
846 gfc_init_block (&tmpblock);
847 if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE)
848 {
849 desta = gfc_build_array_ref (dest, index, NULL);
850 srca = gfc_build_array_ref (src, index, NULL);
851 }
852 else
853 {
854 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest)));
855 tree idx = fold_build2 (MULT_EXPR, sizetype,
856 fold_convert (sizetype, index),
857 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest))));
858 desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
859 TREE_TYPE (dest), dest,
860 idx));
861 srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
862 TREE_TYPE (src), src,
863 idx));
864 }
865 gfc_add_modify (&tmpblock, desta,
866 fold_build2 (PLUS_EXPR, TREE_TYPE (desta),
867 srca, add));
868
869 gfc_loopinfo loop;
870 gfc_init_loopinfo (&loop);
871 loop.dimen = 1;
872 loop.from[0] = gfc_index_zero_node;
873 loop.loopvar[0] = index;
874 loop.to[0] = nelems;
875 gfc_trans_scalarizing_loops (&loop, &tmpblock);
876 gfc_add_block_to_block (block, &loop.pre);
877}
878
879/* Build and return code for a constructor of DEST that initializes
880 it to SRC plus ADD (ADD is scalar integer). */
881
882tree
883gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add)
884{
885 tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE;
886 stmtblock_t block;
887
888 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
889
890 gfc_start_block (&block);
891 add = gfc_evaluate_now (add, &block);
892
893 if ((! GFC_DESCRIPTOR_TYPE_P (type)
894 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
895 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
896 {
897 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
898 if (!TYPE_DOMAIN (type)
899 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
900 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
901 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
902 {
903 nelems = fold_build2 (EXACT_DIV_EXPR, sizetype,
904 TYPE_SIZE_UNIT (type),
905 TYPE_SIZE_UNIT (TREE_TYPE (type)));
906 nelems = size_binop (MINUS_EXPR, nelems, size_one_node);
907 }
908 else
909 nelems = array_type_nelts (type);
910 nelems = fold_convert (gfc_array_index_type, nelems);
911
912 gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems);
913 return gfc_finish_block (&block);
914 }
915
916 /* Allocatable arrays in LINEAR clauses need to be allocated
917 and copied from SRC. */
918 gfc_add_modify (&block, dest, src);
919 if (GFC_DESCRIPTOR_TYPE_P (type))
920 {
921 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
922 size = gfc_conv_descriptor_ubound_get (dest, rank);
923 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
924 size,
925 gfc_conv_descriptor_lbound_get (dest, rank));
926 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
927 size, gfc_index_one_node);
928 if (GFC_TYPE_ARRAY_RANK (type) > 1)
929 size = fold_build2_loc (input_location, MULT_EXPR,
930 gfc_array_index_type, size,
931 gfc_conv_descriptor_stride_get (dest, rank));
932 tree esize = fold_convert (gfc_array_index_type,
933 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
934 nelems = gfc_evaluate_now (unshare_expr (size), &block);
935 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
936 nelems, unshare_expr (esize));
937 size = gfc_evaluate_now (fold_convert (size_type_node, size),
938 &block);
939 nelems = fold_build2_loc (input_location, MINUS_EXPR,
940 gfc_array_index_type, nelems,
941 gfc_index_one_node);
942 }
943 else
944 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
945 ptr = gfc_create_var (pvoid_type_node, NULL);
946 gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
947 if (GFC_DESCRIPTOR_TYPE_P (type))
948 {
949 gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr);
950 tree etype = gfc_get_element_type (type);
951 ptr = fold_convert (build_pointer_type (etype), ptr);
952 tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src));
953 srcptr = fold_convert (build_pointer_type (etype), srcptr);
954 gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems);
955 }
956 else
957 {
958 gfc_add_modify (&block, unshare_expr (dest),
959 fold_convert (TREE_TYPE (dest), ptr));
960 ptr = fold_convert (TREE_TYPE (dest), ptr);
961 tree dstm = build_fold_indirect_ref (ptr);
962 tree srcm = build_fold_indirect_ref (unshare_expr (src));
963 gfc_add_modify (&block, dstm,
964 fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add));
965 }
966 return gfc_finish_block (&block);
967}
968
a68ab351
JJ		 969/* Build and return code destructing DECL. Return NULL if nothing
970 to be done. */
971
972tree
92d28cbb 973gfc_omp_clause_dtor (tree clause, tree decl)
a68ab351 974{
92d28cbb 975 tree type = TREE_TYPE (decl), tem;
a68ab351 976
92d28cbb
JJ		 977 if ((! GFC_DESCRIPTOR_TYPE_P (type)
978 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
979 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
980 {
981 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
982 return gfc_walk_alloc_comps (decl, NULL_TREE,
983 OMP_CLAUSE_DECL (clause),
984 WALK_ALLOC_COMPS_DTOR);
985 return NULL_TREE;
986 }
a68ab351 987
92d28cbb
JJ		 988 if (GFC_DESCRIPTOR_TYPE_P (type))
989 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
990 to be deallocated if they were allocated. */
991 tem = gfc_trans_dealloc_allocated (decl, false, NULL);
992 else
993 tem = gfc_call_free (decl);
994 tem = gfc_omp_unshare_expr (tem);
acf0174b 995
92d28cbb
JJ		 996 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
997 {
998 stmtblock_t block;
999 tree then_b;
1000
1001 gfc_init_block (&block);
1002 gfc_add_expr_to_block (&block,
1003 gfc_walk_alloc_comps (decl, NULL_TREE,
1004 OMP_CLAUSE_DECL (clause),
1005 WALK_ALLOC_COMPS_DTOR));
1006 gfc_add_expr_to_block (&block, tem);
1007 then_b = gfc_finish_block (&block);
1008
1009 tem = fold_convert (pvoid_type_node,
1010 GFC_DESCRIPTOR_TYPE_P (type)
1011 ? gfc_conv_descriptor_data_get (decl) : decl);
1012 tem = unshare_expr (tem);
1013 tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1014 tem, null_pointer_node);
1015 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
1016 then_b, build_empty_stmt (input_location));
1017 }
1018 return tem;
a68ab351
JJ		 1019}
1020
cd75853e 1021
f014c653
JJ		 1022void
1023gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
1024{
1025 if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1026 return;
1027
1028 tree decl = OMP_CLAUSE_DECL (c);
1029 tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1030 if (POINTER_TYPE_P (TREE_TYPE (decl)))
1031 {
1032 if (!gfc_omp_privatize_by_reference (decl)
1033 && !GFC_DECL_GET_SCALAR_POINTER (decl)
1034 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1035 && !GFC_DECL_CRAY_POINTEE (decl)
1036 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
1037 return;
94351473 1038 tree orig_decl = decl;
f014c653 1039 c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
41dbbb37 1040 OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
f014c653
JJ		 1041 OMP_CLAUSE_DECL (c4) = decl;
1042 OMP_CLAUSE_SIZE (c4) = size_int (0);
1043 decl = build_fold_indirect_ref (decl);
1044 OMP_CLAUSE_DECL (c) = decl;
b46ebd6c 1045 OMP_CLAUSE_SIZE (c) = NULL_TREE;
94351473
JJ		 1046 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1047 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1048 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1049 {
1050 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
41dbbb37 1051 OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
94351473
JJ		 1052 OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
1053 OMP_CLAUSE_SIZE (c3) = size_int (0);
1054 decl = build_fold_indirect_ref (decl);
1055 OMP_CLAUSE_DECL (c) = decl;
1056 }
f014c653
JJ		 1057 }
1058 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1059 {
1060 stmtblock_t block;
1061 gfc_start_block (&block);
1062 tree type = TREE_TYPE (decl);
1063 tree ptr = gfc_conv_descriptor_data_get (decl);
1064 ptr = fold_convert (build_pointer_type (char_type_node), ptr);
1065 ptr = build_fold_indirect_ref (ptr);
1066 OMP_CLAUSE_DECL (c) = ptr;
1067 c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
41dbbb37 1068 OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
f014c653
JJ		 1069 OMP_CLAUSE_DECL (c2) = decl;
1070 OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type);
1071 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
41dbbb37 1072 OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
f014c653
JJ		 1073 OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
1074 OMP_CLAUSE_SIZE (c3) = size_int (0);
b731b390 1075 tree size = create_tmp_var (gfc_array_index_type);
f014c653
JJ		 1076 tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
1077 elemsz = fold_convert (gfc_array_index_type, elemsz);
1078 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
1079 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
1080 {
1081 stmtblock_t cond_block;
1082 tree tem, then_b, else_b, zero, cond;
1083
1084 gfc_init_block (&cond_block);
1085 tem = gfc_full_array_size (&cond_block, decl,
1086 GFC_TYPE_ARRAY_RANK (type));
1087 gfc_add_modify (&cond_block, size, tem);
1088 gfc_add_modify (&cond_block, size,
1089 fold_build2 (MULT_EXPR, gfc_array_index_type,
1090 size, elemsz));
1091 then_b = gfc_finish_block (&cond_block);
1092 gfc_init_block (&cond_block);
1093 zero = build_int_cst (gfc_array_index_type, 0);
1094 gfc_add_modify (&cond_block, size, zero);
1095 else_b = gfc_finish_block (&cond_block);
1096 tem = gfc_conv_descriptor_data_get (decl);
1097 tem = fold_convert (pvoid_type_node, tem);
1098 cond = fold_build2_loc (input_location, NE_EXPR,
1099 boolean_type_node, tem, null_pointer_node);
1100 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
1101 void_type_node, cond,
1102 then_b, else_b));
1103 }
1104 else
1105 {
1106 gfc_add_modify (&block, size,
1107 gfc_full_array_size (&block, decl,
1108 GFC_TYPE_ARRAY_RANK (type)));
1109 gfc_add_modify (&block, size,
1110 fold_build2 (MULT_EXPR, gfc_array_index_type,
1111 size, elemsz));
1112 }
1113 OMP_CLAUSE_SIZE (c) = size;
1114 tree stmt = gfc_finish_block (&block);
1115 gimplify_and_add (stmt, pre_p);
1116 }
1117 tree last = c;
b46ebd6c
JJ		 1118 if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
1119 OMP_CLAUSE_SIZE (c)
1120 = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
1121 : TYPE_SIZE_UNIT (TREE_TYPE (decl));
f014c653
JJ		 1122 if (c2)
1123 {
1124 OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last);
1125 OMP_CLAUSE_CHAIN (last) = c2;
1126 last = c2;
1127 }
1128 if (c3)
1129 {
1130 OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last);
1131 OMP_CLAUSE_CHAIN (last) = c3;
1132 last = c3;
1133 }
1134 if (c4)
1135 {
1136 OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last);
1137 OMP_CLAUSE_CHAIN (last) = c4;
1138 last = c4;
1139 }
1140}
1141
1142
6c7a4dfd
JJ		 1143/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1144 disregarded in OpenMP construct, because it is going to be
1145 remapped during OpenMP lowering. SHARED is true if DECL
1146 is going to be shared, false if it is going to be privatized. */
1147
1148bool
1149gfc_omp_disregard_value_expr (tree decl, bool shared)
1150{
1151 if (GFC_DECL_COMMON_OR_EQUIV (decl)
1152 && DECL_HAS_VALUE_EXPR_P (decl))
1153 {
1154 tree value = DECL_VALUE_EXPR (decl);
1155
1156 if (TREE_CODE (value) == COMPONENT_REF
d168c883 1157 && VAR_P (TREE_OPERAND (value, 0))
6c7a4dfd
JJ		 1158 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1159 {
1160 /* If variable in COMMON or EQUIVALENCE is privatized, return
1161 true, as just that variable is supposed to be privatized,
1162 not the whole COMMON or whole EQUIVALENCE.
1163 For shared variables in COMMON or EQUIVALENCE, let them be
1164 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1165 from the same COMMON or EQUIVALENCE just one sharing of the
1166 whole COMMON or EQUIVALENCE is enough. */
1167 return ! shared;
1168 }
1169 }
1170
1171 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
1172 return ! shared;
1173
1174 return false;
1175}
1176
1177/* Return true if DECL that is shared iff SHARED is true should
1178 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1179 flag set. */
1180
1181bool
1182gfc_omp_private_debug_clause (tree decl, bool shared)
1183{
1184 if (GFC_DECL_CRAY_POINTEE (decl))
1185 return true;
1186
1187 if (GFC_DECL_COMMON_OR_EQUIV (decl)
1188 && DECL_HAS_VALUE_EXPR_P (decl))
1189 {
1190 tree value = DECL_VALUE_EXPR (decl);
1191
1192 if (TREE_CODE (value) == COMPONENT_REF
d168c883 1193 && VAR_P (TREE_OPERAND (value, 0))
6c7a4dfd
JJ		 1194 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1195 return shared;
1196 }
1197
1198 return false;
1199}
1200
1201/* Register language specific type size variables as potentially OpenMP
1202 firstprivate variables. */
1203
1204void
1205gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
1206{
1207 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
1208 {
1209 int r;
1210
1211 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
1212 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
1213 {
1214 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
1215 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
1216 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
1217 }
1218 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
1219 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
1220 }
1221}
1222
1223
1224static inline tree
1225gfc_trans_add_clause (tree node, tree tail)
1226{
1227 OMP_CLAUSE_CHAIN (node) = tail;
1228 return node;
1229}
1230
1231static tree
dd2fc525 1232gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
6c7a4dfd 1233{
dd2fc525
JJ		 1234 if (declare_simd)
1235 {
1236 int cnt = 0;
1237 gfc_symbol *proc_sym;
1238 gfc_formal_arglist *f;
1239
1240 gcc_assert (sym->attr.dummy);
1241 proc_sym = sym->ns->proc_name;
1242 if (proc_sym->attr.entry_master)
1243 ++cnt;
1244 if (gfc_return_by_reference (proc_sym))
1245 {
1246 ++cnt;
1247 if (proc_sym->ts.type == BT_CHARACTER)
1248 ++cnt;
1249 }
1250 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
1251 if (f->sym == sym)
1252 break;
1253 else if (f->sym)
1254 ++cnt;
1255 gcc_assert (f);
1256 return build_int_cst (integer_type_node, cnt);
1257 }
1258
6c7a4dfd 1259 tree t = gfc_get_symbol_decl (sym);
11a5f608
JJ		 1260 tree parent_decl;
1261 int parent_flag;
1262 bool return_value;
1263 bool alternate_entry;
1264 bool entry_master;
1265
1266 return_value = sym->attr.function && sym->result == sym;
1267 alternate_entry = sym->attr.function && sym->attr.entry
1268 && sym->result == sym;
1269 entry_master = sym->attr.result
1270 && sym->ns->proc_name->attr.entry_master
1271 && !gfc_return_by_reference (sym->ns->proc_name);
dd2fc525
JJ		 1272 parent_decl = current_function_decl
1273 ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
11a5f608
JJ		 1274
1275 if ((t == parent_decl && return_value)
1276 || (sym->ns && sym->ns->proc_name
1277 && sym->ns->proc_name->backend_decl == parent_decl
1278 && (alternate_entry || entry_master)))
1279 parent_flag = 1;
1280 else
1281 parent_flag = 0;
6c7a4dfd
JJ		 1282
1283 /* Special case for assigning the return value of a function.
1284 Self recursive functions must have an explicit return value. */
11a5f608
JJ		 1285 if (return_value && (t == current_function_decl || parent_flag))
1286 t = gfc_get_fake_result_decl (sym, parent_flag);
6c7a4dfd
JJ		 1287
1288 /* Similarly for alternate entry points. */
11a5f608
JJ		 1289 else if (alternate_entry
1290 && (sym->ns->proc_name->backend_decl == current_function_decl
1291 || parent_flag))
6c7a4dfd
JJ		 1292 {
1293 gfc_entry_list *el = NULL;
1294
1295 for (el = sym->ns->entries; el; el = el->next)
1296 if (sym == el->sym)
1297 {
11a5f608 1298 t = gfc_get_fake_result_decl (sym, parent_flag);
6c7a4dfd
JJ		 1299 break;
1300 }
1301 }
1302
11a5f608
JJ		 1303 else if (entry_master
1304 && (sym->ns->proc_name->backend_decl == current_function_decl
1305 || parent_flag))
1306 t = gfc_get_fake_result_decl (sym, parent_flag);
6c7a4dfd
JJ		 1307
1308 return t;
1309}
1310
1311static tree
dd2fc525
JJ		 1312gfc_trans_omp_variable_list (enum omp_clause_code code,
1313 gfc_omp_namelist *namelist, tree list,
1314 bool declare_simd)
6c7a4dfd
JJ		 1315{
1316 for (; namelist != NULL; namelist = namelist->next)
dd2fc525 1317 if (namelist->sym->attr.referenced || declare_simd)
6c7a4dfd 1318 {
dd2fc525 1319 tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
6c7a4dfd
JJ		 1320 if (t != error_mark_node)
1321 {
c2255bc4 1322 tree node = build_omp_clause (input_location, code);
6c7a4dfd
JJ		 1323 OMP_CLAUSE_DECL (node) = t;
1324 list = gfc_trans_add_clause (node, list);
1325 }
1326 }
1327 return list;
1328}
1329
5f23671d
JJ		 1330struct omp_udr_find_orig_data
1331{
1332 gfc_omp_udr *omp_udr;
1333 bool omp_orig_seen;
1334};
1335
1336static int
1337omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1338 void *data)
1339{
1340 struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
1341 if ((*e)->expr_type == EXPR_VARIABLE
1342 && (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
1343 cd->omp_orig_seen = true;
1344
1345 return 0;
1346}
1347
6c7a4dfd 1348static void
5f23671d 1349gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
6c7a4dfd 1350{
5f23671d 1351 gfc_symbol *sym = n->sym;
6c7a4dfd
JJ		 1352 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
1353 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
1354 gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
5f23671d 1355 gfc_symbol omp_var_copy[4];
6c7a4dfd
JJ		 1356 gfc_expr *e1, *e2, *e3, *e4;
1357 gfc_ref *ref;
af3fcdb4 1358 tree decl, backend_decl, stmt, type, outer_decl;
6c7a4dfd
JJ		 1359 locus old_loc = gfc_current_locus;
1360 const char *iname;
524af0d6 1361 bool t;
b46ebd6c 1362 gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL;
6c7a4dfd
JJ		 1363
1364 decl = OMP_CLAUSE_DECL (c);
1365 gfc_current_locus = where;
af3fcdb4 1366 type = TREE_TYPE (decl);
b731b390 1367 outer_decl = create_tmp_var_raw (type);
af3fcdb4
JJ		 1368 if (TREE_CODE (decl) == PARM_DECL
1369 && TREE_CODE (type) == REFERENCE_TYPE
1370 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
1371 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
1372 {
1373 decl = build_fold_indirect_ref (decl);
1374 type = TREE_TYPE (type);
1375 }
6c7a4dfd
JJ		 1376
1377 /* Create a fake symbol for init value. */
1378 memset (&init_val_sym, 0, sizeof (init_val_sym));
1379 init_val_sym.ns = sym->ns;
1380 init_val_sym.name = sym->name;
1381 init_val_sym.ts = sym->ts;
1382 init_val_sym.attr.referenced = 1;
1383 init_val_sym.declared_at = where;
a7a53ca5 1384 init_val_sym.attr.flavor = FL_VARIABLE;
5f23671d
JJ		 1385 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
1386 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
b46ebd6c 1387 else if (udr->initializer_ns)
5f23671d
JJ		 1388 backend_decl = NULL;
1389 else
1390 switch (sym->ts.type)
1391 {
1392 case BT_LOGICAL:
1393 case BT_INTEGER:
1394 case BT_REAL:
1395 case BT_COMPLEX:
1396 backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
1397 break;
1398 default:
1399 backend_decl = NULL_TREE;
1400 break;
1401 }
6c7a4dfd
JJ		 1402 init_val_sym.backend_decl = backend_decl;
1403
1404 /* Create a fake symbol for the outer array reference. */
1405 outer_sym = *sym;
5f23671d
JJ		 1406 if (sym->as)
1407 outer_sym.as = gfc_copy_array_spec (sym->as);
6c7a4dfd
JJ		 1408 outer_sym.attr.dummy = 0;
1409 outer_sym.attr.result = 0;
a7a53ca5 1410 outer_sym.attr.flavor = FL_VARIABLE;
af3fcdb4
JJ		 1411 outer_sym.backend_decl = outer_decl;
1412 if (decl != OMP_CLAUSE_DECL (c))
1413 outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
6c7a4dfd
JJ		 1414
1415 /* Create fake symtrees for it. */
1416 symtree1 = gfc_new_symtree (&root1, sym->name);
1417 symtree1->n.sym = sym;
1418 gcc_assert (symtree1 == root1);
1419
1420 symtree2 = gfc_new_symtree (&root2, sym->name);
1421 symtree2->n.sym = &init_val_sym;
1422 gcc_assert (symtree2 == root2);
1423
1424 symtree3 = gfc_new_symtree (&root3, sym->name);
1425 symtree3->n.sym = &outer_sym;
1426 gcc_assert (symtree3 == root3);
1427
5f23671d 1428 memset (omp_var_copy, 0, sizeof omp_var_copy);
b46ebd6c 1429 if (udr)
5f23671d 1430 {
b46ebd6c
JJ		 1431 omp_var_copy[0] = *udr->omp_out;
1432 omp_var_copy[1] = *udr->omp_in;
1433 *udr->omp_out = outer_sym;
1434 *udr->omp_in = *sym;
1435 if (udr->initializer_ns)
5f23671d 1436 {
b46ebd6c
JJ		 1437 omp_var_copy[2] = *udr->omp_priv;
1438 omp_var_copy[3] = *udr->omp_orig;
1439 *udr->omp_priv = *sym;
1440 *udr->omp_orig = outer_sym;
5f23671d
JJ		 1441 }
1442 }
1443
6c7a4dfd
JJ		 1444 /* Create expressions. */
1445 e1 = gfc_get_expr ();
1446 e1->expr_type = EXPR_VARIABLE;
1447 e1->where = where;
1448 e1->symtree = symtree1;
1449 e1->ts = sym->ts;
5f23671d
JJ		 1450 if (sym->attr.dimension)
1451 {
1452 e1->ref = ref = gfc_get_ref ();
1453 ref->type = REF_ARRAY;
1454 ref->u.ar.where = where;
1455 ref->u.ar.as = sym->as;
1456 ref->u.ar.type = AR_FULL;
1457 ref->u.ar.dimen = 0;
1458 }
6c7a4dfd 1459 t = gfc_resolve_expr (e1);
524af0d6 1460 gcc_assert (t);
6c7a4dfd 1461
5f23671d
JJ		 1462 e2 = NULL;
1463 if (backend_decl != NULL_TREE)
1464 {
1465 e2 = gfc_get_expr ();
1466 e2->expr_type = EXPR_VARIABLE;
1467 e2->where = where;
1468 e2->symtree = symtree2;
1469 e2->ts = sym->ts;
1470 t = gfc_resolve_expr (e2);
1471 gcc_assert (t);
1472 }
b46ebd6c 1473 else if (udr->initializer_ns == NULL)
5f23671d
JJ		 1474 {
1475 gcc_assert (sym->ts.type == BT_DERIVED);
1476 e2 = gfc_default_initializer (&sym->ts);
1477 gcc_assert (e2);
1478 t = gfc_resolve_expr (e2);
1479 gcc_assert (t);
1480 }
b46ebd6c 1481 else if (n->udr->initializer->op == EXEC_ASSIGN)
5f23671d 1482 {
b46ebd6c
JJ		 1483 e2 = gfc_copy_expr (n->udr->initializer->expr2);
1484 t = gfc_resolve_expr (e2);
1485 gcc_assert (t);
5f23671d 1486 }
b46ebd6c 1487 if (udr && udr->initializer_ns)
5f23671d
JJ		 1488 {
1489 struct omp_udr_find_orig_data cd;
b46ebd6c 1490 cd.omp_udr = udr;
5f23671d 1491 cd.omp_orig_seen = false;
b46ebd6c 1492 gfc_code_walker (&n->udr->initializer,
5f23671d
JJ		 1493 gfc_dummy_code_callback, omp_udr_find_orig, &cd);
1494 if (cd.omp_orig_seen)
1495 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
1496 }
6c7a4dfd
JJ		 1497
1498 e3 = gfc_copy_expr (e1);
1499 e3->symtree = symtree3;
1500 t = gfc_resolve_expr (e3);
524af0d6 1501 gcc_assert (t);
6c7a4dfd
JJ		 1502
1503 iname = NULL;
5f23671d 1504 e4 = NULL;
6c7a4dfd
JJ		 1505 switch (OMP_CLAUSE_REDUCTION_CODE (c))
1506 {
1507 case PLUS_EXPR:
1508 case MINUS_EXPR:
1509 e4 = gfc_add (e3, e1);
1510 break;
1511 case MULT_EXPR:
1512 e4 = gfc_multiply (e3, e1);
1513 break;
1514 case TRUTH_ANDIF_EXPR:
1515 e4 = gfc_and (e3, e1);
1516 break;
1517 case TRUTH_ORIF_EXPR:
1518 e4 = gfc_or (e3, e1);
1519 break;
1520 case EQ_EXPR:
1521 e4 = gfc_eqv (e3, e1);
1522 break;
1523 case NE_EXPR:
1524 e4 = gfc_neqv (e3, e1);
1525 break;
1526 case MIN_EXPR:
1527 iname = "min";
1528 break;
1529 case MAX_EXPR:
1530 iname = "max";
1531 break;
1532 case BIT_AND_EXPR:
1533 iname = "iand";
1534 break;
1535 case BIT_IOR_EXPR:
1536 iname = "ior";
1537 break;
1538 case BIT_XOR_EXPR:
1539 iname = "ieor";
1540 break;
5f23671d 1541 case ERROR_MARK:
b46ebd6c 1542 if (n->udr->combiner->op == EXEC_ASSIGN)
5f23671d 1543 {
b46ebd6c
JJ		 1544 gfc_free_expr (e3);
1545 e3 = gfc_copy_expr (n->udr->combiner->expr1);
1546 e4 = gfc_copy_expr (n->udr->combiner->expr2);
1547 t = gfc_resolve_expr (e3);
1548 gcc_assert (t);
1549 t = gfc_resolve_expr (e4);
1550 gcc_assert (t);
5f23671d
JJ		 1551 }
1552 break;
6c7a4dfd
JJ		 1553 default:
1554 gcc_unreachable ();
1555 }
1556 if (iname != NULL)
1557 {
1558 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
1559 intrinsic_sym.ns = sym->ns;
1560 intrinsic_sym.name = iname;
1561 intrinsic_sym.ts = sym->ts;
1562 intrinsic_sym.attr.referenced = 1;
1563 intrinsic_sym.attr.intrinsic = 1;
1564 intrinsic_sym.attr.function = 1;
1565 intrinsic_sym.result = &intrinsic_sym;
1566 intrinsic_sym.declared_at = where;
1567
1568 symtree4 = gfc_new_symtree (&root4, iname);
1569 symtree4->n.sym = &intrinsic_sym;
1570 gcc_assert (symtree4 == root4);
1571
1572 e4 = gfc_get_expr ();
1573 e4->expr_type = EXPR_FUNCTION;
1574 e4->where = where;
1575 e4->symtree = symtree4;
6c7a4dfd
JJ		 1576 e4->value.function.actual = gfc_get_actual_arglist ();
1577 e4->value.function.actual->expr = e3;
1578 e4->value.function.actual->next = gfc_get_actual_arglist ();
1579 e4->value.function.actual->next->expr = e1;
1580 }
5f23671d
JJ		 1581 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
1582 {
1583 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
1584 e1 = gfc_copy_expr (e1);
1585 e3 = gfc_copy_expr (e3);
1586 t = gfc_resolve_expr (e4);
1587 gcc_assert (t);
1588 }
6c7a4dfd
JJ		 1589
1590 /* Create the init statement list. */
87a60f68 1591 pushlevel ();
92d28cbb 1592 if (e2)
2b56d6a4 1593 stmt = gfc_trans_assignment (e1, e2, false, false);
5f23671d 1594 else
b46ebd6c 1595 stmt = gfc_trans_call (n->udr->initializer, false,
5f23671d 1596 NULL_TREE, NULL_TREE, false);
5b8fdd1f 1597 if (TREE_CODE (stmt) != BIND_EXPR)
87a60f68 1598 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
5b8fdd1f 1599 else
87a60f68 1600 poplevel (0, 0);
5b8fdd1f 1601 OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
6c7a4dfd
JJ		 1602
1603 /* Create the merge statement list. */
87a60f68 1604 pushlevel ();
92d28cbb 1605 if (e4)
2b56d6a4 1606 stmt = gfc_trans_assignment (e3, e4, false, true);
5f23671d 1607 else
b46ebd6c 1608 stmt = gfc_trans_call (n->udr->combiner, false,
5f23671d 1609 NULL_TREE, NULL_TREE, false);
5b8fdd1f 1610 if (TREE_CODE (stmt) != BIND_EXPR)
87a60f68 1611 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
5b8fdd1f 1612 else
87a60f68 1613 poplevel (0, 0);
5b8fdd1f 1614 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
6c7a4dfd
JJ		 1615
1616 /* And stick the placeholder VAR_DECL into the clause as well. */
af3fcdb4 1617 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
6c7a4dfd
JJ		 1618
1619 gfc_current_locus = old_loc;
1620
1621 gfc_free_expr (e1);
5f23671d
JJ		 1622 if (e2)
1623 gfc_free_expr (e2);
6c7a4dfd 1624 gfc_free_expr (e3);
5f23671d
JJ		 1625 if (e4)
1626 gfc_free_expr (e4);
cede9502
JM		 1627 free (symtree1);
1628 free (symtree2);
1629 free (symtree3);
04695783 1630 free (symtree4);
5f23671d
JJ		 1631 if (outer_sym.as)
1632 gfc_free_array_spec (outer_sym.as);
1633
b46ebd6c 1634 if (udr)
5f23671d 1635 {
b46ebd6c
JJ		 1636 *udr->omp_out = omp_var_copy[0];
1637 *udr->omp_in = omp_var_copy[1];
1638 if (udr->initializer_ns)
5f23671d 1639 {
b46ebd6c
JJ		 1640 *udr->omp_priv = omp_var_copy[2];
1641 *udr->omp_orig = omp_var_copy[3];
5f23671d
JJ		 1642 }
1643 }
6c7a4dfd
JJ		 1644}
1645
1646static tree
dd2fc525 1647gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
b605f663 1648 locus where, bool mark_addressable)
6c7a4dfd
JJ		 1649{
1650 for (; namelist != NULL; namelist = namelist->next)
1651 if (namelist->sym->attr.referenced)
1652 {
dd2fc525 1653 tree t = gfc_trans_omp_variable (namelist->sym, false);
6c7a4dfd
JJ		 1654 if (t != error_mark_node)
1655 {
c2255bc4
AH		 1656 tree node = build_omp_clause (where.lb->location,
1657 OMP_CLAUSE_REDUCTION);
6c7a4dfd 1658 OMP_CLAUSE_DECL (node) = t;
b605f663
CLT		 1659 if (mark_addressable)
1660 TREE_ADDRESSABLE (t) = 1;
f014c653 1661 switch (namelist->u.reduction_op)
5f23671d
JJ		 1662 {
1663 case OMP_REDUCTION_PLUS:
1664 OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
1665 break;
1666 case OMP_REDUCTION_MINUS:
1667 OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
1668 break;
1669 case OMP_REDUCTION_TIMES:
1670 OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
1671 break;
1672 case OMP_REDUCTION_AND:
1673 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
1674 break;
1675 case OMP_REDUCTION_OR:
1676 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
1677 break;
1678 case OMP_REDUCTION_EQV:
1679 OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
1680 break;
1681 case OMP_REDUCTION_NEQV:
1682 OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
1683 break;
1684 case OMP_REDUCTION_MAX:
1685 OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
1686 break;
1687 case OMP_REDUCTION_MIN:
1688 OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
1689 break;
1690 case OMP_REDUCTION_IAND:
1691 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
1692 break;
1693 case OMP_REDUCTION_IOR:
1694 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
1695 break;
1696 case OMP_REDUCTION_IEOR:
1697 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
1698 break;
1699 case OMP_REDUCTION_USER:
1700 OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
1701 break;
1702 default:
1703 gcc_unreachable ();
1704 }
1705 if (namelist->sym->attr.dimension
f014c653 1706 || namelist->u.reduction_op == OMP_REDUCTION_USER
92d28cbb 1707 || namelist->sym->attr.allocatable)
5f23671d 1708 gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
6c7a4dfd
JJ		 1709 list = gfc_trans_add_clause (node, list);
1710 }
1711 }
1712 return list;
1713}
1714
41dbbb37
TS		 1715static inline tree
1716gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
1717{
1718 gfc_se se;
1719 tree result;
1720
1721 gfc_init_se (&se, NULL );
1722 gfc_conv_expr (&se, expr);
1723 gfc_add_block_to_block (block, &se.pre);
1724 result = gfc_evaluate_now (se.expr, block);
1725 gfc_add_block_to_block (block, &se.post);
1726
1727 return result;
1728}
1729
6c7a4dfd
JJ		 1730static tree
1731gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
dd2fc525 1732 locus where, bool declare_simd = false)
6c7a4dfd 1733{
c4fae39e 1734 tree omp_clauses = NULL_TREE, chunk_size, c;
6c7a4dfd
JJ		 1735 int list;
1736 enum omp_clause_code clause_code;
1737 gfc_se se;
1738
1739 if (clauses == NULL)
1740 return NULL_TREE;
1741
1742 for (list = 0; list < OMP_LIST_NUM; list++)
1743 {
dd2fc525 1744 gfc_omp_namelist *n = clauses->lists[list];
6c7a4dfd
JJ		 1745
1746 if (n == NULL)
1747 continue;
6c7a4dfd
JJ		 1748 switch (list)
1749 {
5f23671d 1750 case OMP_LIST_REDUCTION:
b605f663
CLT		 1751 /* An OpenACC async clause indicates the need to set reduction
1752 arguments addressable, to allow asynchronous copy-out. */
1753 omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where,
1754 clauses->async);
5f23671d 1755 break;
6c7a4dfd
JJ		 1756 case OMP_LIST_PRIVATE:
1757 clause_code = OMP_CLAUSE_PRIVATE;
1758 goto add_clause;
1759 case OMP_LIST_SHARED:
1760 clause_code = OMP_CLAUSE_SHARED;
1761 goto add_clause;
1762 case OMP_LIST_FIRSTPRIVATE:
1763 clause_code = OMP_CLAUSE_FIRSTPRIVATE;
1764 goto add_clause;
1765 case OMP_LIST_LASTPRIVATE:
1766 clause_code = OMP_CLAUSE_LASTPRIVATE;
1767 goto add_clause;
1768 case OMP_LIST_COPYIN:
1769 clause_code = OMP_CLAUSE_COPYIN;
1770 goto add_clause;
1771 case OMP_LIST_COPYPRIVATE:
1772 clause_code = OMP_CLAUSE_COPYPRIVATE;
dd2fc525
JJ		 1773 goto add_clause;
1774 case OMP_LIST_UNIFORM:
1775 clause_code = OMP_CLAUSE_UNIFORM;
41dbbb37
TS		 1776 goto add_clause;
1777 case OMP_LIST_USE_DEVICE:
c7b48c8a 1778 clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
41dbbb37 1779 goto add_clause;
41dbbb37 1780
6c7a4dfd
JJ		 1781 add_clause:
1782 omp_clauses
dd2fc525
JJ		 1783 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
1784 declare_simd);
1785 break;
1786 case OMP_LIST_ALIGNED:
1787 for (; n != NULL; n = n->next)
1788 if (n->sym->attr.referenced || declare_simd)
1789 {
1790 tree t = gfc_trans_omp_variable (n->sym, declare_simd);
1791 if (t != error_mark_node)
1792 {
1793 tree node = build_omp_clause (input_location,
1794 OMP_CLAUSE_ALIGNED);
1795 OMP_CLAUSE_DECL (node) = t;
1796 if (n->expr)
1797 {
1798 tree alignment_var;
1799
1800 if (block == NULL)
1801 alignment_var = gfc_conv_constant_to_tree (n->expr);
1802 else
1803 {
1804 gfc_init_se (&se, NULL);
1805 gfc_conv_expr (&se, n->expr);
1806 gfc_add_block_to_block (block, &se.pre);
1807 alignment_var = gfc_evaluate_now (se.expr, block);
1808 gfc_add_block_to_block (block, &se.post);
1809 }
1810 OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
1811 }
1812 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1813 }
1814 }
1815 break;
1816 case OMP_LIST_LINEAR:
1817 {
1818 gfc_expr *last_step_expr = NULL;
1819 tree last_step = NULL_TREE;
1820
1821 for (; n != NULL; n = n->next)
1822 {
1823 if (n->expr)
1824 {
1825 last_step_expr = n->expr;
1826 last_step = NULL_TREE;
1827 }
1828 if (n->sym->attr.referenced || declare_simd)
1829 {
1830 tree t = gfc_trans_omp_variable (n->sym, declare_simd);
1831 if (t != error_mark_node)
1832 {
1833 tree node = build_omp_clause (input_location,
1834 OMP_CLAUSE_LINEAR);
1835 OMP_CLAUSE_DECL (node) = t;
1836 if (last_step_expr && last_step == NULL_TREE)
1837 {
1838 if (block == NULL)
1839 last_step
1840 = gfc_conv_constant_to_tree (last_step_expr);
1841 else
1842 {
1843 gfc_init_se (&se, NULL);
1844 gfc_conv_expr (&se, last_step_expr);
1845 gfc_add_block_to_block (block, &se.pre);
1846 last_step = gfc_evaluate_now (se.expr, block);
1847 gfc_add_block_to_block (block, &se.post);
1848 }
1849 }
da6f124d
JJ		 1850 OMP_CLAUSE_LINEAR_STEP (node)
1851 = fold_convert (gfc_typenode_for_spec (&n->sym->ts),
1852 last_step);
1853 if (n->sym->attr.dimension || n->sym->attr.allocatable)
1854 OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
dd2fc525
JJ		 1855 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1856 }
1857 }
1858 }
1859 }
1860 break;
f014c653 1861 case OMP_LIST_DEPEND:
dd2fc525
JJ		 1862 for (; n != NULL; n = n->next)
1863 {
1864 if (!n->sym->attr.referenced)
1865 continue;
1866
1867 tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND);
1868 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
1869 {
f014c653
JJ		 1870 tree decl = gfc_get_symbol_decl (n->sym);
1871 if (gfc_omp_privatize_by_reference (decl))
1872 decl = build_fold_indirect_ref (decl);
1873 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1874 {
1875 decl = gfc_conv_descriptor_data_get (decl);
1876 decl = fold_convert (build_pointer_type (char_type_node),
1877 decl);
1878 decl = build_fold_indirect_ref (decl);
1879 }
1880 else if (DECL_P (decl))
1881 TREE_ADDRESSABLE (decl) = 1;
1882 OMP_CLAUSE_DECL (node) = decl;
dd2fc525
JJ		 1883 }
1884 else
1885 {
1886 tree ptr;
1887 gfc_init_se (&se, NULL);
1888 if (n->expr->ref->u.ar.type == AR_ELEMENT)
1889 {
1890 gfc_conv_expr_reference (&se, n->expr);
1891 ptr = se.expr;
1892 }
1893 else
1894 {
1895 gfc_conv_expr_descriptor (&se, n->expr);
1896 ptr = gfc_conv_array_data (se.expr);
1897 }
1898 gfc_add_block_to_block (block, &se.pre);
1899 gfc_add_block_to_block (block, &se.post);
f014c653
JJ		 1900 ptr = fold_convert (build_pointer_type (char_type_node),
1901 ptr);
1902 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
1903 }
1904 switch (n->u.depend_op)
1905 {
1906 case OMP_DEPEND_IN:
1907 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
1908 break;
1909 case OMP_DEPEND_OUT:
1910 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
1911 break;
1912 case OMP_DEPEND_INOUT:
1913 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
1914 break;
1915 default:
1916 gcc_unreachable ();
1917 }
1918 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1919 }
1920 break;
1921 case OMP_LIST_MAP:
1922 for (; n != NULL; n = n->next)
1923 {
1924 if (!n->sym->attr.referenced)
1925 continue;
1926
1927 tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1928 tree node2 = NULL_TREE;
1929 tree node3 = NULL_TREE;
1930 tree node4 = NULL_TREE;
1931 tree decl = gfc_get_symbol_decl (n->sym);
1932 if (DECL_P (decl))
1933 TREE_ADDRESSABLE (decl) = 1;
1934 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
1935 {
94351473
JJ		 1936 if (POINTER_TYPE_P (TREE_TYPE (decl))
1937 && (gfc_omp_privatize_by_reference (decl)
1938 || GFC_DECL_GET_SCALAR_POINTER (decl)
1939 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1940 || GFC_DECL_CRAY_POINTEE (decl)
1941 || GFC_DESCRIPTOR_TYPE_P
1942 (TREE_TYPE (TREE_TYPE (decl)))))
f014c653 1943 {
94351473 1944 tree orig_decl = decl;
f014c653
JJ		 1945 node4 = build_omp_clause (input_location,
1946 OMP_CLAUSE_MAP);
41dbbb37 1947 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
f014c653
JJ		 1948 OMP_CLAUSE_DECL (node4) = decl;
1949 OMP_CLAUSE_SIZE (node4) = size_int (0);
1950 decl = build_fold_indirect_ref (decl);
94351473
JJ		 1951 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1952 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1953 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1954 {
1955 node3 = build_omp_clause (input_location,
1956 OMP_CLAUSE_MAP);
41dbbb37 1957 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
94351473
JJ		 1958 OMP_CLAUSE_DECL (node3) = decl;
1959 OMP_CLAUSE_SIZE (node3) = size_int (0);
1960 decl = build_fold_indirect_ref (decl);
1961 }
f014c653
JJ		 1962 }
1963 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1964 {
1965 tree type = TREE_TYPE (decl);
1966 tree ptr = gfc_conv_descriptor_data_get (decl);
1967 ptr = fold_convert (build_pointer_type (char_type_node),
1968 ptr);
1969 ptr = build_fold_indirect_ref (ptr);
1970 OMP_CLAUSE_DECL (node) = ptr;
1971 node2 = build_omp_clause (input_location,
1972 OMP_CLAUSE_MAP);
41dbbb37 1973 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
f014c653
JJ		 1974 OMP_CLAUSE_DECL (node2) = decl;
1975 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
1976 node3 = build_omp_clause (input_location,
1977 OMP_CLAUSE_MAP);
41dbbb37 1978 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
f014c653
JJ		 1979 OMP_CLAUSE_DECL (node3)
1980 = gfc_conv_descriptor_data_get (decl);
1981 OMP_CLAUSE_SIZE (node3) = size_int (0);
710700ab
TB		 1982
1983 /* We have to check for n->sym->attr.dimension because
1984 of scalar coarrays. */
1985 if (n->sym->attr.pointer && n->sym->attr.dimension)
f014c653
JJ		 1986 {
1987 stmtblock_t cond_block;
1988 tree size
1989 = gfc_create_var (gfc_array_index_type, NULL);
1990 tree tem, then_b, else_b, zero, cond;
1991
1992 gfc_init_block (&cond_block);
1993 tem
1994 = gfc_full_array_size (&cond_block, decl,
1995 GFC_TYPE_ARRAY_RANK (type));
1996 gfc_add_modify (&cond_block, size, tem);
1997 then_b = gfc_finish_block (&cond_block);
1998 gfc_init_block (&cond_block);
1999 zero = build_int_cst (gfc_array_index_type, 0);
2000 gfc_add_modify (&cond_block, size, zero);
2001 else_b = gfc_finish_block (&cond_block);
2002 tem = gfc_conv_descriptor_data_get (decl);
2003 tem = fold_convert (pvoid_type_node, tem);
2004 cond = fold_build2_loc (input_location, NE_EXPR,
2005 boolean_type_node,
2006 tem, null_pointer_node);
2007 gfc_add_expr_to_block (block,
2008 build3_loc (input_location,
2009 COND_EXPR,
2010 void_type_node,
2011 cond, then_b,
2012 else_b));
2013 OMP_CLAUSE_SIZE (node) = size;
2014 }
710700ab 2015 else if (n->sym->attr.dimension)
f014c653
JJ		 2016 OMP_CLAUSE_SIZE (node)
2017 = gfc_full_array_size (block, decl,
2018 GFC_TYPE_ARRAY_RANK (type));
710700ab
TB		 2019 if (n->sym->attr.dimension)
2020 {
2021 tree elemsz
2022 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2023 elemsz = fold_convert (gfc_array_index_type, elemsz);
2024 OMP_CLAUSE_SIZE (node)
2025 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2026 OMP_CLAUSE_SIZE (node), elemsz);
2027 }
f014c653
JJ		 2028 }
2029 else
2030 OMP_CLAUSE_DECL (node) = decl;
2031 }
2032 else
2033 {
2034 tree ptr, ptr2;
2035 gfc_init_se (&se, NULL);
2036 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2037 {
2038 gfc_conv_expr_reference (&se, n->expr);
2039 gfc_add_block_to_block (block, &se.pre);
2040 ptr = se.expr;
2041 OMP_CLAUSE_SIZE (node)
2042 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2043 }
2044 else
2045 {
2046 gfc_conv_expr_descriptor (&se, n->expr);
2047 ptr = gfc_conv_array_data (se.expr);
2048 tree type = TREE_TYPE (se.expr);
2049 gfc_add_block_to_block (block, &se.pre);
2050 OMP_CLAUSE_SIZE (node)
2051 = gfc_full_array_size (block, se.expr,
2052 GFC_TYPE_ARRAY_RANK (type));
2053 tree elemsz
2054 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2055 elemsz = fold_convert (gfc_array_index_type, elemsz);
2056 OMP_CLAUSE_SIZE (node)
2057 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2058 OMP_CLAUSE_SIZE (node), elemsz);
2059 }
2060 gfc_add_block_to_block (block, &se.post);
2061 ptr = fold_convert (build_pointer_type (char_type_node),
2062 ptr);
2063 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2064
2065 if (POINTER_TYPE_P (TREE_TYPE (decl))
2066 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
2067 {
2068 node4 = build_omp_clause (input_location,
2069 OMP_CLAUSE_MAP);
41dbbb37 2070 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
f014c653
JJ		 2071 OMP_CLAUSE_DECL (node4) = decl;
2072 OMP_CLAUSE_SIZE (node4) = size_int (0);
2073 decl = build_fold_indirect_ref (decl);
2074 }
2075 ptr = fold_convert (sizetype, ptr);
2076 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2077 {
2078 tree type = TREE_TYPE (decl);
2079 ptr2 = gfc_conv_descriptor_data_get (decl);
2080 node2 = build_omp_clause (input_location,
2081 OMP_CLAUSE_MAP);
41dbbb37 2082 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
f014c653
JJ		 2083 OMP_CLAUSE_DECL (node2) = decl;
2084 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
2085 node3 = build_omp_clause (input_location,
2086 OMP_CLAUSE_MAP);
41dbbb37 2087 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
f014c653
JJ		 2088 OMP_CLAUSE_DECL (node3)
2089 = gfc_conv_descriptor_data_get (decl);
2090 }
2091 else
2092 {
2093 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
2094 ptr2 = build_fold_addr_expr (decl);
2095 else
2096 {
2097 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2098 ptr2 = decl;
2099 }
2100 node3 = build_omp_clause (input_location,
2101 OMP_CLAUSE_MAP);
41dbbb37 2102 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
f014c653
JJ		 2103 OMP_CLAUSE_DECL (node3) = decl;
2104 }
2105 ptr2 = fold_convert (sizetype, ptr2);
2106 OMP_CLAUSE_SIZE (node3)
2107 = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
2108 }
2109 switch (n->u.map_op)
2110 {
2111 case OMP_MAP_ALLOC:
41dbbb37 2112 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
f014c653
JJ		 2113 break;
2114 case OMP_MAP_TO:
41dbbb37 2115 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
f014c653
JJ		 2116 break;
2117 case OMP_MAP_FROM:
41dbbb37 2118 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
f014c653
JJ		 2119 break;
2120 case OMP_MAP_TOFROM:
41dbbb37
TS		 2121 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
2122 break;
91106e84
TS		 2123 case OMP_MAP_DELETE:
2124 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
2125 break;
41dbbb37
TS		 2126 case OMP_MAP_FORCE_ALLOC:
2127 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
2128 break;
41dbbb37
TS		 2129 case OMP_MAP_FORCE_TO:
2130 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
2131 break;
2132 case OMP_MAP_FORCE_FROM:
2133 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
2134 break;
2135 case OMP_MAP_FORCE_TOFROM:
2136 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
2137 break;
2138 case OMP_MAP_FORCE_PRESENT:
2139 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
2140 break;
2141 case OMP_MAP_FORCE_DEVICEPTR:
2142 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
f014c653
JJ		 2143 break;
2144 default:
2145 gcc_unreachable ();
2146 }
2147 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2148 if (node2)
2149 omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
2150 if (node3)
2151 omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
2152 if (node4)
2153 omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
2154 }
2155 break;
2156 case OMP_LIST_TO:
2157 case OMP_LIST_FROM:
33497fd2 2158 case OMP_LIST_CACHE:
f014c653
JJ		 2159 for (; n != NULL; n = n->next)
2160 {
2161 if (!n->sym->attr.referenced)
2162 continue;
2163
33497fd2
TS		 2164 switch (list)
2165 {
2166 case OMP_LIST_TO:
2167 clause_code = OMP_CLAUSE_TO;
2168 break;
2169 case OMP_LIST_FROM:
2170 clause_code = OMP_CLAUSE_FROM;
2171 break;
2172 case OMP_LIST_CACHE:
2173 clause_code = OMP_CLAUSE__CACHE_;
2174 break;
2175 default:
2176 gcc_unreachable ();
2177 }
2178 tree node = build_omp_clause (input_location, clause_code);
f014c653
JJ		 2179 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2180 {
2181 tree decl = gfc_get_symbol_decl (n->sym);
2182 if (gfc_omp_privatize_by_reference (decl))
2183 decl = build_fold_indirect_ref (decl);
351beab7
JJ		 2184 else if (DECL_P (decl))
2185 TREE_ADDRESSABLE (decl) = 1;
f014c653
JJ		 2186 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2187 {
2188 tree type = TREE_TYPE (decl);
2189 tree ptr = gfc_conv_descriptor_data_get (decl);
2190 ptr = fold_convert (build_pointer_type (char_type_node),
2191 ptr);
2192 ptr = build_fold_indirect_ref (ptr);
2193 OMP_CLAUSE_DECL (node) = ptr;
2194 OMP_CLAUSE_SIZE (node)
2195 = gfc_full_array_size (block, decl,
2196 GFC_TYPE_ARRAY_RANK (type));
2197 tree elemsz
2198 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2199 elemsz = fold_convert (gfc_array_index_type, elemsz);
2200 OMP_CLAUSE_SIZE (node)
2201 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2202 OMP_CLAUSE_SIZE (node), elemsz);
2203 }
2204 else
2205 OMP_CLAUSE_DECL (node) = decl;
2206 }
2207 else
2208 {
2209 tree ptr;
2210 gfc_init_se (&se, NULL);
2211 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2212 {
2213 gfc_conv_expr_reference (&se, n->expr);
2214 ptr = se.expr;
2215 gfc_add_block_to_block (block, &se.pre);
2216 OMP_CLAUSE_SIZE (node)
2217 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2218 }
2219 else
2220 {
2221 gfc_conv_expr_descriptor (&se, n->expr);
2222 ptr = gfc_conv_array_data (se.expr);
2223 tree type = TREE_TYPE (se.expr);
2224 gfc_add_block_to_block (block, &se.pre);
2225 OMP_CLAUSE_SIZE (node)
2226 = gfc_full_array_size (block, se.expr,
2227 GFC_TYPE_ARRAY_RANK (type));
2228 tree elemsz
2229 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2230 elemsz = fold_convert (gfc_array_index_type, elemsz);
2231 OMP_CLAUSE_SIZE (node)
2232 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2233 OMP_CLAUSE_SIZE (node), elemsz);
2234 }
2235 gfc_add_block_to_block (block, &se.post);
2236 ptr = fold_convert (build_pointer_type (char_type_node),
2237 ptr);
2238 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
dd2fc525 2239 }
dd2fc525
JJ		 2240 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2241 }
6c7a4dfd
JJ		 2242 break;
2243 default:
2244 break;
2245 }
2246 }
2247
2248 if (clauses->if_expr)
2249 {
2250 tree if_var;
2251
2252 gfc_init_se (&se, NULL);
2253 gfc_conv_expr (&se, clauses->if_expr);
2254 gfc_add_block_to_block (block, &se.pre);
2255 if_var = gfc_evaluate_now (se.expr, block);
2256 gfc_add_block_to_block (block, &se.post);
2257
c2255bc4 2258 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
d9a6bd32 2259 OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
6c7a4dfd
JJ		 2260 OMP_CLAUSE_IF_EXPR (c) = if_var;
2261 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2262 }
2263
20906c66
JJ		 2264 if (clauses->final_expr)
2265 {
2266 tree final_var;
2267
2268 gfc_init_se (&se, NULL);
2269 gfc_conv_expr (&se, clauses->final_expr);
2270 gfc_add_block_to_block (block, &se.pre);
2271 final_var = gfc_evaluate_now (se.expr, block);
2272 gfc_add_block_to_block (block, &se.post);
2273
2274 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL);
2275 OMP_CLAUSE_FINAL_EXPR (c) = final_var;
2276 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2277 }
2278
6c7a4dfd
JJ		 2279 if (clauses->num_threads)
2280 {
2281 tree num_threads;
2282
2283 gfc_init_se (&se, NULL);
2284 gfc_conv_expr (&se, clauses->num_threads);
2285 gfc_add_block_to_block (block, &se.pre);
2286 num_threads = gfc_evaluate_now (se.expr, block);
2287 gfc_add_block_to_block (block, &se.post);
2288
c2255bc4 2289 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
6c7a4dfd
JJ		 2290 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
2291 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2292 }
2293
2294 chunk_size = NULL_TREE;
2295 if (clauses->chunk_size)
2296 {
2297 gfc_init_se (&se, NULL);
2298 gfc_conv_expr (&se, clauses->chunk_size);
2299 gfc_add_block_to_block (block, &se.pre);
2300 chunk_size = gfc_evaluate_now (se.expr, block);
2301 gfc_add_block_to_block (block, &se.post);
2302 }
2303
2304 if (clauses->sched_kind != OMP_SCHED_NONE)
2305 {
c2255bc4 2306 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
6c7a4dfd
JJ		 2307 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2308 switch (clauses->sched_kind)
2309 {
2310 case OMP_SCHED_STATIC:
2311 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
2312 break;
2313 case OMP_SCHED_DYNAMIC:
2314 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
2315 break;
2316 case OMP_SCHED_GUIDED:
2317 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
2318 break;
2319 case OMP_SCHED_RUNTIME:
2320 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
2321 break;
a68ab351
JJ		 2322 case OMP_SCHED_AUTO:
2323 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
2324 break;
6c7a4dfd
JJ		 2325 default:
2326 gcc_unreachable ();
2327 }
2328 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2329 }
2330
2331 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
2332 {
c2255bc4 2333 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
6c7a4dfd
JJ		 2334 switch (clauses->default_sharing)
2335 {
2336 case OMP_DEFAULT_NONE:
2337 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
2338 break;
2339 case OMP_DEFAULT_SHARED:
2340 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
2341 break;
2342 case OMP_DEFAULT_PRIVATE:
2343 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
2344 break;
a68ab351
JJ		 2345 case OMP_DEFAULT_FIRSTPRIVATE:
2346 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
2347 break;
6c7a4dfd
JJ		 2348 default:
2349 gcc_unreachable ();
2350 }
2351 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2352 }
2353
2354 if (clauses->nowait)
2355 {
c2255bc4 2356 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
6c7a4dfd
JJ		 2357 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2358 }
2359
2360 if (clauses->ordered)
2361 {
c2255bc4 2362 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
d9a6bd32 2363 OMP_CLAUSE_ORDERED_EXPR (c) = NULL_TREE;
6c7a4dfd
JJ		 2364 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2365 }
2366
a68ab351
JJ		 2367 if (clauses->untied)
2368 {
c2255bc4 2369 c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
a68ab351
JJ		 2370 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2371 }
2372
20906c66
JJ		 2373 if (clauses->mergeable)
2374 {
2375 c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE);
2376 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2377 }
2378
a68ab351
JJ		 2379 if (clauses->collapse)
2380 {
c2255bc4 2381 c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
df09d1d5
RG		 2382 OMP_CLAUSE_COLLAPSE_EXPR (c)
2383 = build_int_cst (integer_type_node, clauses->collapse);
a68ab351
JJ		 2384 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2385 }
2386
dd2fc525
JJ		 2387 if (clauses->inbranch)
2388 {
2389 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH);
2390 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2391 }
2392
2393 if (clauses->notinbranch)
2394 {
2395 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH);
2396 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2397 }
2398
2399 switch (clauses->cancel)
2400 {
2401 case OMP_CANCEL_UNKNOWN:
2402 break;
2403 case OMP_CANCEL_PARALLEL:
2404 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL);
2405 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2406 break;
2407 case OMP_CANCEL_SECTIONS:
2408 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS);
2409 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2410 break;
2411 case OMP_CANCEL_DO:
2412 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR);
2413 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2414 break;
2415 case OMP_CANCEL_TASKGROUP:
2416 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP);
2417 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2418 break;
2419 }
2420
2421 if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
2422 {
2423 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND);
2424 switch (clauses->proc_bind)
2425 {
2426 case OMP_PROC_BIND_MASTER:
2427 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
2428 break;
2429 case OMP_PROC_BIND_SPREAD:
2430 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
2431 break;
2432 case OMP_PROC_BIND_CLOSE:
2433 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
2434 break;
2435 default:
2436 gcc_unreachable ();
2437 }
2438 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2439 }
2440
2441 if (clauses->safelen_expr)
2442 {
2443 tree safelen_var;
2444
2445 gfc_init_se (&se, NULL);
2446 gfc_conv_expr (&se, clauses->safelen_expr);
2447 gfc_add_block_to_block (block, &se.pre);
2448 safelen_var = gfc_evaluate_now (se.expr, block);
2449 gfc_add_block_to_block (block, &se.post);
2450
2451 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN);
2452 OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
2453 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2454 }
2455
2456 if (clauses->simdlen_expr)
2457 {
2458 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN);
2459 OMP_CLAUSE_SIMDLEN_EXPR (c)
2460 = gfc_conv_constant_to_tree (clauses->simdlen_expr);
2461 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2462 }
2463
f014c653
JJ		 2464 if (clauses->num_teams)
2465 {
2466 tree num_teams;
2467
2468 gfc_init_se (&se, NULL);
2469 gfc_conv_expr (&se, clauses->num_teams);
2470 gfc_add_block_to_block (block, &se.pre);
2471 num_teams = gfc_evaluate_now (se.expr, block);
2472 gfc_add_block_to_block (block, &se.post);
2473
2474 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS);
2475 OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams;
2476 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2477 }
2478
2479 if (clauses->device)
2480 {
2481 tree device;
2482
2483 gfc_init_se (&se, NULL);
2484 gfc_conv_expr (&se, clauses->device);
2485 gfc_add_block_to_block (block, &se.pre);
2486 device = gfc_evaluate_now (se.expr, block);
2487 gfc_add_block_to_block (block, &se.post);
2488
2489 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE);
2490 OMP_CLAUSE_DEVICE_ID (c) = device;
2491 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2492 }
2493
2494 if (clauses->thread_limit)
2495 {
2496 tree thread_limit;
2497
2498 gfc_init_se (&se, NULL);
2499 gfc_conv_expr (&se, clauses->thread_limit);
2500 gfc_add_block_to_block (block, &se.pre);
2501 thread_limit = gfc_evaluate_now (se.expr, block);
2502 gfc_add_block_to_block (block, &se.post);
2503
2504 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT);
2505 OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
2506 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2507 }
2508
2509 chunk_size = NULL_TREE;
2510 if (clauses->dist_chunk_size)
2511 {
2512 gfc_init_se (&se, NULL);
2513 gfc_conv_expr (&se, clauses->dist_chunk_size);
2514 gfc_add_block_to_block (block, &se.pre);
2515 chunk_size = gfc_evaluate_now (se.expr, block);
2516 gfc_add_block_to_block (block, &se.post);
2517 }
2518
2519 if (clauses->dist_sched_kind != OMP_SCHED_NONE)
2520 {
2521 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE);
2522 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2523 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2524 }
2525
41dbbb37
TS		 2526 if (clauses->async)
2527 {
2528 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC);
2529 if (clauses->async_expr)
2530 OMP_CLAUSE_ASYNC_EXPR (c)
2531 = gfc_convert_expr_to_tree (block, clauses->async_expr);
2532 else
2533 OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
2534 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2535 }
2536 if (clauses->seq)
2537 {
7a5e4956
CP		 2538 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ);
2539 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2540 }
2541 if (clauses->par_auto)
2542 {
2543 c = build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO);
41dbbb37
TS		 2544 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2545 }
2546 if (clauses->independent)
2547 {
2548 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT);
2549 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2550 }
2551 if (clauses->wait_list)
2552 {
2553 gfc_expr_list *el;
2554
2555 for (el = clauses->wait_list; el; el = el->next)
2556 {
2557 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT);
2558 OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
2559 OMP_CLAUSE_CHAIN (c) = omp_clauses;
2560 omp_clauses = c;
2561 }
2562 }
2563 if (clauses->num_gangs_expr)
2564 {
2565 tree num_gangs_var
2566 = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
2567 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS);
2568 OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
2569 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2570 }
2571 if (clauses->num_workers_expr)
2572 {
2573 tree num_workers_var
2574 = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
2575 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS);
2576 OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
2577 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2578 }
2579 if (clauses->vector_length_expr)
2580 {
2581 tree vector_length_var
2582 = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
2583 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH);
2584 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
2585 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2586 }
7a5e4956
CP		 2587 if (clauses->tile_list)
2588 {
2589 vec<tree, va_gc> *tvec;
2590 gfc_expr_list *el;
2591
2592 vec_alloc (tvec, 4);
2593
2594 for (el = clauses->tile_list; el; el = el->next)
2595 vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr));
2596
2597 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TILE);
2598 OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec);
2599 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2600 tvec->truncate (0);
2601 }
41dbbb37
TS		 2602 if (clauses->vector)
2603 {
2604 if (clauses->vector_expr)
2605 {
2606 tree vector_var
2607 = gfc_convert_expr_to_tree (block, clauses->vector_expr);
2608 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2609 OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
2610 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2611 }
2612 else
2613 {
2614 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2615 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2616 }
2617 }
2618 if (clauses->worker)
2619 {
2620 if (clauses->worker_expr)
2621 {
2622 tree worker_var
2623 = gfc_convert_expr_to_tree (block, clauses->worker_expr);
2624 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2625 OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
2626 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2627 }
2628 else
2629 {
2630 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2631 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2632 }
2633 }
2634 if (clauses->gang)
2635 {
2a70708e
CP		 2636 tree arg;
2637 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
2638 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2639 if (clauses->gang_num_expr)
7a5e4956 2640 {
2a70708e
CP		 2641 arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
2642 OMP_CLAUSE_GANG_EXPR (c) = arg;
41dbbb37 2643 }
2a70708e 2644 if (clauses->gang_static)
41dbbb37 2645 {
2a70708e
CP		 2646 arg = clauses->gang_static_expr
2647 ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
2648 : integer_minus_one_node;
2649 OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
41dbbb37
TS		 2650 }
2651 }
2652
f014c653 2653 return nreverse (omp_clauses);
6c7a4dfd
JJ		 2654}
2655
2656/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
2657
2658static tree
2659gfc_trans_omp_code (gfc_code *code, bool force_empty)
2660{
2661 tree stmt;
2662
87a60f68 2663 pushlevel ();
6c7a4dfd
JJ		 2664 stmt = gfc_trans_code (code);
2665 if (TREE_CODE (stmt) != BIND_EXPR)
2666 {
2667 if (!IS_EMPTY_STMT (stmt) || force_empty)
2668 {
87a60f68 2669 tree block = poplevel (1, 0);
6c7a4dfd
JJ		 2670 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
2671 }
2672 else
87a60f68 2673 poplevel (0, 0);
6c7a4dfd
JJ		 2674 }
2675 else
87a60f68 2676 poplevel (0, 0);
6c7a4dfd
JJ		 2677 return stmt;
2678}
2679
41dbbb37
TS		 2680/* Trans OpenACC directives. */
2681/* parallel, kernels, data and host_data. */
2682static tree
2683gfc_trans_oacc_construct (gfc_code *code)
2684{
2685 stmtblock_t block;
2686 tree stmt, oacc_clauses;
2687 enum tree_code construct_code;
2688
2689 switch (code->op)
2690 {
2691 case EXEC_OACC_PARALLEL:
2692 construct_code = OACC_PARALLEL;
2693 break;
2694 case EXEC_OACC_KERNELS:
2695 construct_code = OACC_KERNELS;
2696 break;
2697 case EXEC_OACC_DATA:
2698 construct_code = OACC_DATA;
2699 break;
2700 case EXEC_OACC_HOST_DATA:
2701 construct_code = OACC_HOST_DATA;
2702 break;
2703 default:
2704 gcc_unreachable ();
2705 }
2706
2707 gfc_start_block (&block);
2708 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
2709 code->loc);
2710 stmt = gfc_trans_omp_code (code->block->next, true);
2711 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
2712 oacc_clauses);
2713 gfc_add_expr_to_block (&block, stmt);
2714 return gfc_finish_block (&block);
2715}
2716
2717/* update, enter_data, exit_data, cache. */
2718static tree
2719gfc_trans_oacc_executable_directive (gfc_code *code)
2720{
2721 stmtblock_t block;
2722 tree stmt, oacc_clauses;
2723 enum tree_code construct_code;
2724
2725 switch (code->op)
2726 {
2727 case EXEC_OACC_UPDATE:
2728 construct_code = OACC_UPDATE;
2729 break;
2730 case EXEC_OACC_ENTER_DATA:
2731 construct_code = OACC_ENTER_DATA;
2732 break;
2733 case EXEC_OACC_EXIT_DATA:
2734 construct_code = OACC_EXIT_DATA;
2735 break;
2736 case EXEC_OACC_CACHE:
2737 construct_code = OACC_CACHE;
2738 break;
2739 default:
2740 gcc_unreachable ();
2741 }
2742
2743 gfc_start_block (&block);
2744 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
2745 code->loc);
2746 stmt = build1_loc (input_location, construct_code, void_type_node,
2747 oacc_clauses);
2748 gfc_add_expr_to_block (&block, stmt);
2749 return gfc_finish_block (&block);
2750}
2751
2752static tree
2753gfc_trans_oacc_wait_directive (gfc_code *code)
2754{
2755 stmtblock_t block;
2756 tree stmt, t;
2757 vec<tree, va_gc> *args;
2758 int nparms = 0;
2759 gfc_expr_list *el;
2760 gfc_omp_clauses *clauses = code->ext.omp_clauses;
2761 location_t loc = input_location;
2762
2763 for (el = clauses->wait_list; el; el = el->next)
2764 nparms++;
2765
2766 vec_alloc (args, nparms + 2);
2767 stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
2768
2769 gfc_start_block (&block);
2770
2771 if (clauses->async_expr)
2772 t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
2773 else
2774 t = build_int_cst (integer_type_node, -2);
2775
2776 args->quick_push (t);
2777 args->quick_push (build_int_cst (integer_type_node, nparms));
2778
2779 for (el = clauses->wait_list; el; el = el->next)
2780 args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
2781
2782 stmt = build_call_expr_loc_vec (loc, stmt, args);
2783 gfc_add_expr_to_block (&block, stmt);
2784
2785 vec_free (args);
2786
2787 return gfc_finish_block (&block);
2788}
6c7a4dfd
JJ		 2789
2790static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
2791static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
2792
2793static tree
2794gfc_trans_omp_atomic (gfc_code *code)
2795{
20906c66 2796 gfc_code *atomic_code = code;
6c7a4dfd
JJ		 2797 gfc_se lse;
2798 gfc_se rse;
20906c66 2799 gfc_se vse;
6c7a4dfd
JJ		 2800 gfc_expr *expr2, *e;
2801 gfc_symbol *var;
2802 stmtblock_t block;
2803 tree lhsaddr, type, rhs, x;
2804 enum tree_code op = ERROR_MARK;
20906c66 2805 enum tree_code aop = OMP_ATOMIC;
6c7a4dfd 2806 bool var_on_left = false;
dd2fc525 2807 bool seq_cst = (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) != 0;
6c7a4dfd
JJ		 2808
2809 code = code->block->next;
2810 gcc_assert (code->op == EXEC_ASSIGN);
a513927a 2811 var = code->expr1->symtree->n.sym;
6c7a4dfd
JJ		 2812
2813 gfc_init_se (&lse, NULL);
2814 gfc_init_se (&rse, NULL);
20906c66 2815 gfc_init_se (&vse, NULL);
6c7a4dfd
JJ		 2816 gfc_start_block (&block);
2817
6c7a4dfd 2818 expr2 = code->expr2;
20b6cf01
JJ		 2819 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2820 != GFC_OMP_ATOMIC_WRITE)
2821 && (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP) == 0
2822 && expr2->expr_type == EXPR_FUNCTION
2823 && expr2->value.function.isym
cd5ecab6 2824 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6c7a4dfd
JJ		 2825 expr2 = expr2->value.function.actual->expr;
2826
dd2fc525 2827 switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
20906c66
JJ		 2828 {
2829 case GFC_OMP_ATOMIC_READ:
2830 gfc_conv_expr (&vse, code->expr1);
2831 gfc_add_block_to_block (&block, &vse.pre);
2832
2833 gfc_conv_expr (&lse, expr2);
2834 gfc_add_block_to_block (&block, &lse.pre);
2835 type = TREE_TYPE (lse.expr);
2836 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
2837
2838 x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
dd2fc525 2839 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
20906c66
JJ		 2840 x = convert (TREE_TYPE (vse.expr), x);
2841 gfc_add_modify (&block, vse.expr, x);
2842
2843 gfc_add_block_to_block (&block, &lse.pre);
2844 gfc_add_block_to_block (&block, &rse.pre);
2845
2846 return gfc_finish_block (&block);
2847 case GFC_OMP_ATOMIC_CAPTURE:
2848 aop = OMP_ATOMIC_CAPTURE_NEW;
2849 if (expr2->expr_type == EXPR_VARIABLE)
2850 {
2851 aop = OMP_ATOMIC_CAPTURE_OLD;
2852 gfc_conv_expr (&vse, code->expr1);
2853 gfc_add_block_to_block (&block, &vse.pre);
2854
2855 gfc_conv_expr (&lse, expr2);
2856 gfc_add_block_to_block (&block, &lse.pre);
2857 gfc_init_se (&lse, NULL);
2858 code = code->next;
2859 var = code->expr1->symtree->n.sym;
2860 expr2 = code->expr2;
2861 if (expr2->expr_type == EXPR_FUNCTION
20b6cf01 2862 && expr2->value.function.isym
20906c66
JJ		 2863 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
2864 expr2 = expr2->value.function.actual->expr;
2865 }
2866 break;
2867 default:
2868 break;
2869 }
2870
2871 gfc_conv_expr (&lse, code->expr1);
2872 gfc_add_block_to_block (&block, &lse.pre);
2873 type = TREE_TYPE (lse.expr);
2874 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
2875
dd2fc525
JJ		 2876 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2877 == GFC_OMP_ATOMIC_WRITE)
2878 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
20906c66
JJ		 2879 {
2880 gfc_conv_expr (&rse, expr2);
2881 gfc_add_block_to_block (&block, &rse.pre);
2882 }
2883 else if (expr2->expr_type == EXPR_OP)
6c7a4dfd
JJ		 2884 {
2885 gfc_expr *e;
a1ee985f 2886 switch (expr2->value.op.op)
6c7a4dfd
JJ		 2887 {
2888 case INTRINSIC_PLUS:
2889 op = PLUS_EXPR;
2890 break;
2891 case INTRINSIC_TIMES:
2892 op = MULT_EXPR;
2893 break;
2894 case INTRINSIC_MINUS:
2895 op = MINUS_EXPR;
2896 break;
2897 case INTRINSIC_DIVIDE:
2898 if (expr2->ts.type == BT_INTEGER)
2899 op = TRUNC_DIV_EXPR;
2900 else
2901 op = RDIV_EXPR;
2902 break;
2903 case INTRINSIC_AND:
2904 op = TRUTH_ANDIF_EXPR;
2905 break;
2906 case INTRINSIC_OR:
2907 op = TRUTH_ORIF_EXPR;
2908 break;
2909 case INTRINSIC_EQV:
2910 op = EQ_EXPR;
2911 break;
2912 case INTRINSIC_NEQV:
2913 op = NE_EXPR;
2914 break;
2915 default:
2916 gcc_unreachable ();
2917 }
2918 e = expr2->value.op.op1;
2919 if (e->expr_type == EXPR_FUNCTION
20b6cf01 2920 && e->value.function.isym
cd5ecab6 2921 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6c7a4dfd
JJ		 2922 e = e->value.function.actual->expr;
2923 if (e->expr_type == EXPR_VARIABLE
2924 && e->symtree != NULL
2925 && e->symtree->n.sym == var)
2926 {
2927 expr2 = expr2->value.op.op2;
2928 var_on_left = true;
2929 }
2930 else
2931 {
2932 e = expr2->value.op.op2;
2933 if (e->expr_type == EXPR_FUNCTION
20b6cf01 2934 && e->value.function.isym
cd5ecab6 2935 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6c7a4dfd
JJ		 2936 e = e->value.function.actual->expr;
2937 gcc_assert (e->expr_type == EXPR_VARIABLE
2938 && e->symtree != NULL
2939 && e->symtree->n.sym == var);
2940 expr2 = expr2->value.op.op1;
2941 var_on_left = false;
2942 }
2943 gfc_conv_expr (&rse, expr2);
2944 gfc_add_block_to_block (&block, &rse.pre);
2945 }
2946 else
2947 {
2948 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
cd5ecab6 2949 switch (expr2->value.function.isym->id)
6c7a4dfd
JJ		 2950 {
2951 case GFC_ISYM_MIN:
2952 op = MIN_EXPR;
2953 break;
2954 case GFC_ISYM_MAX:
2955 op = MAX_EXPR;
2956 break;
2957 case GFC_ISYM_IAND:
2958 op = BIT_AND_EXPR;
2959 break;
2960 case GFC_ISYM_IOR:
2961 op = BIT_IOR_EXPR;
2962 break;
2963 case GFC_ISYM_IEOR:
2964 op = BIT_XOR_EXPR;
2965 break;
2966 default:
2967 gcc_unreachable ();
2968 }
2969 e = expr2->value.function.actual->expr;
2970 gcc_assert (e->expr_type == EXPR_VARIABLE
2971 && e->symtree != NULL
2972 && e->symtree->n.sym == var);
2973
2974 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
2975 gfc_add_block_to_block (&block, &rse.pre);
2976 if (expr2->value.function.actual->next->next != NULL)
2977 {
2978 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
2979 gfc_actual_arglist *arg;
2980
726a989a 2981 gfc_add_modify (&block, accum, rse.expr);
6c7a4dfd
JJ		 2982 for (arg = expr2->value.function.actual->next->next; arg;
2983 arg = arg->next)
2984 {
2985 gfc_init_block (&rse.pre);
2986 gfc_conv_expr (&rse, arg->expr);
2987 gfc_add_block_to_block (&block, &rse.pre);
65a9ca82
TB		 2988 x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
2989 accum, rse.expr);
726a989a 2990 gfc_add_modify (&block, accum, x);
6c7a4dfd
JJ		 2991 }
2992
2993 rse.expr = accum;
2994 }
2995
2996 expr2 = expr2->value.function.actual->next->expr;
2997 }
2998
2999 lhsaddr = save_expr (lhsaddr);
3f9e8f13
JJ		 3000 if (TREE_CODE (lhsaddr) != SAVE_EXPR
3001 && (TREE_CODE (lhsaddr) != ADDR_EXPR
d168c883 3002 || !VAR_P (TREE_OPERAND (lhsaddr, 0))))
3f9e8f13
JJ		 3003 {
3004 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
3005 it even after unsharing function body. */
b731b390 3006 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
3f9e8f13
JJ		 3007 DECL_CONTEXT (var) = current_function_decl;
3008 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
3009 NULL_TREE, NULL_TREE);
3010 }
3011
6c7a4dfd 3012 rhs = gfc_evaluate_now (rse.expr, &block);
6c7a4dfd 3013
dd2fc525
JJ		 3014 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3015 == GFC_OMP_ATOMIC_WRITE)
3016 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
20906c66 3017 x = rhs;
6c7a4dfd 3018 else
20906c66
JJ		 3019 {
3020 x = convert (TREE_TYPE (rhs),
3021 build_fold_indirect_ref_loc (input_location, lhsaddr));
3022 if (var_on_left)
3023 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
3024 else
3025 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
3026 }
6c7a4dfd
JJ		 3027
3028 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
3029 && TREE_CODE (type) != COMPLEX_TYPE)
65a9ca82
TB		 3030 x = fold_build1_loc (input_location, REALPART_EXPR,
3031 TREE_TYPE (TREE_TYPE (rhs)), x);
6c7a4dfd 3032
6c7a4dfd
JJ		 3033 gfc_add_block_to_block (&block, &lse.pre);
3034 gfc_add_block_to_block (&block, &rse.pre);
3035
20906c66
JJ		 3036 if (aop == OMP_ATOMIC)
3037 {
3038 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
dd2fc525 3039 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
20906c66
JJ		 3040 gfc_add_expr_to_block (&block, x);
3041 }
3042 else
3043 {
3044 if (aop == OMP_ATOMIC_CAPTURE_NEW)
3045 {
3046 code = code->next;
3047 expr2 = code->expr2;
3048 if (expr2->expr_type == EXPR_FUNCTION
20b6cf01 3049 && expr2->value.function.isym
20906c66
JJ		 3050 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
3051 expr2 = expr2->value.function.actual->expr;
3052
3053 gcc_assert (expr2->expr_type == EXPR_VARIABLE);
3054 gfc_conv_expr (&vse, code->expr1);
3055 gfc_add_block_to_block (&block, &vse.pre);
3056
3057 gfc_init_se (&lse, NULL);
3058 gfc_conv_expr (&lse, expr2);
3059 gfc_add_block_to_block (&block, &lse.pre);
3060 }
3061 x = build2 (aop, type, lhsaddr, convert (type, x));
dd2fc525 3062 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
20906c66
JJ		 3063 x = convert (TREE_TYPE (vse.expr), x);
3064 gfc_add_modify (&block, vse.expr, x);
3065 }
3066
6c7a4dfd
JJ		 3067 return gfc_finish_block (&block);
3068}
3069
3070static tree
3071gfc_trans_omp_barrier (void)
3072{
e79983f4 3073 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
db3927fb 3074 return build_call_expr_loc (input_location, decl, 0);
6c7a4dfd
JJ		 3075}
3076
dd2fc525
JJ		 3077static tree
3078gfc_trans_omp_cancel (gfc_code *code)
3079{
3080 int mask = 0;
3081 tree ifc = boolean_true_node;
3082 stmtblock_t block;
3083 switch (code->ext.omp_clauses->cancel)
3084 {
3085 case OMP_CANCEL_PARALLEL: mask = 1; break;
3086 case OMP_CANCEL_DO: mask = 2; break;
3087 case OMP_CANCEL_SECTIONS: mask = 4; break;
3088 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3089 default: gcc_unreachable ();
3090 }
3091 gfc_start_block (&block);
3092 if (code->ext.omp_clauses->if_expr)
3093 {
3094 gfc_se se;
3095 tree if_var;
3096
3097 gfc_init_se (&se, NULL);
3098 gfc_conv_expr (&se, code->ext.omp_clauses->if_expr);
3099 gfc_add_block_to_block (&block, &se.pre);
3100 if_var = gfc_evaluate_now (se.expr, &block);
3101 gfc_add_block_to_block (&block, &se.post);
3102 tree type = TREE_TYPE (if_var);
3103 ifc = fold_build2_loc (input_location, NE_EXPR,
3104 boolean_type_node, if_var,
3105 build_zero_cst (type));
3106 }
3107 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
3108 tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
3109 ifc = fold_convert (c_bool_type, ifc);
3110 gfc_add_expr_to_block (&block,
3111 build_call_expr_loc (input_location, decl, 2,
3112 build_int_cst (integer_type_node,
3113 mask), ifc));
3114 return gfc_finish_block (&block);
3115}
3116
3117static tree
3118gfc_trans_omp_cancellation_point (gfc_code *code)
3119{
3120 int mask = 0;
3121 switch (code->ext.omp_clauses->cancel)
3122 {
3123 case OMP_CANCEL_PARALLEL: mask = 1; break;
3124 case OMP_CANCEL_DO: mask = 2; break;
3125 case OMP_CANCEL_SECTIONS: mask = 4; break;
3126 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3127 default: gcc_unreachable ();
3128 }
3129 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
3130 return build_call_expr_loc (input_location, decl, 1,
3131 build_int_cst (integer_type_node, mask));
3132}
3133
6c7a4dfd
JJ		 3134static tree
3135gfc_trans_omp_critical (gfc_code *code)
3136{
3137 tree name = NULL_TREE, stmt;
3138 if (code->ext.omp_name != NULL)
3139 name = get_identifier (code->ext.omp_name);
3140 stmt = gfc_trans_code (code->block->next);
d9a6bd32
JJ		 3141 return build3_loc (input_location, OMP_CRITICAL, void_type_node, stmt,
3142 NULL_TREE, name);
6c7a4dfd
JJ		 3143}
3144
04924d6a
NF		 3145typedef struct dovar_init_d {
3146 tree var;
3147 tree init;
3148} dovar_init;
3149
04924d6a 3150
6c7a4dfd 3151static tree
dd2fc525 3152gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
a68ab351 3153 gfc_omp_clauses *do_clauses, tree par_clauses)
6c7a4dfd
JJ		 3154{
3155 gfc_se se;
3156 tree dovar, stmt, from, to, step, type, init, cond, incr;
3157 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
3158 stmtblock_t block;
3159 stmtblock_t body;
742fae05 3160 gfc_omp_clauses *clauses = code->ext.omp_clauses;
a68ab351 3161 int i, collapse = clauses->collapse;
6e1aa848 3162 vec<dovar_init> inits = vNULL;
04924d6a
NF		 3163 dovar_init *di;
3164 unsigned ix;
6c7a4dfd 3165
a68ab351
JJ		 3166 if (collapse <= 0)
3167 collapse = 1;
3168
c4fae39e 3169 code = code->block->next;
6c7a4dfd
JJ		 3170 gcc_assert (code->op == EXEC_DO);
3171
a68ab351
JJ		 3172 init = make_tree_vec (collapse);
3173 cond = make_tree_vec (collapse);
3174 incr = make_tree_vec (collapse);
3175
6c7a4dfd
JJ		 3176 if (pblock == NULL)
3177 {
3178 gfc_start_block (&block);
3179 pblock = &block;
3180 }
3181
742fae05 3182 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
6c7a4dfd 3183
a68ab351 3184 for (i = 0; i < collapse; i++)
6c7a4dfd 3185 {
a68ab351
JJ		 3186 int simple = 0;
3187 int dovar_found = 0;
281e33e1 3188 tree dovar_decl;
a68ab351
JJ		 3189
3190 if (clauses)
6c7a4dfd 3191 {
f014c653
JJ		 3192 gfc_omp_namelist *n = NULL;
3193 if (op != EXEC_OMP_DISTRIBUTE)
3194 for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1)
3195 ? OMP_LIST_LINEAR : OMP_LIST_LASTPRIVATE];
3196 n != NULL; n = n->next)
3197 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3198 break;
a68ab351
JJ		 3199 if (n != NULL)
3200 dovar_found = 1;
dd2fc525 3201 else if (n == NULL && op != EXEC_OMP_SIMD)
a68ab351
JJ		 3202 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
3203 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3204 break;
3205 if (n != NULL)
3206 dovar_found++;
6c7a4dfd 3207 }
a68ab351
JJ		 3208
3209 /* Evaluate all the expressions in the iterator. */
3210 gfc_init_se (&se, NULL);
3211 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
3212 gfc_add_block_to_block (pblock, &se.pre);
3213 dovar = se.expr;
3214 type = TREE_TYPE (dovar);
3215 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
3216
3217 gfc_init_se (&se, NULL);
3218 gfc_conv_expr_val (&se, code->ext.iterator->start);
3219 gfc_add_block_to_block (pblock, &se.pre);
3220 from = gfc_evaluate_now (se.expr, pblock);
3221
3222 gfc_init_se (&se, NULL);
3223 gfc_conv_expr_val (&se, code->ext.iterator->end);
3224 gfc_add_block_to_block (pblock, &se.pre);
3225 to = gfc_evaluate_now (se.expr, pblock);
3226
3227 gfc_init_se (&se, NULL);
3228 gfc_conv_expr_val (&se, code->ext.iterator->step);
3229 gfc_add_block_to_block (pblock, &se.pre);
3230 step = gfc_evaluate_now (se.expr, pblock);
281e33e1 3231 dovar_decl = dovar;
a68ab351
JJ		 3232
3233 /* Special case simple loops. */
d168c883 3234 if (VAR_P (dovar))
281e33e1
JJ		 3235 {
3236 if (integer_onep (step))
3237 simple = 1;
3238 else if (tree_int_cst_equal (step, integer_minus_one_node))
3239 simple = -1;
3240 }
3241 else
3242 dovar_decl
dd2fc525
JJ		 3243 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
3244 false);
a68ab351
JJ		 3245
3246 /* Loop body. */
3247 if (simple)
6c7a4dfd 3248 {
726a989a 3249 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
edaadf74
JJ		 3250 /* The condition should not be folded. */
3251 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
3252 ? LE_EXPR : GE_EXPR,
3253 boolean_type_node, dovar, to);
65a9ca82
TB		 3254 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3255 type, dovar, step);
3256 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3257 MODIFY_EXPR,
3258 type, dovar,
3259 TREE_VEC_ELT (incr, i));
a68ab351
JJ		 3260 }
3261 else
3262 {
3263 /* STEP is not 1 or -1. Use:
3264 for (count = 0; count < (to + step - from) / step; count++)
3265 {
3266 dovar = from + count * step;
3267 body;
3268 cycle_label:;
3269 } */
65a9ca82
TB		 3270 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
3271 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
3272 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
3273 step);
a68ab351
JJ		 3274 tmp = gfc_evaluate_now (tmp, pblock);
3275 count = gfc_create_var (type, "count");
726a989a 3276 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
a68ab351 3277 build_int_cst (type, 0));
edaadf74
JJ		 3278 /* The condition should not be folded. */
3279 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
3280 boolean_type_node,
3281 count, tmp);
65a9ca82
TB		 3282 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3283 type, count,
3284 build_int_cst (type, 1));
3285 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3286 MODIFY_EXPR, type, count,
3287 TREE_VEC_ELT (incr, i));
a68ab351
JJ		 3288
3289 /* Initialize DOVAR. */
65a9ca82
TB		 3290 tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
3291 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
f32682ca 3292 dovar_init e = {dovar, tmp};
9771b263 3293 inits.safe_push (e);
6c7a4dfd 3294 }
6c7a4dfd 3295
6c384511
JJ		 3296 if (dovar_found == 2
3297 && op == EXEC_OMP_SIMD
3298 && collapse == 1
3299 && !simple)
3300 {
3301 for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
3302 if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
3303 && OMP_CLAUSE_DECL (tmp) == dovar)
3304 {
3305 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3306 break;
3307 }
3308 }
a68ab351
JJ		 3309 if (!dovar_found)
3310 {
dd2fc525
JJ		 3311 if (op == EXEC_OMP_SIMD)
3312 {
3313 if (collapse == 1)
3314 {
3315 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3316 OMP_CLAUSE_LINEAR_STEP (tmp) = step;
6c384511 3317 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
dd2fc525
JJ		 3318 }
3319 else
3320 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3321 if (!simple)
3322 dovar_found = 2;
3323 }
3324 else
3325 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
281e33e1 3326 OMP_CLAUSE_DECL (tmp) = dovar_decl;
a68ab351
JJ		 3327 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3328 }
dd2fc525 3329 if (dovar_found == 2)
a68ab351
JJ		 3330 {
3331 tree c = NULL;
3332
3333 tmp = NULL;
3334 if (!simple)
3335 {
3336 /* If dovar is lastprivate, but different counter is used,
3337 dovar += step needs to be added to
3338 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
3339 will have the value on entry of the last loop, rather
3340 than value after iterator increment. */
3341 tmp = gfc_evaluate_now (step, pblock);
65a9ca82
TB		 3342 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
3343 tmp);
3344 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
3345 dovar, tmp);
a68ab351
JJ		 3346 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3347 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
281e33e1 3348 && OMP_CLAUSE_DECL (c) == dovar_decl)
a68ab351
JJ		 3349 {
3350 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
3351 break;
3352 }
dd2fc525
JJ		 3353 else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
3354 && OMP_CLAUSE_DECL (c) == dovar_decl)
3355 {
3356 OMP_CLAUSE_LINEAR_STMT (c) = tmp;
3357 break;
3358 }
a68ab351 3359 }
dd2fc525 3360 if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
a68ab351
JJ		 3361 {
3362 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3363 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
281e33e1 3364 && OMP_CLAUSE_DECL (c) == dovar_decl)
a68ab351 3365 {
c2255bc4
AH		 3366 tree l = build_omp_clause (input_location,
3367 OMP_CLAUSE_LASTPRIVATE);
281e33e1 3368 OMP_CLAUSE_DECL (l) = dovar_decl;
a68ab351
JJ		 3369 OMP_CLAUSE_CHAIN (l) = omp_clauses;
3370 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
3371 omp_clauses = l;
3372 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
3373 break;
3374 }
3375 }
3376 gcc_assert (simple || c != NULL);
3377 }
3378 if (!simple)
3379 {
dd2fc525
JJ		 3380 if (op != EXEC_OMP_SIMD)
3381 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3382 else if (collapse == 1)
3383 {
3384 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
6c384511 3385 OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
dd2fc525
JJ		 3386 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3387 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
3388 }
3389 else
3390 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
a68ab351
JJ		 3391 OMP_CLAUSE_DECL (tmp) = count;
3392 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3393 }
3394
3395 if (i + 1 < collapse)
3396 code = code->block->next;
6c7a4dfd
JJ		 3397 }
3398
a68ab351 3399 if (pblock != &block)
6c7a4dfd 3400 {
87a60f68 3401 pushlevel ();
a68ab351 3402 gfc_start_block (&block);
6c7a4dfd 3403 }
a68ab351
JJ		 3404
3405 gfc_start_block (&body);
3406
9771b263 3407 FOR_EACH_VEC_ELT (inits, ix, di)
04924d6a 3408 gfc_add_modify (&body, di->var, di->init);
9771b263 3409 inits.release ();
6c7a4dfd
JJ		 3410
3411 /* Cycle statement is implemented with a goto. Exit statement must not be
3412 present for this loop. */
3413 cycle_label = gfc_build_label_decl (NULL_TREE);
3414
e7041633 3415 /* Put these labels where they can be found later. */
6c7a4dfd 3416
7602cb87
JJ		 3417 code->cycle_label = cycle_label;
3418 code->exit_label = NULL_TREE;
6c7a4dfd
JJ		 3419
3420 /* Main loop body. */
3421 tmp = gfc_trans_omp_code (code->block->next, true);
3422 gfc_add_expr_to_block (&body, tmp);
3423
3424 /* Label for cycle statements (if needed). */
3425 if (TREE_USED (cycle_label))
3426 {
3427 tmp = build1_v (LABEL_EXPR, cycle_label);
3428 gfc_add_expr_to_block (&body, tmp);
3429 }
3430
3431 /* End of loop body. */
f014c653
JJ		 3432 switch (op)
3433 {
3434 case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
3435 case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
3436 case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
41dbbb37 3437 case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
f014c653
JJ		 3438 default: gcc_unreachable ();
3439 }
6c7a4dfd
JJ		 3440
3441 TREE_TYPE (stmt) = void_type_node;
3442 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
3443 OMP_FOR_CLAUSES (stmt) = omp_clauses;
3444 OMP_FOR_INIT (stmt) = init;
3445 OMP_FOR_COND (stmt) = cond;
3446 OMP_FOR_INCR (stmt) = incr;
3447 gfc_add_expr_to_block (&block, stmt);
3448
3449 return gfc_finish_block (&block);
3450}
3451
41dbbb37
TS		 3452/* parallel loop and kernels loop. */
3453static tree
3454gfc_trans_oacc_combined_directive (gfc_code *code)
3455{
3456 stmtblock_t block, *pblock = NULL;
3457 gfc_omp_clauses construct_clauses, loop_clauses;
3458 tree stmt, oacc_clauses = NULL_TREE;
3459 enum tree_code construct_code;
3460
3461 switch (code->op)
3462 {
3463 case EXEC_OACC_PARALLEL_LOOP:
3464 construct_code = OACC_PARALLEL;
3465 break;
3466 case EXEC_OACC_KERNELS_LOOP:
3467 construct_code = OACC_KERNELS;
3468 break;
3469 default:
3470 gcc_unreachable ();
3471 }
3472
3473 gfc_start_block (&block);
3474
3475 memset (&loop_clauses, 0, sizeof (loop_clauses));
3476 if (code->ext.omp_clauses != NULL)
3477 {
3478 memcpy (&construct_clauses, code->ext.omp_clauses,
3479 sizeof (construct_clauses));
3480 loop_clauses.collapse = construct_clauses.collapse;
3481 loop_clauses.gang = construct_clauses.gang;
7a5e4956 3482 loop_clauses.gang_static = construct_clauses.gang_static;
2a70708e
CP		 3483 loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
3484 loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
41dbbb37 3485 loop_clauses.vector = construct_clauses.vector;
7a5e4956 3486 loop_clauses.vector_expr = construct_clauses.vector_expr;
41dbbb37 3487 loop_clauses.worker = construct_clauses.worker;
7a5e4956 3488 loop_clauses.worker_expr = construct_clauses.worker_expr;
41dbbb37 3489 loop_clauses.seq = construct_clauses.seq;
7a5e4956 3490 loop_clauses.par_auto = construct_clauses.par_auto;
41dbbb37 3491 loop_clauses.independent = construct_clauses.independent;
7a5e4956
CP		 3492 loop_clauses.tile_list = construct_clauses.tile_list;
3493 loop_clauses.lists[OMP_LIST_PRIVATE]
3494 = construct_clauses.lists[OMP_LIST_PRIVATE];
3495 loop_clauses.lists[OMP_LIST_REDUCTION]
3496 = construct_clauses.lists[OMP_LIST_REDUCTION];
41dbbb37 3497 construct_clauses.gang = false;
7a5e4956 3498 construct_clauses.gang_static = false;
2a70708e
CP		 3499 construct_clauses.gang_num_expr = NULL;
3500 construct_clauses.gang_static_expr = NULL;
41dbbb37 3501 construct_clauses.vector = false;
7a5e4956 3502 construct_clauses.vector_expr = NULL;
41dbbb37 3503 construct_clauses.worker = false;
7a5e4956 3504 construct_clauses.worker_expr = NULL;
41dbbb37 3505 construct_clauses.seq = false;
7a5e4956
CP		 3506 construct_clauses.par_auto = false;
3507 construct_clauses.independent = false;
41dbbb37 3508 construct_clauses.independent = false;
7a5e4956
CP		 3509 construct_clauses.tile_list = NULL;
3510 construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
e7ff0319
CP		 3511 if (construct_code == OACC_KERNELS)
3512 construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
41dbbb37
TS		 3513 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
3514 code->loc);
3515 }
3516 if (!loop_clauses.seq)
3517 pblock = &block;
3518 else
3519 pushlevel ();
c146aced 3520 stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
41dbbb37
TS		 3521 if (TREE_CODE (stmt) != BIND_EXPR)
3522 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3523 else
3524 poplevel (0, 0);
3525 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
3526 oacc_clauses);
41dbbb37
TS		 3527 gfc_add_expr_to_block (&block, stmt);
3528 return gfc_finish_block (&block);
3529}
3530
6c7a4dfd
JJ		 3531static tree
3532gfc_trans_omp_flush (void)
3533{
e79983f4 3534 tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
db3927fb 3535 return build_call_expr_loc (input_location, decl, 0);
6c7a4dfd
JJ		 3536}
3537
3538static tree
3539gfc_trans_omp_master (gfc_code *code)
3540{
3541 tree stmt = gfc_trans_code (code->block->next);
3542 if (IS_EMPTY_STMT (stmt))
3543 return stmt;
3544 return build1_v (OMP_MASTER, stmt);
3545}
3546
3547static tree
3548gfc_trans_omp_ordered (gfc_code *code)
3549{
d9a6bd32
JJ		 3550 return build2_loc (input_location, OMP_ORDERED, void_type_node,
3551 gfc_trans_code (code->block->next), NULL_TREE);
6c7a4dfd
JJ		 3552}
3553
3554static tree
3555gfc_trans_omp_parallel (gfc_code *code)
3556{
3557 stmtblock_t block;
3558 tree stmt, omp_clauses;
3559
3560 gfc_start_block (&block);
3561 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3562 code->loc);
94e73c78 3563 pushlevel ();
6c7a4dfd 3564 stmt = gfc_trans_omp_code (code->block->next, true);
94e73c78 3565 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
5d44e5c8
TB		 3566 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3567 omp_clauses);
6c7a4dfd
JJ		 3568 gfc_add_expr_to_block (&block, stmt);
3569 return gfc_finish_block (&block);
3570}
3571
dd2fc525
JJ		 3572enum
3573{
3574 GFC_OMP_SPLIT_SIMD,
3575 GFC_OMP_SPLIT_DO,
3576 GFC_OMP_SPLIT_PARALLEL,
f014c653
JJ		 3577 GFC_OMP_SPLIT_DISTRIBUTE,
3578 GFC_OMP_SPLIT_TEAMS,
3579 GFC_OMP_SPLIT_TARGET,
dd2fc525
JJ		 3580 GFC_OMP_SPLIT_NUM
3581};
3582
3583enum
3584{
3585 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
3586 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
f014c653
JJ		 3587 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
3588 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
3589 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
3590 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET)
dd2fc525
JJ		 3591};
3592
3593static void
3594gfc_split_omp_clauses (gfc_code *code,
3595 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
3596{
5f23671d 3597 int mask = 0, innermost = 0;
dd2fc525
JJ		 3598 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
3599 switch (code->op)
3600 {
f014c653
JJ		 3601 case EXEC_OMP_DISTRIBUTE:
3602 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3603 break;
3604 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3605 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3606 innermost = GFC_OMP_SPLIT_DO;
3607 break;
3608 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3609 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
3610 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3611 innermost = GFC_OMP_SPLIT_SIMD;
3612 break;
3613 case EXEC_OMP_DISTRIBUTE_SIMD:
3614 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3615 innermost = GFC_OMP_SPLIT_SIMD;
3616 break;
3617 case EXEC_OMP_DO:
3618 innermost = GFC_OMP_SPLIT_DO;
3619 break;
dd2fc525
JJ		 3620 case EXEC_OMP_DO_SIMD:
3621 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3622 innermost = GFC_OMP_SPLIT_SIMD;
3623 break;
f014c653
JJ		 3624 case EXEC_OMP_PARALLEL:
3625 innermost = GFC_OMP_SPLIT_PARALLEL;
3626 break;
dd2fc525
JJ		 3627 case EXEC_OMP_PARALLEL_DO:
3628 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3629 innermost = GFC_OMP_SPLIT_DO;
3630 break;
3631 case EXEC_OMP_PARALLEL_DO_SIMD:
3632 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3633 innermost = GFC_OMP_SPLIT_SIMD;
3634 break;
f014c653
JJ		 3635 case EXEC_OMP_SIMD:
3636 innermost = GFC_OMP_SPLIT_SIMD;
3637 break;
3638 case EXEC_OMP_TARGET:
3639 innermost = GFC_OMP_SPLIT_TARGET;
3640 break;
3641 case EXEC_OMP_TARGET_TEAMS:
3642 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
3643 innermost = GFC_OMP_SPLIT_TEAMS;
3644 break;
3645 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3646 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3647 | GFC_OMP_MASK_DISTRIBUTE;
3648 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3649 break;
3650 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3651 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3652 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3653 innermost = GFC_OMP_SPLIT_DO;
3654 break;
3655 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3656 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3657 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3658 innermost = GFC_OMP_SPLIT_SIMD;
3659 break;
3660 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3661 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3662 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3663 innermost = GFC_OMP_SPLIT_SIMD;
3664 break;
3665 case EXEC_OMP_TEAMS:
3666 innermost = GFC_OMP_SPLIT_TEAMS;
3667 break;
3668 case EXEC_OMP_TEAMS_DISTRIBUTE:
3669 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
3670 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3671 break;
3672 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3673 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3674 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3675 innermost = GFC_OMP_SPLIT_DO;
3676 break;
3677 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3678 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3679 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3680 innermost = GFC_OMP_SPLIT_SIMD;
3681 break;
3682 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3683 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3684 innermost = GFC_OMP_SPLIT_SIMD;
3685 break;
dd2fc525
JJ		 3686 default:
3687 gcc_unreachable ();
3688 }
f014c653
JJ		 3689 if (mask == 0)
3690 {
3691 clausesa[innermost] = *code->ext.omp_clauses;
3692 return;
3693 }
dd2fc525
JJ		 3694 if (code->ext.omp_clauses != NULL)
3695 {
f014c653
JJ		 3696 if (mask & GFC_OMP_MASK_TARGET)
3697 {
3698 /* First the clauses that are unique to some constructs. */
3699 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
3700 = code->ext.omp_clauses->lists[OMP_LIST_MAP];
3701 clausesa[GFC_OMP_SPLIT_TARGET].device
3702 = code->ext.omp_clauses->device;
3703 }
3704 if (mask & GFC_OMP_MASK_TEAMS)
3705 {
3706 /* First the clauses that are unique to some constructs. */
3707 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
3708 = code->ext.omp_clauses->num_teams;
3709 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
3710 = code->ext.omp_clauses->thread_limit;
3711 /* Shared and default clauses are allowed on parallel and teams. */
3712 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
3713 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3714 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
3715 = code->ext.omp_clauses->default_sharing;
3716 }
3717 if (mask & GFC_OMP_MASK_DISTRIBUTE)
3718 {
3719 /* First the clauses that are unique to some constructs. */
3720 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
3721 = code->ext.omp_clauses->dist_sched_kind;
3722 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
3723 = code->ext.omp_clauses->dist_chunk_size;
3724 /* Duplicate collapse. */
3725 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
3726 = code->ext.omp_clauses->collapse;
3727 }
dd2fc525
JJ		 3728 if (mask & GFC_OMP_MASK_PARALLEL)
3729 {
3730 /* First the clauses that are unique to some constructs. */
3731 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
3732 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
3733 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
3734 = code->ext.omp_clauses->num_threads;
3735 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
3736 = code->ext.omp_clauses->proc_bind;
3737 /* Shared and default clauses are allowed on parallel and teams. */
3738 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
3739 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3740 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
3741 = code->ext.omp_clauses->default_sharing;
dd2fc525
JJ		 3742 }
3743 if (mask & GFC_OMP_MASK_DO)
3744 {
3745 /* First the clauses that are unique to some constructs. */
3746 clausesa[GFC_OMP_SPLIT_DO].ordered
3747 = code->ext.omp_clauses->ordered;
3748 clausesa[GFC_OMP_SPLIT_DO].sched_kind
3749 = code->ext.omp_clauses->sched_kind;
3750 clausesa[GFC_OMP_SPLIT_DO].chunk_size
3751 = code->ext.omp_clauses->chunk_size;
3752 clausesa[GFC_OMP_SPLIT_DO].nowait
3753 = code->ext.omp_clauses->nowait;
3754 /* Duplicate collapse. */
3755 clausesa[GFC_OMP_SPLIT_DO].collapse
3756 = code->ext.omp_clauses->collapse;
3757 }
3758 if (mask & GFC_OMP_MASK_SIMD)
3759 {
3760 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
3761 = code->ext.omp_clauses->safelen_expr;
3762 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LINEAR]
3763 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
3764 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
3765 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
3766 /* Duplicate collapse. */
3767 clausesa[GFC_OMP_SPLIT_SIMD].collapse
3768 = code->ext.omp_clauses->collapse;
3769 }
3770 /* Private clause is supported on all constructs but target,
3771 it is enough to put it on the innermost one. For
3772 !$ omp do put it on parallel though,
3773 as that's what we did for OpenMP 3.1. */
3774 clausesa[innermost == GFC_OMP_SPLIT_DO
3775 ? (int) GFC_OMP_SPLIT_PARALLEL
3776 : innermost].lists[OMP_LIST_PRIVATE]
3777 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
3778 /* Firstprivate clause is supported on all constructs but
3779 target and simd. Put it on the outermost of those and
3780 duplicate on parallel. */
f014c653
JJ		 3781 if (mask & GFC_OMP_MASK_TEAMS)
3782 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
3783 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3784 else if (mask & GFC_OMP_MASK_DISTRIBUTE)
3785 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
3786 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
dd2fc525
JJ		 3787 if (mask & GFC_OMP_MASK_PARALLEL)
3788 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
3789 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3790 else if (mask & GFC_OMP_MASK_DO)
3791 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
3792 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3793 /* Lastprivate is allowed on do and simd. In
3794 parallel do{, simd} we actually want to put it on
3795 parallel rather than do. */
3796 if (mask & GFC_OMP_MASK_PARALLEL)
3797 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
3798 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3799 else if (mask & GFC_OMP_MASK_DO)
3800 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
3801 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3802 if (mask & GFC_OMP_MASK_SIMD)
3803 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
3804 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3805 /* Reduction is allowed on simd, do, parallel and teams.
3806 Duplicate it on all of them, but omit on do if
3807 parallel is present. */
f014c653
JJ		 3808 if (mask & GFC_OMP_MASK_TEAMS)
3809 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION]
3810 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
5f23671d
JJ		 3811 if (mask & GFC_OMP_MASK_PARALLEL)
3812 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
3813 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3814 else if (mask & GFC_OMP_MASK_DO)
3815 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
3816 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3817 if (mask & GFC_OMP_MASK_SIMD)
3818 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
3819 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
f014c653
JJ		 3820 /* FIXME: This is currently being discussed. */
3821 if (mask & GFC_OMP_MASK_PARALLEL)
3822 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
3823 = code->ext.omp_clauses->if_expr;
3824 else
3825 clausesa[GFC_OMP_SPLIT_TARGET].if_expr
3826 = code->ext.omp_clauses->if_expr;
dd2fc525
JJ		 3827 }
3828 if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3829 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3830 clausesa[GFC_OMP_SPLIT_DO].nowait = true;
3831}
3832
6c7a4dfd 3833static tree
f014c653
JJ		 3834gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
3835 gfc_omp_clauses *clausesa, tree omp_clauses)
6c7a4dfd 3836{
f014c653 3837 stmtblock_t block;
dd2fc525
JJ		 3838 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3839 tree stmt, body, omp_do_clauses = NULL_TREE;
6c7a4dfd 3840
f014c653
JJ		 3841 if (pblock == NULL)
3842 gfc_start_block (&block);
3843 else
3844 gfc_init_block (&block);
6c7a4dfd 3845
dd2fc525 3846 if (clausesa == NULL)
6c7a4dfd 3847 {
dd2fc525
JJ		 3848 clausesa = clausesa_buf;
3849 gfc_split_omp_clauses (code, clausesa);
6c7a4dfd 3850 }
c61819ff 3851 if (flag_openmp)
92d28cbb
JJ		 3852 omp_do_clauses
3853 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
f014c653 3854 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
dd2fc525 3855 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
f014c653
JJ		 3856 if (pblock == NULL)
3857 {
3858 if (TREE_CODE (body) != BIND_EXPR)
3859 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
3860 else
3861 poplevel (0, 0);
3862 }
3863 else if (TREE_CODE (body) != BIND_EXPR)
3864 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
c61819ff 3865 if (flag_openmp)
92d28cbb
JJ		 3866 {
3867 stmt = make_node (OMP_FOR);
3868 TREE_TYPE (stmt) = void_type_node;
3869 OMP_FOR_BODY (stmt) = body;
3870 OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
3871 }
3872 else
3873 stmt = body;
dd2fc525
JJ		 3874 gfc_add_expr_to_block (&block, stmt);
3875 return gfc_finish_block (&block);
3876}
3877
3878static tree
f014c653
JJ		 3879gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock,
3880 gfc_omp_clauses *clausesa)
dd2fc525 3881{
f014c653
JJ		 3882 stmtblock_t block, *new_pblock = pblock;
3883 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
dd2fc525
JJ		 3884 tree stmt, omp_clauses = NULL_TREE;
3885
f014c653
JJ		 3886 if (pblock == NULL)
3887 gfc_start_block (&block);
3888 else
3889 gfc_init_block (&block);
dd2fc525 3890
f014c653
JJ		 3891 if (clausesa == NULL)
3892 {
3893 clausesa = clausesa_buf;
3894 gfc_split_omp_clauses (code, clausesa);
3895 }
dd2fc525
JJ		 3896 omp_clauses
3897 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3898 code->loc);
f014c653
JJ		 3899 if (pblock == NULL)
3900 {
3901 if (!clausesa[GFC_OMP_SPLIT_DO].ordered
3902 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
3903 new_pblock = &block;
3904 else
3905 pushlevel ();
3906 }
3907 stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock,
dd2fc525 3908 &clausesa[GFC_OMP_SPLIT_DO], omp_clauses);
f014c653
JJ		 3909 if (pblock == NULL)
3910 {
3911 if (TREE_CODE (stmt) != BIND_EXPR)
3912 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3913 else
3914 poplevel (0, 0);
3915 }
3916 else if (TREE_CODE (stmt) != BIND_EXPR)
3917 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
dd2fc525
JJ		 3918 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3919 omp_clauses);
3920 OMP_PARALLEL_COMBINED (stmt) = 1;
3921 gfc_add_expr_to_block (&block, stmt);
3922 return gfc_finish_block (&block);
3923}
3924
3925static tree
f014c653
JJ		 3926gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
3927 gfc_omp_clauses *clausesa)
dd2fc525
JJ		 3928{
3929 stmtblock_t block;
f014c653 3930 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
dd2fc525
JJ		 3931 tree stmt, omp_clauses = NULL_TREE;
3932
f014c653
JJ		 3933 if (pblock == NULL)
3934 gfc_start_block (&block);
3935 else
3936 gfc_init_block (&block);
dd2fc525 3937
f014c653
JJ		 3938 if (clausesa == NULL)
3939 {
3940 clausesa = clausesa_buf;
3941 gfc_split_omp_clauses (code, clausesa);
3942 }
c61819ff 3943 if (flag_openmp)
92d28cbb
JJ		 3944 omp_clauses
3945 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3946 code->loc);
f014c653
JJ		 3947 if (pblock == NULL)
3948 pushlevel ();
3949 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
3950 if (pblock == NULL)
3951 {
3952 if (TREE_CODE (stmt) != BIND_EXPR)
3953 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3954 else
3955 poplevel (0, 0);
3956 }
3957 else if (TREE_CODE (stmt) != BIND_EXPR)
3958 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
c61819ff 3959 if (flag_openmp)
92d28cbb
JJ		 3960 {
3961 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3962 omp_clauses);
3963 OMP_PARALLEL_COMBINED (stmt) = 1;
3964 }
6c7a4dfd
JJ		 3965 gfc_add_expr_to_block (&block, stmt);
3966 return gfc_finish_block (&block);
3967}
3968
3969static tree
3970gfc_trans_omp_parallel_sections (gfc_code *code)
3971{
3972 stmtblock_t block;
3973 gfc_omp_clauses section_clauses;
3974 tree stmt, omp_clauses;
3975
3976 memset (&section_clauses, 0, sizeof (section_clauses));
3977 section_clauses.nowait = true;
3978
3979 gfc_start_block (&block);
3980 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3981 code->loc);
87a60f68 3982 pushlevel ();
6c7a4dfd
JJ		 3983 stmt = gfc_trans_omp_sections (code, &section_clauses);
3984 if (TREE_CODE (stmt) != BIND_EXPR)
87a60f68 3985 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6c7a4dfd 3986 else
87a60f68 3987 poplevel (0, 0);
5d44e5c8
TB		 3988 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3989 omp_clauses);
761041be 3990 OMP_PARALLEL_COMBINED (stmt) = 1;
6c7a4dfd
JJ		 3991 gfc_add_expr_to_block (&block, stmt);
3992 return gfc_finish_block (&block);
3993}
3994
3995static tree
3996gfc_trans_omp_parallel_workshare (gfc_code *code)
3997{
3998 stmtblock_t block;
3999 gfc_omp_clauses workshare_clauses;
4000 tree stmt, omp_clauses;
4001
4002 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
4003 workshare_clauses.nowait = true;
4004
4005 gfc_start_block (&block);
4006 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4007 code->loc);
87a60f68 4008 pushlevel ();
6c7a4dfd 4009 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
d12a0b5a 4010 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
5d44e5c8
TB		 4011 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4012 omp_clauses);
761041be 4013 OMP_PARALLEL_COMBINED (stmt) = 1;
6c7a4dfd
JJ		 4014 gfc_add_expr_to_block (&block, stmt);
4015 return gfc_finish_block (&block);
4016}
4017
4018static tree
4019gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
4020{
4021 stmtblock_t block, body;
4022 tree omp_clauses, stmt;
4023 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
4024
4025 gfc_start_block (&block);
4026
4027 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
4028
4029 gfc_init_block (&body);
4030 for (code = code->block; code; code = code->block)
4031 {
4032 /* Last section is special because of lastprivate, so even if it
4033 is empty, chain it in. */
4034 stmt = gfc_trans_omp_code (code->next,
4035 has_lastprivate && code->block == NULL);
4036 if (! IS_EMPTY_STMT (stmt))
4037 {
4038 stmt = build1_v (OMP_SECTION, stmt);
4039 gfc_add_expr_to_block (&body, stmt);
4040 }
4041 }
4042 stmt = gfc_finish_block (&body);
4043
5d44e5c8
TB		 4044 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
4045 omp_clauses);
6c7a4dfd
JJ		 4046 gfc_add_expr_to_block (&block, stmt);
4047
4048 return gfc_finish_block (&block);
4049}
4050
4051static tree
4052gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
4053{
4054 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
4055 tree stmt = gfc_trans_omp_code (code->block->next, true);
5d44e5c8
TB		 4056 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
4057 omp_clauses);
6c7a4dfd
JJ		 4058 return stmt;
4059}
4060
a68ab351
JJ		 4061static tree
4062gfc_trans_omp_task (gfc_code *code)
4063{
4064 stmtblock_t block;
726a989a 4065 tree stmt, omp_clauses;
a68ab351
JJ		 4066
4067 gfc_start_block (&block);
4068 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4069 code->loc);
94e73c78 4070 pushlevel ();
726a989a 4071 stmt = gfc_trans_omp_code (code->block->next, true);
94e73c78 4072 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
5d44e5c8
TB		 4073 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
4074 omp_clauses);
a68ab351
JJ		 4075 gfc_add_expr_to_block (&block, stmt);
4076 return gfc_finish_block (&block);
4077}
4078
dd2fc525
JJ		 4079static tree
4080gfc_trans_omp_taskgroup (gfc_code *code)
4081{
4082 tree stmt = gfc_trans_code (code->block->next);
4083 return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt);
4084}
4085
a68ab351
JJ		 4086static tree
4087gfc_trans_omp_taskwait (void)
4088{
e79983f4 4089 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
db3927fb 4090 return build_call_expr_loc (input_location, decl, 0);
a68ab351
JJ		 4091}
4092
20906c66
JJ		 4093static tree
4094gfc_trans_omp_taskyield (void)
4095{
e79983f4 4096 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
20906c66
JJ		 4097 return build_call_expr_loc (input_location, decl, 0);
4098}
4099
f014c653
JJ		 4100static tree
4101gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
4102{
4103 stmtblock_t block;
4104 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4105 tree stmt, omp_clauses = NULL_TREE;
4106
4107 gfc_start_block (&block);
4108 if (clausesa == NULL)
4109 {
4110 clausesa = clausesa_buf;
4111 gfc_split_omp_clauses (code, clausesa);
4112 }
c61819ff 4113 if (flag_openmp)
f014c653
JJ		 4114 omp_clauses
4115 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4116 code->loc);
4117 switch (code->op)
4118 {
4119 case EXEC_OMP_DISTRIBUTE:
4120 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4121 case EXEC_OMP_TEAMS_DISTRIBUTE:
4122 /* This is handled in gfc_trans_omp_do. */
4123 gcc_unreachable ();
4124 break;
4125 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4126 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4127 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4128 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa);
4129 if (TREE_CODE (stmt) != BIND_EXPR)
4130 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4131 else
4132 poplevel (0, 0);
4133 break;
4134 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4135 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4136 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4137 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
4138 if (TREE_CODE (stmt) != BIND_EXPR)
4139 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4140 else
4141 poplevel (0, 0);
4142 break;
4143 case EXEC_OMP_DISTRIBUTE_SIMD:
4144 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4145 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4146 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4147 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4148 if (TREE_CODE (stmt) != BIND_EXPR)
4149 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4150 else
4151 poplevel (0, 0);
4152 break;
4153 default:
4154 gcc_unreachable ();
4155 }
c61819ff 4156 if (flag_openmp)
f014c653
JJ		 4157 {
4158 tree distribute = make_node (OMP_DISTRIBUTE);
4159 TREE_TYPE (distribute) = void_type_node;
4160 OMP_FOR_BODY (distribute) = stmt;
4161 OMP_FOR_CLAUSES (distribute) = omp_clauses;
4162 stmt = distribute;
4163 }
4164 gfc_add_expr_to_block (&block, stmt);
4165 return gfc_finish_block (&block);
4166}
4167
4168static tree
4169gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa)
4170{
4171 stmtblock_t block;
4172 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4173 tree stmt, omp_clauses = NULL_TREE;
41b37d5e 4174 bool combined = true;
f014c653
JJ		 4175
4176 gfc_start_block (&block);
4177 if (clausesa == NULL)
4178 {
4179 clausesa = clausesa_buf;
4180 gfc_split_omp_clauses (code, clausesa);
4181 }
c61819ff 4182 if (flag_openmp)
f014c653
JJ		 4183 omp_clauses
4184 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS],
4185 code->loc);
4186 switch (code->op)
4187 {
4188 case EXEC_OMP_TARGET_TEAMS:
4189 case EXEC_OMP_TEAMS:
4190 stmt = gfc_trans_omp_code (code->block->next, true);
41b37d5e 4191 combined = false;
f014c653
JJ		 4192 break;
4193 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4194 case EXEC_OMP_TEAMS_DISTRIBUTE:
4195 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
4196 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4197 NULL);
4198 break;
4199 default:
4200 stmt = gfc_trans_omp_distribute (code, clausesa);
4201 break;
4202 }
4203 stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt,
4204 omp_clauses);
41b37d5e
JJ		 4205 if (combined)
4206 OMP_TEAMS_COMBINED (stmt) = 1;
f014c653
JJ		 4207 gfc_add_expr_to_block (&block, stmt);
4208 return gfc_finish_block (&block);
4209}
4210
4211static tree
4212gfc_trans_omp_target (gfc_code *code)
4213{
4214 stmtblock_t block;
4215 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
4216 tree stmt, omp_clauses = NULL_TREE;
4217
4218 gfc_start_block (&block);
4219 gfc_split_omp_clauses (code, clausesa);
c61819ff 4220 if (flag_openmp)
f014c653
JJ		 4221 omp_clauses
4222 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
4223 code->loc);
4224 if (code->op == EXEC_OMP_TARGET)
94e73c78
JJ		 4225 {
4226 pushlevel ();
4227 stmt = gfc_trans_omp_code (code->block->next, true);
4228 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4229 }
f014c653 4230 else
41b37d5e
JJ		 4231 {
4232 pushlevel ();
4233 stmt = gfc_trans_omp_teams (code, clausesa);
4234 if (TREE_CODE (stmt) != BIND_EXPR)
4235 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4236 else
4237 poplevel (0, 0);
4238 }
c61819ff 4239 if (flag_openmp)
f014c653
JJ		 4240 stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt,
4241 omp_clauses);
4242 gfc_add_expr_to_block (&block, stmt);
4243 return gfc_finish_block (&block);
4244}
4245
4246static tree
4247gfc_trans_omp_target_data (gfc_code *code)
4248{
4249 stmtblock_t block;
4250 tree stmt, omp_clauses;
4251
4252 gfc_start_block (&block);
4253 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4254 code->loc);
4255 stmt = gfc_trans_omp_code (code->block->next, true);
4256 stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt,
4257 omp_clauses);
4258 gfc_add_expr_to_block (&block, stmt);
4259 return gfc_finish_block (&block);
4260}
4261
4262static tree
4263gfc_trans_omp_target_update (gfc_code *code)
4264{
4265 stmtblock_t block;
4266 tree stmt, omp_clauses;
4267
4268 gfc_start_block (&block);
4269 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4270 code->loc);
4271 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
4272 omp_clauses);
4273 gfc_add_expr_to_block (&block, stmt);
4274 return gfc_finish_block (&block);
4275}
4276
6c7a4dfd
JJ		 4277static tree
4278gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
4279{
34d01e1d
VL		 4280 tree res, tmp, stmt;
4281 stmtblock_t block, *pblock = NULL;
4282 stmtblock_t singleblock;
4283 int saved_ompws_flags;
4284 bool singleblock_in_progress = false;
4285 /* True if previous gfc_code in workshare construct is not workshared. */
4286 bool prev_singleunit;
4287
4288 code = code->block->next;
4289
87a60f68 4290 pushlevel ();
34d01e1d 4291
34d01e1d
VL		 4292 gfc_start_block (&block);
4293 pblock = &block;
4294
4295 ompws_flags = OMPWS_WORKSHARE_FLAG;
4296 prev_singleunit = false;
4297
4298 /* Translate statements one by one to trees until we reach
4299 the end of the workshare construct. Adjacent gfc_codes that
4300 are a single unit of work are clustered and encapsulated in a
4301 single OMP_SINGLE construct. */
4302 for (; code; code = code->next)
4303 {
4304 if (code->here != 0)
4305 {
4306 res = gfc_trans_label_here (code);
4307 gfc_add_expr_to_block (pblock, res);
4308 }
4309
4310 /* No dependence analysis, use for clauses with wait.
4311 If this is the last gfc_code, use default omp_clauses. */
4312 if (code->next == NULL && clauses->nowait)
4313 ompws_flags |= OMPWS_NOWAIT;
4314
4315 /* By default, every gfc_code is a single unit of work. */
4316 ompws_flags |= OMPWS_CURR_SINGLEUNIT;
57bf3072 4317 ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
34d01e1d
VL		 4318
4319 switch (code->op)
4320 {
4321 case EXEC_NOP:
4322 res = NULL_TREE;
4323 break;
4324
4325 case EXEC_ASSIGN:
4326 res = gfc_trans_assign (code);
4327 break;
4328
4329 case EXEC_POINTER_ASSIGN:
4330 res = gfc_trans_pointer_assign (code);
4331 break;
4332
4333 case EXEC_INIT_ASSIGN:
4334 res = gfc_trans_init_assign (code);
4335 break;
4336
4337 case EXEC_FORALL:
4338 res = gfc_trans_forall (code);
4339 break;
4340
4341 case EXEC_WHERE:
4342 res = gfc_trans_where (code);
4343 break;
4344
4345 case EXEC_OMP_ATOMIC:
4346 res = gfc_trans_omp_directive (code);
4347 break;
4348
4349 case EXEC_OMP_PARALLEL:
4350 case EXEC_OMP_PARALLEL_DO:
4351 case EXEC_OMP_PARALLEL_SECTIONS:
4352 case EXEC_OMP_PARALLEL_WORKSHARE:
4353 case EXEC_OMP_CRITICAL:
4354 saved_ompws_flags = ompws_flags;
4355 ompws_flags = 0;
4356 res = gfc_trans_omp_directive (code);
4357 ompws_flags = saved_ompws_flags;
4358 break;
4359
4360 default:
17d5d49f 4361 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
34d01e1d
VL		 4362 }
4363
4364 gfc_set_backend_locus (&code->loc);
4365
4366 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
4367 {
34d01e1d
VL		 4368 if (prev_singleunit)
4369 {
4370 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4371 /* Add current gfc_code to single block. */
4372 gfc_add_expr_to_block (&singleblock, res);
4373 else
4374 {
4375 /* Finish single block and add it to pblock. */
4376 tmp = gfc_finish_block (&singleblock);
5d44e5c8
TB		 4377 tmp = build2_loc (input_location, OMP_SINGLE,
4378 void_type_node, tmp, NULL_TREE);
34d01e1d
VL		 4379 gfc_add_expr_to_block (pblock, tmp);
4380 /* Add current gfc_code to pblock. */
4381 gfc_add_expr_to_block (pblock, res);
4382 singleblock_in_progress = false;
4383 }
4384 }
4385 else
4386 {
4387 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4388 {
4389 /* Start single block. */
4390 gfc_init_block (&singleblock);
4391 gfc_add_expr_to_block (&singleblock, res);
4392 singleblock_in_progress = true;
4393 }
4394 else
4395 /* Add the new statement to the block. */
4396 gfc_add_expr_to_block (pblock, res);
4397 }
4398 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
4399 }
4400 }
4401
4402 /* Finish remaining SINGLE block, if we were in the middle of one. */
4403 if (singleblock_in_progress)
4404 {
4405 /* Finish single block and add it to pblock. */
4406 tmp = gfc_finish_block (&singleblock);
5d44e5c8
TB		 4407 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
4408 clauses->nowait
4409 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
4410 : NULL_TREE);
34d01e1d
VL		 4411 gfc_add_expr_to_block (pblock, tmp);
4412 }
4413
4414 stmt = gfc_finish_block (pblock);
4415 if (TREE_CODE (stmt) != BIND_EXPR)
4416 {
4417 if (!IS_EMPTY_STMT (stmt))
4418 {
87a60f68 4419 tree bindblock = poplevel (1, 0);
34d01e1d
VL		 4420 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
4421 }
4422 else
87a60f68 4423 poplevel (0, 0);
34d01e1d
VL		 4424 }
4425 else
87a60f68 4426 poplevel (0, 0);
34d01e1d 4427
c26dffff
JJ		 4428 if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
4429 stmt = gfc_trans_omp_barrier ();
4430
34d01e1d
VL		 4431 ompws_flags = 0;
4432 return stmt;
6c7a4dfd
JJ		 4433}
4434
41dbbb37 4435tree
dc7a8b4b 4436gfc_trans_oacc_declare (gfc_code *code)
41dbbb37 4437{
dc7a8b4b
JN		 4438 stmtblock_t block;
4439 tree stmt, oacc_clauses;
4440 enum tree_code construct_code;
4441
4442 construct_code = OACC_DATA;
4443
4444 gfc_start_block (&block);
4445
4446 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
4447 code->loc);
4448 stmt = gfc_trans_omp_code (code->block->next, true);
4449 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
4450 oacc_clauses);
4451 gfc_add_expr_to_block (&block, stmt);
4452
4453 return gfc_finish_block (&block);
41dbbb37
TS		 4454}
4455
4456tree
4457gfc_trans_oacc_directive (gfc_code *code)
4458{
4459 switch (code->op)
4460 {
4461 case EXEC_OACC_PARALLEL_LOOP:
4462 case EXEC_OACC_KERNELS_LOOP:
4463 return gfc_trans_oacc_combined_directive (code);
4464 case EXEC_OACC_PARALLEL:
4465 case EXEC_OACC_KERNELS:
4466 case EXEC_OACC_DATA:
4467 case EXEC_OACC_HOST_DATA:
4468 return gfc_trans_oacc_construct (code);
4469 case EXEC_OACC_LOOP:
4470 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4471 NULL);
4472 case EXEC_OACC_UPDATE:
4473 case EXEC_OACC_CACHE:
4474 case EXEC_OACC_ENTER_DATA:
4475 case EXEC_OACC_EXIT_DATA:
4476 return gfc_trans_oacc_executable_directive (code);
4477 case EXEC_OACC_WAIT:
4478 return gfc_trans_oacc_wait_directive (code);
4bf9e5a8
TS		 4479 case EXEC_OACC_ATOMIC:
4480 return gfc_trans_omp_atomic (code);
dc7a8b4b
JN		 4481 case EXEC_OACC_DECLARE:
4482 return gfc_trans_oacc_declare (code);
41dbbb37
TS		 4483 default:
4484 gcc_unreachable ();
4485 }
4486}
4487
6c7a4dfd
JJ		 4488tree
4489gfc_trans_omp_directive (gfc_code *code)
4490{
4491 switch (code->op)
4492 {
4493 case EXEC_OMP_ATOMIC:
4494 return gfc_trans_omp_atomic (code);
4495 case EXEC_OMP_BARRIER:
4496 return gfc_trans_omp_barrier ();
dd2fc525
JJ		 4497 case EXEC_OMP_CANCEL:
4498 return gfc_trans_omp_cancel (code);
4499 case EXEC_OMP_CANCELLATION_POINT:
4500 return gfc_trans_omp_cancellation_point (code);
6c7a4dfd
JJ		 4501 case EXEC_OMP_CRITICAL:
4502 return gfc_trans_omp_critical (code);
f014c653 4503 case EXEC_OMP_DISTRIBUTE:
6c7a4dfd 4504 case EXEC_OMP_DO:
dd2fc525
JJ		 4505 case EXEC_OMP_SIMD:
4506 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4507 NULL);
f014c653
JJ		 4508 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4509 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4510 case EXEC_OMP_DISTRIBUTE_SIMD:
4511 return gfc_trans_omp_distribute (code, NULL);
dd2fc525 4512 case EXEC_OMP_DO_SIMD:
f014c653 4513 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
6c7a4dfd
JJ		 4514 case EXEC_OMP_FLUSH:
4515 return gfc_trans_omp_flush ();
4516 case EXEC_OMP_MASTER:
4517 return gfc_trans_omp_master (code);
4518 case EXEC_OMP_ORDERED:
4519 return gfc_trans_omp_ordered (code);
4520 case EXEC_OMP_PARALLEL:
4521 return gfc_trans_omp_parallel (code);
4522 case EXEC_OMP_PARALLEL_DO:
f014c653 4523 return gfc_trans_omp_parallel_do (code, NULL, NULL);
dd2fc525 4524 case EXEC_OMP_PARALLEL_DO_SIMD:
f014c653 4525 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
6c7a4dfd
JJ		 4526 case EXEC_OMP_PARALLEL_SECTIONS:
4527 return gfc_trans_omp_parallel_sections (code);
4528 case EXEC_OMP_PARALLEL_WORKSHARE:
4529 return gfc_trans_omp_parallel_workshare (code);
4530 case EXEC_OMP_SECTIONS:
4531 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
4532 case EXEC_OMP_SINGLE:
4533 return gfc_trans_omp_single (code, code->ext.omp_clauses);
f014c653
JJ		 4534 case EXEC_OMP_TARGET:
4535 case EXEC_OMP_TARGET_TEAMS:
4536 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4537 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4538 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4539 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4540 return gfc_trans_omp_target (code);
4541 case EXEC_OMP_TARGET_DATA:
4542 return gfc_trans_omp_target_data (code);
4543 case EXEC_OMP_TARGET_UPDATE:
4544 return gfc_trans_omp_target_update (code);
a68ab351
JJ		 4545 case EXEC_OMP_TASK:
4546 return gfc_trans_omp_task (code);
dd2fc525
JJ		 4547 case EXEC_OMP_TASKGROUP:
4548 return gfc_trans_omp_taskgroup (code);
a68ab351
JJ		 4549 case EXEC_OMP_TASKWAIT:
4550 return gfc_trans_omp_taskwait ();
20906c66
JJ		 4551 case EXEC_OMP_TASKYIELD:
4552 return gfc_trans_omp_taskyield ();
f014c653
JJ		 4553 case EXEC_OMP_TEAMS:
4554 case EXEC_OMP_TEAMS_DISTRIBUTE:
4555 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4556 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4557 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4558 return gfc_trans_omp_teams (code, NULL);
6c7a4dfd
JJ		 4559 case EXEC_OMP_WORKSHARE:
4560 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
4561 default:
4562 gcc_unreachable ();
4563 }
4564}
dd2fc525
JJ		 4565
4566void
4567gfc_trans_omp_declare_simd (gfc_namespace *ns)
4568{
4569 if (ns->entries)
4570 return;
4571
4572 gfc_omp_declare_simd *ods;
4573 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
4574 {
4575 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
4576 tree fndecl = ns->proc_name->backend_decl;
4577 if (c != NULL_TREE)
4578 c = tree_cons (NULL_TREE, c, NULL_TREE);
4579 c = build_tree_list (get_identifier ("omp declare simd"), c);
4580 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
4581 DECL_ATTRIBUTES (fndecl) = c;
4582 }
4583}
Mirror of https://gcc.gnu.org/git/gcc.git