?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
[AArch64] Avoid GET_MODE_NUNITS in v8.4 support
[official-gcc.git] / gcc / fortran / trans-openmp.c
blob4f5c3855799633341f74e1e78dcab765df1f5ce5
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 tree type = gfc_typenode_for_spec (&n->sym->ts);
1953 OMP_CLAUSE_LINEAR_STEP (node)
1954 = fold_convert (type, last_step);
1955 }
1956 if (n->sym->attr.dimension || n->sym->attr.allocatable)
1957 OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
1958 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1959 }
1960 }
1961 }
1962 }
1963 break;
1964 case OMP_LIST_DEPEND:
1965 for (; n != NULL; n = n->next)
1966 {
1967 if (n->u.depend_op == OMP_DEPEND_SINK_FIRST)
1968 {
1969 tree vec = NULL_TREE;
1970 unsigned int i;
1971 for (i = 0; ; i++)
1972 {
1973 tree addend = integer_zero_node, t;
1974 bool neg = false;
1975 if (n->expr)
1976 {
1977 addend = gfc_conv_constant_to_tree (n->expr);
1978 if (TREE_CODE (addend) == INTEGER_CST
1979 && tree_int_cst_sgn (addend) == -1)
1980 {
1981 neg = true;
1982 addend = const_unop (NEGATE_EXPR,
1983 TREE_TYPE (addend), addend);
1984 }
1985 }
1986 t = gfc_trans_omp_variable (n->sym, false);
1987 if (t != error_mark_node)
1988 {
1989 if (i < vec_safe_length (doacross_steps)
1990 && !integer_zerop (addend)
1991 && (*doacross_steps)[i])
1992 {
1993 tree step = (*doacross_steps)[i];
1994 addend = fold_convert (TREE_TYPE (step), addend);
1995 addend = build2 (TRUNC_DIV_EXPR,
1996 TREE_TYPE (step), addend, step);
1997 }
1998 vec = tree_cons (addend, t, vec);
1999 if (neg)
2000 OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec) = 1;
2001 }
2002 if (n->next == NULL
2003 || n->next->u.depend_op != OMP_DEPEND_SINK)
2004 break;
2005 n = n->next;
2006 }
2007 if (vec == NULL_TREE)
2008 continue;
2009
2010 tree node = build_omp_clause (input_location,
2011 OMP_CLAUSE_DEPEND);
2012 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_SINK;
2013 OMP_CLAUSE_DECL (node) = nreverse (vec);
2014 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2015 continue;
2016 }
2017
2018 if (!n->sym->attr.referenced)
2019 continue;
2020
2021 tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND);
2022 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2023 {
2024 tree decl = gfc_get_symbol_decl (n->sym);
2025 if (gfc_omp_privatize_by_reference (decl))
2026 decl = build_fold_indirect_ref (decl);
2027 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2028 {
2029 decl = gfc_conv_descriptor_data_get (decl);
2030 decl = fold_convert (build_pointer_type (char_type_node),
2031 decl);
2032 decl = build_fold_indirect_ref (decl);
2033 }
2034 else if (DECL_P (decl))
2035 TREE_ADDRESSABLE (decl) = 1;
2036 OMP_CLAUSE_DECL (node) = decl;
2037 }
2038 else
2039 {
2040 tree ptr;
2041 gfc_init_se (&se, NULL);
2042 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2043 {
2044 gfc_conv_expr_reference (&se, n->expr);
2045 ptr = se.expr;
2046 }
2047 else
2048 {
2049 gfc_conv_expr_descriptor (&se, n->expr);
2050 ptr = gfc_conv_array_data (se.expr);
2051 }
2052 gfc_add_block_to_block (block, &se.pre);
2053 gfc_add_block_to_block (block, &se.post);
2054 ptr = fold_convert (build_pointer_type (char_type_node),
2055 ptr);
2056 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2057 }
2058 switch (n->u.depend_op)
2059 {
2060 case OMP_DEPEND_IN:
2061 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
2062 break;
2063 case OMP_DEPEND_OUT:
2064 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
2065 break;
2066 case OMP_DEPEND_INOUT:
2067 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
2068 break;
2069 default:
2070 gcc_unreachable ();
2071 }
2072 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2073 }
2074 break;
2075 case OMP_LIST_MAP:
2076 for (; n != NULL; n = n->next)
2077 {
2078 if (!n->sym->attr.referenced)
2079 continue;
2080
2081 tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2082 tree node2 = NULL_TREE;
2083 tree node3 = NULL_TREE;
2084 tree node4 = NULL_TREE;
2085 tree decl = gfc_get_symbol_decl (n->sym);
2086 if (DECL_P (decl))
2087 TREE_ADDRESSABLE (decl) = 1;
2088 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2089 {
2090 if (POINTER_TYPE_P (TREE_TYPE (decl))
2091 && (gfc_omp_privatize_by_reference (decl)
2092 || GFC_DECL_GET_SCALAR_POINTER (decl)
2093 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
2094 || GFC_DECL_CRAY_POINTEE (decl)
2095 || GFC_DESCRIPTOR_TYPE_P
2096 (TREE_TYPE (TREE_TYPE (decl)))))
2097 {
2098 tree orig_decl = decl;
2099 node4 = build_omp_clause (input_location,
2100 OMP_CLAUSE_MAP);
2101 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
2102 OMP_CLAUSE_DECL (node4) = decl;
2103 OMP_CLAUSE_SIZE (node4) = size_int (0);
2104 decl = build_fold_indirect_ref (decl);
2105 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
2106 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
2107 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
2108 {
2109 node3 = build_omp_clause (input_location,
2110 OMP_CLAUSE_MAP);
2111 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
2112 OMP_CLAUSE_DECL (node3) = decl;
2113 OMP_CLAUSE_SIZE (node3) = size_int (0);
2114 decl = build_fold_indirect_ref (decl);
2115 }
2116 }
2117 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2118 {
2119 tree type = TREE_TYPE (decl);
2120 tree ptr = gfc_conv_descriptor_data_get (decl);
2121 ptr = fold_convert (build_pointer_type (char_type_node),
2122 ptr);
2123 ptr = build_fold_indirect_ref (ptr);
2124 OMP_CLAUSE_DECL (node) = ptr;
2125 node2 = build_omp_clause (input_location,
2126 OMP_CLAUSE_MAP);
2127 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
2128 OMP_CLAUSE_DECL (node2) = decl;
2129 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
2130 node3 = build_omp_clause (input_location,
2131 OMP_CLAUSE_MAP);
2132 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
2133 OMP_CLAUSE_DECL (node3)
2134 = gfc_conv_descriptor_data_get (decl);
2135 OMP_CLAUSE_SIZE (node3) = size_int (0);
2136
2137 /* We have to check for n->sym->attr.dimension because
2138 of scalar coarrays. */
2139 if (n->sym->attr.pointer && n->sym->attr.dimension)
2140 {
2141 stmtblock_t cond_block;
2142 tree size
2143 = gfc_create_var (gfc_array_index_type, NULL);
2144 tree tem, then_b, else_b, zero, cond;
2145
2146 gfc_init_block (&cond_block);
2147 tem
2148 = gfc_full_array_size (&cond_block, decl,
2149 GFC_TYPE_ARRAY_RANK (type));
2150 gfc_add_modify (&cond_block, size, tem);
2151 then_b = gfc_finish_block (&cond_block);
2152 gfc_init_block (&cond_block);
2153 zero = build_int_cst (gfc_array_index_type, 0);
2154 gfc_add_modify (&cond_block, size, zero);
2155 else_b = gfc_finish_block (&cond_block);
2156 tem = gfc_conv_descriptor_data_get (decl);
2157 tem = fold_convert (pvoid_type_node, tem);
2158 cond = fold_build2_loc (input_location, NE_EXPR,
2159 logical_type_node,
2160 tem, null_pointer_node);
2161 gfc_add_expr_to_block (block,
2162 build3_loc (input_location,
2163 COND_EXPR,
2164 void_type_node,
2165 cond, then_b,
2166 else_b));
2167 OMP_CLAUSE_SIZE (node) = size;
2168 }
2169 else if (n->sym->attr.dimension)
2170 OMP_CLAUSE_SIZE (node)
2171 = gfc_full_array_size (block, decl,
2172 GFC_TYPE_ARRAY_RANK (type));
2173 if (n->sym->attr.dimension)
2174 {
2175 tree elemsz
2176 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2177 elemsz = fold_convert (gfc_array_index_type, elemsz);
2178 OMP_CLAUSE_SIZE (node)
2179 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2180 OMP_CLAUSE_SIZE (node), elemsz);
2181 }
2182 }
2183 else
2184 OMP_CLAUSE_DECL (node) = decl;
2185 }
2186 else
2187 {
2188 tree ptr, ptr2;
2189 gfc_init_se (&se, NULL);
2190 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2191 {
2192 gfc_conv_expr_reference (&se, n->expr);
2193 gfc_add_block_to_block (block, &se.pre);
2194 ptr = se.expr;
2195 OMP_CLAUSE_SIZE (node)
2196 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2197 }
2198 else
2199 {
2200 gfc_conv_expr_descriptor (&se, n->expr);
2201 ptr = gfc_conv_array_data (se.expr);
2202 tree type = TREE_TYPE (se.expr);
2203 gfc_add_block_to_block (block, &se.pre);
2204 OMP_CLAUSE_SIZE (node)
2205 = gfc_full_array_size (block, se.expr,
2206 GFC_TYPE_ARRAY_RANK (type));
2207 tree elemsz
2208 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2209 elemsz = fold_convert (gfc_array_index_type, elemsz);
2210 OMP_CLAUSE_SIZE (node)
2211 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2212 OMP_CLAUSE_SIZE (node), elemsz);
2213 }
2214 gfc_add_block_to_block (block, &se.post);
2215 ptr = fold_convert (build_pointer_type (char_type_node),
2216 ptr);
2217 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2218
2219 if (POINTER_TYPE_P (TREE_TYPE (decl))
2220 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
2221 {
2222 node4 = build_omp_clause (input_location,
2223 OMP_CLAUSE_MAP);
2224 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
2225 OMP_CLAUSE_DECL (node4) = decl;
2226 OMP_CLAUSE_SIZE (node4) = size_int (0);
2227 decl = build_fold_indirect_ref (decl);
2228 }
2229 ptr = fold_convert (sizetype, ptr);
2230 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2231 {
2232 tree type = TREE_TYPE (decl);
2233 ptr2 = gfc_conv_descriptor_data_get (decl);
2234 node2 = build_omp_clause (input_location,
2235 OMP_CLAUSE_MAP);
2236 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
2237 OMP_CLAUSE_DECL (node2) = decl;
2238 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
2239 node3 = build_omp_clause (input_location,
2240 OMP_CLAUSE_MAP);
2241 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
2242 OMP_CLAUSE_DECL (node3)
2243 = gfc_conv_descriptor_data_get (decl);
2244 }
2245 else
2246 {
2247 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
2248 ptr2 = build_fold_addr_expr (decl);
2249 else
2250 {
2251 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2252 ptr2 = decl;
2253 }
2254 node3 = build_omp_clause (input_location,
2255 OMP_CLAUSE_MAP);
2256 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
2257 OMP_CLAUSE_DECL (node3) = decl;
2258 }
2259 ptr2 = fold_convert (sizetype, ptr2);
2260 OMP_CLAUSE_SIZE (node3)
2261 = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
2262 }
2263 switch (n->u.map_op)
2264 {
2265 case OMP_MAP_ALLOC:
2266 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
2267 break;
2268 case OMP_MAP_TO:
2269 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
2270 break;
2271 case OMP_MAP_FROM:
2272 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
2273 break;
2274 case OMP_MAP_TOFROM:
2275 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
2276 break;
2277 case OMP_MAP_ALWAYS_TO:
2278 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
2279 break;
2280 case OMP_MAP_ALWAYS_FROM:
2281 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
2282 break;
2283 case OMP_MAP_ALWAYS_TOFROM:
2284 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
2285 break;
2286 case OMP_MAP_RELEASE:
2287 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
2288 break;
2289 case OMP_MAP_DELETE:
2290 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
2291 break;
2292 case OMP_MAP_FORCE_ALLOC:
2293 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
2294 break;
2295 case OMP_MAP_FORCE_TO:
2296 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
2297 break;
2298 case OMP_MAP_FORCE_FROM:
2299 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
2300 break;
2301 case OMP_MAP_FORCE_TOFROM:
2302 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
2303 break;
2304 case OMP_MAP_FORCE_PRESENT:
2305 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
2306 break;
2307 case OMP_MAP_FORCE_DEVICEPTR:
2308 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
2309 break;
2310 default:
2311 gcc_unreachable ();
2312 }
2313 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2314 if (node2)
2315 omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
2316 if (node3)
2317 omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
2318 if (node4)
2319 omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
2320 }
2321 break;
2322 case OMP_LIST_TO:
2323 case OMP_LIST_FROM:
2324 case OMP_LIST_CACHE:
2325 for (; n != NULL; n = n->next)
2326 {
2327 if (!n->sym->attr.referenced)
2328 continue;
2329
2330 switch (list)
2331 {
2332 case OMP_LIST_TO:
2333 clause_code = OMP_CLAUSE_TO;
2334 break;
2335 case OMP_LIST_FROM:
2336 clause_code = OMP_CLAUSE_FROM;
2337 break;
2338 case OMP_LIST_CACHE:
2339 clause_code = OMP_CLAUSE__CACHE_;
2340 break;
2341 default:
2342 gcc_unreachable ();
2343 }
2344 tree node = build_omp_clause (input_location, clause_code);
2345 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2346 {
2347 tree decl = gfc_get_symbol_decl (n->sym);
2348 if (gfc_omp_privatize_by_reference (decl))
2349 decl = build_fold_indirect_ref (decl);
2350 else if (DECL_P (decl))
2351 TREE_ADDRESSABLE (decl) = 1;
2352 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2353 {
2354 tree type = TREE_TYPE (decl);
2355 tree ptr = gfc_conv_descriptor_data_get (decl);
2356 ptr = fold_convert (build_pointer_type (char_type_node),
2357 ptr);
2358 ptr = build_fold_indirect_ref (ptr);
2359 OMP_CLAUSE_DECL (node) = ptr;
2360 OMP_CLAUSE_SIZE (node)
2361 = gfc_full_array_size (block, decl,
2362 GFC_TYPE_ARRAY_RANK (type));
2363 tree elemsz
2364 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2365 elemsz = fold_convert (gfc_array_index_type, elemsz);
2366 OMP_CLAUSE_SIZE (node)
2367 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2368 OMP_CLAUSE_SIZE (node), elemsz);
2369 }
2370 else
2371 OMP_CLAUSE_DECL (node) = decl;
2372 }
2373 else
2374 {
2375 tree ptr;
2376 gfc_init_se (&se, NULL);
2377 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2378 {
2379 gfc_conv_expr_reference (&se, n->expr);
2380 ptr = se.expr;
2381 gfc_add_block_to_block (block, &se.pre);
2382 OMP_CLAUSE_SIZE (node)
2383 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2384 }
2385 else
2386 {
2387 gfc_conv_expr_descriptor (&se, n->expr);
2388 ptr = gfc_conv_array_data (se.expr);
2389 tree type = TREE_TYPE (se.expr);
2390 gfc_add_block_to_block (block, &se.pre);
2391 OMP_CLAUSE_SIZE (node)
2392 = gfc_full_array_size (block, se.expr,
2393 GFC_TYPE_ARRAY_RANK (type));
2394 tree elemsz
2395 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2396 elemsz = fold_convert (gfc_array_index_type, elemsz);
2397 OMP_CLAUSE_SIZE (node)
2398 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2399 OMP_CLAUSE_SIZE (node), elemsz);
2400 }
2401 gfc_add_block_to_block (block, &se.post);
2402 ptr = fold_convert (build_pointer_type (char_type_node),
2403 ptr);
2404 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2405 }
2406 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2407 }
2408 break;
2409 default:
2410 break;
2411 }
2412 }
2413
2414 if (clauses->if_expr)
2415 {
2416 tree if_var;
2417
2418 gfc_init_se (&se, NULL);
2419 gfc_conv_expr (&se, clauses->if_expr);
2420 gfc_add_block_to_block (block, &se.pre);
2421 if_var = gfc_evaluate_now (se.expr, block);
2422 gfc_add_block_to_block (block, &se.post);
2423
2424 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
2425 OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
2426 OMP_CLAUSE_IF_EXPR (c) = if_var;
2427 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2428 }
2429 for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
2430 if (clauses->if_exprs[ifc])
2431 {
2432 tree if_var;
2433
2434 gfc_init_se (&se, NULL);
2435 gfc_conv_expr (&se, clauses->if_exprs[ifc]);
2436 gfc_add_block_to_block (block, &se.pre);
2437 if_var = gfc_evaluate_now (se.expr, block);
2438 gfc_add_block_to_block (block, &se.post);
2439
2440 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
2441 switch (ifc)
2442 {
2443 case OMP_IF_PARALLEL:
2444 OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
2445 break;
2446 case OMP_IF_TASK:
2447 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
2448 break;
2449 case OMP_IF_TASKLOOP:
2450 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
2451 break;
2452 case OMP_IF_TARGET:
2453 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
2454 break;
2455 case OMP_IF_TARGET_DATA:
2456 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
2457 break;
2458 case OMP_IF_TARGET_UPDATE:
2459 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
2460 break;
2461 case OMP_IF_TARGET_ENTER_DATA:
2462 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
2463 break;
2464 case OMP_IF_TARGET_EXIT_DATA:
2465 OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
2466 break;
2467 default:
2468 gcc_unreachable ();
2469 }
2470 OMP_CLAUSE_IF_EXPR (c) = if_var;
2471 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2472 }
2473
2474 if (clauses->final_expr)
2475 {
2476 tree final_var;
2477
2478 gfc_init_se (&se, NULL);
2479 gfc_conv_expr (&se, clauses->final_expr);
2480 gfc_add_block_to_block (block, &se.pre);
2481 final_var = gfc_evaluate_now (se.expr, block);
2482 gfc_add_block_to_block (block, &se.post);
2483
2484 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL);
2485 OMP_CLAUSE_FINAL_EXPR (c) = final_var;
2486 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2487 }
2488
2489 if (clauses->num_threads)
2490 {
2491 tree num_threads;
2492
2493 gfc_init_se (&se, NULL);
2494 gfc_conv_expr (&se, clauses->num_threads);
2495 gfc_add_block_to_block (block, &se.pre);
2496 num_threads = gfc_evaluate_now (se.expr, block);
2497 gfc_add_block_to_block (block, &se.post);
2498
2499 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
2500 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
2501 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2502 }
2503
2504 chunk_size = NULL_TREE;
2505 if (clauses->chunk_size)
2506 {
2507 gfc_init_se (&se, NULL);
2508 gfc_conv_expr (&se, clauses->chunk_size);
2509 gfc_add_block_to_block (block, &se.pre);
2510 chunk_size = gfc_evaluate_now (se.expr, block);
2511 gfc_add_block_to_block (block, &se.post);
2512 }
2513
2514 if (clauses->sched_kind != OMP_SCHED_NONE)
2515 {
2516 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
2517 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2518 switch (clauses->sched_kind)
2519 {
2520 case OMP_SCHED_STATIC:
2521 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
2522 break;
2523 case OMP_SCHED_DYNAMIC:
2524 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
2525 break;
2526 case OMP_SCHED_GUIDED:
2527 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
2528 break;
2529 case OMP_SCHED_RUNTIME:
2530 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
2531 break;
2532 case OMP_SCHED_AUTO:
2533 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
2534 break;
2535 default:
2536 gcc_unreachable ();
2537 }
2538 if (clauses->sched_monotonic)
2539 OMP_CLAUSE_SCHEDULE_KIND (c)
2540 = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
2541 | OMP_CLAUSE_SCHEDULE_MONOTONIC);
2542 else if (clauses->sched_nonmonotonic)
2543 OMP_CLAUSE_SCHEDULE_KIND (c)
2544 = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
2545 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
2546 if (clauses->sched_simd)
2547 OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
2548 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2549 }
2550
2551 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
2552 {
2553 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
2554 switch (clauses->default_sharing)
2555 {
2556 case OMP_DEFAULT_NONE:
2557 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
2558 break;
2559 case OMP_DEFAULT_SHARED:
2560 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
2561 break;
2562 case OMP_DEFAULT_PRIVATE:
2563 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
2564 break;
2565 case OMP_DEFAULT_FIRSTPRIVATE:
2566 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
2567 break;
2568 case OMP_DEFAULT_PRESENT:
2569 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
2570 break;
2571 default:
2572 gcc_unreachable ();
2573 }
2574 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2575 }
2576
2577 if (clauses->nowait)
2578 {
2579 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
2580 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2581 }
2582
2583 if (clauses->ordered)
2584 {
2585 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
2586 OMP_CLAUSE_ORDERED_EXPR (c)
2587 = clauses->orderedc ? build_int_cst (integer_type_node,
2588 clauses->orderedc) : NULL_TREE;
2589 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2590 }
2591
2592 if (clauses->untied)
2593 {
2594 c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
2595 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2596 }
2597
2598 if (clauses->mergeable)
2599 {
2600 c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE);
2601 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2602 }
2603
2604 if (clauses->collapse)
2605 {
2606 c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
2607 OMP_CLAUSE_COLLAPSE_EXPR (c)
2608 = build_int_cst (integer_type_node, clauses->collapse);
2609 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2610 }
2611
2612 if (clauses->inbranch)
2613 {
2614 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH);
2615 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2616 }
2617
2618 if (clauses->notinbranch)
2619 {
2620 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH);
2621 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2622 }
2623
2624 switch (clauses->cancel)
2625 {
2626 case OMP_CANCEL_UNKNOWN:
2627 break;
2628 case OMP_CANCEL_PARALLEL:
2629 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL);
2630 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2631 break;
2632 case OMP_CANCEL_SECTIONS:
2633 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS);
2634 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2635 break;
2636 case OMP_CANCEL_DO:
2637 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR);
2638 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2639 break;
2640 case OMP_CANCEL_TASKGROUP:
2641 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP);
2642 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2643 break;
2644 }
2645
2646 if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
2647 {
2648 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND);
2649 switch (clauses->proc_bind)
2650 {
2651 case OMP_PROC_BIND_MASTER:
2652 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
2653 break;
2654 case OMP_PROC_BIND_SPREAD:
2655 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
2656 break;
2657 case OMP_PROC_BIND_CLOSE:
2658 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
2659 break;
2660 default:
2661 gcc_unreachable ();
2662 }
2663 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2664 }
2665
2666 if (clauses->safelen_expr)
2667 {
2668 tree safelen_var;
2669
2670 gfc_init_se (&se, NULL);
2671 gfc_conv_expr (&se, clauses->safelen_expr);
2672 gfc_add_block_to_block (block, &se.pre);
2673 safelen_var = gfc_evaluate_now (se.expr, block);
2674 gfc_add_block_to_block (block, &se.post);
2675
2676 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN);
2677 OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
2678 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2679 }
2680
2681 if (clauses->simdlen_expr)
2682 {
2683 if (declare_simd)
2684 {
2685 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN);
2686 OMP_CLAUSE_SIMDLEN_EXPR (c)
2687 = gfc_conv_constant_to_tree (clauses->simdlen_expr);
2688 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2689 }
2690 else
2691 {
2692 tree simdlen_var;
2693
2694 gfc_init_se (&se, NULL);
2695 gfc_conv_expr (&se, clauses->simdlen_expr);
2696 gfc_add_block_to_block (block, &se.pre);
2697 simdlen_var = gfc_evaluate_now (se.expr, block);
2698 gfc_add_block_to_block (block, &se.post);
2699
2700 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN);
2701 OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var;
2702 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2703 }
2704 }
2705
2706 if (clauses->num_teams)
2707 {
2708 tree num_teams;
2709
2710 gfc_init_se (&se, NULL);
2711 gfc_conv_expr (&se, clauses->num_teams);
2712 gfc_add_block_to_block (block, &se.pre);
2713 num_teams = gfc_evaluate_now (se.expr, block);
2714 gfc_add_block_to_block (block, &se.post);
2715
2716 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS);
2717 OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams;
2718 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2719 }
2720
2721 if (clauses->device)
2722 {
2723 tree device;
2724
2725 gfc_init_se (&se, NULL);
2726 gfc_conv_expr (&se, clauses->device);
2727 gfc_add_block_to_block (block, &se.pre);
2728 device = gfc_evaluate_now (se.expr, block);
2729 gfc_add_block_to_block (block, &se.post);
2730
2731 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE);
2732 OMP_CLAUSE_DEVICE_ID (c) = device;
2733 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2734 }
2735
2736 if (clauses->thread_limit)
2737 {
2738 tree thread_limit;
2739
2740 gfc_init_se (&se, NULL);
2741 gfc_conv_expr (&se, clauses->thread_limit);
2742 gfc_add_block_to_block (block, &se.pre);
2743 thread_limit = gfc_evaluate_now (se.expr, block);
2744 gfc_add_block_to_block (block, &se.post);
2745
2746 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT);
2747 OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
2748 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2749 }
2750
2751 chunk_size = NULL_TREE;
2752 if (clauses->dist_chunk_size)
2753 {
2754 gfc_init_se (&se, NULL);
2755 gfc_conv_expr (&se, clauses->dist_chunk_size);
2756 gfc_add_block_to_block (block, &se.pre);
2757 chunk_size = gfc_evaluate_now (se.expr, block);
2758 gfc_add_block_to_block (block, &se.post);
2759 }
2760
2761 if (clauses->dist_sched_kind != OMP_SCHED_NONE)
2762 {
2763 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE);
2764 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2765 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2766 }
2767
2768 if (clauses->grainsize)
2769 {
2770 tree grainsize;
2771
2772 gfc_init_se (&se, NULL);
2773 gfc_conv_expr (&se, clauses->grainsize);
2774 gfc_add_block_to_block (block, &se.pre);
2775 grainsize = gfc_evaluate_now (se.expr, block);
2776 gfc_add_block_to_block (block, &se.post);
2777
2778 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GRAINSIZE);
2779 OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
2780 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2781 }
2782
2783 if (clauses->num_tasks)
2784 {
2785 tree num_tasks;
2786
2787 gfc_init_se (&se, NULL);
2788 gfc_conv_expr (&se, clauses->num_tasks);
2789 gfc_add_block_to_block (block, &se.pre);
2790 num_tasks = gfc_evaluate_now (se.expr, block);
2791 gfc_add_block_to_block (block, &se.post);
2792
2793 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TASKS);
2794 OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
2795 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2796 }
2797
2798 if (clauses->priority)
2799 {
2800 tree priority;
2801
2802 gfc_init_se (&se, NULL);
2803 gfc_conv_expr (&se, clauses->priority);
2804 gfc_add_block_to_block (block, &se.pre);
2805 priority = gfc_evaluate_now (se.expr, block);
2806 gfc_add_block_to_block (block, &se.post);
2807
2808 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PRIORITY);
2809 OMP_CLAUSE_PRIORITY_EXPR (c) = priority;
2810 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2811 }
2812
2813 if (clauses->hint)
2814 {
2815 tree hint;
2816
2817 gfc_init_se (&se, NULL);
2818 gfc_conv_expr (&se, clauses->hint);
2819 gfc_add_block_to_block (block, &se.pre);
2820 hint = gfc_evaluate_now (se.expr, block);
2821 gfc_add_block_to_block (block, &se.post);
2822
2823 c = build_omp_clause (where.lb->location, OMP_CLAUSE_HINT);
2824 OMP_CLAUSE_HINT_EXPR (c) = hint;
2825 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2826 }
2827
2828 if (clauses->simd)
2829 {
2830 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMD);
2831 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2832 }
2833 if (clauses->threads)
2834 {
2835 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREADS);
2836 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2837 }
2838 if (clauses->nogroup)
2839 {
2840 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOGROUP);
2841 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2842 }
2843 if (clauses->defaultmap)
2844 {
2845 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULTMAP);
2846 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2847 }
2848 if (clauses->depend_source)
2849 {
2850 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEPEND);
2851 OMP_CLAUSE_DEPEND_KIND (c) = OMP_CLAUSE_DEPEND_SOURCE;
2852 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2853 }
2854
2855 if (clauses->async)
2856 {
2857 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC);
2858 if (clauses->async_expr)
2859 OMP_CLAUSE_ASYNC_EXPR (c)
2860 = gfc_convert_expr_to_tree (block, clauses->async_expr);
2861 else
2862 OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
2863 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2864 }
2865 if (clauses->seq)
2866 {
2867 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ);
2868 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2869 }
2870 if (clauses->par_auto)
2871 {
2872 c = build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO);
2873 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2874 }
2875 if (clauses->independent)
2876 {
2877 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT);
2878 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2879 }
2880 if (clauses->wait_list)
2881 {
2882 gfc_expr_list *el;
2883
2884 for (el = clauses->wait_list; el; el = el->next)
2885 {
2886 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT);
2887 OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
2888 OMP_CLAUSE_CHAIN (c) = omp_clauses;
2889 omp_clauses = c;
2890 }
2891 }
2892 if (clauses->num_gangs_expr)
2893 {
2894 tree num_gangs_var
2895 = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
2896 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS);
2897 OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
2898 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2899 }
2900 if (clauses->num_workers_expr)
2901 {
2902 tree num_workers_var
2903 = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
2904 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS);
2905 OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
2906 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2907 }
2908 if (clauses->vector_length_expr)
2909 {
2910 tree vector_length_var
2911 = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
2912 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH);
2913 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
2914 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2915 }
2916 if (clauses->tile_list)
2917 {
2918 vec<tree, va_gc> *tvec;
2919 gfc_expr_list *el;
2920
2921 vec_alloc (tvec, 4);
2922
2923 for (el = clauses->tile_list; el; el = el->next)
2924 vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr));
2925
2926 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TILE);
2927 OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec);
2928 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2929 tvec->truncate (0);
2930 }
2931 if (clauses->vector)
2932 {
2933 if (clauses->vector_expr)
2934 {
2935 tree vector_var
2936 = gfc_convert_expr_to_tree (block, clauses->vector_expr);
2937 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2938 OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
2939 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2940 }
2941 else
2942 {
2943 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2944 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2945 }
2946 }
2947 if (clauses->worker)
2948 {
2949 if (clauses->worker_expr)
2950 {
2951 tree worker_var
2952 = gfc_convert_expr_to_tree (block, clauses->worker_expr);
2953 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2954 OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
2955 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2956 }
2957 else
2958 {
2959 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2960 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2961 }
2962 }
2963 if (clauses->gang)
2964 {
2965 tree arg;
2966 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
2967 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2968 if (clauses->gang_num_expr)
2969 {
2970 arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
2971 OMP_CLAUSE_GANG_EXPR (c) = arg;
2972 }
2973 if (clauses->gang_static)
2974 {
2975 arg = clauses->gang_static_expr
2976 ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
2977 : integer_minus_one_node;
2978 OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
2979 }
2980 }
2981
2982 return nreverse (omp_clauses);
2983 }
2984
2985 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
2986
2987 static tree
2988 gfc_trans_omp_code (gfc_code *code, bool force_empty)
2989 {
2990 tree stmt;
2991
2992 pushlevel ();
2993 stmt = gfc_trans_code (code);
2994 if (TREE_CODE (stmt) != BIND_EXPR)
2995 {
2996 if (!IS_EMPTY_STMT (stmt) || force_empty)
2997 {
2998 tree block = poplevel (1, 0);
2999 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
3000 }
3001 else
3002 poplevel (0, 0);
3003 }
3004 else
3005 poplevel (0, 0);
3006 return stmt;
3007 }
3008
3009 /* Trans OpenACC directives. */
3010 /* parallel, kernels, data and host_data. */
3011 static tree
3012 gfc_trans_oacc_construct (gfc_code *code)
3013 {
3014 stmtblock_t block;
3015 tree stmt, oacc_clauses;
3016 enum tree_code construct_code;
3017
3018 switch (code->op)
3019 {
3020 case EXEC_OACC_PARALLEL:
3021 construct_code = OACC_PARALLEL;
3022 break;
3023 case EXEC_OACC_KERNELS:
3024 construct_code = OACC_KERNELS;
3025 break;
3026 case EXEC_OACC_DATA:
3027 construct_code = OACC_DATA;
3028 break;
3029 case EXEC_OACC_HOST_DATA:
3030 construct_code = OACC_HOST_DATA;
3031 break;
3032 default:
3033 gcc_unreachable ();
3034 }
3035
3036 gfc_start_block (&block);
3037 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3038 code->loc);
3039 stmt = gfc_trans_omp_code (code->block->next, true);
3040 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
3041 oacc_clauses);
3042 gfc_add_expr_to_block (&block, stmt);
3043 return gfc_finish_block (&block);
3044 }
3045
3046 /* update, enter_data, exit_data, cache. */
3047 static tree
3048 gfc_trans_oacc_executable_directive (gfc_code *code)
3049 {
3050 stmtblock_t block;
3051 tree stmt, oacc_clauses;
3052 enum tree_code construct_code;
3053
3054 switch (code->op)
3055 {
3056 case EXEC_OACC_UPDATE:
3057 construct_code = OACC_UPDATE;
3058 break;
3059 case EXEC_OACC_ENTER_DATA:
3060 construct_code = OACC_ENTER_DATA;
3061 break;
3062 case EXEC_OACC_EXIT_DATA:
3063 construct_code = OACC_EXIT_DATA;
3064 break;
3065 case EXEC_OACC_CACHE:
3066 construct_code = OACC_CACHE;
3067 break;
3068 default:
3069 gcc_unreachable ();
3070 }
3071
3072 gfc_start_block (&block);
3073 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3074 code->loc);
3075 stmt = build1_loc (input_location, construct_code, void_type_node,
3076 oacc_clauses);
3077 gfc_add_expr_to_block (&block, stmt);
3078 return gfc_finish_block (&block);
3079 }
3080
3081 static tree
3082 gfc_trans_oacc_wait_directive (gfc_code *code)
3083 {
3084 stmtblock_t block;
3085 tree stmt, t;
3086 vec<tree, va_gc> *args;
3087 int nparms = 0;
3088 gfc_expr_list *el;
3089 gfc_omp_clauses *clauses = code->ext.omp_clauses;
3090 location_t loc = input_location;
3091
3092 for (el = clauses->wait_list; el; el = el->next)
3093 nparms++;
3094
3095 vec_alloc (args, nparms + 2);
3096 stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
3097
3098 gfc_start_block (&block);
3099
3100 if (clauses->async_expr)
3101 t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
3102 else
3103 t = build_int_cst (integer_type_node, -2);
3104
3105 args->quick_push (t);
3106 args->quick_push (build_int_cst (integer_type_node, nparms));
3107
3108 for (el = clauses->wait_list; el; el = el->next)
3109 args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
3110
3111 stmt = build_call_expr_loc_vec (loc, stmt, args);
3112 gfc_add_expr_to_block (&block, stmt);
3113
3114 vec_free (args);
3115
3116 return gfc_finish_block (&block);
3117 }
3118
3119 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
3120 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
3121
3122 static tree
3123 gfc_trans_omp_atomic (gfc_code *code)
3124 {
3125 gfc_code *atomic_code = code;
3126 gfc_se lse;
3127 gfc_se rse;
3128 gfc_se vse;
3129 gfc_expr *expr2, *e;
3130 gfc_symbol *var;
3131 stmtblock_t block;
3132 tree lhsaddr, type, rhs, x;
3133 enum tree_code op = ERROR_MARK;
3134 enum tree_code aop = OMP_ATOMIC;
3135 bool var_on_left = false;
3136 bool seq_cst = (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) != 0;
3137
3138 code = code->block->next;
3139 gcc_assert (code->op == EXEC_ASSIGN);
3140 var = code->expr1->symtree->n.sym;
3141
3142 gfc_init_se (&lse, NULL);
3143 gfc_init_se (&rse, NULL);
3144 gfc_init_se (&vse, NULL);
3145 gfc_start_block (&block);
3146
3147 expr2 = code->expr2;
3148 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3149 != GFC_OMP_ATOMIC_WRITE)
3150 && (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP) == 0
3151 && expr2->expr_type == EXPR_FUNCTION
3152 && expr2->value.function.isym
3153 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
3154 expr2 = expr2->value.function.actual->expr;
3155
3156 switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3157 {
3158 case GFC_OMP_ATOMIC_READ:
3159 gfc_conv_expr (&vse, code->expr1);
3160 gfc_add_block_to_block (&block, &vse.pre);
3161
3162 gfc_conv_expr (&lse, expr2);
3163 gfc_add_block_to_block (&block, &lse.pre);
3164 type = TREE_TYPE (lse.expr);
3165 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
3166
3167 x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
3168 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
3169 x = convert (TREE_TYPE (vse.expr), x);
3170 gfc_add_modify (&block, vse.expr, x);
3171
3172 gfc_add_block_to_block (&block, &lse.pre);
3173 gfc_add_block_to_block (&block, &rse.pre);
3174
3175 return gfc_finish_block (&block);
3176 case GFC_OMP_ATOMIC_CAPTURE:
3177 aop = OMP_ATOMIC_CAPTURE_NEW;
3178 if (expr2->expr_type == EXPR_VARIABLE)
3179 {
3180 aop = OMP_ATOMIC_CAPTURE_OLD;
3181 gfc_conv_expr (&vse, code->expr1);
3182 gfc_add_block_to_block (&block, &vse.pre);
3183
3184 gfc_conv_expr (&lse, expr2);
3185 gfc_add_block_to_block (&block, &lse.pre);
3186 gfc_init_se (&lse, NULL);
3187 code = code->next;
3188 var = code->expr1->symtree->n.sym;
3189 expr2 = code->expr2;
3190 if (expr2->expr_type == EXPR_FUNCTION
3191 && expr2->value.function.isym
3192 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
3193 expr2 = expr2->value.function.actual->expr;
3194 }
3195 break;
3196 default:
3197 break;
3198 }
3199
3200 gfc_conv_expr (&lse, code->expr1);
3201 gfc_add_block_to_block (&block, &lse.pre);
3202 type = TREE_TYPE (lse.expr);
3203 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
3204
3205 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3206 == GFC_OMP_ATOMIC_WRITE)
3207 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
3208 {
3209 gfc_conv_expr (&rse, expr2);
3210 gfc_add_block_to_block (&block, &rse.pre);
3211 }
3212 else if (expr2->expr_type == EXPR_OP)
3213 {
3214 gfc_expr *e;
3215 switch (expr2->value.op.op)
3216 {
3217 case INTRINSIC_PLUS:
3218 op = PLUS_EXPR;
3219 break;
3220 case INTRINSIC_TIMES:
3221 op = MULT_EXPR;
3222 break;
3223 case INTRINSIC_MINUS:
3224 op = MINUS_EXPR;
3225 break;
3226 case INTRINSIC_DIVIDE:
3227 if (expr2->ts.type == BT_INTEGER)
3228 op = TRUNC_DIV_EXPR;
3229 else
3230 op = RDIV_EXPR;
3231 break;
3232 case INTRINSIC_AND:
3233 op = TRUTH_ANDIF_EXPR;
3234 break;
3235 case INTRINSIC_OR:
3236 op = TRUTH_ORIF_EXPR;
3237 break;
3238 case INTRINSIC_EQV:
3239 op = EQ_EXPR;
3240 break;
3241 case INTRINSIC_NEQV:
3242 op = NE_EXPR;
3243 break;
3244 default:
3245 gcc_unreachable ();
3246 }
3247 e = expr2->value.op.op1;
3248 if (e->expr_type == EXPR_FUNCTION
3249 && e->value.function.isym
3250 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
3251 e = e->value.function.actual->expr;
3252 if (e->expr_type == EXPR_VARIABLE
3253 && e->symtree != NULL
3254 && e->symtree->n.sym == var)
3255 {
3256 expr2 = expr2->value.op.op2;
3257 var_on_left = true;
3258 }
3259 else
3260 {
3261 e = expr2->value.op.op2;
3262 if (e->expr_type == EXPR_FUNCTION
3263 && e->value.function.isym
3264 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
3265 e = e->value.function.actual->expr;
3266 gcc_assert (e->expr_type == EXPR_VARIABLE
3267 && e->symtree != NULL
3268 && e->symtree->n.sym == var);
3269 expr2 = expr2->value.op.op1;
3270 var_on_left = false;
3271 }
3272 gfc_conv_expr (&rse, expr2);
3273 gfc_add_block_to_block (&block, &rse.pre);
3274 }
3275 else
3276 {
3277 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
3278 switch (expr2->value.function.isym->id)
3279 {
3280 case GFC_ISYM_MIN:
3281 op = MIN_EXPR;
3282 break;
3283 case GFC_ISYM_MAX:
3284 op = MAX_EXPR;
3285 break;
3286 case GFC_ISYM_IAND:
3287 op = BIT_AND_EXPR;
3288 break;
3289 case GFC_ISYM_IOR:
3290 op = BIT_IOR_EXPR;
3291 break;
3292 case GFC_ISYM_IEOR:
3293 op = BIT_XOR_EXPR;
3294 break;
3295 default:
3296 gcc_unreachable ();
3297 }
3298 e = expr2->value.function.actual->expr;
3299 gcc_assert (e->expr_type == EXPR_VARIABLE
3300 && e->symtree != NULL
3301 && e->symtree->n.sym == var);
3302
3303 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
3304 gfc_add_block_to_block (&block, &rse.pre);
3305 if (expr2->value.function.actual->next->next != NULL)
3306 {
3307 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
3308 gfc_actual_arglist *arg;
3309
3310 gfc_add_modify (&block, accum, rse.expr);
3311 for (arg = expr2->value.function.actual->next->next; arg;
3312 arg = arg->next)
3313 {
3314 gfc_init_block (&rse.pre);
3315 gfc_conv_expr (&rse, arg->expr);
3316 gfc_add_block_to_block (&block, &rse.pre);
3317 x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
3318 accum, rse.expr);
3319 gfc_add_modify (&block, accum, x);
3320 }
3321
3322 rse.expr = accum;
3323 }
3324
3325 expr2 = expr2->value.function.actual->next->expr;
3326 }
3327
3328 lhsaddr = save_expr (lhsaddr);
3329 if (TREE_CODE (lhsaddr) != SAVE_EXPR
3330 && (TREE_CODE (lhsaddr) != ADDR_EXPR
3331 || !VAR_P (TREE_OPERAND (lhsaddr, 0))))
3332 {
3333 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
3334 it even after unsharing function body. */
3335 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
3336 DECL_CONTEXT (var) = current_function_decl;
3337 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
3338 NULL_TREE, NULL_TREE);
3339 }
3340
3341 rhs = gfc_evaluate_now (rse.expr, &block);
3342
3343 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3344 == GFC_OMP_ATOMIC_WRITE)
3345 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
3346 x = rhs;
3347 else
3348 {
3349 x = convert (TREE_TYPE (rhs),
3350 build_fold_indirect_ref_loc (input_location, lhsaddr));
3351 if (var_on_left)
3352 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
3353 else
3354 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
3355 }
3356
3357 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
3358 && TREE_CODE (type) != COMPLEX_TYPE)
3359 x = fold_build1_loc (input_location, REALPART_EXPR,
3360 TREE_TYPE (TREE_TYPE (rhs)), x);
3361
3362 gfc_add_block_to_block (&block, &lse.pre);
3363 gfc_add_block_to_block (&block, &rse.pre);
3364
3365 if (aop == OMP_ATOMIC)
3366 {
3367 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
3368 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
3369 gfc_add_expr_to_block (&block, x);
3370 }
3371 else
3372 {
3373 if (aop == OMP_ATOMIC_CAPTURE_NEW)
3374 {
3375 code = code->next;
3376 expr2 = code->expr2;
3377 if (expr2->expr_type == EXPR_FUNCTION
3378 && expr2->value.function.isym
3379 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
3380 expr2 = expr2->value.function.actual->expr;
3381
3382 gcc_assert (expr2->expr_type == EXPR_VARIABLE);
3383 gfc_conv_expr (&vse, code->expr1);
3384 gfc_add_block_to_block (&block, &vse.pre);
3385
3386 gfc_init_se (&lse, NULL);
3387 gfc_conv_expr (&lse, expr2);
3388 gfc_add_block_to_block (&block, &lse.pre);
3389 }
3390 x = build2 (aop, type, lhsaddr, convert (type, x));
3391 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
3392 x = convert (TREE_TYPE (vse.expr), x);
3393 gfc_add_modify (&block, vse.expr, x);
3394 }
3395
3396 return gfc_finish_block (&block);
3397 }
3398
3399 static tree
3400 gfc_trans_omp_barrier (void)
3401 {
3402 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
3403 return build_call_expr_loc (input_location, decl, 0);
3404 }
3405
3406 static tree
3407 gfc_trans_omp_cancel (gfc_code *code)
3408 {
3409 int mask = 0;
3410 tree ifc = boolean_true_node;
3411 stmtblock_t block;
3412 switch (code->ext.omp_clauses->cancel)
3413 {
3414 case OMP_CANCEL_PARALLEL: mask = 1; break;
3415 case OMP_CANCEL_DO: mask = 2; break;
3416 case OMP_CANCEL_SECTIONS: mask = 4; break;
3417 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3418 default: gcc_unreachable ();
3419 }
3420 gfc_start_block (&block);
3421 if (code->ext.omp_clauses->if_expr)
3422 {
3423 gfc_se se;
3424 tree if_var;
3425
3426 gfc_init_se (&se, NULL);
3427 gfc_conv_expr (&se, code->ext.omp_clauses->if_expr);
3428 gfc_add_block_to_block (&block, &se.pre);
3429 if_var = gfc_evaluate_now (se.expr, &block);
3430 gfc_add_block_to_block (&block, &se.post);
3431 tree type = TREE_TYPE (if_var);
3432 ifc = fold_build2_loc (input_location, NE_EXPR,
3433 boolean_type_node, if_var,
3434 build_zero_cst (type));
3435 }
3436 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
3437 tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
3438 ifc = fold_convert (c_bool_type, ifc);
3439 gfc_add_expr_to_block (&block,
3440 build_call_expr_loc (input_location, decl, 2,
3441 build_int_cst (integer_type_node,
3442 mask), ifc));
3443 return gfc_finish_block (&block);
3444 }
3445
3446 static tree
3447 gfc_trans_omp_cancellation_point (gfc_code *code)
3448 {
3449 int mask = 0;
3450 switch (code->ext.omp_clauses->cancel)
3451 {
3452 case OMP_CANCEL_PARALLEL: mask = 1; break;
3453 case OMP_CANCEL_DO: mask = 2; break;
3454 case OMP_CANCEL_SECTIONS: mask = 4; break;
3455 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3456 default: gcc_unreachable ();
3457 }
3458 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
3459 return build_call_expr_loc (input_location, decl, 1,
3460 build_int_cst (integer_type_node, mask));
3461 }
3462
3463 static tree
3464 gfc_trans_omp_critical (gfc_code *code)
3465 {
3466 tree name = NULL_TREE, stmt;
3467 if (code->ext.omp_clauses != NULL)
3468 name = get_identifier (code->ext.omp_clauses->critical_name);
3469 stmt = gfc_trans_code (code->block->next);
3470 return build3_loc (input_location, OMP_CRITICAL, void_type_node, stmt,
3471 NULL_TREE, name);
3472 }
3473
3474 typedef struct dovar_init_d {
3475 tree var;
3476 tree init;
3477 } dovar_init;
3478
3479
3480 static tree
3481 gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
3482 gfc_omp_clauses *do_clauses, tree par_clauses)
3483 {
3484 gfc_se se;
3485 tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
3486 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
3487 stmtblock_t block;
3488 stmtblock_t body;
3489 gfc_omp_clauses *clauses = code->ext.omp_clauses;
3490 int i, collapse = clauses->collapse;
3491 vec<dovar_init> inits = vNULL;
3492 dovar_init *di;
3493 unsigned ix;
3494 vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
3495 gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list;
3496
3497 /* Both collapsed and tiled loops are lowered the same way. In
3498 OpenACC, those clauses are not compatible, so prioritize the tile
3499 clause, if present. */
3500 if (tile)
3501 {
3502 collapse = 0;
3503 for (gfc_expr_list *el = tile; el; el = el->next)
3504 collapse++;
3505 }
3506
3507 doacross_steps = NULL;
3508 if (clauses->orderedc)
3509 collapse = clauses->orderedc;
3510 if (collapse <= 0)
3511 collapse = 1;
3512
3513 code = code->block->next;
3514 gcc_assert (code->op == EXEC_DO);
3515
3516 init = make_tree_vec (collapse);
3517 cond = make_tree_vec (collapse);
3518 incr = make_tree_vec (collapse);
3519 orig_decls = clauses->orderedc ? make_tree_vec (collapse) : NULL_TREE;
3520
3521 if (pblock == NULL)
3522 {
3523 gfc_start_block (&block);
3524 pblock = &block;
3525 }
3526
3527 /* simd schedule modifier is only useful for composite do simd and other
3528 constructs including that, where gfc_trans_omp_do is only called
3529 on the simd construct and DO's clauses are translated elsewhere. */
3530 do_clauses->sched_simd = false;
3531
3532 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
3533
3534 for (i = 0; i < collapse; i++)
3535 {
3536 int simple = 0;
3537 int dovar_found = 0;
3538 tree dovar_decl;
3539
3540 if (clauses)
3541 {
3542 gfc_omp_namelist *n = NULL;
3543 if (op != EXEC_OMP_DISTRIBUTE)
3544 for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1)
3545 ? OMP_LIST_LINEAR : OMP_LIST_LASTPRIVATE];
3546 n != NULL; n = n->next)
3547 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3548 break;
3549 if (n != NULL)
3550 dovar_found = 1;
3551 else if (n == NULL && op != EXEC_OMP_SIMD)
3552 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
3553 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3554 break;
3555 if (n != NULL)
3556 dovar_found++;
3557 }
3558
3559 /* Evaluate all the expressions in the iterator. */
3560 gfc_init_se (&se, NULL);
3561 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
3562 gfc_add_block_to_block (pblock, &se.pre);
3563 dovar = se.expr;
3564 type = TREE_TYPE (dovar);
3565 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
3566
3567 gfc_init_se (&se, NULL);
3568 gfc_conv_expr_val (&se, code->ext.iterator->start);
3569 gfc_add_block_to_block (pblock, &se.pre);
3570 from = gfc_evaluate_now (se.expr, pblock);
3571
3572 gfc_init_se (&se, NULL);
3573 gfc_conv_expr_val (&se, code->ext.iterator->end);
3574 gfc_add_block_to_block (pblock, &se.pre);
3575 to = gfc_evaluate_now (se.expr, pblock);
3576
3577 gfc_init_se (&se, NULL);
3578 gfc_conv_expr_val (&se, code->ext.iterator->step);
3579 gfc_add_block_to_block (pblock, &se.pre);
3580 step = gfc_evaluate_now (se.expr, pblock);
3581 dovar_decl = dovar;
3582
3583 /* Special case simple loops. */
3584 if (VAR_P (dovar))
3585 {
3586 if (integer_onep (step))
3587 simple = 1;
3588 else if (tree_int_cst_equal (step, integer_minus_one_node))
3589 simple = -1;
3590 }
3591 else
3592 dovar_decl
3593 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
3594 false);
3595
3596 /* Loop body. */
3597 if (simple)
3598 {
3599 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
3600 /* The condition should not be folded. */
3601 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
3602 ? LE_EXPR : GE_EXPR,
3603 logical_type_node, dovar, to);
3604 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3605 type, dovar, step);
3606 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3607 MODIFY_EXPR,
3608 type, dovar,
3609 TREE_VEC_ELT (incr, i));
3610 }
3611 else
3612 {
3613 /* STEP is not 1 or -1. Use:
3614 for (count = 0; count < (to + step - from) / step; count++)
3615 {
3616 dovar = from + count * step;
3617 body;
3618 cycle_label:;
3619 } */
3620 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
3621 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
3622 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
3623 step);
3624 tmp = gfc_evaluate_now (tmp, pblock);
3625 count = gfc_create_var (type, "count");
3626 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
3627 build_int_cst (type, 0));
3628 /* The condition should not be folded. */
3629 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
3630 logical_type_node,
3631 count, tmp);
3632 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3633 type, count,
3634 build_int_cst (type, 1));
3635 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3636 MODIFY_EXPR, type, count,
3637 TREE_VEC_ELT (incr, i));
3638
3639 /* Initialize DOVAR. */
3640 tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
3641 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
3642 dovar_init e = {dovar, tmp};
3643 inits.safe_push (e);
3644 if (clauses->orderedc)
3645 {
3646 if (doacross_steps == NULL)
3647 vec_safe_grow_cleared (doacross_steps, clauses->orderedc);
3648 (*doacross_steps)[i] = step;
3649 }
3650 }
3651 if (orig_decls)
3652 TREE_VEC_ELT (orig_decls, i) = dovar_decl;
3653
3654 if (dovar_found == 2
3655 && op == EXEC_OMP_SIMD
3656 && collapse == 1
3657 && !simple)
3658 {
3659 for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
3660 if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
3661 && OMP_CLAUSE_DECL (tmp) == dovar)
3662 {
3663 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3664 break;
3665 }
3666 }
3667 if (!dovar_found)
3668 {
3669 if (op == EXEC_OMP_SIMD)
3670 {
3671 if (collapse == 1)
3672 {
3673 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3674 OMP_CLAUSE_LINEAR_STEP (tmp) = step;
3675 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3676 }
3677 else
3678 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3679 if (!simple)
3680 dovar_found = 2;
3681 }
3682 else
3683 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3684 OMP_CLAUSE_DECL (tmp) = dovar_decl;
3685 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3686 }
3687 if (dovar_found == 2)
3688 {
3689 tree c = NULL;
3690
3691 tmp = NULL;
3692 if (!simple)
3693 {
3694 /* If dovar is lastprivate, but different counter is used,
3695 dovar += step needs to be added to
3696 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
3697 will have the value on entry of the last loop, rather
3698 than value after iterator increment. */
3699 if (clauses->orderedc)
3700 {
3701 if (clauses->collapse <= 1 || i >= clauses->collapse)
3702 tmp = count;
3703 else
3704 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3705 type, count, build_one_cst (type));
3706 tmp = fold_build2_loc (input_location, MULT_EXPR, type,
3707 tmp, step);
3708 tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
3709 from, tmp);
3710 }
3711 else
3712 {
3713 tmp = gfc_evaluate_now (step, pblock);
3714 tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
3715 dovar, tmp);
3716 }
3717 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
3718 dovar, tmp);
3719 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3720 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
3721 && OMP_CLAUSE_DECL (c) == dovar_decl)
3722 {
3723 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
3724 break;
3725 }
3726 else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
3727 && OMP_CLAUSE_DECL (c) == dovar_decl)
3728 {
3729 OMP_CLAUSE_LINEAR_STMT (c) = tmp;
3730 break;
3731 }
3732 }
3733 if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
3734 {
3735 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3736 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
3737 && OMP_CLAUSE_DECL (c) == dovar_decl)
3738 {
3739 tree l = build_omp_clause (input_location,
3740 OMP_CLAUSE_LASTPRIVATE);
3741 OMP_CLAUSE_DECL (l) = dovar_decl;
3742 OMP_CLAUSE_CHAIN (l) = omp_clauses;
3743 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
3744 omp_clauses = l;
3745 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
3746 break;
3747 }
3748 }
3749 gcc_assert (simple || c != NULL);
3750 }
3751 if (!simple)
3752 {
3753 if (op != EXEC_OMP_SIMD)
3754 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3755 else if (collapse == 1)
3756 {
3757 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3758 OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
3759 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3760 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
3761 }
3762 else
3763 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3764 OMP_CLAUSE_DECL (tmp) = count;
3765 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3766 }
3767
3768 if (i + 1 < collapse)
3769 code = code->block->next;
3770 }
3771
3772 if (pblock != &block)
3773 {
3774 pushlevel ();
3775 gfc_start_block (&block);
3776 }
3777
3778 gfc_start_block (&body);
3779
3780 FOR_EACH_VEC_ELT (inits, ix, di)
3781 gfc_add_modify (&body, di->var, di->init);
3782 inits.release ();
3783
3784 /* Cycle statement is implemented with a goto. Exit statement must not be
3785 present for this loop. */
3786 cycle_label = gfc_build_label_decl (NULL_TREE);
3787
3788 /* Put these labels where they can be found later. */
3789
3790 code->cycle_label = cycle_label;
3791 code->exit_label = NULL_TREE;
3792
3793 /* Main loop body. */
3794 tmp = gfc_trans_omp_code (code->block->next, true);
3795 gfc_add_expr_to_block (&body, tmp);
3796
3797 /* Label for cycle statements (if needed). */
3798 if (TREE_USED (cycle_label))
3799 {
3800 tmp = build1_v (LABEL_EXPR, cycle_label);
3801 gfc_add_expr_to_block (&body, tmp);
3802 }
3803
3804 /* End of loop body. */
3805 switch (op)
3806 {
3807 case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
3808 case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
3809 case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
3810 case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
3811 case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
3812 default: gcc_unreachable ();
3813 }
3814
3815 TREE_TYPE (stmt) = void_type_node;
3816 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
3817 OMP_FOR_CLAUSES (stmt) = omp_clauses;
3818 OMP_FOR_INIT (stmt) = init;
3819 OMP_FOR_COND (stmt) = cond;
3820 OMP_FOR_INCR (stmt) = incr;
3821 if (orig_decls)
3822 OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
3823 gfc_add_expr_to_block (&block, stmt);
3824
3825 vec_free (doacross_steps);
3826 doacross_steps = saved_doacross_steps;
3827
3828 return gfc_finish_block (&block);
3829 }
3830
3831 /* parallel loop and kernels loop. */
3832 static tree
3833 gfc_trans_oacc_combined_directive (gfc_code *code)
3834 {
3835 stmtblock_t block, *pblock = NULL;
3836 gfc_omp_clauses construct_clauses, loop_clauses;
3837 tree stmt, oacc_clauses = NULL_TREE;
3838 enum tree_code construct_code;
3839
3840 switch (code->op)
3841 {
3842 case EXEC_OACC_PARALLEL_LOOP:
3843 construct_code = OACC_PARALLEL;
3844 break;
3845 case EXEC_OACC_KERNELS_LOOP:
3846 construct_code = OACC_KERNELS;
3847 break;
3848 default:
3849 gcc_unreachable ();
3850 }
3851
3852 gfc_start_block (&block);
3853
3854 memset (&loop_clauses, 0, sizeof (loop_clauses));
3855 if (code->ext.omp_clauses != NULL)
3856 {
3857 memcpy (&construct_clauses, code->ext.omp_clauses,
3858 sizeof (construct_clauses));
3859 loop_clauses.collapse = construct_clauses.collapse;
3860 loop_clauses.gang = construct_clauses.gang;
3861 loop_clauses.gang_static = construct_clauses.gang_static;
3862 loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
3863 loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
3864 loop_clauses.vector = construct_clauses.vector;
3865 loop_clauses.vector_expr = construct_clauses.vector_expr;
3866 loop_clauses.worker = construct_clauses.worker;
3867 loop_clauses.worker_expr = construct_clauses.worker_expr;
3868 loop_clauses.seq = construct_clauses.seq;
3869 loop_clauses.par_auto = construct_clauses.par_auto;
3870 loop_clauses.independent = construct_clauses.independent;
3871 loop_clauses.tile_list = construct_clauses.tile_list;
3872 loop_clauses.lists[OMP_LIST_PRIVATE]
3873 = construct_clauses.lists[OMP_LIST_PRIVATE];
3874 loop_clauses.lists[OMP_LIST_REDUCTION]
3875 = construct_clauses.lists[OMP_LIST_REDUCTION];
3876 construct_clauses.gang = false;
3877 construct_clauses.gang_static = false;
3878 construct_clauses.gang_num_expr = NULL;
3879 construct_clauses.gang_static_expr = NULL;
3880 construct_clauses.vector = false;
3881 construct_clauses.vector_expr = NULL;
3882 construct_clauses.worker = false;
3883 construct_clauses.worker_expr = NULL;
3884 construct_clauses.seq = false;
3885 construct_clauses.par_auto = false;
3886 construct_clauses.independent = false;
3887 construct_clauses.independent = false;
3888 construct_clauses.tile_list = NULL;
3889 construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
3890 if (construct_code == OACC_KERNELS)
3891 construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
3892 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
3893 code->loc);
3894 }
3895 if (!loop_clauses.seq)
3896 pblock = &block;
3897 else
3898 pushlevel ();
3899 stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
3900 if (TREE_CODE (stmt) != BIND_EXPR)
3901 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3902 else
3903 poplevel (0, 0);
3904 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
3905 oacc_clauses);
3906 gfc_add_expr_to_block (&block, stmt);
3907 return gfc_finish_block (&block);
3908 }
3909
3910 static tree
3911 gfc_trans_omp_flush (void)
3912 {
3913 tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
3914 return build_call_expr_loc (input_location, decl, 0);
3915 }
3916
3917 static tree
3918 gfc_trans_omp_master (gfc_code *code)
3919 {
3920 tree stmt = gfc_trans_code (code->block->next);
3921 if (IS_EMPTY_STMT (stmt))
3922 return stmt;
3923 return build1_v (OMP_MASTER, stmt);
3924 }
3925
3926 static tree
3927 gfc_trans_omp_ordered (gfc_code *code)
3928 {
3929 if (!flag_openmp)
3930 {
3931 if (!code->ext.omp_clauses->simd)
3932 return gfc_trans_code (code->block ? code->block->next : NULL);
3933 code->ext.omp_clauses->threads = 0;
3934 }
3935 tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses,
3936 code->loc);
3937 return build2_loc (input_location, OMP_ORDERED, void_type_node,
3938 code->block ? gfc_trans_code (code->block->next)
3939 : NULL_TREE, omp_clauses);
3940 }
3941
3942 static tree
3943 gfc_trans_omp_parallel (gfc_code *code)
3944 {
3945 stmtblock_t block;
3946 tree stmt, omp_clauses;
3947
3948 gfc_start_block (&block);
3949 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3950 code->loc);
3951 pushlevel ();
3952 stmt = gfc_trans_omp_code (code->block->next, true);
3953 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3954 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3955 omp_clauses);
3956 gfc_add_expr_to_block (&block, stmt);
3957 return gfc_finish_block (&block);
3958 }
3959
3960 enum
3961 {
3962 GFC_OMP_SPLIT_SIMD,
3963 GFC_OMP_SPLIT_DO,
3964 GFC_OMP_SPLIT_PARALLEL,
3965 GFC_OMP_SPLIT_DISTRIBUTE,
3966 GFC_OMP_SPLIT_TEAMS,
3967 GFC_OMP_SPLIT_TARGET,
3968 GFC_OMP_SPLIT_TASKLOOP,
3969 GFC_OMP_SPLIT_NUM
3970 };
3971
3972 enum
3973 {
3974 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
3975 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
3976 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
3977 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
3978 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
3979 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET),
3980 GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP)
3981 };
3982
3983 static void
3984 gfc_split_omp_clauses (gfc_code *code,
3985 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
3986 {
3987 int mask = 0, innermost = 0;
3988 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
3989 switch (code->op)
3990 {
3991 case EXEC_OMP_DISTRIBUTE:
3992 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3993 break;
3994 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3995 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3996 innermost = GFC_OMP_SPLIT_DO;
3997 break;
3998 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3999 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
4000 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
4001 innermost = GFC_OMP_SPLIT_SIMD;
4002 break;
4003 case EXEC_OMP_DISTRIBUTE_SIMD:
4004 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
4005 innermost = GFC_OMP_SPLIT_SIMD;
4006 break;
4007 case EXEC_OMP_DO:
4008 innermost = GFC_OMP_SPLIT_DO;
4009 break;
4010 case EXEC_OMP_DO_SIMD:
4011 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
4012 innermost = GFC_OMP_SPLIT_SIMD;
4013 break;
4014 case EXEC_OMP_PARALLEL:
4015 innermost = GFC_OMP_SPLIT_PARALLEL;
4016 break;
4017 case EXEC_OMP_PARALLEL_DO:
4018 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
4019 innermost = GFC_OMP_SPLIT_DO;
4020 break;
4021 case EXEC_OMP_PARALLEL_DO_SIMD:
4022 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
4023 innermost = GFC_OMP_SPLIT_SIMD;
4024 break;
4025 case EXEC_OMP_SIMD:
4026 innermost = GFC_OMP_SPLIT_SIMD;
4027 break;
4028 case EXEC_OMP_TARGET:
4029 innermost = GFC_OMP_SPLIT_TARGET;
4030 break;
4031 case EXEC_OMP_TARGET_PARALLEL:
4032 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
4033 innermost = GFC_OMP_SPLIT_PARALLEL;
4034 break;
4035 case EXEC_OMP_TARGET_PARALLEL_DO:
4036 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
4037 innermost = GFC_OMP_SPLIT_DO;
4038 break;
4039 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
4040 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
4041 | GFC_OMP_MASK_SIMD;
4042 innermost = GFC_OMP_SPLIT_SIMD;
4043 break;
4044 case EXEC_OMP_TARGET_SIMD:
4045 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
4046 innermost = GFC_OMP_SPLIT_SIMD;
4047 break;
4048 case EXEC_OMP_TARGET_TEAMS:
4049 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
4050 innermost = GFC_OMP_SPLIT_TEAMS;
4051 break;
4052 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4053 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
4054 | GFC_OMP_MASK_DISTRIBUTE;
4055 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
4056 break;
4057 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4058 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
4059 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
4060 innermost = GFC_OMP_SPLIT_DO;
4061 break;
4062 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4063 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
4064 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
4065 innermost = GFC_OMP_SPLIT_SIMD;
4066 break;
4067 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4068 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
4069 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
4070 innermost = GFC_OMP_SPLIT_SIMD;
4071 break;
4072 case EXEC_OMP_TASKLOOP:
4073 innermost = GFC_OMP_SPLIT_TASKLOOP;
4074 break;
4075 case EXEC_OMP_TASKLOOP_SIMD:
4076 mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
4077 innermost = GFC_OMP_SPLIT_SIMD;
4078 break;
4079 case EXEC_OMP_TEAMS:
4080 innermost = GFC_OMP_SPLIT_TEAMS;
4081 break;
4082 case EXEC_OMP_TEAMS_DISTRIBUTE:
4083 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
4084 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
4085 break;
4086 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4087 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
4088 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
4089 innermost = GFC_OMP_SPLIT_DO;
4090 break;
4091 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4092 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
4093 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
4094 innermost = GFC_OMP_SPLIT_SIMD;
4095 break;
4096 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4097 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
4098 innermost = GFC_OMP_SPLIT_SIMD;
4099 break;
4100 default:
4101 gcc_unreachable ();
4102 }
4103 if (mask == 0)
4104 {
4105 clausesa[innermost] = *code->ext.omp_clauses;
4106 return;
4107 }
4108 if (code->ext.omp_clauses != NULL)
4109 {
4110 if (mask & GFC_OMP_MASK_TARGET)
4111 {
4112 /* First the clauses that are unique to some constructs. */
4113 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
4114 = code->ext.omp_clauses->lists[OMP_LIST_MAP];
4115 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR]
4116 = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
4117 clausesa[GFC_OMP_SPLIT_TARGET].device
4118 = code->ext.omp_clauses->device;
4119 clausesa[GFC_OMP_SPLIT_TARGET].defaultmap
4120 = code->ext.omp_clauses->defaultmap;
4121 clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
4122 = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
4123 /* And this is copied to all. */
4124 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
4125 = code->ext.omp_clauses->if_expr;
4126 }
4127 if (mask & GFC_OMP_MASK_TEAMS)
4128 {
4129 /* First the clauses that are unique to some constructs. */
4130 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
4131 = code->ext.omp_clauses->num_teams;
4132 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
4133 = code->ext.omp_clauses->thread_limit;
4134 /* Shared and default clauses are allowed on parallel, teams
4135 and taskloop. */
4136 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
4137 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
4138 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
4139 = code->ext.omp_clauses->default_sharing;
4140 }
4141 if (mask & GFC_OMP_MASK_DISTRIBUTE)
4142 {
4143 /* First the clauses that are unique to some constructs. */
4144 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
4145 = code->ext.omp_clauses->dist_sched_kind;
4146 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
4147 = code->ext.omp_clauses->dist_chunk_size;
4148 /* Duplicate collapse. */
4149 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
4150 = code->ext.omp_clauses->collapse;
4151 }
4152 if (mask & GFC_OMP_MASK_PARALLEL)
4153 {
4154 /* First the clauses that are unique to some constructs. */
4155 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
4156 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
4157 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
4158 = code->ext.omp_clauses->num_threads;
4159 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
4160 = code->ext.omp_clauses->proc_bind;
4161 /* Shared and default clauses are allowed on parallel, teams
4162 and taskloop. */
4163 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
4164 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
4165 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
4166 = code->ext.omp_clauses->default_sharing;
4167 clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
4168 = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
4169 /* And this is copied to all. */
4170 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
4171 = code->ext.omp_clauses->if_expr;
4172 }
4173 if (mask & GFC_OMP_MASK_DO)
4174 {
4175 /* First the clauses that are unique to some constructs. */
4176 clausesa[GFC_OMP_SPLIT_DO].ordered
4177 = code->ext.omp_clauses->ordered;
4178 clausesa[GFC_OMP_SPLIT_DO].orderedc
4179 = code->ext.omp_clauses->orderedc;
4180 clausesa[GFC_OMP_SPLIT_DO].sched_kind
4181 = code->ext.omp_clauses->sched_kind;
4182 if (innermost == GFC_OMP_SPLIT_SIMD)
4183 clausesa[GFC_OMP_SPLIT_DO].sched_simd
4184 = code->ext.omp_clauses->sched_simd;
4185 clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
4186 = code->ext.omp_clauses->sched_monotonic;
4187 clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
4188 = code->ext.omp_clauses->sched_nonmonotonic;
4189 clausesa[GFC_OMP_SPLIT_DO].chunk_size
4190 = code->ext.omp_clauses->chunk_size;
4191 clausesa[GFC_OMP_SPLIT_DO].nowait
4192 = code->ext.omp_clauses->nowait;
4193 /* Duplicate collapse. */
4194 clausesa[GFC_OMP_SPLIT_DO].collapse
4195 = code->ext.omp_clauses->collapse;
4196 }
4197 if (mask & GFC_OMP_MASK_SIMD)
4198 {
4199 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
4200 = code->ext.omp_clauses->safelen_expr;
4201 clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
4202 = code->ext.omp_clauses->simdlen_expr;
4203 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
4204 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
4205 /* Duplicate collapse. */
4206 clausesa[GFC_OMP_SPLIT_SIMD].collapse
4207 = code->ext.omp_clauses->collapse;
4208 }
4209 if (mask & GFC_OMP_MASK_TASKLOOP)
4210 {
4211 /* First the clauses that are unique to some constructs. */
4212 clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
4213 = code->ext.omp_clauses->nogroup;
4214 clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
4215 = code->ext.omp_clauses->grainsize;
4216 clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
4217 = code->ext.omp_clauses->num_tasks;
4218 clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
4219 = code->ext.omp_clauses->priority;
4220 clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
4221 = code->ext.omp_clauses->final_expr;
4222 clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
4223 = code->ext.omp_clauses->untied;
4224 clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
4225 = code->ext.omp_clauses->mergeable;
4226 clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
4227 = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
4228 /* And this is copied to all. */
4229 clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
4230 = code->ext.omp_clauses->if_expr;
4231 /* Shared and default clauses are allowed on parallel, teams
4232 and taskloop. */
4233 clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
4234 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
4235 clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
4236 = code->ext.omp_clauses->default_sharing;
4237 /* Duplicate collapse. */
4238 clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
4239 = code->ext.omp_clauses->collapse;
4240 }
4241 /* Private clause is supported on all constructs,
4242 it is enough to put it on the innermost one. For
4243 !$ omp parallel do put it on parallel though,
4244 as that's what we did for OpenMP 3.1. */
4245 clausesa[innermost == GFC_OMP_SPLIT_DO
4246 ? (int) GFC_OMP_SPLIT_PARALLEL
4247 : innermost].lists[OMP_LIST_PRIVATE]
4248 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
4249 /* Firstprivate clause is supported on all constructs but
4250 simd. Put it on the outermost of those and duplicate
4251 on parallel and teams. */
4252 if (mask & GFC_OMP_MASK_TARGET)
4253 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_FIRSTPRIVATE]
4254 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
4255 if (mask & GFC_OMP_MASK_TEAMS)
4256 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
4257 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
4258 else if (mask & GFC_OMP_MASK_DISTRIBUTE)
4259 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
4260 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
4261 if (mask & GFC_OMP_MASK_PARALLEL)
4262 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
4263 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
4264 else if (mask & GFC_OMP_MASK_DO)
4265 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
4266 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
4267 /* Lastprivate is allowed on distribute, do and simd.
4268 In parallel do{, simd} we actually want to put it on
4269 parallel rather than do. */
4270 if (mask & GFC_OMP_MASK_DISTRIBUTE)
4271 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
4272 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
4273 if (mask & GFC_OMP_MASK_PARALLEL)
4274 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
4275 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
4276 else if (mask & GFC_OMP_MASK_DO)
4277 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
4278 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
4279 if (mask & GFC_OMP_MASK_SIMD)
4280 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
4281 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
4282 /* Reduction is allowed on simd, do, parallel and teams.
4283 Duplicate it on all of them, but omit on do if
4284 parallel is present. */
4285 if (mask & GFC_OMP_MASK_TEAMS)
4286 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION]
4287 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
4288 if (mask & GFC_OMP_MASK_PARALLEL)
4289 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
4290 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
4291 else if (mask & GFC_OMP_MASK_DO)
4292 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
4293 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
4294 if (mask & GFC_OMP_MASK_SIMD)
4295 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
4296 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
4297 /* Linear clause is supported on do and simd,
4298 put it on the innermost one. */
4299 clausesa[innermost].lists[OMP_LIST_LINEAR]
4300 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
4301 }
4302 if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
4303 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
4304 clausesa[GFC_OMP_SPLIT_DO].nowait = true;
4305 }
4306
4307 static tree
4308 gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
4309 gfc_omp_clauses *clausesa, tree omp_clauses)
4310 {
4311 stmtblock_t block;
4312 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4313 tree stmt, body, omp_do_clauses = NULL_TREE;
4314
4315 if (pblock == NULL)
4316 gfc_start_block (&block);
4317 else
4318 gfc_init_block (&block);
4319
4320 if (clausesa == NULL)
4321 {
4322 clausesa = clausesa_buf;
4323 gfc_split_omp_clauses (code, clausesa);
4324 }
4325 if (flag_openmp)
4326 omp_do_clauses
4327 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
4328 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
4329 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
4330 if (pblock == NULL)
4331 {
4332 if (TREE_CODE (body) != BIND_EXPR)
4333 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
4334 else
4335 poplevel (0, 0);
4336 }
4337 else if (TREE_CODE (body) != BIND_EXPR)
4338 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
4339 if (flag_openmp)
4340 {
4341 stmt = make_node (OMP_FOR);
4342 TREE_TYPE (stmt) = void_type_node;
4343 OMP_FOR_BODY (stmt) = body;
4344 OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
4345 }
4346 else
4347 stmt = body;
4348 gfc_add_expr_to_block (&block, stmt);
4349 return gfc_finish_block (&block);
4350 }
4351
4352 static tree
4353 gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock,
4354 gfc_omp_clauses *clausesa)
4355 {
4356 stmtblock_t block, *new_pblock = pblock;
4357 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4358 tree stmt, omp_clauses = NULL_TREE;
4359
4360 if (pblock == NULL)
4361 gfc_start_block (&block);
4362 else
4363 gfc_init_block (&block);
4364
4365 if (clausesa == NULL)
4366 {
4367 clausesa = clausesa_buf;
4368 gfc_split_omp_clauses (code, clausesa);
4369 }
4370 omp_clauses
4371 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
4372 code->loc);
4373 if (pblock == NULL)
4374 {
4375 if (!clausesa[GFC_OMP_SPLIT_DO].ordered
4376 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
4377 new_pblock = &block;
4378 else
4379 pushlevel ();
4380 }
4381 stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock,
4382 &clausesa[GFC_OMP_SPLIT_DO], omp_clauses);
4383 if (pblock == NULL)
4384 {
4385 if (TREE_CODE (stmt) != BIND_EXPR)
4386 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4387 else
4388 poplevel (0, 0);
4389 }
4390 else if (TREE_CODE (stmt) != BIND_EXPR)
4391 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
4392 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4393 omp_clauses);
4394 OMP_PARALLEL_COMBINED (stmt) = 1;
4395 gfc_add_expr_to_block (&block, stmt);
4396 return gfc_finish_block (&block);
4397 }
4398
4399 static tree
4400 gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
4401 gfc_omp_clauses *clausesa)
4402 {
4403 stmtblock_t block;
4404 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4405 tree stmt, omp_clauses = NULL_TREE;
4406
4407 if (pblock == NULL)
4408 gfc_start_block (&block);
4409 else
4410 gfc_init_block (&block);
4411
4412 if (clausesa == NULL)
4413 {
4414 clausesa = clausesa_buf;
4415 gfc_split_omp_clauses (code, clausesa);
4416 }
4417 if (flag_openmp)
4418 omp_clauses
4419 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
4420 code->loc);
4421 if (pblock == NULL)
4422 pushlevel ();
4423 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
4424 if (pblock == NULL)
4425 {
4426 if (TREE_CODE (stmt) != BIND_EXPR)
4427 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4428 else
4429 poplevel (0, 0);
4430 }
4431 else if (TREE_CODE (stmt) != BIND_EXPR)
4432 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
4433 if (flag_openmp)
4434 {
4435 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4436 omp_clauses);
4437 OMP_PARALLEL_COMBINED (stmt) = 1;
4438 }
4439 gfc_add_expr_to_block (&block, stmt);
4440 return gfc_finish_block (&block);
4441 }
4442
4443 static tree
4444 gfc_trans_omp_parallel_sections (gfc_code *code)
4445 {
4446 stmtblock_t block;
4447 gfc_omp_clauses section_clauses;
4448 tree stmt, omp_clauses;
4449
4450 memset (&section_clauses, 0, sizeof (section_clauses));
4451 section_clauses.nowait = true;
4452
4453 gfc_start_block (&block);
4454 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4455 code->loc);
4456 pushlevel ();
4457 stmt = gfc_trans_omp_sections (code, &section_clauses);
4458 if (TREE_CODE (stmt) != BIND_EXPR)
4459 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4460 else
4461 poplevel (0, 0);
4462 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4463 omp_clauses);
4464 OMP_PARALLEL_COMBINED (stmt) = 1;
4465 gfc_add_expr_to_block (&block, stmt);
4466 return gfc_finish_block (&block);
4467 }
4468
4469 static tree
4470 gfc_trans_omp_parallel_workshare (gfc_code *code)
4471 {
4472 stmtblock_t block;
4473 gfc_omp_clauses workshare_clauses;
4474 tree stmt, omp_clauses;
4475
4476 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
4477 workshare_clauses.nowait = true;
4478
4479 gfc_start_block (&block);
4480 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4481 code->loc);
4482 pushlevel ();
4483 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
4484 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4485 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4486 omp_clauses);
4487 OMP_PARALLEL_COMBINED (stmt) = 1;
4488 gfc_add_expr_to_block (&block, stmt);
4489 return gfc_finish_block (&block);
4490 }
4491
4492 static tree
4493 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
4494 {
4495 stmtblock_t block, body;
4496 tree omp_clauses, stmt;
4497 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
4498
4499 gfc_start_block (&block);
4500
4501 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
4502
4503 gfc_init_block (&body);
4504 for (code = code->block; code; code = code->block)
4505 {
4506 /* Last section is special because of lastprivate, so even if it
4507 is empty, chain it in. */
4508 stmt = gfc_trans_omp_code (code->next,
4509 has_lastprivate && code->block == NULL);
4510 if (! IS_EMPTY_STMT (stmt))
4511 {
4512 stmt = build1_v (OMP_SECTION, stmt);
4513 gfc_add_expr_to_block (&body, stmt);
4514 }
4515 }
4516 stmt = gfc_finish_block (&body);
4517
4518 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
4519 omp_clauses);
4520 gfc_add_expr_to_block (&block, stmt);
4521
4522 return gfc_finish_block (&block);
4523 }
4524
4525 static tree
4526 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
4527 {
4528 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
4529 tree stmt = gfc_trans_omp_code (code->block->next, true);
4530 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
4531 omp_clauses);
4532 return stmt;
4533 }
4534
4535 static tree
4536 gfc_trans_omp_task (gfc_code *code)
4537 {
4538 stmtblock_t block;
4539 tree stmt, omp_clauses;
4540
4541 gfc_start_block (&block);
4542 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4543 code->loc);
4544 pushlevel ();
4545 stmt = gfc_trans_omp_code (code->block->next, true);
4546 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4547 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
4548 omp_clauses);
4549 gfc_add_expr_to_block (&block, stmt);
4550 return gfc_finish_block (&block);
4551 }
4552
4553 static tree
4554 gfc_trans_omp_taskgroup (gfc_code *code)
4555 {
4556 tree stmt = gfc_trans_code (code->block->next);
4557 return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt);
4558 }
4559
4560 static tree
4561 gfc_trans_omp_taskwait (void)
4562 {
4563 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
4564 return build_call_expr_loc (input_location, decl, 0);
4565 }
4566
4567 static tree
4568 gfc_trans_omp_taskyield (void)
4569 {
4570 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
4571 return build_call_expr_loc (input_location, decl, 0);
4572 }
4573
4574 static tree
4575 gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
4576 {
4577 stmtblock_t block;
4578 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4579 tree stmt, omp_clauses = NULL_TREE;
4580
4581 gfc_start_block (&block);
4582 if (clausesa == NULL)
4583 {
4584 clausesa = clausesa_buf;
4585 gfc_split_omp_clauses (code, clausesa);
4586 }
4587 if (flag_openmp)
4588 omp_clauses
4589 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4590 code->loc);
4591 switch (code->op)
4592 {
4593 case EXEC_OMP_DISTRIBUTE:
4594 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4595 case EXEC_OMP_TEAMS_DISTRIBUTE:
4596 /* This is handled in gfc_trans_omp_do. */
4597 gcc_unreachable ();
4598 break;
4599 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4600 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4601 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4602 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa);
4603 if (TREE_CODE (stmt) != BIND_EXPR)
4604 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4605 else
4606 poplevel (0, 0);
4607 break;
4608 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4609 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4610 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4611 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
4612 if (TREE_CODE (stmt) != BIND_EXPR)
4613 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4614 else
4615 poplevel (0, 0);
4616 break;
4617 case EXEC_OMP_DISTRIBUTE_SIMD:
4618 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4619 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4620 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4621 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4622 if (TREE_CODE (stmt) != BIND_EXPR)
4623 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4624 else
4625 poplevel (0, 0);
4626 break;
4627 default:
4628 gcc_unreachable ();
4629 }
4630 if (flag_openmp)
4631 {
4632 tree distribute = make_node (OMP_DISTRIBUTE);
4633 TREE_TYPE (distribute) = void_type_node;
4634 OMP_FOR_BODY (distribute) = stmt;
4635 OMP_FOR_CLAUSES (distribute) = omp_clauses;
4636 stmt = distribute;
4637 }
4638 gfc_add_expr_to_block (&block, stmt);
4639 return gfc_finish_block (&block);
4640 }
4641
4642 static tree
4643 gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
4644 tree omp_clauses)
4645 {
4646 stmtblock_t block;
4647 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4648 tree stmt;
4649 bool combined = true;
4650
4651 gfc_start_block (&block);
4652 if (clausesa == NULL)
4653 {
4654 clausesa = clausesa_buf;
4655 gfc_split_omp_clauses (code, clausesa);
4656 }
4657 if (flag_openmp)
4658 omp_clauses
4659 = chainon (omp_clauses,
4660 gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS],
4661 code->loc));
4662 switch (code->op)
4663 {
4664 case EXEC_OMP_TARGET_TEAMS:
4665 case EXEC_OMP_TEAMS:
4666 stmt = gfc_trans_omp_code (code->block->next, true);
4667 combined = false;
4668 break;
4669 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4670 case EXEC_OMP_TEAMS_DISTRIBUTE:
4671 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
4672 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4673 NULL);
4674 break;
4675 default:
4676 stmt = gfc_trans_omp_distribute (code, clausesa);
4677 break;
4678 }
4679 if (flag_openmp)
4680 {
4681 stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt,
4682 omp_clauses);
4683 if (combined)
4684 OMP_TEAMS_COMBINED (stmt) = 1;
4685 }
4686 gfc_add_expr_to_block (&block, stmt);
4687 return gfc_finish_block (&block);
4688 }
4689
4690 static tree
4691 gfc_trans_omp_target (gfc_code *code)
4692 {
4693 stmtblock_t block;
4694 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
4695 tree stmt, omp_clauses = NULL_TREE;
4696
4697 gfc_start_block (&block);
4698 gfc_split_omp_clauses (code, clausesa);
4699 if (flag_openmp)
4700 omp_clauses
4701 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
4702 code->loc);
4703 switch (code->op)
4704 {
4705 case EXEC_OMP_TARGET:
4706 pushlevel ();
4707 stmt = gfc_trans_omp_code (code->block->next, true);
4708 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4709 break;
4710 case EXEC_OMP_TARGET_PARALLEL:
4711 {
4712 stmtblock_t iblock;
4713
4714 gfc_start_block (&iblock);
4715 tree inner_clauses
4716 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
4717 code->loc);
4718 stmt = gfc_trans_omp_code (code->block->next, true);
4719 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4720 inner_clauses);
4721 gfc_add_expr_to_block (&iblock, stmt);
4722 stmt = gfc_finish_block (&iblock);
4723 if (TREE_CODE (stmt) != BIND_EXPR)
4724 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4725 else
4726 poplevel (0, 0);
4727 }
4728 break;
4729 case EXEC_OMP_TARGET_PARALLEL_DO:
4730 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
4731 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa);
4732 if (TREE_CODE (stmt) != BIND_EXPR)
4733 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4734 else
4735 poplevel (0, 0);
4736 break;
4737 case EXEC_OMP_TARGET_SIMD:
4738 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4739 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4740 if (TREE_CODE (stmt) != BIND_EXPR)
4741 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4742 else
4743 poplevel (0, 0);
4744 break;
4745 default:
4746 if (flag_openmp
4747 && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
4748 || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
4749 {
4750 gfc_omp_clauses clausesb;
4751 tree teams_clauses;
4752 /* For combined !$omp target teams, the num_teams and
4753 thread_limit clauses are evaluated before entering the
4754 target construct. */
4755 memset (&clausesb, '\0', sizeof (clausesb));
4756 clausesb.num_teams = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams;
4757 clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
4758 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams = NULL;
4759 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
4760 teams_clauses
4761 = gfc_trans_omp_clauses (&block, &clausesb, code->loc);
4762 pushlevel ();
4763 stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses);
4764 }
4765 else
4766 {
4767 pushlevel ();
4768 stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
4769 }
4770 if (TREE_CODE (stmt) != BIND_EXPR)
4771 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4772 else
4773 poplevel (0, 0);
4774 break;
4775 }
4776 if (flag_openmp)
4777 {
4778 stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt,
4779 omp_clauses);
4780 if (code->op != EXEC_OMP_TARGET)
4781 OMP_TARGET_COMBINED (stmt) = 1;
4782 }
4783 gfc_add_expr_to_block (&block, stmt);
4784 return gfc_finish_block (&block);
4785 }
4786
4787 static tree
4788 gfc_trans_omp_taskloop (gfc_code *code)
4789 {
4790 stmtblock_t block;
4791 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
4792 tree stmt, omp_clauses = NULL_TREE;
4793
4794 gfc_start_block (&block);
4795 gfc_split_omp_clauses (code, clausesa);
4796 if (flag_openmp)
4797 omp_clauses
4798 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP],
4799 code->loc);
4800 switch (code->op)
4801 {
4802 case EXEC_OMP_TASKLOOP:
4803 /* This is handled in gfc_trans_omp_do. */
4804 gcc_unreachable ();
4805 break;
4806 case EXEC_OMP_TASKLOOP_SIMD:
4807 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4808 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4809 if (TREE_CODE (stmt) != BIND_EXPR)
4810 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4811 else
4812 poplevel (0, 0);
4813 break;
4814 default:
4815 gcc_unreachable ();
4816 }
4817 if (flag_openmp)
4818 {
4819 tree taskloop = make_node (OMP_TASKLOOP);
4820 TREE_TYPE (taskloop) = void_type_node;
4821 OMP_FOR_BODY (taskloop) = stmt;
4822 OMP_FOR_CLAUSES (taskloop) = omp_clauses;
4823 stmt = taskloop;
4824 }
4825 gfc_add_expr_to_block (&block, stmt);
4826 return gfc_finish_block (&block);
4827 }
4828
4829 static tree
4830 gfc_trans_omp_target_data (gfc_code *code)
4831 {
4832 stmtblock_t block;
4833 tree stmt, omp_clauses;
4834
4835 gfc_start_block (&block);
4836 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4837 code->loc);
4838 stmt = gfc_trans_omp_code (code->block->next, true);
4839 stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt,
4840 omp_clauses);
4841 gfc_add_expr_to_block (&block, stmt);
4842 return gfc_finish_block (&block);
4843 }
4844
4845 static tree
4846 gfc_trans_omp_target_enter_data (gfc_code *code)
4847 {
4848 stmtblock_t block;
4849 tree stmt, omp_clauses;
4850
4851 gfc_start_block (&block);
4852 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4853 code->loc);
4854 stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
4855 omp_clauses);
4856 gfc_add_expr_to_block (&block, stmt);
4857 return gfc_finish_block (&block);
4858 }
4859
4860 static tree
4861 gfc_trans_omp_target_exit_data (gfc_code *code)
4862 {
4863 stmtblock_t block;
4864 tree stmt, omp_clauses;
4865
4866 gfc_start_block (&block);
4867 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4868 code->loc);
4869 stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
4870 omp_clauses);
4871 gfc_add_expr_to_block (&block, stmt);
4872 return gfc_finish_block (&block);
4873 }
4874
4875 static tree
4876 gfc_trans_omp_target_update (gfc_code *code)
4877 {
4878 stmtblock_t block;
4879 tree stmt, omp_clauses;
4880
4881 gfc_start_block (&block);
4882 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4883 code->loc);
4884 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
4885 omp_clauses);
4886 gfc_add_expr_to_block (&block, stmt);
4887 return gfc_finish_block (&block);
4888 }
4889
4890 static tree
4891 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
4892 {
4893 tree res, tmp, stmt;
4894 stmtblock_t block, *pblock = NULL;
4895 stmtblock_t singleblock;
4896 int saved_ompws_flags;
4897 bool singleblock_in_progress = false;
4898 /* True if previous gfc_code in workshare construct is not workshared. */
4899 bool prev_singleunit;
4900
4901 code = code->block->next;
4902
4903 pushlevel ();
4904
4905 gfc_start_block (&block);
4906 pblock = &block;
4907
4908 ompws_flags = OMPWS_WORKSHARE_FLAG;
4909 prev_singleunit = false;
4910
4911 /* Translate statements one by one to trees until we reach
4912 the end of the workshare construct. Adjacent gfc_codes that
4913 are a single unit of work are clustered and encapsulated in a
4914 single OMP_SINGLE construct. */
4915 for (; code; code = code->next)
4916 {
4917 if (code->here != 0)
4918 {
4919 res = gfc_trans_label_here (code);
4920 gfc_add_expr_to_block (pblock, res);
4921 }
4922
4923 /* No dependence analysis, use for clauses with wait.
4924 If this is the last gfc_code, use default omp_clauses. */
4925 if (code->next == NULL && clauses->nowait)
4926 ompws_flags |= OMPWS_NOWAIT;
4927
4928 /* By default, every gfc_code is a single unit of work. */
4929 ompws_flags |= OMPWS_CURR_SINGLEUNIT;
4930 ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
4931
4932 switch (code->op)
4933 {
4934 case EXEC_NOP:
4935 res = NULL_TREE;
4936 break;
4937
4938 case EXEC_ASSIGN:
4939 res = gfc_trans_assign (code);
4940 break;
4941
4942 case EXEC_POINTER_ASSIGN:
4943 res = gfc_trans_pointer_assign (code);
4944 break;
4945
4946 case EXEC_INIT_ASSIGN:
4947 res = gfc_trans_init_assign (code);
4948 break;
4949
4950 case EXEC_FORALL:
4951 res = gfc_trans_forall (code);
4952 break;
4953
4954 case EXEC_WHERE:
4955 res = gfc_trans_where (code);
4956 break;
4957
4958 case EXEC_OMP_ATOMIC:
4959 res = gfc_trans_omp_directive (code);
4960 break;
4961
4962 case EXEC_OMP_PARALLEL:
4963 case EXEC_OMP_PARALLEL_DO:
4964 case EXEC_OMP_PARALLEL_SECTIONS:
4965 case EXEC_OMP_PARALLEL_WORKSHARE:
4966 case EXEC_OMP_CRITICAL:
4967 saved_ompws_flags = ompws_flags;
4968 ompws_flags = 0;
4969 res = gfc_trans_omp_directive (code);
4970 ompws_flags = saved_ompws_flags;
4971 break;
4972
4973 default:
4974 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
4975 }
4976
4977 gfc_set_backend_locus (&code->loc);
4978
4979 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
4980 {
4981 if (prev_singleunit)
4982 {
4983 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4984 /* Add current gfc_code to single block. */
4985 gfc_add_expr_to_block (&singleblock, res);
4986 else
4987 {
4988 /* Finish single block and add it to pblock. */
4989 tmp = gfc_finish_block (&singleblock);
4990 tmp = build2_loc (input_location, OMP_SINGLE,
4991 void_type_node, tmp, NULL_TREE);
4992 gfc_add_expr_to_block (pblock, tmp);
4993 /* Add current gfc_code to pblock. */
4994 gfc_add_expr_to_block (pblock, res);
4995 singleblock_in_progress = false;
4996 }
4997 }
4998 else
4999 {
5000 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
5001 {
5002 /* Start single block. */
5003 gfc_init_block (&singleblock);
5004 gfc_add_expr_to_block (&singleblock, res);
5005 singleblock_in_progress = true;
5006 }
5007 else
5008 /* Add the new statement to the block. */
5009 gfc_add_expr_to_block (pblock, res);
5010 }
5011 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
5012 }
5013 }
5014
5015 /* Finish remaining SINGLE block, if we were in the middle of one. */
5016 if (singleblock_in_progress)
5017 {
5018 /* Finish single block and add it to pblock. */
5019 tmp = gfc_finish_block (&singleblock);
5020 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
5021 clauses->nowait
5022 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
5023 : NULL_TREE);
5024 gfc_add_expr_to_block (pblock, tmp);
5025 }
5026
5027 stmt = gfc_finish_block (pblock);
5028 if (TREE_CODE (stmt) != BIND_EXPR)
5029 {
5030 if (!IS_EMPTY_STMT (stmt))
5031 {
5032 tree bindblock = poplevel (1, 0);
5033 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
5034 }
5035 else
5036 poplevel (0, 0);
5037 }
5038 else
5039 poplevel (0, 0);
5040
5041 if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
5042 stmt = gfc_trans_omp_barrier ();
5043
5044 ompws_flags = 0;
5045 return stmt;
5046 }
5047
5048 tree
5049 gfc_trans_oacc_declare (gfc_code *code)
5050 {
5051 stmtblock_t block;
5052 tree stmt, oacc_clauses;
5053 enum tree_code construct_code;
5054
5055 construct_code = OACC_DATA;
5056
5057 gfc_start_block (&block);
5058
5059 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
5060 code->loc);
5061 stmt = gfc_trans_omp_code (code->block->next, true);
5062 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
5063 oacc_clauses);
5064 gfc_add_expr_to_block (&block, stmt);
5065
5066 return gfc_finish_block (&block);
5067 }
5068
5069 tree
5070 gfc_trans_oacc_directive (gfc_code *code)
5071 {
5072 switch (code->op)
5073 {
5074 case EXEC_OACC_PARALLEL_LOOP:
5075 case EXEC_OACC_KERNELS_LOOP:
5076 return gfc_trans_oacc_combined_directive (code);
5077 case EXEC_OACC_PARALLEL:
5078 case EXEC_OACC_KERNELS:
5079 case EXEC_OACC_DATA:
5080 case EXEC_OACC_HOST_DATA:
5081 return gfc_trans_oacc_construct (code);
5082 case EXEC_OACC_LOOP:
5083 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
5084 NULL);
5085 case EXEC_OACC_UPDATE:
5086 case EXEC_OACC_CACHE:
5087 case EXEC_OACC_ENTER_DATA:
5088 case EXEC_OACC_EXIT_DATA:
5089 return gfc_trans_oacc_executable_directive (code);
5090 case EXEC_OACC_WAIT:
5091 return gfc_trans_oacc_wait_directive (code);
5092 case EXEC_OACC_ATOMIC:
5093 return gfc_trans_omp_atomic (code);
5094 case EXEC_OACC_DECLARE:
5095 return gfc_trans_oacc_declare (code);
5096 default:
5097 gcc_unreachable ();
5098 }
5099 }
5100
5101 tree
5102 gfc_trans_omp_directive (gfc_code *code)
5103 {
5104 switch (code->op)
5105 {
5106 case EXEC_OMP_ATOMIC:
5107 return gfc_trans_omp_atomic (code);
5108 case EXEC_OMP_BARRIER:
5109 return gfc_trans_omp_barrier ();
5110 case EXEC_OMP_CANCEL:
5111 return gfc_trans_omp_cancel (code);
5112 case EXEC_OMP_CANCELLATION_POINT:
5113 return gfc_trans_omp_cancellation_point (code);
5114 case EXEC_OMP_CRITICAL:
5115 return gfc_trans_omp_critical (code);
5116 case EXEC_OMP_DISTRIBUTE:
5117 case EXEC_OMP_DO:
5118 case EXEC_OMP_SIMD:
5119 case EXEC_OMP_TASKLOOP:
5120 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
5121 NULL);
5122 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5123 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5124 case EXEC_OMP_DISTRIBUTE_SIMD:
5125 return gfc_trans_omp_distribute (code, NULL);
5126 case EXEC_OMP_DO_SIMD:
5127 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
5128 case EXEC_OMP_FLUSH:
5129 return gfc_trans_omp_flush ();
5130 case EXEC_OMP_MASTER:
5131 return gfc_trans_omp_master (code);
5132 case EXEC_OMP_ORDERED:
5133 return gfc_trans_omp_ordered (code);
5134 case EXEC_OMP_PARALLEL:
5135 return gfc_trans_omp_parallel (code);
5136 case EXEC_OMP_PARALLEL_DO:
5137 return gfc_trans_omp_parallel_do (code, NULL, NULL);
5138 case EXEC_OMP_PARALLEL_DO_SIMD:
5139 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
5140 case EXEC_OMP_PARALLEL_SECTIONS:
5141 return gfc_trans_omp_parallel_sections (code);
5142 case EXEC_OMP_PARALLEL_WORKSHARE:
5143 return gfc_trans_omp_parallel_workshare (code);
5144 case EXEC_OMP_SECTIONS:
5145 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
5146 case EXEC_OMP_SINGLE:
5147 return gfc_trans_omp_single (code, code->ext.omp_clauses);
5148 case EXEC_OMP_TARGET:
5149 case EXEC_OMP_TARGET_PARALLEL:
5150 case EXEC_OMP_TARGET_PARALLEL_DO:
5151 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5152 case EXEC_OMP_TARGET_SIMD:
5153 case EXEC_OMP_TARGET_TEAMS:
5154 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5155 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5156 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5157 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5158 return gfc_trans_omp_target (code);
5159 case EXEC_OMP_TARGET_DATA:
5160 return gfc_trans_omp_target_data (code);
5161 case EXEC_OMP_TARGET_ENTER_DATA:
5162 return gfc_trans_omp_target_enter_data (code);
5163 case EXEC_OMP_TARGET_EXIT_DATA:
5164 return gfc_trans_omp_target_exit_data (code);
5165 case EXEC_OMP_TARGET_UPDATE:
5166 return gfc_trans_omp_target_update (code);
5167 case EXEC_OMP_TASK:
5168 return gfc_trans_omp_task (code);
5169 case EXEC_OMP_TASKGROUP:
5170 return gfc_trans_omp_taskgroup (code);
5171 case EXEC_OMP_TASKLOOP_SIMD:
5172 return gfc_trans_omp_taskloop (code);
5173 case EXEC_OMP_TASKWAIT:
5174 return gfc_trans_omp_taskwait ();
5175 case EXEC_OMP_TASKYIELD:
5176 return gfc_trans_omp_taskyield ();
5177 case EXEC_OMP_TEAMS:
5178 case EXEC_OMP_TEAMS_DISTRIBUTE:
5179 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5180 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5181 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5182 return gfc_trans_omp_teams (code, NULL, NULL_TREE);
5183 case EXEC_OMP_WORKSHARE:
5184 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
5185 default:
5186 gcc_unreachable ();
5187 }
5188 }
5189
5190 void
5191 gfc_trans_omp_declare_simd (gfc_namespace *ns)
5192 {
5193 if (ns->entries)
5194 return;
5195
5196 gfc_omp_declare_simd *ods;
5197 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
5198 {
5199 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
5200 tree fndecl = ns->proc_name->backend_decl;
5201 if (c != NULL_TREE)
5202 c = tree_cons (NULL_TREE, c, NULL_TREE);
5203 c = build_tree_list (get_identifier ("omp declare simd"), c);
5204 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
5205 DECL_ATTRIBUTES (fndecl) = c;
5206 }
5207 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org