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