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