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