?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix memory leak in tree-vect-slp.c
[official-gcc.git] / gcc / fortran / trans-openmp.c
blobc2d89eb3effb84b8c2794fb4daa350bda0e9e066
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)
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 switch (namelist->u.reduction_op)
1661 {
1662 case OMP_REDUCTION_PLUS:
1663 OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
1664 break;
1665 case OMP_REDUCTION_MINUS:
1666 OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
1667 break;
1668 case OMP_REDUCTION_TIMES:
1669 OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
1670 break;
1671 case OMP_REDUCTION_AND:
1672 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
1673 break;
1674 case OMP_REDUCTION_OR:
1675 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
1676 break;
1677 case OMP_REDUCTION_EQV:
1678 OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
1679 break;
1680 case OMP_REDUCTION_NEQV:
1681 OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
1682 break;
1683 case OMP_REDUCTION_MAX:
1684 OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
1685 break;
1686 case OMP_REDUCTION_MIN:
1687 OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
1688 break;
1689 case OMP_REDUCTION_IAND:
1690 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
1691 break;
1692 case OMP_REDUCTION_IOR:
1693 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
1694 break;
1695 case OMP_REDUCTION_IEOR:
1696 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
1697 break;
1698 case OMP_REDUCTION_USER:
1699 OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
1700 break;
1701 default:
1702 gcc_unreachable ();
1703 }
1704 if (namelist->sym->attr.dimension
1705 || namelist->u.reduction_op == OMP_REDUCTION_USER
1706 || namelist->sym->attr.allocatable)
1707 gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
1708 list = gfc_trans_add_clause (node, list);
1709 }
1710 }
1711 return list;
1712 }
1713
1714 static inline tree
1715 gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
1716 {
1717 gfc_se se;
1718 tree result;
1719
1720 gfc_init_se (&se, NULL );
1721 gfc_conv_expr (&se, expr);
1722 gfc_add_block_to_block (block, &se.pre);
1723 result = gfc_evaluate_now (se.expr, block);
1724 gfc_add_block_to_block (block, &se.post);
1725
1726 return result;
1727 }
1728
1729 static tree
1730 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
1731 locus where, bool declare_simd = false)
1732 {
1733 tree omp_clauses = NULL_TREE, chunk_size, c;
1734 int list;
1735 enum omp_clause_code clause_code;
1736 gfc_se se;
1737
1738 if (clauses == NULL)
1739 return NULL_TREE;
1740
1741 for (list = 0; list < OMP_LIST_NUM; list++)
1742 {
1743 gfc_omp_namelist *n = clauses->lists[list];
1744
1745 if (n == NULL)
1746 continue;
1747 switch (list)
1748 {
1749 case OMP_LIST_REDUCTION:
1750 omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where);
1751 break;
1752 case OMP_LIST_PRIVATE:
1753 clause_code = OMP_CLAUSE_PRIVATE;
1754 goto add_clause;
1755 case OMP_LIST_SHARED:
1756 clause_code = OMP_CLAUSE_SHARED;
1757 goto add_clause;
1758 case OMP_LIST_FIRSTPRIVATE:
1759 clause_code = OMP_CLAUSE_FIRSTPRIVATE;
1760 goto add_clause;
1761 case OMP_LIST_LASTPRIVATE:
1762 clause_code = OMP_CLAUSE_LASTPRIVATE;
1763 goto add_clause;
1764 case OMP_LIST_COPYIN:
1765 clause_code = OMP_CLAUSE_COPYIN;
1766 goto add_clause;
1767 case OMP_LIST_COPYPRIVATE:
1768 clause_code = OMP_CLAUSE_COPYPRIVATE;
1769 goto add_clause;
1770 case OMP_LIST_UNIFORM:
1771 clause_code = OMP_CLAUSE_UNIFORM;
1772 goto add_clause;
1773 case OMP_LIST_USE_DEVICE:
1774 clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
1775 goto add_clause;
1776 case OMP_LIST_DEVICE_RESIDENT:
1777 clause_code = OMP_CLAUSE_DEVICE_RESIDENT;
1778 goto add_clause;
1779
1780 add_clause:
1781 omp_clauses
1782 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
1783 declare_simd);
1784 break;
1785 case OMP_LIST_ALIGNED:
1786 for (; n != NULL; n = n->next)
1787 if (n->sym->attr.referenced || declare_simd)
1788 {
1789 tree t = gfc_trans_omp_variable (n->sym, declare_simd);
1790 if (t != error_mark_node)
1791 {
1792 tree node = build_omp_clause (input_location,
1793 OMP_CLAUSE_ALIGNED);
1794 OMP_CLAUSE_DECL (node) = t;
1795 if (n->expr)
1796 {
1797 tree alignment_var;
1798
1799 if (block == NULL)
1800 alignment_var = gfc_conv_constant_to_tree (n->expr);
1801 else
1802 {
1803 gfc_init_se (&se, NULL);
1804 gfc_conv_expr (&se, n->expr);
1805 gfc_add_block_to_block (block, &se.pre);
1806 alignment_var = gfc_evaluate_now (se.expr, block);
1807 gfc_add_block_to_block (block, &se.post);
1808 }
1809 OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
1810 }
1811 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1812 }
1813 }
1814 break;
1815 case OMP_LIST_LINEAR:
1816 {
1817 gfc_expr *last_step_expr = NULL;
1818 tree last_step = NULL_TREE;
1819
1820 for (; n != NULL; n = n->next)
1821 {
1822 if (n->expr)
1823 {
1824 last_step_expr = n->expr;
1825 last_step = NULL_TREE;
1826 }
1827 if (n->sym->attr.referenced || declare_simd)
1828 {
1829 tree t = gfc_trans_omp_variable (n->sym, declare_simd);
1830 if (t != error_mark_node)
1831 {
1832 tree node = build_omp_clause (input_location,
1833 OMP_CLAUSE_LINEAR);
1834 OMP_CLAUSE_DECL (node) = t;
1835 if (last_step_expr && last_step == NULL_TREE)
1836 {
1837 if (block == NULL)
1838 last_step
1839 = gfc_conv_constant_to_tree (last_step_expr);
1840 else
1841 {
1842 gfc_init_se (&se, NULL);
1843 gfc_conv_expr (&se, last_step_expr);
1844 gfc_add_block_to_block (block, &se.pre);
1845 last_step = gfc_evaluate_now (se.expr, block);
1846 gfc_add_block_to_block (block, &se.post);
1847 }
1848 }
1849 OMP_CLAUSE_LINEAR_STEP (node)
1850 = fold_convert (gfc_typenode_for_spec (&n->sym->ts),
1851 last_step);
1852 if (n->sym->attr.dimension || n->sym->attr.allocatable)
1853 OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
1854 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1855 }
1856 }
1857 }
1858 }
1859 break;
1860 case OMP_LIST_DEPEND:
1861 for (; n != NULL; n = n->next)
1862 {
1863 if (!n->sym->attr.referenced)
1864 continue;
1865
1866 tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND);
1867 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
1868 {
1869 tree decl = gfc_get_symbol_decl (n->sym);
1870 if (gfc_omp_privatize_by_reference (decl))
1871 decl = build_fold_indirect_ref (decl);
1872 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1873 {
1874 decl = gfc_conv_descriptor_data_get (decl);
1875 decl = fold_convert (build_pointer_type (char_type_node),
1876 decl);
1877 decl = build_fold_indirect_ref (decl);
1878 }
1879 else if (DECL_P (decl))
1880 TREE_ADDRESSABLE (decl) = 1;
1881 OMP_CLAUSE_DECL (node) = decl;
1882 }
1883 else
1884 {
1885 tree ptr;
1886 gfc_init_se (&se, NULL);
1887 if (n->expr->ref->u.ar.type == AR_ELEMENT)
1888 {
1889 gfc_conv_expr_reference (&se, n->expr);
1890 ptr = se.expr;
1891 }
1892 else
1893 {
1894 gfc_conv_expr_descriptor (&se, n->expr);
1895 ptr = gfc_conv_array_data (se.expr);
1896 }
1897 gfc_add_block_to_block (block, &se.pre);
1898 gfc_add_block_to_block (block, &se.post);
1899 ptr = fold_convert (build_pointer_type (char_type_node),
1900 ptr);
1901 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
1902 }
1903 switch (n->u.depend_op)
1904 {
1905 case OMP_DEPEND_IN:
1906 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
1907 break;
1908 case OMP_DEPEND_OUT:
1909 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
1910 break;
1911 case OMP_DEPEND_INOUT:
1912 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
1913 break;
1914 default:
1915 gcc_unreachable ();
1916 }
1917 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1918 }
1919 break;
1920 case OMP_LIST_MAP:
1921 for (; n != NULL; n = n->next)
1922 {
1923 if (!n->sym->attr.referenced)
1924 continue;
1925
1926 tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1927 tree node2 = NULL_TREE;
1928 tree node3 = NULL_TREE;
1929 tree node4 = NULL_TREE;
1930 tree decl = gfc_get_symbol_decl (n->sym);
1931 if (DECL_P (decl))
1932 TREE_ADDRESSABLE (decl) = 1;
1933 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
1934 {
1935 if (POINTER_TYPE_P (TREE_TYPE (decl))
1936 && (gfc_omp_privatize_by_reference (decl)
1937 || GFC_DECL_GET_SCALAR_POINTER (decl)
1938 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1939 || GFC_DECL_CRAY_POINTEE (decl)
1940 || GFC_DESCRIPTOR_TYPE_P
1941 (TREE_TYPE (TREE_TYPE (decl)))))
1942 {
1943 tree orig_decl = decl;
1944 node4 = build_omp_clause (input_location,
1945 OMP_CLAUSE_MAP);
1946 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
1947 OMP_CLAUSE_DECL (node4) = decl;
1948 OMP_CLAUSE_SIZE (node4) = size_int (0);
1949 decl = build_fold_indirect_ref (decl);
1950 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1951 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1952 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1953 {
1954 node3 = build_omp_clause (input_location,
1955 OMP_CLAUSE_MAP);
1956 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
1957 OMP_CLAUSE_DECL (node3) = decl;
1958 OMP_CLAUSE_SIZE (node3) = size_int (0);
1959 decl = build_fold_indirect_ref (decl);
1960 }
1961 }
1962 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1963 {
1964 tree type = TREE_TYPE (decl);
1965 tree ptr = gfc_conv_descriptor_data_get (decl);
1966 ptr = fold_convert (build_pointer_type (char_type_node),
1967 ptr);
1968 ptr = build_fold_indirect_ref (ptr);
1969 OMP_CLAUSE_DECL (node) = ptr;
1970 node2 = build_omp_clause (input_location,
1971 OMP_CLAUSE_MAP);
1972 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
1973 OMP_CLAUSE_DECL (node2) = decl;
1974 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
1975 node3 = build_omp_clause (input_location,
1976 OMP_CLAUSE_MAP);
1977 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
1978 OMP_CLAUSE_DECL (node3)
1979 = gfc_conv_descriptor_data_get (decl);
1980 OMP_CLAUSE_SIZE (node3) = size_int (0);
1981
1982 /* We have to check for n->sym->attr.dimension because
1983 of scalar coarrays. */
1984 if (n->sym->attr.pointer && n->sym->attr.dimension)
1985 {
1986 stmtblock_t cond_block;
1987 tree size
1988 = gfc_create_var (gfc_array_index_type, NULL);
1989 tree tem, then_b, else_b, zero, cond;
1990
1991 gfc_init_block (&cond_block);
1992 tem
1993 = gfc_full_array_size (&cond_block, decl,
1994 GFC_TYPE_ARRAY_RANK (type));
1995 gfc_add_modify (&cond_block, size, tem);
1996 then_b = gfc_finish_block (&cond_block);
1997 gfc_init_block (&cond_block);
1998 zero = build_int_cst (gfc_array_index_type, 0);
1999 gfc_add_modify (&cond_block, size, zero);
2000 else_b = gfc_finish_block (&cond_block);
2001 tem = gfc_conv_descriptor_data_get (decl);
2002 tem = fold_convert (pvoid_type_node, tem);
2003 cond = fold_build2_loc (input_location, NE_EXPR,
2004 boolean_type_node,
2005 tem, null_pointer_node);
2006 gfc_add_expr_to_block (block,
2007 build3_loc (input_location,
2008 COND_EXPR,
2009 void_type_node,
2010 cond, then_b,
2011 else_b));
2012 OMP_CLAUSE_SIZE (node) = size;
2013 }
2014 else if (n->sym->attr.dimension)
2015 OMP_CLAUSE_SIZE (node)
2016 = gfc_full_array_size (block, decl,
2017 GFC_TYPE_ARRAY_RANK (type));
2018 if (n->sym->attr.dimension)
2019 {
2020 tree elemsz
2021 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2022 elemsz = fold_convert (gfc_array_index_type, elemsz);
2023 OMP_CLAUSE_SIZE (node)
2024 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2025 OMP_CLAUSE_SIZE (node), elemsz);
2026 }
2027 }
2028 else
2029 OMP_CLAUSE_DECL (node) = decl;
2030 }
2031 else
2032 {
2033 tree ptr, ptr2;
2034 gfc_init_se (&se, NULL);
2035 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2036 {
2037 gfc_conv_expr_reference (&se, n->expr);
2038 gfc_add_block_to_block (block, &se.pre);
2039 ptr = se.expr;
2040 OMP_CLAUSE_SIZE (node)
2041 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2042 }
2043 else
2044 {
2045 gfc_conv_expr_descriptor (&se, n->expr);
2046 ptr = gfc_conv_array_data (se.expr);
2047 tree type = TREE_TYPE (se.expr);
2048 gfc_add_block_to_block (block, &se.pre);
2049 OMP_CLAUSE_SIZE (node)
2050 = gfc_full_array_size (block, se.expr,
2051 GFC_TYPE_ARRAY_RANK (type));
2052 tree elemsz
2053 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2054 elemsz = fold_convert (gfc_array_index_type, elemsz);
2055 OMP_CLAUSE_SIZE (node)
2056 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2057 OMP_CLAUSE_SIZE (node), elemsz);
2058 }
2059 gfc_add_block_to_block (block, &se.post);
2060 ptr = fold_convert (build_pointer_type (char_type_node),
2061 ptr);
2062 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2063
2064 if (POINTER_TYPE_P (TREE_TYPE (decl))
2065 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
2066 {
2067 node4 = build_omp_clause (input_location,
2068 OMP_CLAUSE_MAP);
2069 OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
2070 OMP_CLAUSE_DECL (node4) = decl;
2071 OMP_CLAUSE_SIZE (node4) = size_int (0);
2072 decl = build_fold_indirect_ref (decl);
2073 }
2074 ptr = fold_convert (sizetype, ptr);
2075 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2076 {
2077 tree type = TREE_TYPE (decl);
2078 ptr2 = gfc_conv_descriptor_data_get (decl);
2079 node2 = build_omp_clause (input_location,
2080 OMP_CLAUSE_MAP);
2081 OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
2082 OMP_CLAUSE_DECL (node2) = decl;
2083 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
2084 node3 = build_omp_clause (input_location,
2085 OMP_CLAUSE_MAP);
2086 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
2087 OMP_CLAUSE_DECL (node3)
2088 = gfc_conv_descriptor_data_get (decl);
2089 }
2090 else
2091 {
2092 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
2093 ptr2 = build_fold_addr_expr (decl);
2094 else
2095 {
2096 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2097 ptr2 = decl;
2098 }
2099 node3 = build_omp_clause (input_location,
2100 OMP_CLAUSE_MAP);
2101 OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
2102 OMP_CLAUSE_DECL (node3) = decl;
2103 }
2104 ptr2 = fold_convert (sizetype, ptr2);
2105 OMP_CLAUSE_SIZE (node3)
2106 = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
2107 }
2108 switch (n->u.map_op)
2109 {
2110 case OMP_MAP_ALLOC:
2111 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
2112 break;
2113 case OMP_MAP_TO:
2114 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
2115 break;
2116 case OMP_MAP_FROM:
2117 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
2118 break;
2119 case OMP_MAP_TOFROM:
2120 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
2121 break;
2122 case OMP_MAP_DELETE:
2123 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
2124 break;
2125 case OMP_MAP_FORCE_ALLOC:
2126 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
2127 break;
2128 case OMP_MAP_FORCE_TO:
2129 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
2130 break;
2131 case OMP_MAP_FORCE_FROM:
2132 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
2133 break;
2134 case OMP_MAP_FORCE_TOFROM:
2135 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
2136 break;
2137 case OMP_MAP_FORCE_PRESENT:
2138 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
2139 break;
2140 case OMP_MAP_FORCE_DEVICEPTR:
2141 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
2142 break;
2143 default:
2144 gcc_unreachable ();
2145 }
2146 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2147 if (node2)
2148 omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
2149 if (node3)
2150 omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
2151 if (node4)
2152 omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
2153 }
2154 break;
2155 case OMP_LIST_TO:
2156 case OMP_LIST_FROM:
2157 case OMP_LIST_CACHE:
2158 for (; n != NULL; n = n->next)
2159 {
2160 if (!n->sym->attr.referenced)
2161 continue;
2162
2163 switch (list)
2164 {
2165 case OMP_LIST_TO:
2166 clause_code = OMP_CLAUSE_TO;
2167 break;
2168 case OMP_LIST_FROM:
2169 clause_code = OMP_CLAUSE_FROM;
2170 break;
2171 case OMP_LIST_CACHE:
2172 clause_code = OMP_CLAUSE__CACHE_;
2173 break;
2174 default:
2175 gcc_unreachable ();
2176 }
2177 tree node = build_omp_clause (input_location, clause_code);
2178 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2179 {
2180 tree decl = gfc_get_symbol_decl (n->sym);
2181 if (gfc_omp_privatize_by_reference (decl))
2182 decl = build_fold_indirect_ref (decl);
2183 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2184 {
2185 tree type = TREE_TYPE (decl);
2186 tree ptr = gfc_conv_descriptor_data_get (decl);
2187 ptr = fold_convert (build_pointer_type (char_type_node),
2188 ptr);
2189 ptr = build_fold_indirect_ref (ptr);
2190 OMP_CLAUSE_DECL (node) = ptr;
2191 OMP_CLAUSE_SIZE (node)
2192 = gfc_full_array_size (block, decl,
2193 GFC_TYPE_ARRAY_RANK (type));
2194 tree elemsz
2195 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2196 elemsz = fold_convert (gfc_array_index_type, elemsz);
2197 OMP_CLAUSE_SIZE (node)
2198 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2199 OMP_CLAUSE_SIZE (node), elemsz);
2200 }
2201 else
2202 OMP_CLAUSE_DECL (node) = decl;
2203 }
2204 else
2205 {
2206 tree ptr;
2207 gfc_init_se (&se, NULL);
2208 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2209 {
2210 gfc_conv_expr_reference (&se, n->expr);
2211 ptr = se.expr;
2212 gfc_add_block_to_block (block, &se.pre);
2213 OMP_CLAUSE_SIZE (node)
2214 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2215 }
2216 else
2217 {
2218 gfc_conv_expr_descriptor (&se, n->expr);
2219 ptr = gfc_conv_array_data (se.expr);
2220 tree type = TREE_TYPE (se.expr);
2221 gfc_add_block_to_block (block, &se.pre);
2222 OMP_CLAUSE_SIZE (node)
2223 = gfc_full_array_size (block, se.expr,
2224 GFC_TYPE_ARRAY_RANK (type));
2225 tree elemsz
2226 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2227 elemsz = fold_convert (gfc_array_index_type, elemsz);
2228 OMP_CLAUSE_SIZE (node)
2229 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2230 OMP_CLAUSE_SIZE (node), elemsz);
2231 }
2232 gfc_add_block_to_block (block, &se.post);
2233 ptr = fold_convert (build_pointer_type (char_type_node),
2234 ptr);
2235 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2236 }
2237 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2238 }
2239 break;
2240 default:
2241 break;
2242 }
2243 }
2244
2245 if (clauses->if_expr)
2246 {
2247 tree if_var;
2248
2249 gfc_init_se (&se, NULL);
2250 gfc_conv_expr (&se, clauses->if_expr);
2251 gfc_add_block_to_block (block, &se.pre);
2252 if_var = gfc_evaluate_now (se.expr, block);
2253 gfc_add_block_to_block (block, &se.post);
2254
2255 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
2256 OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
2257 OMP_CLAUSE_IF_EXPR (c) = if_var;
2258 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2259 }
2260
2261 if (clauses->final_expr)
2262 {
2263 tree final_var;
2264
2265 gfc_init_se (&se, NULL);
2266 gfc_conv_expr (&se, clauses->final_expr);
2267 gfc_add_block_to_block (block, &se.pre);
2268 final_var = gfc_evaluate_now (se.expr, block);
2269 gfc_add_block_to_block (block, &se.post);
2270
2271 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL);
2272 OMP_CLAUSE_FINAL_EXPR (c) = final_var;
2273 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2274 }
2275
2276 if (clauses->num_threads)
2277 {
2278 tree num_threads;
2279
2280 gfc_init_se (&se, NULL);
2281 gfc_conv_expr (&se, clauses->num_threads);
2282 gfc_add_block_to_block (block, &se.pre);
2283 num_threads = gfc_evaluate_now (se.expr, block);
2284 gfc_add_block_to_block (block, &se.post);
2285
2286 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
2287 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
2288 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2289 }
2290
2291 chunk_size = NULL_TREE;
2292 if (clauses->chunk_size)
2293 {
2294 gfc_init_se (&se, NULL);
2295 gfc_conv_expr (&se, clauses->chunk_size);
2296 gfc_add_block_to_block (block, &se.pre);
2297 chunk_size = gfc_evaluate_now (se.expr, block);
2298 gfc_add_block_to_block (block, &se.post);
2299 }
2300
2301 if (clauses->sched_kind != OMP_SCHED_NONE)
2302 {
2303 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
2304 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2305 switch (clauses->sched_kind)
2306 {
2307 case OMP_SCHED_STATIC:
2308 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
2309 break;
2310 case OMP_SCHED_DYNAMIC:
2311 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
2312 break;
2313 case OMP_SCHED_GUIDED:
2314 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
2315 break;
2316 case OMP_SCHED_RUNTIME:
2317 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
2318 break;
2319 case OMP_SCHED_AUTO:
2320 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
2321 break;
2322 default:
2323 gcc_unreachable ();
2324 }
2325 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2326 }
2327
2328 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
2329 {
2330 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
2331 switch (clauses->default_sharing)
2332 {
2333 case OMP_DEFAULT_NONE:
2334 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
2335 break;
2336 case OMP_DEFAULT_SHARED:
2337 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
2338 break;
2339 case OMP_DEFAULT_PRIVATE:
2340 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
2341 break;
2342 case OMP_DEFAULT_FIRSTPRIVATE:
2343 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
2344 break;
2345 default:
2346 gcc_unreachable ();
2347 }
2348 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2349 }
2350
2351 if (clauses->nowait)
2352 {
2353 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
2354 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2355 }
2356
2357 if (clauses->ordered)
2358 {
2359 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
2360 OMP_CLAUSE_ORDERED_EXPR (c) = NULL_TREE;
2361 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2362 }
2363
2364 if (clauses->untied)
2365 {
2366 c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
2367 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2368 }
2369
2370 if (clauses->mergeable)
2371 {
2372 c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE);
2373 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2374 }
2375
2376 if (clauses->collapse)
2377 {
2378 c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
2379 OMP_CLAUSE_COLLAPSE_EXPR (c)
2380 = build_int_cst (integer_type_node, clauses->collapse);
2381 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2382 }
2383
2384 if (clauses->inbranch)
2385 {
2386 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH);
2387 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2388 }
2389
2390 if (clauses->notinbranch)
2391 {
2392 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH);
2393 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2394 }
2395
2396 switch (clauses->cancel)
2397 {
2398 case OMP_CANCEL_UNKNOWN:
2399 break;
2400 case OMP_CANCEL_PARALLEL:
2401 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL);
2402 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2403 break;
2404 case OMP_CANCEL_SECTIONS:
2405 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS);
2406 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2407 break;
2408 case OMP_CANCEL_DO:
2409 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR);
2410 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2411 break;
2412 case OMP_CANCEL_TASKGROUP:
2413 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP);
2414 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2415 break;
2416 }
2417
2418 if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
2419 {
2420 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND);
2421 switch (clauses->proc_bind)
2422 {
2423 case OMP_PROC_BIND_MASTER:
2424 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
2425 break;
2426 case OMP_PROC_BIND_SPREAD:
2427 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
2428 break;
2429 case OMP_PROC_BIND_CLOSE:
2430 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
2431 break;
2432 default:
2433 gcc_unreachable ();
2434 }
2435 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2436 }
2437
2438 if (clauses->safelen_expr)
2439 {
2440 tree safelen_var;
2441
2442 gfc_init_se (&se, NULL);
2443 gfc_conv_expr (&se, clauses->safelen_expr);
2444 gfc_add_block_to_block (block, &se.pre);
2445 safelen_var = gfc_evaluate_now (se.expr, block);
2446 gfc_add_block_to_block (block, &se.post);
2447
2448 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN);
2449 OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
2450 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2451 }
2452
2453 if (clauses->simdlen_expr)
2454 {
2455 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN);
2456 OMP_CLAUSE_SIMDLEN_EXPR (c)
2457 = gfc_conv_constant_to_tree (clauses->simdlen_expr);
2458 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2459 }
2460
2461 if (clauses->num_teams)
2462 {
2463 tree num_teams;
2464
2465 gfc_init_se (&se, NULL);
2466 gfc_conv_expr (&se, clauses->num_teams);
2467 gfc_add_block_to_block (block, &se.pre);
2468 num_teams = gfc_evaluate_now (se.expr, block);
2469 gfc_add_block_to_block (block, &se.post);
2470
2471 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS);
2472 OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams;
2473 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2474 }
2475
2476 if (clauses->device)
2477 {
2478 tree device;
2479
2480 gfc_init_se (&se, NULL);
2481 gfc_conv_expr (&se, clauses->device);
2482 gfc_add_block_to_block (block, &se.pre);
2483 device = gfc_evaluate_now (se.expr, block);
2484 gfc_add_block_to_block (block, &se.post);
2485
2486 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE);
2487 OMP_CLAUSE_DEVICE_ID (c) = device;
2488 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2489 }
2490
2491 if (clauses->thread_limit)
2492 {
2493 tree thread_limit;
2494
2495 gfc_init_se (&se, NULL);
2496 gfc_conv_expr (&se, clauses->thread_limit);
2497 gfc_add_block_to_block (block, &se.pre);
2498 thread_limit = gfc_evaluate_now (se.expr, block);
2499 gfc_add_block_to_block (block, &se.post);
2500
2501 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT);
2502 OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
2503 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2504 }
2505
2506 chunk_size = NULL_TREE;
2507 if (clauses->dist_chunk_size)
2508 {
2509 gfc_init_se (&se, NULL);
2510 gfc_conv_expr (&se, clauses->dist_chunk_size);
2511 gfc_add_block_to_block (block, &se.pre);
2512 chunk_size = gfc_evaluate_now (se.expr, block);
2513 gfc_add_block_to_block (block, &se.post);
2514 }
2515
2516 if (clauses->dist_sched_kind != OMP_SCHED_NONE)
2517 {
2518 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE);
2519 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2520 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2521 }
2522
2523 if (clauses->async)
2524 {
2525 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC);
2526 if (clauses->async_expr)
2527 OMP_CLAUSE_ASYNC_EXPR (c)
2528 = gfc_convert_expr_to_tree (block, clauses->async_expr);
2529 else
2530 OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
2531 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2532 }
2533 if (clauses->seq)
2534 {
2535 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ);
2536 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2537 }
2538 if (clauses->par_auto)
2539 {
2540 c = build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO);
2541 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2542 }
2543 if (clauses->independent)
2544 {
2545 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT);
2546 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2547 }
2548 if (clauses->wait_list)
2549 {
2550 gfc_expr_list *el;
2551
2552 for (el = clauses->wait_list; el; el = el->next)
2553 {
2554 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT);
2555 OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
2556 OMP_CLAUSE_CHAIN (c) = omp_clauses;
2557 omp_clauses = c;
2558 }
2559 }
2560 if (clauses->num_gangs_expr)
2561 {
2562 tree num_gangs_var
2563 = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
2564 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS);
2565 OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
2566 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2567 }
2568 if (clauses->num_workers_expr)
2569 {
2570 tree num_workers_var
2571 = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
2572 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS);
2573 OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
2574 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2575 }
2576 if (clauses->vector_length_expr)
2577 {
2578 tree vector_length_var
2579 = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
2580 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH);
2581 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
2582 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2583 }
2584 if (clauses->tile_list)
2585 {
2586 vec<tree, va_gc> *tvec;
2587 gfc_expr_list *el;
2588
2589 vec_alloc (tvec, 4);
2590
2591 for (el = clauses->tile_list; el; el = el->next)
2592 vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr));
2593
2594 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TILE);
2595 OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec);
2596 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2597 tvec->truncate (0);
2598 }
2599 if (clauses->vector)
2600 {
2601 if (clauses->vector_expr)
2602 {
2603 tree vector_var
2604 = gfc_convert_expr_to_tree (block, clauses->vector_expr);
2605 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2606 OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
2607 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2608 }
2609 else
2610 {
2611 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2612 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2613 }
2614 }
2615 if (clauses->worker)
2616 {
2617 if (clauses->worker_expr)
2618 {
2619 tree worker_var
2620 = gfc_convert_expr_to_tree (block, clauses->worker_expr);
2621 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2622 OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
2623 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2624 }
2625 else
2626 {
2627 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2628 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2629 }
2630 }
2631 if (clauses->gang)
2632 {
2633 tree arg;
2634 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
2635 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2636 if (clauses->gang_num_expr)
2637 {
2638 arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
2639 OMP_CLAUSE_GANG_EXPR (c) = arg;
2640 }
2641 if (clauses->gang_static)
2642 {
2643 arg = clauses->gang_static_expr
2644 ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
2645 : integer_minus_one_node;
2646 OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
2647 }
2648 }
2649
2650 return nreverse (omp_clauses);
2651 }
2652
2653 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
2654
2655 static tree
2656 gfc_trans_omp_code (gfc_code *code, bool force_empty)
2657 {
2658 tree stmt;
2659
2660 pushlevel ();
2661 stmt = gfc_trans_code (code);
2662 if (TREE_CODE (stmt) != BIND_EXPR)
2663 {
2664 if (!IS_EMPTY_STMT (stmt) || force_empty)
2665 {
2666 tree block = poplevel (1, 0);
2667 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
2668 }
2669 else
2670 poplevel (0, 0);
2671 }
2672 else
2673 poplevel (0, 0);
2674 return stmt;
2675 }
2676
2677 /* Trans OpenACC directives. */
2678 /* parallel, kernels, data and host_data. */
2679 static tree
2680 gfc_trans_oacc_construct (gfc_code *code)
2681 {
2682 stmtblock_t block;
2683 tree stmt, oacc_clauses;
2684 enum tree_code construct_code;
2685
2686 switch (code->op)
2687 {
2688 case EXEC_OACC_PARALLEL:
2689 construct_code = OACC_PARALLEL;
2690 break;
2691 case EXEC_OACC_KERNELS:
2692 construct_code = OACC_KERNELS;
2693 break;
2694 case EXEC_OACC_DATA:
2695 construct_code = OACC_DATA;
2696 break;
2697 case EXEC_OACC_HOST_DATA:
2698 construct_code = OACC_HOST_DATA;
2699 break;
2700 default:
2701 gcc_unreachable ();
2702 }
2703
2704 gfc_start_block (&block);
2705 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
2706 code->loc);
2707 stmt = gfc_trans_omp_code (code->block->next, true);
2708 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
2709 oacc_clauses);
2710 gfc_add_expr_to_block (&block, stmt);
2711 return gfc_finish_block (&block);
2712 }
2713
2714 /* update, enter_data, exit_data, cache. */
2715 static tree
2716 gfc_trans_oacc_executable_directive (gfc_code *code)
2717 {
2718 stmtblock_t block;
2719 tree stmt, oacc_clauses;
2720 enum tree_code construct_code;
2721
2722 switch (code->op)
2723 {
2724 case EXEC_OACC_UPDATE:
2725 construct_code = OACC_UPDATE;
2726 break;
2727 case EXEC_OACC_ENTER_DATA:
2728 construct_code = OACC_ENTER_DATA;
2729 break;
2730 case EXEC_OACC_EXIT_DATA:
2731 construct_code = OACC_EXIT_DATA;
2732 break;
2733 case EXEC_OACC_CACHE:
2734 construct_code = OACC_CACHE;
2735 break;
2736 default:
2737 gcc_unreachable ();
2738 }
2739
2740 gfc_start_block (&block);
2741 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
2742 code->loc);
2743 stmt = build1_loc (input_location, construct_code, void_type_node,
2744 oacc_clauses);
2745 gfc_add_expr_to_block (&block, stmt);
2746 return gfc_finish_block (&block);
2747 }
2748
2749 static tree
2750 gfc_trans_oacc_wait_directive (gfc_code *code)
2751 {
2752 stmtblock_t block;
2753 tree stmt, t;
2754 vec<tree, va_gc> *args;
2755 int nparms = 0;
2756 gfc_expr_list *el;
2757 gfc_omp_clauses *clauses = code->ext.omp_clauses;
2758 location_t loc = input_location;
2759
2760 for (el = clauses->wait_list; el; el = el->next)
2761 nparms++;
2762
2763 vec_alloc (args, nparms + 2);
2764 stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
2765
2766 gfc_start_block (&block);
2767
2768 if (clauses->async_expr)
2769 t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
2770 else
2771 t = build_int_cst (integer_type_node, -2);
2772
2773 args->quick_push (t);
2774 args->quick_push (build_int_cst (integer_type_node, nparms));
2775
2776 for (el = clauses->wait_list; el; el = el->next)
2777 args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
2778
2779 stmt = build_call_expr_loc_vec (loc, stmt, args);
2780 gfc_add_expr_to_block (&block, stmt);
2781
2782 vec_free (args);
2783
2784 return gfc_finish_block (&block);
2785 }
2786
2787 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
2788 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
2789
2790 static tree
2791 gfc_trans_omp_atomic (gfc_code *code)
2792 {
2793 gfc_code *atomic_code = code;
2794 gfc_se lse;
2795 gfc_se rse;
2796 gfc_se vse;
2797 gfc_expr *expr2, *e;
2798 gfc_symbol *var;
2799 stmtblock_t block;
2800 tree lhsaddr, type, rhs, x;
2801 enum tree_code op = ERROR_MARK;
2802 enum tree_code aop = OMP_ATOMIC;
2803 bool var_on_left = false;
2804 bool seq_cst = (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) != 0;
2805
2806 code = code->block->next;
2807 gcc_assert (code->op == EXEC_ASSIGN);
2808 var = code->expr1->symtree->n.sym;
2809
2810 gfc_init_se (&lse, NULL);
2811 gfc_init_se (&rse, NULL);
2812 gfc_init_se (&vse, NULL);
2813 gfc_start_block (&block);
2814
2815 expr2 = code->expr2;
2816 if (expr2->expr_type == EXPR_FUNCTION
2817 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
2818 expr2 = expr2->value.function.actual->expr;
2819
2820 switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2821 {
2822 case GFC_OMP_ATOMIC_READ:
2823 gfc_conv_expr (&vse, code->expr1);
2824 gfc_add_block_to_block (&block, &vse.pre);
2825
2826 gfc_conv_expr (&lse, expr2);
2827 gfc_add_block_to_block (&block, &lse.pre);
2828 type = TREE_TYPE (lse.expr);
2829 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
2830
2831 x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
2832 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
2833 x = convert (TREE_TYPE (vse.expr), x);
2834 gfc_add_modify (&block, vse.expr, x);
2835
2836 gfc_add_block_to_block (&block, &lse.pre);
2837 gfc_add_block_to_block (&block, &rse.pre);
2838
2839 return gfc_finish_block (&block);
2840 case GFC_OMP_ATOMIC_CAPTURE:
2841 aop = OMP_ATOMIC_CAPTURE_NEW;
2842 if (expr2->expr_type == EXPR_VARIABLE)
2843 {
2844 aop = OMP_ATOMIC_CAPTURE_OLD;
2845 gfc_conv_expr (&vse, code->expr1);
2846 gfc_add_block_to_block (&block, &vse.pre);
2847
2848 gfc_conv_expr (&lse, expr2);
2849 gfc_add_block_to_block (&block, &lse.pre);
2850 gfc_init_se (&lse, NULL);
2851 code = code->next;
2852 var = code->expr1->symtree->n.sym;
2853 expr2 = code->expr2;
2854 if (expr2->expr_type == EXPR_FUNCTION
2855 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
2856 expr2 = expr2->value.function.actual->expr;
2857 }
2858 break;
2859 default:
2860 break;
2861 }
2862
2863 gfc_conv_expr (&lse, code->expr1);
2864 gfc_add_block_to_block (&block, &lse.pre);
2865 type = TREE_TYPE (lse.expr);
2866 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
2867
2868 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2869 == GFC_OMP_ATOMIC_WRITE)
2870 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
2871 {
2872 gfc_conv_expr (&rse, expr2);
2873 gfc_add_block_to_block (&block, &rse.pre);
2874 }
2875 else if (expr2->expr_type == EXPR_OP)
2876 {
2877 gfc_expr *e;
2878 switch (expr2->value.op.op)
2879 {
2880 case INTRINSIC_PLUS:
2881 op = PLUS_EXPR;
2882 break;
2883 case INTRINSIC_TIMES:
2884 op = MULT_EXPR;
2885 break;
2886 case INTRINSIC_MINUS:
2887 op = MINUS_EXPR;
2888 break;
2889 case INTRINSIC_DIVIDE:
2890 if (expr2->ts.type == BT_INTEGER)
2891 op = TRUNC_DIV_EXPR;
2892 else
2893 op = RDIV_EXPR;
2894 break;
2895 case INTRINSIC_AND:
2896 op = TRUTH_ANDIF_EXPR;
2897 break;
2898 case INTRINSIC_OR:
2899 op = TRUTH_ORIF_EXPR;
2900 break;
2901 case INTRINSIC_EQV:
2902 op = EQ_EXPR;
2903 break;
2904 case INTRINSIC_NEQV:
2905 op = NE_EXPR;
2906 break;
2907 default:
2908 gcc_unreachable ();
2909 }
2910 e = expr2->value.op.op1;
2911 if (e->expr_type == EXPR_FUNCTION
2912 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
2913 e = e->value.function.actual->expr;
2914 if (e->expr_type == EXPR_VARIABLE
2915 && e->symtree != NULL
2916 && e->symtree->n.sym == var)
2917 {
2918 expr2 = expr2->value.op.op2;
2919 var_on_left = true;
2920 }
2921 else
2922 {
2923 e = expr2->value.op.op2;
2924 if (e->expr_type == EXPR_FUNCTION
2925 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
2926 e = e->value.function.actual->expr;
2927 gcc_assert (e->expr_type == EXPR_VARIABLE
2928 && e->symtree != NULL
2929 && e->symtree->n.sym == var);
2930 expr2 = expr2->value.op.op1;
2931 var_on_left = false;
2932 }
2933 gfc_conv_expr (&rse, expr2);
2934 gfc_add_block_to_block (&block, &rse.pre);
2935 }
2936 else
2937 {
2938 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
2939 switch (expr2->value.function.isym->id)
2940 {
2941 case GFC_ISYM_MIN:
2942 op = MIN_EXPR;
2943 break;
2944 case GFC_ISYM_MAX:
2945 op = MAX_EXPR;
2946 break;
2947 case GFC_ISYM_IAND:
2948 op = BIT_AND_EXPR;
2949 break;
2950 case GFC_ISYM_IOR:
2951 op = BIT_IOR_EXPR;
2952 break;
2953 case GFC_ISYM_IEOR:
2954 op = BIT_XOR_EXPR;
2955 break;
2956 default:
2957 gcc_unreachable ();
2958 }
2959 e = expr2->value.function.actual->expr;
2960 gcc_assert (e->expr_type == EXPR_VARIABLE
2961 && e->symtree != NULL
2962 && e->symtree->n.sym == var);
2963
2964 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
2965 gfc_add_block_to_block (&block, &rse.pre);
2966 if (expr2->value.function.actual->next->next != NULL)
2967 {
2968 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
2969 gfc_actual_arglist *arg;
2970
2971 gfc_add_modify (&block, accum, rse.expr);
2972 for (arg = expr2->value.function.actual->next->next; arg;
2973 arg = arg->next)
2974 {
2975 gfc_init_block (&rse.pre);
2976 gfc_conv_expr (&rse, arg->expr);
2977 gfc_add_block_to_block (&block, &rse.pre);
2978 x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
2979 accum, rse.expr);
2980 gfc_add_modify (&block, accum, x);
2981 }
2982
2983 rse.expr = accum;
2984 }
2985
2986 expr2 = expr2->value.function.actual->next->expr;
2987 }
2988
2989 lhsaddr = save_expr (lhsaddr);
2990 if (TREE_CODE (lhsaddr) != SAVE_EXPR
2991 && (TREE_CODE (lhsaddr) != ADDR_EXPR
2992 || TREE_CODE (TREE_OPERAND (lhsaddr, 0)) != VAR_DECL))
2993 {
2994 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
2995 it even after unsharing function body. */
2996 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
2997 DECL_CONTEXT (var) = current_function_decl;
2998 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
2999 NULL_TREE, NULL_TREE);
3000 }
3001
3002 rhs = gfc_evaluate_now (rse.expr, &block);
3003
3004 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3005 == GFC_OMP_ATOMIC_WRITE)
3006 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
3007 x = rhs;
3008 else
3009 {
3010 x = convert (TREE_TYPE (rhs),
3011 build_fold_indirect_ref_loc (input_location, lhsaddr));
3012 if (var_on_left)
3013 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
3014 else
3015 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
3016 }
3017
3018 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
3019 && TREE_CODE (type) != COMPLEX_TYPE)
3020 x = fold_build1_loc (input_location, REALPART_EXPR,
3021 TREE_TYPE (TREE_TYPE (rhs)), x);
3022
3023 gfc_add_block_to_block (&block, &lse.pre);
3024 gfc_add_block_to_block (&block, &rse.pre);
3025
3026 if (aop == OMP_ATOMIC)
3027 {
3028 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
3029 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
3030 gfc_add_expr_to_block (&block, x);
3031 }
3032 else
3033 {
3034 if (aop == OMP_ATOMIC_CAPTURE_NEW)
3035 {
3036 code = code->next;
3037 expr2 = code->expr2;
3038 if (expr2->expr_type == EXPR_FUNCTION
3039 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
3040 expr2 = expr2->value.function.actual->expr;
3041
3042 gcc_assert (expr2->expr_type == EXPR_VARIABLE);
3043 gfc_conv_expr (&vse, code->expr1);
3044 gfc_add_block_to_block (&block, &vse.pre);
3045
3046 gfc_init_se (&lse, NULL);
3047 gfc_conv_expr (&lse, expr2);
3048 gfc_add_block_to_block (&block, &lse.pre);
3049 }
3050 x = build2 (aop, type, lhsaddr, convert (type, x));
3051 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
3052 x = convert (TREE_TYPE (vse.expr), x);
3053 gfc_add_modify (&block, vse.expr, x);
3054 }
3055
3056 return gfc_finish_block (&block);
3057 }
3058
3059 static tree
3060 gfc_trans_omp_barrier (void)
3061 {
3062 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
3063 return build_call_expr_loc (input_location, decl, 0);
3064 }
3065
3066 static tree
3067 gfc_trans_omp_cancel (gfc_code *code)
3068 {
3069 int mask = 0;
3070 tree ifc = boolean_true_node;
3071 stmtblock_t block;
3072 switch (code->ext.omp_clauses->cancel)
3073 {
3074 case OMP_CANCEL_PARALLEL: mask = 1; break;
3075 case OMP_CANCEL_DO: mask = 2; break;
3076 case OMP_CANCEL_SECTIONS: mask = 4; break;
3077 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3078 default: gcc_unreachable ();
3079 }
3080 gfc_start_block (&block);
3081 if (code->ext.omp_clauses->if_expr)
3082 {
3083 gfc_se se;
3084 tree if_var;
3085
3086 gfc_init_se (&se, NULL);
3087 gfc_conv_expr (&se, code->ext.omp_clauses->if_expr);
3088 gfc_add_block_to_block (&block, &se.pre);
3089 if_var = gfc_evaluate_now (se.expr, &block);
3090 gfc_add_block_to_block (&block, &se.post);
3091 tree type = TREE_TYPE (if_var);
3092 ifc = fold_build2_loc (input_location, NE_EXPR,
3093 boolean_type_node, if_var,
3094 build_zero_cst (type));
3095 }
3096 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
3097 tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
3098 ifc = fold_convert (c_bool_type, ifc);
3099 gfc_add_expr_to_block (&block,
3100 build_call_expr_loc (input_location, decl, 2,
3101 build_int_cst (integer_type_node,
3102 mask), ifc));
3103 return gfc_finish_block (&block);
3104 }
3105
3106 static tree
3107 gfc_trans_omp_cancellation_point (gfc_code *code)
3108 {
3109 int mask = 0;
3110 switch (code->ext.omp_clauses->cancel)
3111 {
3112 case OMP_CANCEL_PARALLEL: mask = 1; break;
3113 case OMP_CANCEL_DO: mask = 2; break;
3114 case OMP_CANCEL_SECTIONS: mask = 4; break;
3115 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3116 default: gcc_unreachable ();
3117 }
3118 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
3119 return build_call_expr_loc (input_location, decl, 1,
3120 build_int_cst (integer_type_node, mask));
3121 }
3122
3123 static tree
3124 gfc_trans_omp_critical (gfc_code *code)
3125 {
3126 tree name = NULL_TREE, stmt;
3127 if (code->ext.omp_name != NULL)
3128 name = get_identifier (code->ext.omp_name);
3129 stmt = gfc_trans_code (code->block->next);
3130 return build3_loc (input_location, OMP_CRITICAL, void_type_node, stmt,
3131 NULL_TREE, name);
3132 }
3133
3134 typedef struct dovar_init_d {
3135 tree var;
3136 tree init;
3137 } dovar_init;
3138
3139
3140 static tree
3141 gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
3142 gfc_omp_clauses *do_clauses, tree par_clauses)
3143 {
3144 gfc_se se;
3145 tree dovar, stmt, from, to, step, type, init, cond, incr;
3146 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
3147 stmtblock_t block;
3148 stmtblock_t body;
3149 gfc_omp_clauses *clauses = code->ext.omp_clauses;
3150 int i, collapse = clauses->collapse;
3151 vec<dovar_init> inits = vNULL;
3152 dovar_init *di;
3153 unsigned ix;
3154
3155 if (collapse <= 0)
3156 collapse = 1;
3157
3158 code = code->block->next;
3159 gcc_assert (code->op == EXEC_DO);
3160
3161 init = make_tree_vec (collapse);
3162 cond = make_tree_vec (collapse);
3163 incr = make_tree_vec (collapse);
3164
3165 if (pblock == NULL)
3166 {
3167 gfc_start_block (&block);
3168 pblock = &block;
3169 }
3170
3171 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
3172
3173 for (i = 0; i < collapse; i++)
3174 {
3175 int simple = 0;
3176 int dovar_found = 0;
3177 tree dovar_decl;
3178
3179 if (clauses)
3180 {
3181 gfc_omp_namelist *n = NULL;
3182 if (op != EXEC_OMP_DISTRIBUTE)
3183 for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1)
3184 ? OMP_LIST_LINEAR : OMP_LIST_LASTPRIVATE];
3185 n != NULL; n = n->next)
3186 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3187 break;
3188 if (n != NULL)
3189 dovar_found = 1;
3190 else if (n == NULL && op != EXEC_OMP_SIMD)
3191 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
3192 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3193 break;
3194 if (n != NULL)
3195 dovar_found++;
3196 }
3197
3198 /* Evaluate all the expressions in the iterator. */
3199 gfc_init_se (&se, NULL);
3200 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
3201 gfc_add_block_to_block (pblock, &se.pre);
3202 dovar = se.expr;
3203 type = TREE_TYPE (dovar);
3204 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
3205
3206 gfc_init_se (&se, NULL);
3207 gfc_conv_expr_val (&se, code->ext.iterator->start);
3208 gfc_add_block_to_block (pblock, &se.pre);
3209 from = gfc_evaluate_now (se.expr, pblock);
3210
3211 gfc_init_se (&se, NULL);
3212 gfc_conv_expr_val (&se, code->ext.iterator->end);
3213 gfc_add_block_to_block (pblock, &se.pre);
3214 to = gfc_evaluate_now (se.expr, pblock);
3215
3216 gfc_init_se (&se, NULL);
3217 gfc_conv_expr_val (&se, code->ext.iterator->step);
3218 gfc_add_block_to_block (pblock, &se.pre);
3219 step = gfc_evaluate_now (se.expr, pblock);
3220 dovar_decl = dovar;
3221
3222 /* Special case simple loops. */
3223 if (TREE_CODE (dovar) == VAR_DECL)
3224 {
3225 if (integer_onep (step))
3226 simple = 1;
3227 else if (tree_int_cst_equal (step, integer_minus_one_node))
3228 simple = -1;
3229 }
3230 else
3231 dovar_decl
3232 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
3233 false);
3234
3235 /* Loop body. */
3236 if (simple)
3237 {
3238 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
3239 /* The condition should not be folded. */
3240 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
3241 ? LE_EXPR : GE_EXPR,
3242 boolean_type_node, dovar, to);
3243 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3244 type, dovar, step);
3245 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3246 MODIFY_EXPR,
3247 type, dovar,
3248 TREE_VEC_ELT (incr, i));
3249 }
3250 else
3251 {
3252 /* STEP is not 1 or -1. Use:
3253 for (count = 0; count < (to + step - from) / step; count++)
3254 {
3255 dovar = from + count * step;
3256 body;
3257 cycle_label:;
3258 } */
3259 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
3260 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
3261 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
3262 step);
3263 tmp = gfc_evaluate_now (tmp, pblock);
3264 count = gfc_create_var (type, "count");
3265 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
3266 build_int_cst (type, 0));
3267 /* The condition should not be folded. */
3268 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
3269 boolean_type_node,
3270 count, tmp);
3271 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3272 type, count,
3273 build_int_cst (type, 1));
3274 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3275 MODIFY_EXPR, type, count,
3276 TREE_VEC_ELT (incr, i));
3277
3278 /* Initialize DOVAR. */
3279 tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
3280 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
3281 dovar_init e = {dovar, tmp};
3282 inits.safe_push (e);
3283 }
3284
3285 if (dovar_found == 2
3286 && op == EXEC_OMP_SIMD
3287 && collapse == 1
3288 && !simple)
3289 {
3290 for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
3291 if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
3292 && OMP_CLAUSE_DECL (tmp) == dovar)
3293 {
3294 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3295 break;
3296 }
3297 }
3298 if (!dovar_found)
3299 {
3300 if (op == EXEC_OMP_SIMD)
3301 {
3302 if (collapse == 1)
3303 {
3304 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3305 OMP_CLAUSE_LINEAR_STEP (tmp) = step;
3306 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3307 }
3308 else
3309 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3310 if (!simple)
3311 dovar_found = 2;
3312 }
3313 else
3314 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3315 OMP_CLAUSE_DECL (tmp) = dovar_decl;
3316 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3317 }
3318 if (dovar_found == 2)
3319 {
3320 tree c = NULL;
3321
3322 tmp = NULL;
3323 if (!simple)
3324 {
3325 /* If dovar is lastprivate, but different counter is used,
3326 dovar += step needs to be added to
3327 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
3328 will have the value on entry of the last loop, rather
3329 than value after iterator increment. */
3330 tmp = gfc_evaluate_now (step, pblock);
3331 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
3332 tmp);
3333 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
3334 dovar, tmp);
3335 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3336 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
3337 && OMP_CLAUSE_DECL (c) == dovar_decl)
3338 {
3339 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
3340 break;
3341 }
3342 else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
3343 && OMP_CLAUSE_DECL (c) == dovar_decl)
3344 {
3345 OMP_CLAUSE_LINEAR_STMT (c) = tmp;
3346 break;
3347 }
3348 }
3349 if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
3350 {
3351 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3352 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
3353 && OMP_CLAUSE_DECL (c) == dovar_decl)
3354 {
3355 tree l = build_omp_clause (input_location,
3356 OMP_CLAUSE_LASTPRIVATE);
3357 OMP_CLAUSE_DECL (l) = dovar_decl;
3358 OMP_CLAUSE_CHAIN (l) = omp_clauses;
3359 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
3360 omp_clauses = l;
3361 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
3362 break;
3363 }
3364 }
3365 gcc_assert (simple || c != NULL);
3366 }
3367 if (!simple)
3368 {
3369 if (op != EXEC_OMP_SIMD)
3370 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3371 else if (collapse == 1)
3372 {
3373 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3374 OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
3375 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3376 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
3377 }
3378 else
3379 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3380 OMP_CLAUSE_DECL (tmp) = count;
3381 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3382 }
3383
3384 if (i + 1 < collapse)
3385 code = code->block->next;
3386 }
3387
3388 if (pblock != &block)
3389 {
3390 pushlevel ();
3391 gfc_start_block (&block);
3392 }
3393
3394 gfc_start_block (&body);
3395
3396 FOR_EACH_VEC_ELT (inits, ix, di)
3397 gfc_add_modify (&body, di->var, di->init);
3398 inits.release ();
3399
3400 /* Cycle statement is implemented with a goto. Exit statement must not be
3401 present for this loop. */
3402 cycle_label = gfc_build_label_decl (NULL_TREE);
3403
3404 /* Put these labels where they can be found later. */
3405
3406 code->cycle_label = cycle_label;
3407 code->exit_label = NULL_TREE;
3408
3409 /* Main loop body. */
3410 tmp = gfc_trans_omp_code (code->block->next, true);
3411 gfc_add_expr_to_block (&body, tmp);
3412
3413 /* Label for cycle statements (if needed). */
3414 if (TREE_USED (cycle_label))
3415 {
3416 tmp = build1_v (LABEL_EXPR, cycle_label);
3417 gfc_add_expr_to_block (&body, tmp);
3418 }
3419
3420 /* End of loop body. */
3421 switch (op)
3422 {
3423 case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
3424 case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
3425 case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
3426 case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
3427 default: gcc_unreachable ();
3428 }
3429
3430 TREE_TYPE (stmt) = void_type_node;
3431 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
3432 OMP_FOR_CLAUSES (stmt) = omp_clauses;
3433 OMP_FOR_INIT (stmt) = init;
3434 OMP_FOR_COND (stmt) = cond;
3435 OMP_FOR_INCR (stmt) = incr;
3436 gfc_add_expr_to_block (&block, stmt);
3437
3438 return gfc_finish_block (&block);
3439 }
3440
3441 /* parallel loop and kernels loop. */
3442 static tree
3443 gfc_trans_oacc_combined_directive (gfc_code *code)
3444 {
3445 stmtblock_t block, *pblock = NULL;
3446 gfc_omp_clauses construct_clauses, loop_clauses;
3447 tree stmt, oacc_clauses = NULL_TREE;
3448 enum tree_code construct_code;
3449
3450 switch (code->op)
3451 {
3452 case EXEC_OACC_PARALLEL_LOOP:
3453 construct_code = OACC_PARALLEL;
3454 break;
3455 case EXEC_OACC_KERNELS_LOOP:
3456 construct_code = OACC_KERNELS;
3457 break;
3458 default:
3459 gcc_unreachable ();
3460 }
3461
3462 gfc_start_block (&block);
3463
3464 memset (&loop_clauses, 0, sizeof (loop_clauses));
3465 if (code->ext.omp_clauses != NULL)
3466 {
3467 memcpy (&construct_clauses, code->ext.omp_clauses,
3468 sizeof (construct_clauses));
3469 loop_clauses.collapse = construct_clauses.collapse;
3470 loop_clauses.gang = construct_clauses.gang;
3471 loop_clauses.gang_static = construct_clauses.gang_static;
3472 loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
3473 loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
3474 loop_clauses.vector = construct_clauses.vector;
3475 loop_clauses.vector_expr = construct_clauses.vector_expr;
3476 loop_clauses.worker = construct_clauses.worker;
3477 loop_clauses.worker_expr = construct_clauses.worker_expr;
3478 loop_clauses.seq = construct_clauses.seq;
3479 loop_clauses.par_auto = construct_clauses.par_auto;
3480 loop_clauses.independent = construct_clauses.independent;
3481 loop_clauses.tile_list = construct_clauses.tile_list;
3482 loop_clauses.lists[OMP_LIST_PRIVATE]
3483 = construct_clauses.lists[OMP_LIST_PRIVATE];
3484 loop_clauses.lists[OMP_LIST_REDUCTION]
3485 = construct_clauses.lists[OMP_LIST_REDUCTION];
3486 construct_clauses.gang = false;
3487 construct_clauses.gang_static = false;
3488 construct_clauses.gang_num_expr = NULL;
3489 construct_clauses.gang_static_expr = NULL;
3490 construct_clauses.vector = false;
3491 construct_clauses.vector_expr = NULL;
3492 construct_clauses.worker = false;
3493 construct_clauses.worker_expr = NULL;
3494 construct_clauses.seq = false;
3495 construct_clauses.par_auto = false;
3496 construct_clauses.independent = false;
3497 construct_clauses.independent = false;
3498 construct_clauses.tile_list = NULL;
3499 construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
3500 if (construct_code == OACC_KERNELS)
3501 construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
3502 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
3503 code->loc);
3504 }
3505 if (!loop_clauses.seq)
3506 pblock = &block;
3507 else
3508 pushlevel ();
3509 stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
3510 if (TREE_CODE (stmt) != BIND_EXPR)
3511 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3512 else
3513 poplevel (0, 0);
3514 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
3515 oacc_clauses);
3516 gfc_add_expr_to_block (&block, stmt);
3517 return gfc_finish_block (&block);
3518 }
3519
3520 static tree
3521 gfc_trans_omp_flush (void)
3522 {
3523 tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
3524 return build_call_expr_loc (input_location, decl, 0);
3525 }
3526
3527 static tree
3528 gfc_trans_omp_master (gfc_code *code)
3529 {
3530 tree stmt = gfc_trans_code (code->block->next);
3531 if (IS_EMPTY_STMT (stmt))
3532 return stmt;
3533 return build1_v (OMP_MASTER, stmt);
3534 }
3535
3536 static tree
3537 gfc_trans_omp_ordered (gfc_code *code)
3538 {
3539 return build2_loc (input_location, OMP_ORDERED, void_type_node,
3540 gfc_trans_code (code->block->next), NULL_TREE);
3541 }
3542
3543 static tree
3544 gfc_trans_omp_parallel (gfc_code *code)
3545 {
3546 stmtblock_t block;
3547 tree stmt, omp_clauses;
3548
3549 gfc_start_block (&block);
3550 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3551 code->loc);
3552 stmt = gfc_trans_omp_code (code->block->next, true);
3553 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3554 omp_clauses);
3555 gfc_add_expr_to_block (&block, stmt);
3556 return gfc_finish_block (&block);
3557 }
3558
3559 enum
3560 {
3561 GFC_OMP_SPLIT_SIMD,
3562 GFC_OMP_SPLIT_DO,
3563 GFC_OMP_SPLIT_PARALLEL,
3564 GFC_OMP_SPLIT_DISTRIBUTE,
3565 GFC_OMP_SPLIT_TEAMS,
3566 GFC_OMP_SPLIT_TARGET,
3567 GFC_OMP_SPLIT_NUM
3568 };
3569
3570 enum
3571 {
3572 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
3573 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
3574 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
3575 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
3576 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
3577 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET)
3578 };
3579
3580 static void
3581 gfc_split_omp_clauses (gfc_code *code,
3582 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
3583 {
3584 int mask = 0, innermost = 0;
3585 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
3586 switch (code->op)
3587 {
3588 case EXEC_OMP_DISTRIBUTE:
3589 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3590 break;
3591 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3592 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3593 innermost = GFC_OMP_SPLIT_DO;
3594 break;
3595 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3596 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
3597 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3598 innermost = GFC_OMP_SPLIT_SIMD;
3599 break;
3600 case EXEC_OMP_DISTRIBUTE_SIMD:
3601 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3602 innermost = GFC_OMP_SPLIT_SIMD;
3603 break;
3604 case EXEC_OMP_DO:
3605 innermost = GFC_OMP_SPLIT_DO;
3606 break;
3607 case EXEC_OMP_DO_SIMD:
3608 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3609 innermost = GFC_OMP_SPLIT_SIMD;
3610 break;
3611 case EXEC_OMP_PARALLEL:
3612 innermost = GFC_OMP_SPLIT_PARALLEL;
3613 break;
3614 case EXEC_OMP_PARALLEL_DO:
3615 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3616 innermost = GFC_OMP_SPLIT_DO;
3617 break;
3618 case EXEC_OMP_PARALLEL_DO_SIMD:
3619 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3620 innermost = GFC_OMP_SPLIT_SIMD;
3621 break;
3622 case EXEC_OMP_SIMD:
3623 innermost = GFC_OMP_SPLIT_SIMD;
3624 break;
3625 case EXEC_OMP_TARGET:
3626 innermost = GFC_OMP_SPLIT_TARGET;
3627 break;
3628 case EXEC_OMP_TARGET_TEAMS:
3629 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
3630 innermost = GFC_OMP_SPLIT_TEAMS;
3631 break;
3632 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3633 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3634 | GFC_OMP_MASK_DISTRIBUTE;
3635 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3636 break;
3637 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3638 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3639 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3640 innermost = GFC_OMP_SPLIT_DO;
3641 break;
3642 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3643 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3644 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3645 innermost = GFC_OMP_SPLIT_SIMD;
3646 break;
3647 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3648 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3649 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3650 innermost = GFC_OMP_SPLIT_SIMD;
3651 break;
3652 case EXEC_OMP_TEAMS:
3653 innermost = GFC_OMP_SPLIT_TEAMS;
3654 break;
3655 case EXEC_OMP_TEAMS_DISTRIBUTE:
3656 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
3657 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3658 break;
3659 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3660 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3661 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3662 innermost = GFC_OMP_SPLIT_DO;
3663 break;
3664 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3665 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3666 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3667 innermost = GFC_OMP_SPLIT_SIMD;
3668 break;
3669 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3670 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3671 innermost = GFC_OMP_SPLIT_SIMD;
3672 break;
3673 default:
3674 gcc_unreachable ();
3675 }
3676 if (mask == 0)
3677 {
3678 clausesa[innermost] = *code->ext.omp_clauses;
3679 return;
3680 }
3681 if (code->ext.omp_clauses != NULL)
3682 {
3683 if (mask & GFC_OMP_MASK_TARGET)
3684 {
3685 /* First the clauses that are unique to some constructs. */
3686 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
3687 = code->ext.omp_clauses->lists[OMP_LIST_MAP];
3688 clausesa[GFC_OMP_SPLIT_TARGET].device
3689 = code->ext.omp_clauses->device;
3690 }
3691 if (mask & GFC_OMP_MASK_TEAMS)
3692 {
3693 /* First the clauses that are unique to some constructs. */
3694 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
3695 = code->ext.omp_clauses->num_teams;
3696 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
3697 = code->ext.omp_clauses->thread_limit;
3698 /* Shared and default clauses are allowed on parallel and teams. */
3699 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
3700 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3701 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
3702 = code->ext.omp_clauses->default_sharing;
3703 }
3704 if (mask & GFC_OMP_MASK_DISTRIBUTE)
3705 {
3706 /* First the clauses that are unique to some constructs. */
3707 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
3708 = code->ext.omp_clauses->dist_sched_kind;
3709 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
3710 = code->ext.omp_clauses->dist_chunk_size;
3711 /* Duplicate collapse. */
3712 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
3713 = code->ext.omp_clauses->collapse;
3714 }
3715 if (mask & GFC_OMP_MASK_PARALLEL)
3716 {
3717 /* First the clauses that are unique to some constructs. */
3718 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
3719 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
3720 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
3721 = code->ext.omp_clauses->num_threads;
3722 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
3723 = code->ext.omp_clauses->proc_bind;
3724 /* Shared and default clauses are allowed on parallel and teams. */
3725 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
3726 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3727 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
3728 = code->ext.omp_clauses->default_sharing;
3729 }
3730 if (mask & GFC_OMP_MASK_DO)
3731 {
3732 /* First the clauses that are unique to some constructs. */
3733 clausesa[GFC_OMP_SPLIT_DO].ordered
3734 = code->ext.omp_clauses->ordered;
3735 clausesa[GFC_OMP_SPLIT_DO].sched_kind
3736 = code->ext.omp_clauses->sched_kind;
3737 clausesa[GFC_OMP_SPLIT_DO].chunk_size
3738 = code->ext.omp_clauses->chunk_size;
3739 clausesa[GFC_OMP_SPLIT_DO].nowait
3740 = code->ext.omp_clauses->nowait;
3741 /* Duplicate collapse. */
3742 clausesa[GFC_OMP_SPLIT_DO].collapse
3743 = code->ext.omp_clauses->collapse;
3744 }
3745 if (mask & GFC_OMP_MASK_SIMD)
3746 {
3747 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
3748 = code->ext.omp_clauses->safelen_expr;
3749 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LINEAR]
3750 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
3751 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
3752 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
3753 /* Duplicate collapse. */
3754 clausesa[GFC_OMP_SPLIT_SIMD].collapse
3755 = code->ext.omp_clauses->collapse;
3756 }
3757 /* Private clause is supported on all constructs but target,
3758 it is enough to put it on the innermost one. For
3759 !$ omp do put it on parallel though,
3760 as that's what we did for OpenMP 3.1. */
3761 clausesa[innermost == GFC_OMP_SPLIT_DO
3762 ? (int) GFC_OMP_SPLIT_PARALLEL
3763 : innermost].lists[OMP_LIST_PRIVATE]
3764 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
3765 /* Firstprivate clause is supported on all constructs but
3766 target and simd. Put it on the outermost of those and
3767 duplicate on parallel. */
3768 if (mask & GFC_OMP_MASK_TEAMS)
3769 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
3770 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3771 else if (mask & GFC_OMP_MASK_DISTRIBUTE)
3772 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
3773 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3774 if (mask & GFC_OMP_MASK_PARALLEL)
3775 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
3776 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3777 else if (mask & GFC_OMP_MASK_DO)
3778 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
3779 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3780 /* Lastprivate is allowed on do and simd. In
3781 parallel do{, simd} we actually want to put it on
3782 parallel rather than do. */
3783 if (mask & GFC_OMP_MASK_PARALLEL)
3784 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
3785 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3786 else if (mask & GFC_OMP_MASK_DO)
3787 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
3788 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3789 if (mask & GFC_OMP_MASK_SIMD)
3790 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
3791 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3792 /* Reduction is allowed on simd, do, parallel and teams.
3793 Duplicate it on all of them, but omit on do if
3794 parallel is present. */
3795 if (mask & GFC_OMP_MASK_TEAMS)
3796 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION]
3797 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3798 if (mask & GFC_OMP_MASK_PARALLEL)
3799 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
3800 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3801 else if (mask & GFC_OMP_MASK_DO)
3802 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
3803 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3804 if (mask & GFC_OMP_MASK_SIMD)
3805 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
3806 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3807 /* FIXME: This is currently being discussed. */
3808 if (mask & GFC_OMP_MASK_PARALLEL)
3809 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
3810 = code->ext.omp_clauses->if_expr;
3811 else
3812 clausesa[GFC_OMP_SPLIT_TARGET].if_expr
3813 = code->ext.omp_clauses->if_expr;
3814 }
3815 if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3816 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3817 clausesa[GFC_OMP_SPLIT_DO].nowait = true;
3818 }
3819
3820 static tree
3821 gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
3822 gfc_omp_clauses *clausesa, tree omp_clauses)
3823 {
3824 stmtblock_t block;
3825 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3826 tree stmt, body, omp_do_clauses = NULL_TREE;
3827
3828 if (pblock == NULL)
3829 gfc_start_block (&block);
3830 else
3831 gfc_init_block (&block);
3832
3833 if (clausesa == NULL)
3834 {
3835 clausesa = clausesa_buf;
3836 gfc_split_omp_clauses (code, clausesa);
3837 }
3838 if (flag_openmp)
3839 omp_do_clauses
3840 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
3841 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
3842 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
3843 if (pblock == NULL)
3844 {
3845 if (TREE_CODE (body) != BIND_EXPR)
3846 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
3847 else
3848 poplevel (0, 0);
3849 }
3850 else if (TREE_CODE (body) != BIND_EXPR)
3851 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
3852 if (flag_openmp)
3853 {
3854 stmt = make_node (OMP_FOR);
3855 TREE_TYPE (stmt) = void_type_node;
3856 OMP_FOR_BODY (stmt) = body;
3857 OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
3858 }
3859 else
3860 stmt = body;
3861 gfc_add_expr_to_block (&block, stmt);
3862 return gfc_finish_block (&block);
3863 }
3864
3865 static tree
3866 gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock,
3867 gfc_omp_clauses *clausesa)
3868 {
3869 stmtblock_t block, *new_pblock = pblock;
3870 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3871 tree stmt, omp_clauses = NULL_TREE;
3872
3873 if (pblock == NULL)
3874 gfc_start_block (&block);
3875 else
3876 gfc_init_block (&block);
3877
3878 if (clausesa == NULL)
3879 {
3880 clausesa = clausesa_buf;
3881 gfc_split_omp_clauses (code, clausesa);
3882 }
3883 omp_clauses
3884 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3885 code->loc);
3886 if (pblock == NULL)
3887 {
3888 if (!clausesa[GFC_OMP_SPLIT_DO].ordered
3889 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
3890 new_pblock = &block;
3891 else
3892 pushlevel ();
3893 }
3894 stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock,
3895 &clausesa[GFC_OMP_SPLIT_DO], omp_clauses);
3896 if (pblock == NULL)
3897 {
3898 if (TREE_CODE (stmt) != BIND_EXPR)
3899 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3900 else
3901 poplevel (0, 0);
3902 }
3903 else if (TREE_CODE (stmt) != BIND_EXPR)
3904 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
3905 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3906 omp_clauses);
3907 OMP_PARALLEL_COMBINED (stmt) = 1;
3908 gfc_add_expr_to_block (&block, stmt);
3909 return gfc_finish_block (&block);
3910 }
3911
3912 static tree
3913 gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
3914 gfc_omp_clauses *clausesa)
3915 {
3916 stmtblock_t block;
3917 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3918 tree stmt, omp_clauses = NULL_TREE;
3919
3920 if (pblock == NULL)
3921 gfc_start_block (&block);
3922 else
3923 gfc_init_block (&block);
3924
3925 if (clausesa == NULL)
3926 {
3927 clausesa = clausesa_buf;
3928 gfc_split_omp_clauses (code, clausesa);
3929 }
3930 if (flag_openmp)
3931 omp_clauses
3932 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3933 code->loc);
3934 if (pblock == NULL)
3935 pushlevel ();
3936 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
3937 if (pblock == NULL)
3938 {
3939 if (TREE_CODE (stmt) != BIND_EXPR)
3940 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3941 else
3942 poplevel (0, 0);
3943 }
3944 else if (TREE_CODE (stmt) != BIND_EXPR)
3945 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
3946 if (flag_openmp)
3947 {
3948 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3949 omp_clauses);
3950 OMP_PARALLEL_COMBINED (stmt) = 1;
3951 }
3952 gfc_add_expr_to_block (&block, stmt);
3953 return gfc_finish_block (&block);
3954 }
3955
3956 static tree
3957 gfc_trans_omp_parallel_sections (gfc_code *code)
3958 {
3959 stmtblock_t block;
3960 gfc_omp_clauses section_clauses;
3961 tree stmt, omp_clauses;
3962
3963 memset (&section_clauses, 0, sizeof (section_clauses));
3964 section_clauses.nowait = true;
3965
3966 gfc_start_block (&block);
3967 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3968 code->loc);
3969 pushlevel ();
3970 stmt = gfc_trans_omp_sections (code, &section_clauses);
3971 if (TREE_CODE (stmt) != BIND_EXPR)
3972 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3973 else
3974 poplevel (0, 0);
3975 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3976 omp_clauses);
3977 OMP_PARALLEL_COMBINED (stmt) = 1;
3978 gfc_add_expr_to_block (&block, stmt);
3979 return gfc_finish_block (&block);
3980 }
3981
3982 static tree
3983 gfc_trans_omp_parallel_workshare (gfc_code *code)
3984 {
3985 stmtblock_t block;
3986 gfc_omp_clauses workshare_clauses;
3987 tree stmt, omp_clauses;
3988
3989 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
3990 workshare_clauses.nowait = true;
3991
3992 gfc_start_block (&block);
3993 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3994 code->loc);
3995 pushlevel ();
3996 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
3997 if (TREE_CODE (stmt) != BIND_EXPR)
3998 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3999 else
4000 poplevel (0, 0);
4001 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4002 omp_clauses);
4003 OMP_PARALLEL_COMBINED (stmt) = 1;
4004 gfc_add_expr_to_block (&block, stmt);
4005 return gfc_finish_block (&block);
4006 }
4007
4008 static tree
4009 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
4010 {
4011 stmtblock_t block, body;
4012 tree omp_clauses, stmt;
4013 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
4014
4015 gfc_start_block (&block);
4016
4017 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
4018
4019 gfc_init_block (&body);
4020 for (code = code->block; code; code = code->block)
4021 {
4022 /* Last section is special because of lastprivate, so even if it
4023 is empty, chain it in. */
4024 stmt = gfc_trans_omp_code (code->next,
4025 has_lastprivate && code->block == NULL);
4026 if (! IS_EMPTY_STMT (stmt))
4027 {
4028 stmt = build1_v (OMP_SECTION, stmt);
4029 gfc_add_expr_to_block (&body, stmt);
4030 }
4031 }
4032 stmt = gfc_finish_block (&body);
4033
4034 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
4035 omp_clauses);
4036 gfc_add_expr_to_block (&block, stmt);
4037
4038 return gfc_finish_block (&block);
4039 }
4040
4041 static tree
4042 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
4043 {
4044 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
4045 tree stmt = gfc_trans_omp_code (code->block->next, true);
4046 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
4047 omp_clauses);
4048 return stmt;
4049 }
4050
4051 static tree
4052 gfc_trans_omp_task (gfc_code *code)
4053 {
4054 stmtblock_t block;
4055 tree stmt, omp_clauses;
4056
4057 gfc_start_block (&block);
4058 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4059 code->loc);
4060 stmt = gfc_trans_omp_code (code->block->next, true);
4061 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
4062 omp_clauses);
4063 gfc_add_expr_to_block (&block, stmt);
4064 return gfc_finish_block (&block);
4065 }
4066
4067 static tree
4068 gfc_trans_omp_taskgroup (gfc_code *code)
4069 {
4070 tree stmt = gfc_trans_code (code->block->next);
4071 return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt);
4072 }
4073
4074 static tree
4075 gfc_trans_omp_taskwait (void)
4076 {
4077 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
4078 return build_call_expr_loc (input_location, decl, 0);
4079 }
4080
4081 static tree
4082 gfc_trans_omp_taskyield (void)
4083 {
4084 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
4085 return build_call_expr_loc (input_location, decl, 0);
4086 }
4087
4088 static tree
4089 gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
4090 {
4091 stmtblock_t block;
4092 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4093 tree stmt, omp_clauses = NULL_TREE;
4094
4095 gfc_start_block (&block);
4096 if (clausesa == NULL)
4097 {
4098 clausesa = clausesa_buf;
4099 gfc_split_omp_clauses (code, clausesa);
4100 }
4101 if (flag_openmp)
4102 omp_clauses
4103 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4104 code->loc);
4105 switch (code->op)
4106 {
4107 case EXEC_OMP_DISTRIBUTE:
4108 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4109 case EXEC_OMP_TEAMS_DISTRIBUTE:
4110 /* This is handled in gfc_trans_omp_do. */
4111 gcc_unreachable ();
4112 break;
4113 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4114 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4115 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4116 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa);
4117 if (TREE_CODE (stmt) != BIND_EXPR)
4118 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4119 else
4120 poplevel (0, 0);
4121 break;
4122 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4123 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4124 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4125 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
4126 if (TREE_CODE (stmt) != BIND_EXPR)
4127 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4128 else
4129 poplevel (0, 0);
4130 break;
4131 case EXEC_OMP_DISTRIBUTE_SIMD:
4132 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4133 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4134 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4135 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4136 if (TREE_CODE (stmt) != BIND_EXPR)
4137 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4138 else
4139 poplevel (0, 0);
4140 break;
4141 default:
4142 gcc_unreachable ();
4143 }
4144 if (flag_openmp)
4145 {
4146 tree distribute = make_node (OMP_DISTRIBUTE);
4147 TREE_TYPE (distribute) = void_type_node;
4148 OMP_FOR_BODY (distribute) = stmt;
4149 OMP_FOR_CLAUSES (distribute) = omp_clauses;
4150 stmt = distribute;
4151 }
4152 gfc_add_expr_to_block (&block, stmt);
4153 return gfc_finish_block (&block);
4154 }
4155
4156 static tree
4157 gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa)
4158 {
4159 stmtblock_t block;
4160 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4161 tree stmt, omp_clauses = NULL_TREE;
4162 bool combined = true;
4163
4164 gfc_start_block (&block);
4165 if (clausesa == NULL)
4166 {
4167 clausesa = clausesa_buf;
4168 gfc_split_omp_clauses (code, clausesa);
4169 }
4170 if (flag_openmp)
4171 omp_clauses
4172 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS],
4173 code->loc);
4174 switch (code->op)
4175 {
4176 case EXEC_OMP_TARGET_TEAMS:
4177 case EXEC_OMP_TEAMS:
4178 stmt = gfc_trans_omp_code (code->block->next, true);
4179 combined = false;
4180 break;
4181 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4182 case EXEC_OMP_TEAMS_DISTRIBUTE:
4183 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
4184 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4185 NULL);
4186 break;
4187 default:
4188 stmt = gfc_trans_omp_distribute (code, clausesa);
4189 break;
4190 }
4191 stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt,
4192 omp_clauses);
4193 if (combined)
4194 OMP_TEAMS_COMBINED (stmt) = 1;
4195 gfc_add_expr_to_block (&block, stmt);
4196 return gfc_finish_block (&block);
4197 }
4198
4199 static tree
4200 gfc_trans_omp_target (gfc_code *code)
4201 {
4202 stmtblock_t block;
4203 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
4204 tree stmt, omp_clauses = NULL_TREE;
4205
4206 gfc_start_block (&block);
4207 gfc_split_omp_clauses (code, clausesa);
4208 if (flag_openmp)
4209 omp_clauses
4210 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
4211 code->loc);
4212 if (code->op == EXEC_OMP_TARGET)
4213 stmt = gfc_trans_omp_code (code->block->next, true);
4214 else
4215 {
4216 pushlevel ();
4217 stmt = gfc_trans_omp_teams (code, clausesa);
4218 if (TREE_CODE (stmt) != BIND_EXPR)
4219 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4220 else
4221 poplevel (0, 0);
4222 }
4223 if (flag_openmp)
4224 stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt,
4225 omp_clauses);
4226 gfc_add_expr_to_block (&block, stmt);
4227 return gfc_finish_block (&block);
4228 }
4229
4230 static tree
4231 gfc_trans_omp_target_data (gfc_code *code)
4232 {
4233 stmtblock_t block;
4234 tree stmt, omp_clauses;
4235
4236 gfc_start_block (&block);
4237 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4238 code->loc);
4239 stmt = gfc_trans_omp_code (code->block->next, true);
4240 stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt,
4241 omp_clauses);
4242 gfc_add_expr_to_block (&block, stmt);
4243 return gfc_finish_block (&block);
4244 }
4245
4246 static tree
4247 gfc_trans_omp_target_update (gfc_code *code)
4248 {
4249 stmtblock_t block;
4250 tree stmt, omp_clauses;
4251
4252 gfc_start_block (&block);
4253 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4254 code->loc);
4255 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
4256 omp_clauses);
4257 gfc_add_expr_to_block (&block, stmt);
4258 return gfc_finish_block (&block);
4259 }
4260
4261 static tree
4262 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
4263 {
4264 tree res, tmp, stmt;
4265 stmtblock_t block, *pblock = NULL;
4266 stmtblock_t singleblock;
4267 int saved_ompws_flags;
4268 bool singleblock_in_progress = false;
4269 /* True if previous gfc_code in workshare construct is not workshared. */
4270 bool prev_singleunit;
4271
4272 code = code->block->next;
4273
4274 pushlevel ();
4275
4276 gfc_start_block (&block);
4277 pblock = &block;
4278
4279 ompws_flags = OMPWS_WORKSHARE_FLAG;
4280 prev_singleunit = false;
4281
4282 /* Translate statements one by one to trees until we reach
4283 the end of the workshare construct. Adjacent gfc_codes that
4284 are a single unit of work are clustered and encapsulated in a
4285 single OMP_SINGLE construct. */
4286 for (; code; code = code->next)
4287 {
4288 if (code->here != 0)
4289 {
4290 res = gfc_trans_label_here (code);
4291 gfc_add_expr_to_block (pblock, res);
4292 }
4293
4294 /* No dependence analysis, use for clauses with wait.
4295 If this is the last gfc_code, use default omp_clauses. */
4296 if (code->next == NULL && clauses->nowait)
4297 ompws_flags |= OMPWS_NOWAIT;
4298
4299 /* By default, every gfc_code is a single unit of work. */
4300 ompws_flags |= OMPWS_CURR_SINGLEUNIT;
4301 ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
4302
4303 switch (code->op)
4304 {
4305 case EXEC_NOP:
4306 res = NULL_TREE;
4307 break;
4308
4309 case EXEC_ASSIGN:
4310 res = gfc_trans_assign (code);
4311 break;
4312
4313 case EXEC_POINTER_ASSIGN:
4314 res = gfc_trans_pointer_assign (code);
4315 break;
4316
4317 case EXEC_INIT_ASSIGN:
4318 res = gfc_trans_init_assign (code);
4319 break;
4320
4321 case EXEC_FORALL:
4322 res = gfc_trans_forall (code);
4323 break;
4324
4325 case EXEC_WHERE:
4326 res = gfc_trans_where (code);
4327 break;
4328
4329 case EXEC_OMP_ATOMIC:
4330 res = gfc_trans_omp_directive (code);
4331 break;
4332
4333 case EXEC_OMP_PARALLEL:
4334 case EXEC_OMP_PARALLEL_DO:
4335 case EXEC_OMP_PARALLEL_SECTIONS:
4336 case EXEC_OMP_PARALLEL_WORKSHARE:
4337 case EXEC_OMP_CRITICAL:
4338 saved_ompws_flags = ompws_flags;
4339 ompws_flags = 0;
4340 res = gfc_trans_omp_directive (code);
4341 ompws_flags = saved_ompws_flags;
4342 break;
4343
4344 default:
4345 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
4346 }
4347
4348 gfc_set_backend_locus (&code->loc);
4349
4350 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
4351 {
4352 if (prev_singleunit)
4353 {
4354 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4355 /* Add current gfc_code to single block. */
4356 gfc_add_expr_to_block (&singleblock, res);
4357 else
4358 {
4359 /* Finish single block and add it to pblock. */
4360 tmp = gfc_finish_block (&singleblock);
4361 tmp = build2_loc (input_location, OMP_SINGLE,
4362 void_type_node, tmp, NULL_TREE);
4363 gfc_add_expr_to_block (pblock, tmp);
4364 /* Add current gfc_code to pblock. */
4365 gfc_add_expr_to_block (pblock, res);
4366 singleblock_in_progress = false;
4367 }
4368 }
4369 else
4370 {
4371 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4372 {
4373 /* Start single block. */
4374 gfc_init_block (&singleblock);
4375 gfc_add_expr_to_block (&singleblock, res);
4376 singleblock_in_progress = true;
4377 }
4378 else
4379 /* Add the new statement to the block. */
4380 gfc_add_expr_to_block (pblock, res);
4381 }
4382 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
4383 }
4384 }
4385
4386 /* Finish remaining SINGLE block, if we were in the middle of one. */
4387 if (singleblock_in_progress)
4388 {
4389 /* Finish single block and add it to pblock. */
4390 tmp = gfc_finish_block (&singleblock);
4391 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
4392 clauses->nowait
4393 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
4394 : NULL_TREE);
4395 gfc_add_expr_to_block (pblock, tmp);
4396 }
4397
4398 stmt = gfc_finish_block (pblock);
4399 if (TREE_CODE (stmt) != BIND_EXPR)
4400 {
4401 if (!IS_EMPTY_STMT (stmt))
4402 {
4403 tree bindblock = poplevel (1, 0);
4404 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
4405 }
4406 else
4407 poplevel (0, 0);
4408 }
4409 else
4410 poplevel (0, 0);
4411
4412 if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
4413 stmt = gfc_trans_omp_barrier ();
4414
4415 ompws_flags = 0;
4416 return stmt;
4417 }
4418
4419 tree
4420 gfc_trans_oacc_declare (gfc_code *code)
4421 {
4422 stmtblock_t block;
4423 tree stmt, oacc_clauses;
4424 enum tree_code construct_code;
4425
4426 construct_code = OACC_DATA;
4427
4428 gfc_start_block (&block);
4429
4430 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
4431 code->loc);
4432 stmt = gfc_trans_omp_code (code->block->next, true);
4433 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
4434 oacc_clauses);
4435 gfc_add_expr_to_block (&block, stmt);
4436
4437 return gfc_finish_block (&block);
4438 }
4439
4440 tree
4441 gfc_trans_oacc_directive (gfc_code *code)
4442 {
4443 switch (code->op)
4444 {
4445 case EXEC_OACC_PARALLEL_LOOP:
4446 case EXEC_OACC_KERNELS_LOOP:
4447 return gfc_trans_oacc_combined_directive (code);
4448 case EXEC_OACC_PARALLEL:
4449 case EXEC_OACC_KERNELS:
4450 case EXEC_OACC_DATA:
4451 case EXEC_OACC_HOST_DATA:
4452 return gfc_trans_oacc_construct (code);
4453 case EXEC_OACC_LOOP:
4454 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4455 NULL);
4456 case EXEC_OACC_UPDATE:
4457 case EXEC_OACC_CACHE:
4458 case EXEC_OACC_ENTER_DATA:
4459 case EXEC_OACC_EXIT_DATA:
4460 return gfc_trans_oacc_executable_directive (code);
4461 case EXEC_OACC_WAIT:
4462 return gfc_trans_oacc_wait_directive (code);
4463 case EXEC_OACC_ATOMIC:
4464 return gfc_trans_omp_atomic (code);
4465 case EXEC_OACC_DECLARE:
4466 return gfc_trans_oacc_declare (code);
4467 default:
4468 gcc_unreachable ();
4469 }
4470 }
4471
4472 tree
4473 gfc_trans_omp_directive (gfc_code *code)
4474 {
4475 switch (code->op)
4476 {
4477 case EXEC_OMP_ATOMIC:
4478 return gfc_trans_omp_atomic (code);
4479 case EXEC_OMP_BARRIER:
4480 return gfc_trans_omp_barrier ();
4481 case EXEC_OMP_CANCEL:
4482 return gfc_trans_omp_cancel (code);
4483 case EXEC_OMP_CANCELLATION_POINT:
4484 return gfc_trans_omp_cancellation_point (code);
4485 case EXEC_OMP_CRITICAL:
4486 return gfc_trans_omp_critical (code);
4487 case EXEC_OMP_DISTRIBUTE:
4488 case EXEC_OMP_DO:
4489 case EXEC_OMP_SIMD:
4490 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4491 NULL);
4492 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4493 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4494 case EXEC_OMP_DISTRIBUTE_SIMD:
4495 return gfc_trans_omp_distribute (code, NULL);
4496 case EXEC_OMP_DO_SIMD:
4497 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
4498 case EXEC_OMP_FLUSH:
4499 return gfc_trans_omp_flush ();
4500 case EXEC_OMP_MASTER:
4501 return gfc_trans_omp_master (code);
4502 case EXEC_OMP_ORDERED:
4503 return gfc_trans_omp_ordered (code);
4504 case EXEC_OMP_PARALLEL:
4505 return gfc_trans_omp_parallel (code);
4506 case EXEC_OMP_PARALLEL_DO:
4507 return gfc_trans_omp_parallel_do (code, NULL, NULL);
4508 case EXEC_OMP_PARALLEL_DO_SIMD:
4509 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
4510 case EXEC_OMP_PARALLEL_SECTIONS:
4511 return gfc_trans_omp_parallel_sections (code);
4512 case EXEC_OMP_PARALLEL_WORKSHARE:
4513 return gfc_trans_omp_parallel_workshare (code);
4514 case EXEC_OMP_SECTIONS:
4515 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
4516 case EXEC_OMP_SINGLE:
4517 return gfc_trans_omp_single (code, code->ext.omp_clauses);
4518 case EXEC_OMP_TARGET:
4519 case EXEC_OMP_TARGET_TEAMS:
4520 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4521 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4522 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4523 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4524 return gfc_trans_omp_target (code);
4525 case EXEC_OMP_TARGET_DATA:
4526 return gfc_trans_omp_target_data (code);
4527 case EXEC_OMP_TARGET_UPDATE:
4528 return gfc_trans_omp_target_update (code);
4529 case EXEC_OMP_TASK:
4530 return gfc_trans_omp_task (code);
4531 case EXEC_OMP_TASKGROUP:
4532 return gfc_trans_omp_taskgroup (code);
4533 case EXEC_OMP_TASKWAIT:
4534 return gfc_trans_omp_taskwait ();
4535 case EXEC_OMP_TASKYIELD:
4536 return gfc_trans_omp_taskyield ();
4537 case EXEC_OMP_TEAMS:
4538 case EXEC_OMP_TEAMS_DISTRIBUTE:
4539 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4540 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4541 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4542 return gfc_trans_omp_teams (code, NULL);
4543 case EXEC_OMP_WORKSHARE:
4544 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
4545 default:
4546 gcc_unreachable ();
4547 }
4548 }
4549
4550 void
4551 gfc_trans_omp_declare_simd (gfc_namespace *ns)
4552 {
4553 if (ns->entries)
4554 return;
4555
4556 gfc_omp_declare_simd *ods;
4557 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
4558 {
4559 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
4560 tree fndecl = ns->proc_name->backend_decl;
4561 if (c != NULL_TREE)
4562 c = tree_cons (NULL_TREE, c, NULL_TREE);
4563 c = build_tree_list (get_identifier ("omp declare simd"), c);
4564 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
4565 DECL_ATTRIBUTES (fndecl) = c;
4566 }
4567 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org