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