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