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