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