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