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