?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-12-18 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-openmp.c
blob227964cb2f6804d188238910bb41b9d6fa5164d8
1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2015 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;
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_FORCE_ALLOC:
2123 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
2124 break;
2125 case OMP_MAP_FORCE_DEALLOC:
2126 OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEALLOC);
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 construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
3501 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
3502 code->loc);
3503 }
3504 if (!loop_clauses.seq)
3505 pblock = &block;
3506 else
3507 pushlevel ();
3508 stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
3509 if (TREE_CODE (stmt) != BIND_EXPR)
3510 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3511 else
3512 poplevel (0, 0);
3513 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
3514 oacc_clauses);
3515 gfc_add_expr_to_block (&block, stmt);
3516 return gfc_finish_block (&block);
3517 }
3518
3519 static tree
3520 gfc_trans_omp_flush (void)
3521 {
3522 tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
3523 return build_call_expr_loc (input_location, decl, 0);
3524 }
3525
3526 static tree
3527 gfc_trans_omp_master (gfc_code *code)
3528 {
3529 tree stmt = gfc_trans_code (code->block->next);
3530 if (IS_EMPTY_STMT (stmt))
3531 return stmt;
3532 return build1_v (OMP_MASTER, stmt);
3533 }
3534
3535 static tree
3536 gfc_trans_omp_ordered (gfc_code *code)
3537 {
3538 return build2_loc (input_location, OMP_ORDERED, void_type_node,
3539 gfc_trans_code (code->block->next), NULL_TREE);
3540 }
3541
3542 static tree
3543 gfc_trans_omp_parallel (gfc_code *code)
3544 {
3545 stmtblock_t block;
3546 tree stmt, omp_clauses;
3547
3548 gfc_start_block (&block);
3549 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3550 code->loc);
3551 stmt = gfc_trans_omp_code (code->block->next, true);
3552 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3553 omp_clauses);
3554 gfc_add_expr_to_block (&block, stmt);
3555 return gfc_finish_block (&block);
3556 }
3557
3558 enum
3559 {
3560 GFC_OMP_SPLIT_SIMD,
3561 GFC_OMP_SPLIT_DO,
3562 GFC_OMP_SPLIT_PARALLEL,
3563 GFC_OMP_SPLIT_DISTRIBUTE,
3564 GFC_OMP_SPLIT_TEAMS,
3565 GFC_OMP_SPLIT_TARGET,
3566 GFC_OMP_SPLIT_NUM
3567 };
3568
3569 enum
3570 {
3571 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
3572 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
3573 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
3574 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
3575 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
3576 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET)
3577 };
3578
3579 static void
3580 gfc_split_omp_clauses (gfc_code *code,
3581 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
3582 {
3583 int mask = 0, innermost = 0;
3584 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
3585 switch (code->op)
3586 {
3587 case EXEC_OMP_DISTRIBUTE:
3588 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3589 break;
3590 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3591 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3592 innermost = GFC_OMP_SPLIT_DO;
3593 break;
3594 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3595 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
3596 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3597 innermost = GFC_OMP_SPLIT_SIMD;
3598 break;
3599 case EXEC_OMP_DISTRIBUTE_SIMD:
3600 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3601 innermost = GFC_OMP_SPLIT_SIMD;
3602 break;
3603 case EXEC_OMP_DO:
3604 innermost = GFC_OMP_SPLIT_DO;
3605 break;
3606 case EXEC_OMP_DO_SIMD:
3607 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3608 innermost = GFC_OMP_SPLIT_SIMD;
3609 break;
3610 case EXEC_OMP_PARALLEL:
3611 innermost = GFC_OMP_SPLIT_PARALLEL;
3612 break;
3613 case EXEC_OMP_PARALLEL_DO:
3614 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3615 innermost = GFC_OMP_SPLIT_DO;
3616 break;
3617 case EXEC_OMP_PARALLEL_DO_SIMD:
3618 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3619 innermost = GFC_OMP_SPLIT_SIMD;
3620 break;
3621 case EXEC_OMP_SIMD:
3622 innermost = GFC_OMP_SPLIT_SIMD;
3623 break;
3624 case EXEC_OMP_TARGET:
3625 innermost = GFC_OMP_SPLIT_TARGET;
3626 break;
3627 case EXEC_OMP_TARGET_TEAMS:
3628 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
3629 innermost = GFC_OMP_SPLIT_TEAMS;
3630 break;
3631 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3632 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3633 | GFC_OMP_MASK_DISTRIBUTE;
3634 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3635 break;
3636 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3637 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3638 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3639 innermost = GFC_OMP_SPLIT_DO;
3640 break;
3641 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3642 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3643 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3644 innermost = GFC_OMP_SPLIT_SIMD;
3645 break;
3646 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3647 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3648 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3649 innermost = GFC_OMP_SPLIT_SIMD;
3650 break;
3651 case EXEC_OMP_TEAMS:
3652 innermost = GFC_OMP_SPLIT_TEAMS;
3653 break;
3654 case EXEC_OMP_TEAMS_DISTRIBUTE:
3655 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
3656 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3657 break;
3658 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3659 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3660 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3661 innermost = GFC_OMP_SPLIT_DO;
3662 break;
3663 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3664 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3665 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3666 innermost = GFC_OMP_SPLIT_SIMD;
3667 break;
3668 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3669 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3670 innermost = GFC_OMP_SPLIT_SIMD;
3671 break;
3672 default:
3673 gcc_unreachable ();
3674 }
3675 if (mask == 0)
3676 {
3677 clausesa[innermost] = *code->ext.omp_clauses;
3678 return;
3679 }
3680 if (code->ext.omp_clauses != NULL)
3681 {
3682 if (mask & GFC_OMP_MASK_TARGET)
3683 {
3684 /* First the clauses that are unique to some constructs. */
3685 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
3686 = code->ext.omp_clauses->lists[OMP_LIST_MAP];
3687 clausesa[GFC_OMP_SPLIT_TARGET].device
3688 = code->ext.omp_clauses->device;
3689 }
3690 if (mask & GFC_OMP_MASK_TEAMS)
3691 {
3692 /* First the clauses that are unique to some constructs. */
3693 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
3694 = code->ext.omp_clauses->num_teams;
3695 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
3696 = code->ext.omp_clauses->thread_limit;
3697 /* Shared and default clauses are allowed on parallel and teams. */
3698 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
3699 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3700 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
3701 = code->ext.omp_clauses->default_sharing;
3702 }
3703 if (mask & GFC_OMP_MASK_DISTRIBUTE)
3704 {
3705 /* First the clauses that are unique to some constructs. */
3706 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
3707 = code->ext.omp_clauses->dist_sched_kind;
3708 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
3709 = code->ext.omp_clauses->dist_chunk_size;
3710 /* Duplicate collapse. */
3711 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
3712 = code->ext.omp_clauses->collapse;
3713 }
3714 if (mask & GFC_OMP_MASK_PARALLEL)
3715 {
3716 /* First the clauses that are unique to some constructs. */
3717 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
3718 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
3719 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
3720 = code->ext.omp_clauses->num_threads;
3721 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
3722 = code->ext.omp_clauses->proc_bind;
3723 /* Shared and default clauses are allowed on parallel and teams. */
3724 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
3725 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3726 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
3727 = code->ext.omp_clauses->default_sharing;
3728 }
3729 if (mask & GFC_OMP_MASK_DO)
3730 {
3731 /* First the clauses that are unique to some constructs. */
3732 clausesa[GFC_OMP_SPLIT_DO].ordered
3733 = code->ext.omp_clauses->ordered;
3734 clausesa[GFC_OMP_SPLIT_DO].sched_kind
3735 = code->ext.omp_clauses->sched_kind;
3736 clausesa[GFC_OMP_SPLIT_DO].chunk_size
3737 = code->ext.omp_clauses->chunk_size;
3738 clausesa[GFC_OMP_SPLIT_DO].nowait
3739 = code->ext.omp_clauses->nowait;
3740 /* Duplicate collapse. */
3741 clausesa[GFC_OMP_SPLIT_DO].collapse
3742 = code->ext.omp_clauses->collapse;
3743 }
3744 if (mask & GFC_OMP_MASK_SIMD)
3745 {
3746 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
3747 = code->ext.omp_clauses->safelen_expr;
3748 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LINEAR]
3749 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
3750 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
3751 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
3752 /* Duplicate collapse. */
3753 clausesa[GFC_OMP_SPLIT_SIMD].collapse
3754 = code->ext.omp_clauses->collapse;
3755 }
3756 /* Private clause is supported on all constructs but target,
3757 it is enough to put it on the innermost one. For
3758 !$ omp do put it on parallel though,
3759 as that's what we did for OpenMP 3.1. */
3760 clausesa[innermost == GFC_OMP_SPLIT_DO
3761 ? (int) GFC_OMP_SPLIT_PARALLEL
3762 : innermost].lists[OMP_LIST_PRIVATE]
3763 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
3764 /* Firstprivate clause is supported on all constructs but
3765 target and simd. Put it on the outermost of those and
3766 duplicate on parallel. */
3767 if (mask & GFC_OMP_MASK_TEAMS)
3768 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
3769 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3770 else if (mask & GFC_OMP_MASK_DISTRIBUTE)
3771 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
3772 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3773 if (mask & GFC_OMP_MASK_PARALLEL)
3774 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
3775 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3776 else if (mask & GFC_OMP_MASK_DO)
3777 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
3778 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3779 /* Lastprivate is allowed on do and simd. In
3780 parallel do{, simd} we actually want to put it on
3781 parallel rather than do. */
3782 if (mask & GFC_OMP_MASK_PARALLEL)
3783 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
3784 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3785 else if (mask & GFC_OMP_MASK_DO)
3786 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
3787 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3788 if (mask & GFC_OMP_MASK_SIMD)
3789 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
3790 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3791 /* Reduction is allowed on simd, do, parallel and teams.
3792 Duplicate it on all of them, but omit on do if
3793 parallel is present. */
3794 if (mask & GFC_OMP_MASK_TEAMS)
3795 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION]
3796 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3797 if (mask & GFC_OMP_MASK_PARALLEL)
3798 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
3799 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3800 else if (mask & GFC_OMP_MASK_DO)
3801 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
3802 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3803 if (mask & GFC_OMP_MASK_SIMD)
3804 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
3805 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3806 /* FIXME: This is currently being discussed. */
3807 if (mask & GFC_OMP_MASK_PARALLEL)
3808 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
3809 = code->ext.omp_clauses->if_expr;
3810 else
3811 clausesa[GFC_OMP_SPLIT_TARGET].if_expr
3812 = code->ext.omp_clauses->if_expr;
3813 }
3814 if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3815 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3816 clausesa[GFC_OMP_SPLIT_DO].nowait = true;
3817 }
3818
3819 static tree
3820 gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
3821 gfc_omp_clauses *clausesa, tree omp_clauses)
3822 {
3823 stmtblock_t block;
3824 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3825 tree stmt, body, omp_do_clauses = NULL_TREE;
3826
3827 if (pblock == NULL)
3828 gfc_start_block (&block);
3829 else
3830 gfc_init_block (&block);
3831
3832 if (clausesa == NULL)
3833 {
3834 clausesa = clausesa_buf;
3835 gfc_split_omp_clauses (code, clausesa);
3836 }
3837 if (flag_openmp)
3838 omp_do_clauses
3839 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
3840 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
3841 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
3842 if (pblock == NULL)
3843 {
3844 if (TREE_CODE (body) != BIND_EXPR)
3845 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
3846 else
3847 poplevel (0, 0);
3848 }
3849 else if (TREE_CODE (body) != BIND_EXPR)
3850 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
3851 if (flag_openmp)
3852 {
3853 stmt = make_node (OMP_FOR);
3854 TREE_TYPE (stmt) = void_type_node;
3855 OMP_FOR_BODY (stmt) = body;
3856 OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
3857 }
3858 else
3859 stmt = body;
3860 gfc_add_expr_to_block (&block, stmt);
3861 return gfc_finish_block (&block);
3862 }
3863
3864 static tree
3865 gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock,
3866 gfc_omp_clauses *clausesa)
3867 {
3868 stmtblock_t block, *new_pblock = pblock;
3869 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3870 tree stmt, omp_clauses = NULL_TREE;
3871
3872 if (pblock == NULL)
3873 gfc_start_block (&block);
3874 else
3875 gfc_init_block (&block);
3876
3877 if (clausesa == NULL)
3878 {
3879 clausesa = clausesa_buf;
3880 gfc_split_omp_clauses (code, clausesa);
3881 }
3882 omp_clauses
3883 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3884 code->loc);
3885 if (pblock == NULL)
3886 {
3887 if (!clausesa[GFC_OMP_SPLIT_DO].ordered
3888 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
3889 new_pblock = &block;
3890 else
3891 pushlevel ();
3892 }
3893 stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock,
3894 &clausesa[GFC_OMP_SPLIT_DO], omp_clauses);
3895 if (pblock == NULL)
3896 {
3897 if (TREE_CODE (stmt) != BIND_EXPR)
3898 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3899 else
3900 poplevel (0, 0);
3901 }
3902 else if (TREE_CODE (stmt) != BIND_EXPR)
3903 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
3904 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3905 omp_clauses);
3906 OMP_PARALLEL_COMBINED (stmt) = 1;
3907 gfc_add_expr_to_block (&block, stmt);
3908 return gfc_finish_block (&block);
3909 }
3910
3911 static tree
3912 gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
3913 gfc_omp_clauses *clausesa)
3914 {
3915 stmtblock_t block;
3916 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3917 tree stmt, omp_clauses = NULL_TREE;
3918
3919 if (pblock == NULL)
3920 gfc_start_block (&block);
3921 else
3922 gfc_init_block (&block);
3923
3924 if (clausesa == NULL)
3925 {
3926 clausesa = clausesa_buf;
3927 gfc_split_omp_clauses (code, clausesa);
3928 }
3929 if (flag_openmp)
3930 omp_clauses
3931 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3932 code->loc);
3933 if (pblock == NULL)
3934 pushlevel ();
3935 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
3936 if (pblock == NULL)
3937 {
3938 if (TREE_CODE (stmt) != BIND_EXPR)
3939 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3940 else
3941 poplevel (0, 0);
3942 }
3943 else if (TREE_CODE (stmt) != BIND_EXPR)
3944 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
3945 if (flag_openmp)
3946 {
3947 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3948 omp_clauses);
3949 OMP_PARALLEL_COMBINED (stmt) = 1;
3950 }
3951 gfc_add_expr_to_block (&block, stmt);
3952 return gfc_finish_block (&block);
3953 }
3954
3955 static tree
3956 gfc_trans_omp_parallel_sections (gfc_code *code)
3957 {
3958 stmtblock_t block;
3959 gfc_omp_clauses section_clauses;
3960 tree stmt, omp_clauses;
3961
3962 memset (&section_clauses, 0, sizeof (section_clauses));
3963 section_clauses.nowait = true;
3964
3965 gfc_start_block (&block);
3966 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3967 code->loc);
3968 pushlevel ();
3969 stmt = gfc_trans_omp_sections (code, &section_clauses);
3970 if (TREE_CODE (stmt) != BIND_EXPR)
3971 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3972 else
3973 poplevel (0, 0);
3974 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3975 omp_clauses);
3976 OMP_PARALLEL_COMBINED (stmt) = 1;
3977 gfc_add_expr_to_block (&block, stmt);
3978 return gfc_finish_block (&block);
3979 }
3980
3981 static tree
3982 gfc_trans_omp_parallel_workshare (gfc_code *code)
3983 {
3984 stmtblock_t block;
3985 gfc_omp_clauses workshare_clauses;
3986 tree stmt, omp_clauses;
3987
3988 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
3989 workshare_clauses.nowait = true;
3990
3991 gfc_start_block (&block);
3992 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3993 code->loc);
3994 pushlevel ();
3995 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
3996 if (TREE_CODE (stmt) != BIND_EXPR)
3997 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3998 else
3999 poplevel (0, 0);
4000 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
4001 omp_clauses);
4002 OMP_PARALLEL_COMBINED (stmt) = 1;
4003 gfc_add_expr_to_block (&block, stmt);
4004 return gfc_finish_block (&block);
4005 }
4006
4007 static tree
4008 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
4009 {
4010 stmtblock_t block, body;
4011 tree omp_clauses, stmt;
4012 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
4013
4014 gfc_start_block (&block);
4015
4016 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
4017
4018 gfc_init_block (&body);
4019 for (code = code->block; code; code = code->block)
4020 {
4021 /* Last section is special because of lastprivate, so even if it
4022 is empty, chain it in. */
4023 stmt = gfc_trans_omp_code (code->next,
4024 has_lastprivate && code->block == NULL);
4025 if (! IS_EMPTY_STMT (stmt))
4026 {
4027 stmt = build1_v (OMP_SECTION, stmt);
4028 gfc_add_expr_to_block (&body, stmt);
4029 }
4030 }
4031 stmt = gfc_finish_block (&body);
4032
4033 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
4034 omp_clauses);
4035 gfc_add_expr_to_block (&block, stmt);
4036
4037 return gfc_finish_block (&block);
4038 }
4039
4040 static tree
4041 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
4042 {
4043 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
4044 tree stmt = gfc_trans_omp_code (code->block->next, true);
4045 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
4046 omp_clauses);
4047 return stmt;
4048 }
4049
4050 static tree
4051 gfc_trans_omp_task (gfc_code *code)
4052 {
4053 stmtblock_t block;
4054 tree stmt, omp_clauses;
4055
4056 gfc_start_block (&block);
4057 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4058 code->loc);
4059 stmt = gfc_trans_omp_code (code->block->next, true);
4060 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
4061 omp_clauses);
4062 gfc_add_expr_to_block (&block, stmt);
4063 return gfc_finish_block (&block);
4064 }
4065
4066 static tree
4067 gfc_trans_omp_taskgroup (gfc_code *code)
4068 {
4069 tree stmt = gfc_trans_code (code->block->next);
4070 return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt);
4071 }
4072
4073 static tree
4074 gfc_trans_omp_taskwait (void)
4075 {
4076 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
4077 return build_call_expr_loc (input_location, decl, 0);
4078 }
4079
4080 static tree
4081 gfc_trans_omp_taskyield (void)
4082 {
4083 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
4084 return build_call_expr_loc (input_location, decl, 0);
4085 }
4086
4087 static tree
4088 gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
4089 {
4090 stmtblock_t block;
4091 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4092 tree stmt, omp_clauses = NULL_TREE;
4093
4094 gfc_start_block (&block);
4095 if (clausesa == NULL)
4096 {
4097 clausesa = clausesa_buf;
4098 gfc_split_omp_clauses (code, clausesa);
4099 }
4100 if (flag_openmp)
4101 omp_clauses
4102 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4103 code->loc);
4104 switch (code->op)
4105 {
4106 case EXEC_OMP_DISTRIBUTE:
4107 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4108 case EXEC_OMP_TEAMS_DISTRIBUTE:
4109 /* This is handled in gfc_trans_omp_do. */
4110 gcc_unreachable ();
4111 break;
4112 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4113 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4114 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4115 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa);
4116 if (TREE_CODE (stmt) != BIND_EXPR)
4117 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4118 else
4119 poplevel (0, 0);
4120 break;
4121 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4122 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4123 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4124 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
4125 if (TREE_CODE (stmt) != BIND_EXPR)
4126 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4127 else
4128 poplevel (0, 0);
4129 break;
4130 case EXEC_OMP_DISTRIBUTE_SIMD:
4131 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4132 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4133 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4134 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4135 if (TREE_CODE (stmt) != BIND_EXPR)
4136 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4137 else
4138 poplevel (0, 0);
4139 break;
4140 default:
4141 gcc_unreachable ();
4142 }
4143 if (flag_openmp)
4144 {
4145 tree distribute = make_node (OMP_DISTRIBUTE);
4146 TREE_TYPE (distribute) = void_type_node;
4147 OMP_FOR_BODY (distribute) = stmt;
4148 OMP_FOR_CLAUSES (distribute) = omp_clauses;
4149 stmt = distribute;
4150 }
4151 gfc_add_expr_to_block (&block, stmt);
4152 return gfc_finish_block (&block);
4153 }
4154
4155 static tree
4156 gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa)
4157 {
4158 stmtblock_t block;
4159 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4160 tree stmt, omp_clauses = NULL_TREE;
4161 bool combined = true;
4162
4163 gfc_start_block (&block);
4164 if (clausesa == NULL)
4165 {
4166 clausesa = clausesa_buf;
4167 gfc_split_omp_clauses (code, clausesa);
4168 }
4169 if (flag_openmp)
4170 omp_clauses
4171 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS],
4172 code->loc);
4173 switch (code->op)
4174 {
4175 case EXEC_OMP_TARGET_TEAMS:
4176 case EXEC_OMP_TEAMS:
4177 stmt = gfc_trans_omp_code (code->block->next, true);
4178 combined = false;
4179 break;
4180 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4181 case EXEC_OMP_TEAMS_DISTRIBUTE:
4182 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
4183 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4184 NULL);
4185 break;
4186 default:
4187 stmt = gfc_trans_omp_distribute (code, clausesa);
4188 break;
4189 }
4190 stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt,
4191 omp_clauses);
4192 if (combined)
4193 OMP_TEAMS_COMBINED (stmt) = 1;
4194 gfc_add_expr_to_block (&block, stmt);
4195 return gfc_finish_block (&block);
4196 }
4197
4198 static tree
4199 gfc_trans_omp_target (gfc_code *code)
4200 {
4201 stmtblock_t block;
4202 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
4203 tree stmt, omp_clauses = NULL_TREE;
4204
4205 gfc_start_block (&block);
4206 gfc_split_omp_clauses (code, clausesa);
4207 if (flag_openmp)
4208 omp_clauses
4209 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
4210 code->loc);
4211 if (code->op == EXEC_OMP_TARGET)
4212 stmt = gfc_trans_omp_code (code->block->next, true);
4213 else
4214 {
4215 pushlevel ();
4216 stmt = gfc_trans_omp_teams (code, clausesa);
4217 if (TREE_CODE (stmt) != BIND_EXPR)
4218 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4219 else
4220 poplevel (0, 0);
4221 }
4222 if (flag_openmp)
4223 stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt,
4224 omp_clauses);
4225 gfc_add_expr_to_block (&block, stmt);
4226 return gfc_finish_block (&block);
4227 }
4228
4229 static tree
4230 gfc_trans_omp_target_data (gfc_code *code)
4231 {
4232 stmtblock_t block;
4233 tree stmt, omp_clauses;
4234
4235 gfc_start_block (&block);
4236 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4237 code->loc);
4238 stmt = gfc_trans_omp_code (code->block->next, true);
4239 stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt,
4240 omp_clauses);
4241 gfc_add_expr_to_block (&block, stmt);
4242 return gfc_finish_block (&block);
4243 }
4244
4245 static tree
4246 gfc_trans_omp_target_update (gfc_code *code)
4247 {
4248 stmtblock_t block;
4249 tree stmt, omp_clauses;
4250
4251 gfc_start_block (&block);
4252 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4253 code->loc);
4254 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
4255 omp_clauses);
4256 gfc_add_expr_to_block (&block, stmt);
4257 return gfc_finish_block (&block);
4258 }
4259
4260 static tree
4261 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
4262 {
4263 tree res, tmp, stmt;
4264 stmtblock_t block, *pblock = NULL;
4265 stmtblock_t singleblock;
4266 int saved_ompws_flags;
4267 bool singleblock_in_progress = false;
4268 /* True if previous gfc_code in workshare construct is not workshared. */
4269 bool prev_singleunit;
4270
4271 code = code->block->next;
4272
4273 pushlevel ();
4274
4275 gfc_start_block (&block);
4276 pblock = &block;
4277
4278 ompws_flags = OMPWS_WORKSHARE_FLAG;
4279 prev_singleunit = false;
4280
4281 /* Translate statements one by one to trees until we reach
4282 the end of the workshare construct. Adjacent gfc_codes that
4283 are a single unit of work are clustered and encapsulated in a
4284 single OMP_SINGLE construct. */
4285 for (; code; code = code->next)
4286 {
4287 if (code->here != 0)
4288 {
4289 res = gfc_trans_label_here (code);
4290 gfc_add_expr_to_block (pblock, res);
4291 }
4292
4293 /* No dependence analysis, use for clauses with wait.
4294 If this is the last gfc_code, use default omp_clauses. */
4295 if (code->next == NULL && clauses->nowait)
4296 ompws_flags |= OMPWS_NOWAIT;
4297
4298 /* By default, every gfc_code is a single unit of work. */
4299 ompws_flags |= OMPWS_CURR_SINGLEUNIT;
4300 ompws_flags &= ~OMPWS_SCALARIZER_WS;
4301
4302 switch (code->op)
4303 {
4304 case EXEC_NOP:
4305 res = NULL_TREE;
4306 break;
4307
4308 case EXEC_ASSIGN:
4309 res = gfc_trans_assign (code);
4310 break;
4311
4312 case EXEC_POINTER_ASSIGN:
4313 res = gfc_trans_pointer_assign (code);
4314 break;
4315
4316 case EXEC_INIT_ASSIGN:
4317 res = gfc_trans_init_assign (code);
4318 break;
4319
4320 case EXEC_FORALL:
4321 res = gfc_trans_forall (code);
4322 break;
4323
4324 case EXEC_WHERE:
4325 res = gfc_trans_where (code);
4326 break;
4327
4328 case EXEC_OMP_ATOMIC:
4329 res = gfc_trans_omp_directive (code);
4330 break;
4331
4332 case EXEC_OMP_PARALLEL:
4333 case EXEC_OMP_PARALLEL_DO:
4334 case EXEC_OMP_PARALLEL_SECTIONS:
4335 case EXEC_OMP_PARALLEL_WORKSHARE:
4336 case EXEC_OMP_CRITICAL:
4337 saved_ompws_flags = ompws_flags;
4338 ompws_flags = 0;
4339 res = gfc_trans_omp_directive (code);
4340 ompws_flags = saved_ompws_flags;
4341 break;
4342
4343 default:
4344 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
4345 }
4346
4347 gfc_set_backend_locus (&code->loc);
4348
4349 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
4350 {
4351 if (prev_singleunit)
4352 {
4353 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4354 /* Add current gfc_code to single block. */
4355 gfc_add_expr_to_block (&singleblock, res);
4356 else
4357 {
4358 /* Finish single block and add it to pblock. */
4359 tmp = gfc_finish_block (&singleblock);
4360 tmp = build2_loc (input_location, OMP_SINGLE,
4361 void_type_node, tmp, NULL_TREE);
4362 gfc_add_expr_to_block (pblock, tmp);
4363 /* Add current gfc_code to pblock. */
4364 gfc_add_expr_to_block (pblock, res);
4365 singleblock_in_progress = false;
4366 }
4367 }
4368 else
4369 {
4370 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4371 {
4372 /* Start single block. */
4373 gfc_init_block (&singleblock);
4374 gfc_add_expr_to_block (&singleblock, res);
4375 singleblock_in_progress = true;
4376 }
4377 else
4378 /* Add the new statement to the block. */
4379 gfc_add_expr_to_block (pblock, res);
4380 }
4381 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
4382 }
4383 }
4384
4385 /* Finish remaining SINGLE block, if we were in the middle of one. */
4386 if (singleblock_in_progress)
4387 {
4388 /* Finish single block and add it to pblock. */
4389 tmp = gfc_finish_block (&singleblock);
4390 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
4391 clauses->nowait
4392 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
4393 : NULL_TREE);
4394 gfc_add_expr_to_block (pblock, tmp);
4395 }
4396
4397 stmt = gfc_finish_block (pblock);
4398 if (TREE_CODE (stmt) != BIND_EXPR)
4399 {
4400 if (!IS_EMPTY_STMT (stmt))
4401 {
4402 tree bindblock = poplevel (1, 0);
4403 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
4404 }
4405 else
4406 poplevel (0, 0);
4407 }
4408 else
4409 poplevel (0, 0);
4410
4411 if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
4412 stmt = gfc_trans_omp_barrier ();
4413
4414 ompws_flags = 0;
4415 return stmt;
4416 }
4417
4418 tree
4419 gfc_trans_oacc_declare (gfc_code *code)
4420 {
4421 stmtblock_t block;
4422 tree stmt, oacc_clauses;
4423 enum tree_code construct_code;
4424
4425 construct_code = OACC_DATA;
4426
4427 gfc_start_block (&block);
4428
4429 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
4430 code->loc);
4431 stmt = gfc_trans_omp_code (code->block->next, true);
4432 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
4433 oacc_clauses);
4434 gfc_add_expr_to_block (&block, stmt);
4435
4436 return gfc_finish_block (&block);
4437 }
4438
4439 tree
4440 gfc_trans_oacc_directive (gfc_code *code)
4441 {
4442 switch (code->op)
4443 {
4444 case EXEC_OACC_PARALLEL_LOOP:
4445 case EXEC_OACC_KERNELS_LOOP:
4446 return gfc_trans_oacc_combined_directive (code);
4447 case EXEC_OACC_PARALLEL:
4448 case EXEC_OACC_KERNELS:
4449 case EXEC_OACC_DATA:
4450 case EXEC_OACC_HOST_DATA:
4451 return gfc_trans_oacc_construct (code);
4452 case EXEC_OACC_LOOP:
4453 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4454 NULL);
4455 case EXEC_OACC_UPDATE:
4456 case EXEC_OACC_CACHE:
4457 case EXEC_OACC_ENTER_DATA:
4458 case EXEC_OACC_EXIT_DATA:
4459 return gfc_trans_oacc_executable_directive (code);
4460 case EXEC_OACC_WAIT:
4461 return gfc_trans_oacc_wait_directive (code);
4462 case EXEC_OACC_ATOMIC:
4463 return gfc_trans_omp_atomic (code);
4464 case EXEC_OACC_DECLARE:
4465 return gfc_trans_oacc_declare (code);
4466 default:
4467 gcc_unreachable ();
4468 }
4469 }
4470
4471 tree
4472 gfc_trans_omp_directive (gfc_code *code)
4473 {
4474 switch (code->op)
4475 {
4476 case EXEC_OMP_ATOMIC:
4477 return gfc_trans_omp_atomic (code);
4478 case EXEC_OMP_BARRIER:
4479 return gfc_trans_omp_barrier ();
4480 case EXEC_OMP_CANCEL:
4481 return gfc_trans_omp_cancel (code);
4482 case EXEC_OMP_CANCELLATION_POINT:
4483 return gfc_trans_omp_cancellation_point (code);
4484 case EXEC_OMP_CRITICAL:
4485 return gfc_trans_omp_critical (code);
4486 case EXEC_OMP_DISTRIBUTE:
4487 case EXEC_OMP_DO:
4488 case EXEC_OMP_SIMD:
4489 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4490 NULL);
4491 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4492 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4493 case EXEC_OMP_DISTRIBUTE_SIMD:
4494 return gfc_trans_omp_distribute (code, NULL);
4495 case EXEC_OMP_DO_SIMD:
4496 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
4497 case EXEC_OMP_FLUSH:
4498 return gfc_trans_omp_flush ();
4499 case EXEC_OMP_MASTER:
4500 return gfc_trans_omp_master (code);
4501 case EXEC_OMP_ORDERED:
4502 return gfc_trans_omp_ordered (code);
4503 case EXEC_OMP_PARALLEL:
4504 return gfc_trans_omp_parallel (code);
4505 case EXEC_OMP_PARALLEL_DO:
4506 return gfc_trans_omp_parallel_do (code, NULL, NULL);
4507 case EXEC_OMP_PARALLEL_DO_SIMD:
4508 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
4509 case EXEC_OMP_PARALLEL_SECTIONS:
4510 return gfc_trans_omp_parallel_sections (code);
4511 case EXEC_OMP_PARALLEL_WORKSHARE:
4512 return gfc_trans_omp_parallel_workshare (code);
4513 case EXEC_OMP_SECTIONS:
4514 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
4515 case EXEC_OMP_SINGLE:
4516 return gfc_trans_omp_single (code, code->ext.omp_clauses);
4517 case EXEC_OMP_TARGET:
4518 case EXEC_OMP_TARGET_TEAMS:
4519 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4520 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4521 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4522 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4523 return gfc_trans_omp_target (code);
4524 case EXEC_OMP_TARGET_DATA:
4525 return gfc_trans_omp_target_data (code);
4526 case EXEC_OMP_TARGET_UPDATE:
4527 return gfc_trans_omp_target_update (code);
4528 case EXEC_OMP_TASK:
4529 return gfc_trans_omp_task (code);
4530 case EXEC_OMP_TASKGROUP:
4531 return gfc_trans_omp_taskgroup (code);
4532 case EXEC_OMP_TASKWAIT:
4533 return gfc_trans_omp_taskwait ();
4534 case EXEC_OMP_TASKYIELD:
4535 return gfc_trans_omp_taskyield ();
4536 case EXEC_OMP_TEAMS:
4537 case EXEC_OMP_TEAMS_DISTRIBUTE:
4538 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4539 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4540 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4541 return gfc_trans_omp_teams (code, NULL);
4542 case EXEC_OMP_WORKSHARE:
4543 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
4544 default:
4545 gcc_unreachable ();
4546 }
4547 }
4548
4549 void
4550 gfc_trans_omp_declare_simd (gfc_namespace *ns)
4551 {
4552 if (ns->entries)
4553 return;
4554
4555 gfc_omp_declare_simd *ods;
4556 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
4557 {
4558 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
4559 tree fndecl = ns->proc_name->backend_decl;
4560 if (c != NULL_TREE)
4561 c = tree_cons (NULL_TREE, c, NULL_TREE);
4562 c = build_tree_list (get_identifier ("omp declare simd"), c);
4563 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
4564 DECL_ATTRIBUTES (fndecl) = c;
4565 }
4566 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org