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