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