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