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