Line data Source code
1 : /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 : Copyright (C) 2005-2026 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 "basic-block.h"
29 : #include "tree-ssa.h"
30 : #include "function.h"
31 : #include "gimple.h"
32 : #include "gimple-expr.h"
33 : #include "trans.h"
34 : #include "stringpool.h"
35 : #include "fold-const.h"
36 : #include "gimplify.h" /* For create_tmp_var_raw. */
37 : #include "trans-stmt.h"
38 : #include "trans-types.h"
39 : #include "trans-array.h"
40 : #include "trans-const.h"
41 : #include "arith.h"
42 : #include "constructor.h"
43 : #include "gomp-constants.h"
44 : #include "omp-general.h"
45 : #include "omp-low.h"
46 : #include "memmodel.h" /* For MEMMODEL_ enums. */
47 : #include "dependency.h"
48 : #include "gimple-iterator.h" /* For gsi_iterator_update. */
49 : #include "gimplify-me.h" /* For force_gimple_operand. */
50 :
51 : #undef GCC_DIAG_STYLE
52 : #define GCC_DIAG_STYLE __gcc_tdiag__
53 : #include "diagnostic-core.h"
54 : #undef GCC_DIAG_STYLE
55 : #define GCC_DIAG_STYLE __gcc_gfc__
56 : #include "attribs.h"
57 : #include "function.h"
58 :
59 : int ompws_flags;
60 :
61 : /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
62 : allocatable or pointer attribute. */
63 :
64 : bool
65 5964 : gfc_omp_is_allocatable_or_ptr (const_tree decl)
66 : {
67 5964 : return (DECL_P (decl)
68 5964 : && (GFC_DECL_GET_SCALAR_POINTER (decl)
69 4233 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)));
70 : }
71 :
72 : /* True if the argument is an optional argument; except that false is also
73 : returned for arguments with the value attribute (nonpointers) and for
74 : assumed-shape variables (decl is a local variable containing arg->data).
75 : Note that for 'procedure(), optional' the value false is used as that's
76 : always a pointer and no additional indirection is used.
77 : Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */
78 :
79 : static bool
80 46332 : gfc_omp_is_optional_argument (const_tree decl)
81 : {
82 : /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
83 30531 : return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl))
84 46332 : && DECL_LANG_SPECIFIC (decl)
85 20813 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
86 20629 : && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
87 20394 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE
88 66701 : && GFC_DECL_OPTIONAL_ARGUMENT (decl));
89 : }
90 :
91 : /* Check whether this DECL belongs to a Fortran optional argument.
92 : With 'for_present_check' set to false, decls which are optional parameters
93 : themselves are returned as tree - or a NULL_TREE otherwise. Those decls are
94 : always pointers. With 'for_present_check' set to true, the decl for checking
95 : whether an argument is present is returned; for arguments with value
96 : attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is
97 : unrelated to optional arguments, NULL_TREE is returned. */
98 :
99 : tree
100 22206 : gfc_omp_check_optional_argument (tree decl, bool for_present_check)
101 : {
102 22206 : if (!for_present_check)
103 2175 : return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE;
104 :
105 20031 : if (!DECL_LANG_SPECIFIC (decl))
106 : return NULL_TREE;
107 :
108 5358 : tree orig_decl = decl;
109 :
110 : /* For assumed-shape arrays, a local decl with arg->data is used. */
111 5358 : if (TREE_CODE (decl) != PARM_DECL
112 5358 : && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
113 1954 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))))
114 745 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
115 :
116 : /* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */
117 5358 : if (decl == NULL_TREE
118 5221 : || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL)
119 5221 : || !DECL_LANG_SPECIFIC (decl)
120 10174 : || !GFC_DECL_OPTIONAL_ARGUMENT (decl))
121 : return NULL_TREE;
122 :
123 : /* Scalars with VALUE attribute which are passed by value use a hidden
124 : argument to denote the present status. They are passed as nonpointer type
125 : with one exception: 'type(c_ptr), value' as 'void*'. */
126 : /* Cf. trans-expr.cc's gfc_conv_expr_present. */
127 2834 : if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
128 2834 : || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
129 : {
130 205 : char name[GFC_MAX_SYMBOL_LEN + 2];
131 205 : tree tree_name;
132 :
133 205 : name[0] = '.';
134 205 : strcpy (&name[1], IDENTIFIER_POINTER (DECL_NAME (decl)));
135 205 : tree_name = get_identifier (name);
136 :
137 : /* Walk function argument list to find the hidden arg. */
138 205 : decl = DECL_ARGUMENTS (DECL_CONTEXT (decl));
139 1437 : for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl))
140 1437 : if (DECL_NAME (decl) == tree_name
141 1437 : && DECL_ARTIFICIAL (decl))
142 : break;
143 :
144 205 : gcc_assert (decl);
145 205 : return decl;
146 : }
147 :
148 2629 : return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
149 2629 : orig_decl, null_pointer_node);
150 : }
151 :
152 :
153 : /* Returns tree with NULL if it is not an array descriptor and with the tree to
154 : access the 'data' component otherwise. With type_only = true, it returns the
155 : TREE_TYPE without creating a new tree. */
156 :
157 : tree
158 18967 : gfc_omp_array_data (tree decl, bool type_only)
159 : {
160 18967 : tree type = TREE_TYPE (decl);
161 :
162 18967 : if (POINTER_TYPE_P (type))
163 10206 : type = TREE_TYPE (type);
164 :
165 18967 : if (!GFC_DESCRIPTOR_TYPE_P (type))
166 : return NULL_TREE;
167 :
168 4577 : if (type_only)
169 3356 : return GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
170 :
171 1221 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
172 415 : decl = build_fold_indirect_ref (decl);
173 :
174 1221 : decl = gfc_conv_descriptor_data_get (decl);
175 1221 : STRIP_NOPS (decl);
176 1221 : return decl;
177 : }
178 :
179 : /* Return the byte-size of the passed array descriptor. */
180 :
181 : tree
182 19 : gfc_omp_array_size (tree decl, gimple_seq *pre_p)
183 : {
184 19 : stmtblock_t block;
185 19 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
186 19 : decl = build_fold_indirect_ref (decl);
187 19 : tree type = TREE_TYPE (decl);
188 19 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
189 19 : bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
190 2 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
191 19 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT);
192 19 : gfc_init_block (&block);
193 57 : tree size = gfc_full_array_size (&block, decl,
194 19 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)));
195 19 : size = fold_convert (size_type_node, size);
196 19 : tree elemsz = gfc_get_element_type (TREE_TYPE (decl));
197 19 : if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz))
198 6 : elemsz = gfc_conv_descriptor_elem_len (decl);
199 : else
200 13 : elemsz = TYPE_SIZE_UNIT (elemsz);
201 19 : size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz);
202 19 : if (!allocatable)
203 0 : gimplify_and_add (gfc_finish_block (&block), pre_p);
204 : else
205 : {
206 19 : tree var = create_tmp_var (size_type_node);
207 19 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size));
208 19 : tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
209 : gfc_conv_descriptor_data_get (decl),
210 : null_pointer_node);
211 19 : tmp = build3_loc (input_location, COND_EXPR, void_type_node, tmp,
212 : gfc_finish_block (&block),
213 : build2 (MODIFY_EXPR, sizetype, var, size_zero_node));
214 19 : gimplify_and_add (tmp, pre_p);
215 19 : size = var;
216 : }
217 19 : return size;
218 : }
219 :
220 :
221 : /* True if OpenMP should privatize what this DECL points to rather
222 : than the DECL itself. */
223 :
224 : bool
225 458154 : gfc_omp_privatize_by_reference (const_tree decl)
226 : {
227 458154 : tree type = TREE_TYPE (decl);
228 :
229 458154 : if (TREE_CODE (type) == REFERENCE_TYPE
230 458154 : && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
231 : return true;
232 :
233 435333 : if (TREE_CODE (type) == POINTER_TYPE
234 435333 : && gfc_omp_is_optional_argument (decl))
235 : return true;
236 :
237 426248 : if (TREE_CODE (type) == POINTER_TYPE)
238 : {
239 32919 : while (TREE_CODE (decl) == COMPONENT_REF)
240 0 : decl = TREE_OPERAND (decl, 1);
241 :
242 : /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
243 : that have POINTER_TYPE type and aren't scalar pointers, scalar
244 : allocatables, Cray pointees or C pointers are supposed to be
245 : privatized by reference. */
246 32919 : if (GFC_DECL_GET_SCALAR_POINTER (decl)
247 31404 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
248 29051 : || GFC_DECL_CRAY_POINTEE (decl)
249 29045 : || GFC_DECL_ASSOCIATE_VAR_P (decl)
250 38432 : || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
251 : return false;
252 :
253 20986 : if (!DECL_ARTIFICIAL (decl)
254 20986 : && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
255 : return true;
256 :
257 : /* Some arrays are expanded as DECL_ARTIFICIAL pointers
258 : by the frontend. */
259 13533 : if (DECL_LANG_SPECIFIC (decl)
260 13533 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
261 : return true;
262 : }
263 :
264 : return false;
265 : }
266 :
267 : /* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
268 : of DECL is predetermined. */
269 :
270 : enum omp_clause_default_kind
271 8455 : gfc_omp_predetermined_sharing (tree decl)
272 : {
273 : /* Associate names preserve the association established during ASSOCIATE.
274 : As they are implemented either as pointers to the selector or array
275 : descriptor and shouldn't really change in the ASSOCIATE region,
276 : this decl can be either shared or firstprivate. If it is a pointer,
277 : use firstprivate, as it is cheaper that way, otherwise make it shared. */
278 8455 : if (GFC_DECL_ASSOCIATE_VAR_P (decl))
279 : {
280 45 : if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
281 : return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
282 : else
283 18 : return OMP_CLAUSE_DEFAULT_SHARED;
284 : }
285 :
286 8410 : if (DECL_ARTIFICIAL (decl)
287 1588 : && ! GFC_DECL_RESULT (decl)
288 9974 : && ! (DECL_LANG_SPECIFIC (decl)
289 375 : && GFC_DECL_SAVED_DESCRIPTOR (decl)))
290 : return OMP_CLAUSE_DEFAULT_SHARED;
291 :
292 : /* Cray pointees shouldn't be listed in any clauses and should be
293 : gimplified to dereference of the corresponding Cray pointer.
294 : Make them all private, so that they are emitted in the debug
295 : information. */
296 7172 : if (GFC_DECL_CRAY_POINTEE (decl))
297 : return OMP_CLAUSE_DEFAULT_PRIVATE;
298 :
299 : /* Assumed-size arrays are predetermined shared. */
300 7136 : if (TREE_CODE (decl) == PARM_DECL
301 1963 : && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
302 716 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
303 7852 : && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
304 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
305 : == NULL)
306 : return OMP_CLAUSE_DEFAULT_SHARED;
307 :
308 : /* Dummy procedures aren't considered variables by OpenMP, thus are
309 : disallowed in OpenMP clauses. They are represented as PARM_DECLs
310 : in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
311 : to avoid complaining about their uses with default(none). */
312 7068 : if (TREE_CODE (decl) == PARM_DECL
313 1895 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
314 7853 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
315 : return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
316 :
317 : /* COMMON and EQUIVALENCE decls are shared. They
318 : are only referenced through DECL_VALUE_EXPR of the variables
319 : contained in them. If those are privatized, they will not be
320 : gimplified to the COMMON or EQUIVALENCE decls. */
321 7052 : if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
322 : return OMP_CLAUSE_DEFAULT_SHARED;
323 :
324 7023 : if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
325 : return OMP_CLAUSE_DEFAULT_SHARED;
326 :
327 : /* These are either array or derived parameters, or vtables.
328 : In the former cases, the OpenMP standard doesn't consider them to be
329 : variables at all (they can't be redefined), but they can nevertheless appear
330 : in parallel/task regions and for default(none) purposes treat them as shared.
331 : For vtables likely the same handling is desirable. */
332 5120 : if (VAR_P (decl) && TREE_READONLY (decl)
333 7002 : && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
334 3 : return OMP_CLAUSE_DEFAULT_SHARED;
335 :
336 : return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
337 : }
338 :
339 :
340 : /* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
341 : of DECL is predetermined. */
342 :
343 : enum omp_clause_defaultmap_kind
344 3983 : gfc_omp_predetermined_mapping (tree decl)
345 : {
346 3983 : if (DECL_ARTIFICIAL (decl)
347 880 : && ! GFC_DECL_RESULT (decl)
348 4857 : && ! (DECL_LANG_SPECIFIC (decl)
349 73 : && GFC_DECL_SAVED_DESCRIPTOR (decl)))
350 : return OMP_CLAUSE_DEFAULTMAP_TO;
351 :
352 : /* Dummy procedures aren't considered variables by OpenMP, thus are
353 : disallowed in OpenMP clauses. They are represented as PARM_DECLs
354 : in the middle-end, so return OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE here
355 : to avoid complaining about their uses with defaultmap(none). */
356 3152 : if (TREE_CODE (decl) == PARM_DECL
357 1814 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
358 3531 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
359 : return OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
360 :
361 : /* These are either array or derived parameters, or vtables. */
362 1338 : if (VAR_P (decl) && TREE_READONLY (decl)
363 3145 : && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
364 0 : return OMP_CLAUSE_DEFAULTMAP_TO;
365 :
366 : return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
367 : }
368 :
369 :
370 : /* Return decl that should be used when reporting DEFAULT(NONE)
371 : diagnostics. */
372 :
373 : tree
374 130 : gfc_omp_report_decl (tree decl)
375 : {
376 130 : if (DECL_ARTIFICIAL (decl)
377 3 : && DECL_LANG_SPECIFIC (decl)
378 133 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
379 3 : return GFC_DECL_SAVED_DESCRIPTOR (decl);
380 :
381 : return decl;
382 : }
383 :
384 : /* Return true if TYPE has any allocatable components;
385 : if ptr_ok, the decl itself is permitted to have the POINTER attribute.
386 : if shallow_alloc_only, returns only true if any of the fields is an
387 : allocatable; called with true by gfc_omp_replace_alloc_by_to_mapping. */
388 :
389 : static bool
390 122070 : gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok,
391 : bool shallow_alloc_only=false)
392 : {
393 122070 : tree field, ftype;
394 :
395 122070 : if (POINTER_TYPE_P (type))
396 : {
397 3411 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
398 3411 : || (ptr_ok && GFC_DECL_GET_SCALAR_POINTER (decl)))
399 2383 : type = TREE_TYPE (type);
400 1028 : else if (GFC_DECL_GET_SCALAR_POINTER (decl))
401 : return false;
402 : }
403 :
404 121937 : if (!ptr_ok
405 98279 : && GFC_DESCRIPTOR_TYPE_P (type)
406 125086 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
407 2889 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
408 : return false;
409 :
410 121674 : if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
411 12469 : type = gfc_get_element_type (type);
412 :
413 121674 : if (TREE_CODE (type) != RECORD_TYPE)
414 : return false;
415 :
416 9841 : for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
417 : {
418 8839 : ftype = TREE_TYPE (field);
419 8839 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
420 : return true;
421 8271 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
422 8271 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
423 : return true;
424 5798 : if (!shallow_alloc_only
425 5798 : && gfc_has_alloc_comps (ftype, field, false))
426 : return true;
427 : }
428 : return false;
429 : }
430 :
431 : /* gfc_omp_replace_alloc_by_to_mapping is used with gfc_omp_deep_mapping... to
432 : handle the following:
433 :
434 : For map(alloc: dt), the array descriptors of allocatable components should
435 : be mapped as 'to'; this could be done by (A) adding 'map(to: dt%alloc_comp)'
436 : for each component (and avoiding to increment the reference count).
437 : Or (B) by just mapping all of 'dt' as 'to'.
438 :
439 : If 'dt' contains several allocatable components and not much other data,
440 : (A) is more efficient. If 'dt' contains a large const-size array, (A) will
441 : copy it to the device instead of only 'alloc'ating it.
442 :
443 : IMPLEMENTATION CHOICE: We do (A). It avoids the ref-count issue and it is
444 : expected that, for real-world code, derived types with allocatable
445 : components only have few other components and either no const-size arrays.
446 : This copying is done irrespectively whether the allocatables are allocated.
447 :
448 : If users wanted to save memory, they have to use 'map(alloc:dt%comp)' as
449 : also with 'map(alloc:dt)' all components get copied.
450 :
451 : For the copy to the device, only allocatable arrays are relevant as their
452 : the bounds are required; the pointer is set separately (GOMP_MAP_ATTACH)
453 : and the only setting required for scalars. However, when later copying out
454 : of the device, an unallocated allocatable must remain unallocated/NULL on
455 : the host; to achieve this we also must have it set to NULL on the device
456 : to avoid issues with uninitialized memory being copied back for the pointer
457 : address. If we could set the pointer to NULL, gfc_has_alloc_comps's
458 : shallow_alloc_only could be restricted to return true only for arrays.
459 :
460 : We only need to return true if there are allocatable-array components. */
461 :
462 : static bool
463 62 : gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok)
464 : {
465 18 : return gfc_has_alloc_comps (type, decl, ptr_ok, true);
466 : }
467 :
468 :
469 : static bool
470 66172 : gfc_is_polymorphic_nonptr (tree type)
471 : {
472 66172 : if (POINTER_TYPE_P (type))
473 3567 : type = TREE_TYPE (type);
474 66172 : return GFC_CLASS_TYPE_P (type);
475 : }
476 :
477 : /* Return true if TYPE is a class container for a POINTER entity. */
478 :
479 : static bool
480 41208 : gfc_is_class_pointer_type (tree type)
481 : {
482 41208 : tree name;
483 41208 : const char *s;
484 :
485 41208 : if (POINTER_TYPE_P (type))
486 3289 : type = TREE_TYPE (type);
487 :
488 41208 : if (!GFC_CLASS_TYPE_P (type))
489 : return false;
490 :
491 95 : name = TYPE_NAME (type);
492 95 : if (name && TREE_CODE (name) == TYPE_DECL)
493 0 : name = DECL_NAME (name);
494 0 : if (!name)
495 : return false;
496 :
497 95 : s = IDENTIFIER_POINTER (name);
498 95 : return startswith (s, "__class_") && s[strlen (s) - 1] == 'p';
499 : }
500 :
501 : /* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
502 : unlimited means also intrinsic types are handled and _len is used. */
503 :
504 : static bool
505 77 : gfc_is_unlimited_polymorphic_nonptr (tree type)
506 : {
507 77 : if (POINTER_TYPE_P (type))
508 0 : type = TREE_TYPE (type);
509 77 : if (!GFC_CLASS_TYPE_P (type))
510 : return false;
511 :
512 77 : tree field = TYPE_FIELDS (type); /* _data */
513 77 : gcc_assert (field);
514 77 : field = DECL_CHAIN (field); /* _vptr */
515 77 : gcc_assert (field);
516 77 : field = DECL_CHAIN (field);
517 77 : if (!field)
518 : return false;
519 26 : gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0);
520 : return true;
521 : }
522 :
523 : /* Return true if the DECL is for an allocatable array or scalar. */
524 :
525 : bool
526 3983 : gfc_omp_allocatable_p (tree decl)
527 : {
528 3983 : if (!DECL_P (decl))
529 : return false;
530 :
531 3983 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
532 : return true;
533 :
534 3758 : tree type = TREE_TYPE (decl);
535 3758 : if (gfc_omp_privatize_by_reference (decl))
536 1801 : type = TREE_TYPE (type);
537 :
538 3758 : if (GFC_DESCRIPTOR_TYPE_P (type)
539 3758 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
540 : return true;
541 :
542 : return false;
543 : }
544 :
545 :
546 : /* Return true if DECL in private clause needs
547 : OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
548 : bool
549 14486 : gfc_omp_private_outer_ref (tree decl)
550 : {
551 14486 : tree type = TREE_TYPE (decl);
552 :
553 14486 : if (gfc_omp_privatize_by_reference (decl))
554 618 : type = TREE_TYPE (type);
555 :
556 14486 : if (GFC_DESCRIPTOR_TYPE_P (type)
557 14486 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
558 : return true;
559 :
560 14359 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
561 : return true;
562 :
563 14273 : if (gfc_has_alloc_comps (type, decl, false))
564 : return true;
565 :
566 : return false;
567 : }
568 :
569 : /* Callback for gfc_omp_unshare_expr. */
570 :
571 : static tree
572 92345 : gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
573 : {
574 92345 : tree t = *tp;
575 92345 : enum tree_code code = TREE_CODE (t);
576 :
577 : /* Stop at types, decls, constants like copy_tree_r. */
578 92345 : if (TREE_CODE_CLASS (code) == tcc_type
579 : || TREE_CODE_CLASS (code) == tcc_declaration
580 92345 : || TREE_CODE_CLASS (code) == tcc_constant
581 61220 : || code == BLOCK)
582 31125 : *walk_subtrees = 0;
583 61220 : else if (handled_component_p (t)
584 46282 : || TREE_CODE (t) == MEM_REF)
585 : {
586 14998 : *tp = unshare_expr (t);
587 14998 : *walk_subtrees = 0;
588 : }
589 :
590 92345 : return NULL_TREE;
591 : }
592 :
593 : /* Unshare in expr anything that the FE which normally doesn't
594 : care much about tree sharing (because during gimplification
595 : everything is unshared) could cause problems with tree sharing
596 : at omp-low.cc time. */
597 :
598 : static tree
599 5070 : gfc_omp_unshare_expr (tree expr)
600 : {
601 5070 : walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
602 5070 : return expr;
603 : }
604 :
605 : enum walk_alloc_comps
606 : {
607 : WALK_ALLOC_COMPS_DTOR,
608 : WALK_ALLOC_COMPS_DEFAULT_CTOR,
609 : WALK_ALLOC_COMPS_COPY_CTOR
610 : };
611 :
612 : /* Handle allocatable components in OpenMP clauses. */
613 :
614 : static tree
615 2803 : gfc_walk_alloc_comps (tree decl, tree dest, tree var,
616 : enum walk_alloc_comps kind)
617 : {
618 2803 : stmtblock_t block, tmpblock;
619 2803 : tree type = TREE_TYPE (decl), then_b, tem, field;
620 2803 : gfc_init_block (&block);
621 :
622 2803 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
623 : {
624 1092 : if (GFC_DESCRIPTOR_TYPE_P (type))
625 : {
626 548 : gfc_init_block (&tmpblock);
627 1644 : tem = gfc_full_array_size (&tmpblock, decl,
628 548 : GFC_TYPE_ARRAY_RANK (type));
629 548 : then_b = gfc_finish_block (&tmpblock);
630 548 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b));
631 548 : tem = gfc_omp_unshare_expr (tem);
632 548 : tem = fold_build2_loc (input_location, MINUS_EXPR,
633 : gfc_array_index_type, tem,
634 : gfc_index_one_node);
635 : }
636 : else
637 : {
638 544 : bool compute_nelts = false;
639 544 : if (!TYPE_DOMAIN (type)
640 544 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
641 544 : || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
642 1088 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
643 : compute_nelts = true;
644 544 : else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
645 : {
646 80 : tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
647 80 : if (lookup_attribute ("omp dummy var", a))
648 : compute_nelts = true;
649 : }
650 : if (compute_nelts)
651 : {
652 80 : tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
653 : TYPE_SIZE_UNIT (type),
654 : TYPE_SIZE_UNIT (TREE_TYPE (type)));
655 80 : tem = size_binop (MINUS_EXPR, tem, size_one_node);
656 : }
657 : else
658 464 : tem = array_type_nelts_minus_one (type);
659 544 : tem = fold_convert (gfc_array_index_type, tem);
660 : }
661 :
662 1092 : tree nelems = gfc_evaluate_now (tem, &block);
663 1092 : tree index = gfc_create_var (gfc_array_index_type, "S");
664 :
665 1092 : gfc_init_block (&tmpblock);
666 1092 : tem = gfc_conv_array_data (decl);
667 1092 : tree declvar = build_fold_indirect_ref_loc (input_location, tem);
668 1092 : tree declvref = gfc_build_array_ref (declvar, index, NULL);
669 1092 : tree destvar, destvref = NULL_TREE;
670 1092 : if (dest)
671 : {
672 546 : tem = gfc_conv_array_data (dest);
673 546 : destvar = build_fold_indirect_ref_loc (input_location, tem);
674 546 : destvref = gfc_build_array_ref (destvar, index, NULL);
675 : }
676 1092 : gfc_add_expr_to_block (&tmpblock,
677 : gfc_walk_alloc_comps (declvref, destvref,
678 : var, kind));
679 :
680 1092 : gfc_loopinfo loop;
681 1092 : gfc_init_loopinfo (&loop);
682 1092 : loop.dimen = 1;
683 1092 : loop.from[0] = gfc_index_zero_node;
684 1092 : loop.loopvar[0] = index;
685 1092 : loop.to[0] = nelems;
686 1092 : gfc_trans_scalarizing_loops (&loop, &tmpblock);
687 1092 : gfc_add_block_to_block (&block, &loop.pre);
688 1092 : return gfc_finish_block (&block);
689 : }
690 1711 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
691 : {
692 536 : decl = build_fold_indirect_ref_loc (input_location, decl);
693 536 : if (dest)
694 268 : dest = build_fold_indirect_ref_loc (input_location, dest);
695 536 : type = TREE_TYPE (decl);
696 : }
697 :
698 1711 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
699 11494 : for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
700 : {
701 9783 : tree ftype = TREE_TYPE (field);
702 9783 : tree declf, destf = NULL_TREE;
703 9783 : bool has_alloc_comps = gfc_has_alloc_comps (ftype, field, false);
704 9783 : if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
705 1710 : || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
706 8073 : && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
707 16159 : && !has_alloc_comps)
708 5952 : continue;
709 3831 : declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
710 : decl, field, NULL_TREE);
711 3831 : if (dest)
712 1916 : destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
713 : dest, field, NULL_TREE);
714 :
715 3831 : tem = NULL_TREE;
716 3831 : switch (kind)
717 : {
718 : case WALK_ALLOC_COMPS_DTOR:
719 : break;
720 962 : case WALK_ALLOC_COMPS_DEFAULT_CTOR:
721 962 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
722 962 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
723 : {
724 431 : gfc_add_modify (&block, unshare_expr (destf),
725 : unshare_expr (declf));
726 431 : tem = gfc_duplicate_allocatable_nocopy
727 431 : (destf, declf, ftype,
728 431 : GFC_TYPE_ARRAY_RANK (ftype));
729 : }
730 531 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
731 425 : tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
732 : break;
733 954 : case WALK_ALLOC_COMPS_COPY_CTOR:
734 954 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
735 954 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
736 848 : tem = gfc_duplicate_allocatable (destf, declf, ftype,
737 424 : GFC_TYPE_ARRAY_RANK (ftype),
738 : NULL_TREE);
739 530 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
740 424 : tem = gfc_duplicate_allocatable (destf, declf, ftype, 0,
741 : NULL_TREE);
742 : break;
743 : }
744 1704 : if (tem)
745 1704 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
746 3831 : if (has_alloc_comps)
747 : {
748 1272 : gfc_init_block (&tmpblock);
749 1272 : gfc_add_expr_to_block (&tmpblock,
750 : gfc_walk_alloc_comps (declf, destf,
751 : field, kind));
752 1272 : then_b = gfc_finish_block (&tmpblock);
753 1272 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
754 1272 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
755 424 : tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
756 848 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
757 424 : tem = unshare_expr (declf);
758 : else
759 : tem = NULL_TREE;
760 848 : if (tem)
761 : {
762 848 : tem = fold_convert (pvoid_type_node, tem);
763 848 : tem = fold_build2_loc (input_location, NE_EXPR,
764 : logical_type_node, tem,
765 : null_pointer_node);
766 848 : then_b = build3_loc (input_location, COND_EXPR, void_type_node,
767 : tem, then_b,
768 : build_empty_stmt (input_location));
769 : }
770 1272 : gfc_add_expr_to_block (&block, then_b);
771 : }
772 3831 : if (kind == WALK_ALLOC_COMPS_DTOR)
773 : {
774 1915 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
775 1915 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
776 : {
777 855 : tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
778 855 : tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE,
779 : NULL_TREE, NULL_TREE, true,
780 : NULL,
781 : GFC_CAF_COARRAY_NOCOARRAY);
782 855 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
783 : }
784 1060 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
785 : {
786 848 : tem = gfc_call_free (unshare_expr (declf));
787 848 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
788 : }
789 : }
790 : }
791 :
792 1711 : return gfc_finish_block (&block);
793 : }
794 :
795 : /* Return code to initialize DECL with its default constructor, or
796 : NULL if there's nothing to do. */
797 :
798 : tree
799 20399 : gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
800 : {
801 20399 : tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
802 20399 : stmtblock_t block, cond_block;
803 :
804 20399 : switch (OMP_CLAUSE_CODE (clause))
805 : {
806 : case OMP_CLAUSE__LOOPTEMP_:
807 : case OMP_CLAUSE__REDUCTEMP_:
808 : case OMP_CLAUSE__CONDTEMP_:
809 : case OMP_CLAUSE__SCANTEMP_:
810 : return NULL;
811 20372 : case OMP_CLAUSE_PRIVATE:
812 20372 : case OMP_CLAUSE_LASTPRIVATE:
813 20372 : case OMP_CLAUSE_LINEAR:
814 20372 : case OMP_CLAUSE_REDUCTION:
815 20372 : case OMP_CLAUSE_IN_REDUCTION:
816 20372 : case OMP_CLAUSE_TASK_REDUCTION:
817 20372 : break;
818 0 : default:
819 0 : gcc_unreachable ();
820 : }
821 :
822 20372 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
823 263 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
824 20391 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
825 86 : || !POINTER_TYPE_P (type)))
826 : {
827 20042 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
828 : {
829 52 : gcc_assert (outer);
830 52 : gfc_start_block (&block);
831 104 : tree tem = gfc_walk_alloc_comps (outer, decl,
832 52 : OMP_CLAUSE_DECL (clause),
833 : WALK_ALLOC_COMPS_DEFAULT_CTOR);
834 52 : gfc_add_expr_to_block (&block, tem);
835 52 : return gfc_finish_block (&block);
836 : }
837 : return NULL_TREE;
838 : }
839 :
840 330 : gcc_assert (outer != NULL_TREE
841 : || (!GFC_DESCRIPTOR_TYPE_P (type)
842 : && !gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause),
843 : false)));
844 :
845 : /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
846 : "not currently allocated" allocation status if outer
847 : array is "not currently allocated", otherwise should be allocated. */
848 330 : gfc_start_block (&block);
849 :
850 330 : gfc_init_block (&cond_block);
851 :
852 330 : if (GFC_DESCRIPTOR_TYPE_P (type))
853 : {
854 244 : gfc_add_modify (&cond_block, decl, outer);
855 244 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
856 244 : size = gfc_conv_descriptor_ubound_get (decl, rank);
857 244 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
858 : size,
859 : gfc_conv_descriptor_lbound_get (decl, rank));
860 244 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
861 : size, gfc_index_one_node);
862 244 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
863 130 : size = fold_build2_loc (input_location, MULT_EXPR,
864 : gfc_array_index_type, size,
865 : gfc_conv_descriptor_stride_get (decl, rank));
866 244 : tree esize = fold_convert (gfc_array_index_type,
867 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
868 244 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
869 : size, esize);
870 244 : size = unshare_expr (size);
871 244 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
872 : &cond_block);
873 : }
874 : else
875 86 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
876 330 : ptr = gfc_create_var (pvoid_type_node, NULL);
877 330 : gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
878 330 : if (GFC_DESCRIPTOR_TYPE_P (type))
879 244 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
880 : else
881 86 : gfc_add_modify (&cond_block, unshare_expr (decl),
882 86 : fold_convert (TREE_TYPE (decl), ptr));
883 330 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
884 : {
885 124 : tree tem = gfc_walk_alloc_comps (outer, decl,
886 62 : OMP_CLAUSE_DECL (clause),
887 : WALK_ALLOC_COMPS_DEFAULT_CTOR);
888 62 : gfc_add_expr_to_block (&cond_block, tem);
889 : }
890 330 : then_b = gfc_finish_block (&cond_block);
891 :
892 : /* Reduction clause requires allocated ALLOCATABLE. */
893 330 : if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION
894 185 : && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION
895 515 : && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_REDUCTION)
896 : {
897 185 : gfc_init_block (&cond_block);
898 185 : if (GFC_DESCRIPTOR_TYPE_P (type))
899 124 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
900 : null_pointer_node);
901 : else
902 61 : gfc_add_modify (&cond_block, unshare_expr (decl),
903 61 : build_zero_cst (TREE_TYPE (decl)));
904 185 : else_b = gfc_finish_block (&cond_block);
905 :
906 185 : tree tem = fold_convert (pvoid_type_node,
907 : GFC_DESCRIPTOR_TYPE_P (type)
908 : ? gfc_conv_descriptor_data_get (outer) : outer);
909 185 : tem = unshare_expr (tem);
910 185 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
911 : tem, null_pointer_node);
912 185 : gfc_add_expr_to_block (&block,
913 : build3_loc (input_location, COND_EXPR,
914 : void_type_node, cond, then_b,
915 : else_b));
916 : /* Avoid -W*uninitialized warnings. */
917 185 : if (DECL_P (decl))
918 146 : suppress_warning (decl, OPT_Wuninitialized);
919 : }
920 : else
921 145 : gfc_add_expr_to_block (&block, then_b);
922 :
923 330 : return gfc_finish_block (&block);
924 : }
925 :
926 : /* Build and return code for a copy constructor from SRC to DEST. */
927 :
928 : tree
929 9236 : gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
930 : {
931 9236 : tree type = TREE_TYPE (dest), ptr, size, call;
932 9236 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
933 9236 : tree orig_decl = OMP_CLAUSE_DECL (clause);
934 9236 : tree cond, then_b, else_b;
935 9236 : stmtblock_t block, cond_block;
936 :
937 9236 : gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
938 : || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
939 :
940 9236 : if (DECL_ARTIFICIAL (orig_decl)
941 6154 : && DECL_LANG_SPECIFIC (orig_decl)
942 9419 : && GFC_DECL_SAVED_DESCRIPTOR (orig_decl))
943 : {
944 167 : orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl);
945 167 : decl_type = TREE_TYPE (orig_decl);
946 : }
947 :
948 : /* Privatize pointer association only; cf. gfc_omp_predetermined_sharing.
949 : This includes scalar class pointers, whose tree type is still the class
950 : record even though the Fortran entity has POINTER semantics. */
951 9236 : if (DECL_P (orig_decl)
952 9236 : && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl)
953 9209 : || GFC_DECL_GET_SCALAR_POINTER (orig_decl)
954 9183 : || gfc_is_class_pointer_type (decl_type)))
955 59 : return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
956 :
957 9177 : if (gfc_is_polymorphic_nonptr (decl_type))
958 : {
959 40 : if (POINTER_TYPE_P (decl_type))
960 27 : decl_type = TREE_TYPE (decl_type);
961 40 : decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
962 40 : if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
963 4 : fatal_error (input_location,
964 : "Sorry, polymorphic arrays not yet supported for "
965 : "firstprivate");
966 36 : tree src_len;
967 36 : tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */
968 36 : tree src_data = gfc_class_data_get (unshare_expr (src));
969 36 : tree dest_data = gfc_class_data_get (unshare_expr (dest));
970 36 : bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type);
971 :
972 36 : gfc_start_block (&block);
973 36 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
974 : gfc_class_vptr_get (src));
975 36 : gfc_init_block (&cond_block);
976 :
977 36 : if (unlimited)
978 : {
979 24 : src_len = gfc_class_len_get (src);
980 24 : gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len);
981 : }
982 :
983 : /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
984 36 : size = fold_convert (size_type_node, gfc_class_vtab_size_get (src));
985 36 : if (unlimited)
986 : {
987 24 : cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
988 : unshare_expr (src_len),
989 24 : build_zero_cst (TREE_TYPE (src_len)));
990 24 : cond = build3_loc (input_location, COND_EXPR, size_type_node, cond,
991 : fold_convert (size_type_node,
992 : unshare_expr (src_len)),
993 : build_int_cst (size_type_node, 1));
994 24 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
995 : size, cond);
996 : }
997 :
998 : /* Malloc memory + call class->_vpt->_copy. */
999 36 : call = builtin_decl_explicit (BUILT_IN_MALLOC);
1000 36 : call = build_call_expr_loc (input_location, call, 1, size);
1001 36 : gfc_add_modify (&cond_block, dest_data,
1002 36 : fold_convert (TREE_TYPE (dest_data), call));
1003 36 : gfc_add_expr_to_block (&cond_block,
1004 : gfc_copy_class_to_class (src, dest, nelems,
1005 : unlimited));
1006 :
1007 36 : gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF);
1008 36 : if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
1009 : {
1010 12 : gfc_add_block_to_block (&block, &cond_block);
1011 : }
1012 : else
1013 : {
1014 : /* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
1015 24 : cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1016 : src_data, null_pointer_node);
1017 24 : gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
1018 : void_type_node, cond,
1019 : gfc_finish_block (&cond_block),
1020 : fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
1021 : unshare_expr (dest_data), null_pointer_node)));
1022 : }
1023 36 : return gfc_finish_block (&block);
1024 : }
1025 :
1026 9137 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1027 139 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1028 9161 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1029 77 : || !POINTER_TYPE_P (type)))
1030 : {
1031 8947 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1032 : {
1033 20 : gfc_start_block (&block);
1034 20 : gfc_add_modify (&block, dest, src);
1035 20 : tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
1036 : WALK_ALLOC_COMPS_COPY_CTOR);
1037 20 : gfc_add_expr_to_block (&block, tem);
1038 20 : return gfc_finish_block (&block);
1039 : }
1040 : else
1041 8927 : return build2_v (MODIFY_EXPR, dest, src);
1042 : }
1043 :
1044 : /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
1045 : and copied from SRC. */
1046 190 : gfc_start_block (&block);
1047 :
1048 190 : gfc_init_block (&cond_block);
1049 :
1050 190 : gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src));
1051 190 : if (GFC_DESCRIPTOR_TYPE_P (type))
1052 : {
1053 115 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1054 115 : size = gfc_conv_descriptor_ubound_get (dest, rank);
1055 115 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1056 : size,
1057 : gfc_conv_descriptor_lbound_get (dest, rank));
1058 115 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1059 : size, gfc_index_one_node);
1060 115 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
1061 42 : size = fold_build2_loc (input_location, MULT_EXPR,
1062 : gfc_array_index_type, size,
1063 : gfc_conv_descriptor_stride_get (dest, rank));
1064 115 : tree esize = fold_convert (gfc_array_index_type,
1065 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1066 115 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1067 : size, esize);
1068 115 : size = unshare_expr (size);
1069 115 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
1070 : &cond_block);
1071 : }
1072 : else
1073 75 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1074 190 : ptr = gfc_create_var (pvoid_type_node, NULL);
1075 190 : gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
1076 190 : if (GFC_DESCRIPTOR_TYPE_P (type))
1077 115 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
1078 : else
1079 75 : gfc_add_modify (&cond_block, unshare_expr (dest),
1080 75 : fold_convert (TREE_TYPE (dest), ptr));
1081 :
1082 190 : tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
1083 190 : ? gfc_conv_descriptor_data_get (src) : src;
1084 190 : srcptr = unshare_expr (srcptr);
1085 190 : srcptr = fold_convert (pvoid_type_node, srcptr);
1086 190 : call = build_call_expr_loc (input_location,
1087 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
1088 : srcptr, size);
1089 190 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1090 190 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1091 : {
1092 48 : tree tem = gfc_walk_alloc_comps (src, dest,
1093 24 : OMP_CLAUSE_DECL (clause),
1094 : WALK_ALLOC_COMPS_COPY_CTOR);
1095 24 : gfc_add_expr_to_block (&cond_block, tem);
1096 : }
1097 190 : then_b = gfc_finish_block (&cond_block);
1098 :
1099 190 : gfc_init_block (&cond_block);
1100 190 : if (GFC_DESCRIPTOR_TYPE_P (type))
1101 115 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
1102 : null_pointer_node);
1103 : else
1104 75 : gfc_add_modify (&cond_block, unshare_expr (dest),
1105 75 : build_zero_cst (TREE_TYPE (dest)));
1106 190 : else_b = gfc_finish_block (&cond_block);
1107 :
1108 190 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1109 : unshare_expr (srcptr), null_pointer_node);
1110 190 : gfc_add_expr_to_block (&block,
1111 : build3_loc (input_location, COND_EXPR,
1112 : void_type_node, cond, then_b, else_b));
1113 : /* Avoid -W*uninitialized warnings. */
1114 190 : if (DECL_P (dest))
1115 121 : suppress_warning (dest, OPT_Wuninitialized);
1116 :
1117 190 : return gfc_finish_block (&block);
1118 : }
1119 :
1120 : /* Similarly, except use an intrinsic or pointer assignment operator
1121 : instead. */
1122 :
1123 : tree
1124 6345 : gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
1125 : {
1126 6345 : tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
1127 6345 : tree cond, then_b, else_b;
1128 6345 : stmtblock_t block, cond_block, cond_block2, inner_block;
1129 :
1130 6345 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1131 234 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1132 12487 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1133 136 : || !POINTER_TYPE_P (type)))
1134 : {
1135 6006 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1136 : {
1137 30 : gfc_start_block (&block);
1138 : /* First dealloc any allocatable components in DEST. */
1139 60 : tree tem = gfc_walk_alloc_comps (dest, NULL_TREE,
1140 30 : OMP_CLAUSE_DECL (clause),
1141 : WALK_ALLOC_COMPS_DTOR);
1142 30 : gfc_add_expr_to_block (&block, tem);
1143 : /* Then copy over toplevel data. */
1144 30 : gfc_add_modify (&block, dest, src);
1145 : /* Finally allocate any allocatable components and copy. */
1146 30 : tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
1147 : WALK_ALLOC_COMPS_COPY_CTOR);
1148 30 : gfc_add_expr_to_block (&block, tem);
1149 30 : return gfc_finish_block (&block);
1150 : }
1151 : else
1152 5976 : return build2_v (MODIFY_EXPR, dest, src);
1153 : }
1154 :
1155 339 : gfc_start_block (&block);
1156 :
1157 339 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1158 : {
1159 32 : then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
1160 : WALK_ALLOC_COMPS_DTOR);
1161 32 : tree tem = fold_convert (pvoid_type_node,
1162 : GFC_DESCRIPTOR_TYPE_P (type)
1163 : ? gfc_conv_descriptor_data_get (dest) : dest);
1164 32 : tem = unshare_expr (tem);
1165 32 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1166 : tem, null_pointer_node);
1167 32 : tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
1168 : then_b, build_empty_stmt (input_location));
1169 32 : gfc_add_expr_to_block (&block, tem);
1170 : }
1171 :
1172 339 : gfc_init_block (&cond_block);
1173 :
1174 339 : if (GFC_DESCRIPTOR_TYPE_P (type))
1175 : {
1176 203 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1177 203 : size = gfc_conv_descriptor_ubound_get (src, rank);
1178 203 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1179 : size,
1180 : gfc_conv_descriptor_lbound_get (src, rank));
1181 203 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1182 : size, gfc_index_one_node);
1183 203 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
1184 88 : size = fold_build2_loc (input_location, MULT_EXPR,
1185 : gfc_array_index_type, size,
1186 : gfc_conv_descriptor_stride_get (src, rank));
1187 203 : tree esize = fold_convert (gfc_array_index_type,
1188 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1189 203 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1190 : size, esize);
1191 203 : size = unshare_expr (size);
1192 203 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
1193 : &cond_block);
1194 : }
1195 : else
1196 136 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1197 339 : ptr = gfc_create_var (pvoid_type_node, NULL);
1198 :
1199 339 : tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
1200 339 : ? gfc_conv_descriptor_data_get (dest) : dest;
1201 339 : destptr = unshare_expr (destptr);
1202 339 : destptr = fold_convert (pvoid_type_node, destptr);
1203 339 : gfc_add_modify (&cond_block, ptr, destptr);
1204 :
1205 339 : nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
1206 : destptr, null_pointer_node);
1207 339 : cond = nonalloc;
1208 339 : if (GFC_DESCRIPTOR_TYPE_P (type))
1209 : {
1210 : int i;
1211 494 : for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
1212 : {
1213 291 : tree rank = gfc_rank_cst[i];
1214 291 : tree tem = gfc_conv_descriptor_ubound_get (src, rank);
1215 291 : tem = fold_build2_loc (input_location, MINUS_EXPR,
1216 : gfc_array_index_type, tem,
1217 : gfc_conv_descriptor_lbound_get (src, rank));
1218 291 : tem = fold_build2_loc (input_location, PLUS_EXPR,
1219 : gfc_array_index_type, tem,
1220 : gfc_conv_descriptor_lbound_get (dest, rank));
1221 291 : tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1222 : tem, gfc_conv_descriptor_ubound_get (dest,
1223 : rank));
1224 291 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1225 : logical_type_node, cond, tem);
1226 : }
1227 : }
1228 :
1229 339 : gfc_init_block (&cond_block2);
1230 :
1231 339 : if (GFC_DESCRIPTOR_TYPE_P (type))
1232 : {
1233 203 : gfc_init_block (&inner_block);
1234 203 : gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
1235 203 : then_b = gfc_finish_block (&inner_block);
1236 :
1237 203 : gfc_init_block (&inner_block);
1238 203 : gfc_add_modify (&inner_block, ptr,
1239 : gfc_call_realloc (&inner_block, ptr, size));
1240 203 : else_b = gfc_finish_block (&inner_block);
1241 :
1242 203 : gfc_add_expr_to_block (&cond_block2,
1243 : build3_loc (input_location, COND_EXPR,
1244 : void_type_node,
1245 : unshare_expr (nonalloc),
1246 : then_b, else_b));
1247 203 : gfc_add_modify (&cond_block2, dest, src);
1248 203 : gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
1249 : }
1250 : else
1251 : {
1252 136 : gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
1253 136 : gfc_add_modify (&cond_block2, unshare_expr (dest),
1254 : fold_convert (type, ptr));
1255 : }
1256 339 : then_b = gfc_finish_block (&cond_block2);
1257 339 : else_b = build_empty_stmt (input_location);
1258 :
1259 339 : gfc_add_expr_to_block (&cond_block,
1260 : build3_loc (input_location, COND_EXPR,
1261 : void_type_node, unshare_expr (cond),
1262 : then_b, else_b));
1263 :
1264 339 : tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
1265 339 : ? gfc_conv_descriptor_data_get (src) : src;
1266 339 : srcptr = unshare_expr (srcptr);
1267 339 : srcptr = fold_convert (pvoid_type_node, srcptr);
1268 339 : call = build_call_expr_loc (input_location,
1269 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
1270 : srcptr, size);
1271 339 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1272 339 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1273 : {
1274 64 : tree tem = gfc_walk_alloc_comps (src, dest,
1275 32 : OMP_CLAUSE_DECL (clause),
1276 : WALK_ALLOC_COMPS_COPY_CTOR);
1277 32 : gfc_add_expr_to_block (&cond_block, tem);
1278 : }
1279 339 : then_b = gfc_finish_block (&cond_block);
1280 :
1281 339 : if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
1282 : {
1283 66 : gfc_init_block (&cond_block);
1284 66 : if (GFC_DESCRIPTOR_TYPE_P (type))
1285 : {
1286 48 : tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest));
1287 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1288 : NULL_TREE, NULL_TREE, true, NULL,
1289 : GFC_CAF_COARRAY_NOCOARRAY);
1290 48 : gfc_add_expr_to_block (&cond_block, tmp);
1291 : }
1292 : else
1293 : {
1294 18 : destptr = gfc_evaluate_now (destptr, &cond_block);
1295 18 : gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
1296 18 : gfc_add_modify (&cond_block, unshare_expr (dest),
1297 18 : build_zero_cst (TREE_TYPE (dest)));
1298 : }
1299 66 : else_b = gfc_finish_block (&cond_block);
1300 :
1301 66 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1302 : unshare_expr (srcptr), null_pointer_node);
1303 66 : gfc_add_expr_to_block (&block,
1304 : build3_loc (input_location, COND_EXPR,
1305 : void_type_node, cond,
1306 : then_b, else_b));
1307 : }
1308 : else
1309 273 : gfc_add_expr_to_block (&block, then_b);
1310 :
1311 339 : return gfc_finish_block (&block);
1312 : }
1313 :
1314 : static void
1315 84 : gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src,
1316 : tree add, tree nelems)
1317 : {
1318 84 : stmtblock_t tmpblock;
1319 84 : tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S");
1320 84 : nelems = gfc_evaluate_now (nelems, block);
1321 :
1322 84 : gfc_init_block (&tmpblock);
1323 84 : if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE)
1324 : {
1325 60 : desta = gfc_build_array_ref (dest, index, NULL);
1326 60 : srca = gfc_build_array_ref (src, index, NULL);
1327 : }
1328 : else
1329 : {
1330 24 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest)));
1331 24 : tree idx = fold_build2 (MULT_EXPR, sizetype,
1332 : fold_convert (sizetype, index),
1333 : TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest))));
1334 24 : desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
1335 : TREE_TYPE (dest), dest,
1336 : idx));
1337 24 : srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
1338 : TREE_TYPE (src), src,
1339 : idx));
1340 : }
1341 84 : gfc_add_modify (&tmpblock, desta,
1342 84 : fold_build2 (PLUS_EXPR, TREE_TYPE (desta),
1343 : srca, add));
1344 :
1345 84 : gfc_loopinfo loop;
1346 84 : gfc_init_loopinfo (&loop);
1347 84 : loop.dimen = 1;
1348 84 : loop.from[0] = gfc_index_zero_node;
1349 84 : loop.loopvar[0] = index;
1350 84 : loop.to[0] = nelems;
1351 84 : gfc_trans_scalarizing_loops (&loop, &tmpblock);
1352 84 : gfc_add_block_to_block (block, &loop.pre);
1353 84 : }
1354 :
1355 : /* Build and return code for a constructor of DEST that initializes
1356 : it to SRC plus ADD (ADD is scalar integer). */
1357 :
1358 : tree
1359 108 : gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add)
1360 : {
1361 108 : tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE;
1362 108 : stmtblock_t block;
1363 :
1364 108 : gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
1365 :
1366 108 : gfc_start_block (&block);
1367 108 : add = gfc_evaluate_now (add, &block);
1368 :
1369 108 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1370 24 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1371 192 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1372 24 : || !POINTER_TYPE_P (type)))
1373 : {
1374 60 : bool compute_nelts = false;
1375 60 : gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1376 60 : if (!TYPE_DOMAIN (type)
1377 60 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
1378 60 : || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
1379 120 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
1380 : compute_nelts = true;
1381 60 : else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
1382 : {
1383 48 : tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
1384 48 : if (lookup_attribute ("omp dummy var", a))
1385 : compute_nelts = true;
1386 : }
1387 : if (compute_nelts)
1388 : {
1389 48 : nelems = fold_build2 (EXACT_DIV_EXPR, sizetype,
1390 : TYPE_SIZE_UNIT (type),
1391 : TYPE_SIZE_UNIT (TREE_TYPE (type)));
1392 48 : nelems = size_binop (MINUS_EXPR, nelems, size_one_node);
1393 : }
1394 : else
1395 12 : nelems = array_type_nelts_minus_one (type);
1396 60 : nelems = fold_convert (gfc_array_index_type, nelems);
1397 :
1398 60 : gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems);
1399 60 : return gfc_finish_block (&block);
1400 : }
1401 :
1402 : /* Allocatable arrays in LINEAR clauses need to be allocated
1403 : and copied from SRC. */
1404 48 : gfc_add_modify (&block, dest, src);
1405 48 : if (GFC_DESCRIPTOR_TYPE_P (type))
1406 : {
1407 24 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1408 24 : size = gfc_conv_descriptor_ubound_get (dest, rank);
1409 24 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1410 : size,
1411 : gfc_conv_descriptor_lbound_get (dest, rank));
1412 24 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1413 : size, gfc_index_one_node);
1414 24 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
1415 0 : size = fold_build2_loc (input_location, MULT_EXPR,
1416 : gfc_array_index_type, size,
1417 : gfc_conv_descriptor_stride_get (dest, rank));
1418 24 : tree esize = fold_convert (gfc_array_index_type,
1419 : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1420 24 : nelems = gfc_evaluate_now (unshare_expr (size), &block);
1421 24 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1422 : nelems, unshare_expr (esize));
1423 24 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
1424 : &block);
1425 24 : nelems = fold_build2_loc (input_location, MINUS_EXPR,
1426 : gfc_array_index_type, nelems,
1427 : gfc_index_one_node);
1428 : }
1429 : else
1430 24 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1431 48 : ptr = gfc_create_var (pvoid_type_node, NULL);
1432 48 : gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
1433 48 : if (GFC_DESCRIPTOR_TYPE_P (type))
1434 : {
1435 24 : gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr);
1436 24 : tree etype = gfc_get_element_type (type);
1437 24 : ptr = fold_convert (build_pointer_type (etype), ptr);
1438 24 : tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src));
1439 24 : srcptr = fold_convert (build_pointer_type (etype), srcptr);
1440 24 : gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems);
1441 : }
1442 : else
1443 : {
1444 24 : gfc_add_modify (&block, unshare_expr (dest),
1445 24 : fold_convert (TREE_TYPE (dest), ptr));
1446 24 : ptr = fold_convert (TREE_TYPE (dest), ptr);
1447 24 : tree dstm = build_fold_indirect_ref (ptr);
1448 24 : tree srcm = build_fold_indirect_ref (unshare_expr (src));
1449 24 : gfc_add_modify (&block, dstm,
1450 24 : fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add));
1451 : }
1452 48 : return gfc_finish_block (&block);
1453 : }
1454 :
1455 : /* Build and return code destructing DECL. Return NULL if nothing
1456 : to be done. */
1457 :
1458 : tree
1459 32097 : gfc_omp_clause_dtor (tree clause, tree decl)
1460 : {
1461 32097 : tree type = TREE_TYPE (decl), tem;
1462 32097 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
1463 32097 : tree orig_decl = OMP_CLAUSE_DECL (clause);
1464 :
1465 32097 : if (DECL_ARTIFICIAL (orig_decl)
1466 11900 : && DECL_LANG_SPECIFIC (orig_decl)
1467 32453 : && GFC_DECL_SAVED_DESCRIPTOR (orig_decl))
1468 : {
1469 340 : orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl);
1470 340 : decl_type = TREE_TYPE (orig_decl);
1471 : }
1472 :
1473 : /* Only pointer association was privatized; cf. gfc_omp_clause_copy_ctor.
1474 : Scalar class pointers must not finalize or free their targets here. */
1475 32097 : if (DECL_P (orig_decl)
1476 32097 : && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl)
1477 32070 : || GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1478 32025 : || gfc_is_class_pointer_type (decl_type)))
1479 : return NULL_TREE;
1480 32013 : if (gfc_is_polymorphic_nonptr (decl_type))
1481 : {
1482 37 : if (POINTER_TYPE_P (decl_type))
1483 24 : decl_type = TREE_TYPE (decl_type);
1484 37 : decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
1485 37 : if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
1486 0 : fatal_error (input_location,
1487 : "Sorry, polymorphic arrays not yet supported for "
1488 : "firstprivate");
1489 37 : stmtblock_t block, cond_block;
1490 37 : gfc_start_block (&block);
1491 37 : gfc_init_block (&cond_block);
1492 37 : tree final = gfc_class_vtab_final_get (decl);
1493 37 : tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl));
1494 37 : gfc_se se;
1495 37 : gfc_init_se (&se, NULL);
1496 37 : symbol_attribute attr = {};
1497 37 : tree data = gfc_class_data_get (decl);
1498 37 : tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr);
1499 :
1500 : /* Call class->_vpt->_finalize + free. */
1501 37 : tree call = build_fold_indirect_ref (final);
1502 37 : call = build_call_expr_loc (input_location, call, 3,
1503 : gfc_build_addr_expr (NULL, desc),
1504 : size, boolean_false_node);
1505 37 : gfc_add_block_to_block (&cond_block, &se.pre);
1506 37 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1507 37 : gfc_add_block_to_block (&cond_block, &se.post);
1508 : /* Create: if (_vtab && _final) <cond_block> */
1509 37 : tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1510 : gfc_class_vptr_get (decl),
1511 : null_pointer_node);
1512 37 : tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1513 : final, null_pointer_node);
1514 37 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1515 : boolean_type_node, cond, cond2);
1516 37 : gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
1517 : void_type_node, cond,
1518 : gfc_finish_block (&cond_block), NULL_TREE));
1519 37 : call = builtin_decl_explicit (BUILT_IN_FREE);
1520 37 : call = build_call_expr_loc (input_location, call, 1, data);
1521 37 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
1522 37 : return gfc_finish_block (&block);
1523 : }
1524 :
1525 31976 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1526 433 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1527 32027 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1528 187 : || !POINTER_TYPE_P (type)))
1529 : {
1530 31409 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1531 142 : return gfc_walk_alloc_comps (decl, NULL_TREE,
1532 71 : OMP_CLAUSE_DECL (clause),
1533 71 : WALK_ALLOC_COMPS_DTOR);
1534 : return NULL_TREE;
1535 : }
1536 :
1537 567 : if (GFC_DESCRIPTOR_TYPE_P (type))
1538 : {
1539 : /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1540 : to be deallocated if they were allocated. */
1541 382 : tem = gfc_conv_descriptor_data_get (decl);
1542 382 : tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE,
1543 : NULL_TREE, true, NULL,
1544 : GFC_CAF_COARRAY_NOCOARRAY);
1545 : }
1546 : else
1547 185 : tem = gfc_call_free (decl);
1548 567 : tem = gfc_omp_unshare_expr (tem);
1549 :
1550 567 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
1551 : {
1552 86 : stmtblock_t block;
1553 86 : tree then_b;
1554 :
1555 86 : gfc_init_block (&block);
1556 172 : gfc_add_expr_to_block (&block,
1557 : gfc_walk_alloc_comps (decl, NULL_TREE,
1558 86 : OMP_CLAUSE_DECL (clause),
1559 : WALK_ALLOC_COMPS_DTOR));
1560 86 : gfc_add_expr_to_block (&block, tem);
1561 86 : then_b = gfc_finish_block (&block);
1562 :
1563 86 : tem = fold_convert (pvoid_type_node,
1564 : GFC_DESCRIPTOR_TYPE_P (type)
1565 : ? gfc_conv_descriptor_data_get (decl) : decl);
1566 86 : tem = unshare_expr (tem);
1567 86 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1568 : tem, null_pointer_node);
1569 86 : tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
1570 : then_b, build_empty_stmt (input_location));
1571 : }
1572 : return tem;
1573 : }
1574 :
1575 : /* Build a conditional expression in BLOCK. If COND_VAL is not
1576 : null, then the block THEN_B is executed, otherwise ELSE_VAL
1577 : is assigned to VAL. */
1578 :
1579 : static void
1580 1026 : gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val,
1581 : tree then_b, tree else_val)
1582 : {
1583 1026 : stmtblock_t cond_block;
1584 1026 : tree else_b = NULL_TREE;
1585 1026 : tree val_ty = TREE_TYPE (val);
1586 :
1587 1026 : if (else_val)
1588 : {
1589 1026 : gfc_init_block (&cond_block);
1590 1026 : gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val));
1591 1026 : else_b = gfc_finish_block (&cond_block);
1592 : }
1593 1026 : gfc_add_expr_to_block (block,
1594 : build3_loc (input_location, COND_EXPR, void_type_node,
1595 : cond_val, then_b, else_b));
1596 1026 : }
1597 :
1598 : /* Build a conditional expression in BLOCK, returning a temporary
1599 : variable containing the result. If COND_VAL is not null, then
1600 : THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
1601 : is assigned.
1602 : */
1603 :
1604 : static tree
1605 1025 : gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val,
1606 : tree then_val, tree else_val)
1607 : {
1608 1025 : tree val;
1609 1025 : tree val_ty = TREE_TYPE (then_val);
1610 1025 : stmtblock_t cond_block;
1611 :
1612 1025 : val = create_tmp_var (val_ty);
1613 :
1614 1025 : gfc_init_block (&cond_block);
1615 1025 : gfc_add_modify (&cond_block, val, then_val);
1616 1025 : tree then_b = gfc_finish_block (&cond_block);
1617 :
1618 1025 : gfc_build_cond_assign (block, val, cond_val, then_b, else_val);
1619 :
1620 1025 : return val;
1621 : }
1622 :
1623 : void
1624 28762 : gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
1625 : {
1626 28762 : if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1627 : return;
1628 :
1629 6983 : tree decl = OMP_CLAUSE_DECL (c);
1630 6983 : location_t loc = OMP_CLAUSE_LOCATION (c);
1631 :
1632 : /* Assumed-size arrays can't be mapped implicitly, they have to be
1633 : mapped explicitly using array sections. */
1634 6983 : if (TREE_CODE (decl) == PARM_DECL
1635 1047 : && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
1636 371 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
1637 7354 : && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
1638 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
1639 : == NULL)
1640 : {
1641 1 : error_at (OMP_CLAUSE_LOCATION (c),
1642 : "implicit mapping of assumed size array %qD", decl);
1643 1 : return;
1644 : }
1645 :
1646 6982 : tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1647 6982 : tree present = gfc_omp_check_optional_argument (decl, true);
1648 6982 : tree orig_decl = NULL_TREE;
1649 6982 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
1650 : {
1651 1288 : if (!gfc_omp_privatize_by_reference (decl)
1652 156 : && !GFC_DECL_GET_SCALAR_POINTER (decl)
1653 93 : && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1654 3 : && !GFC_DECL_CRAY_POINTEE (decl)
1655 1291 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
1656 : return;
1657 1285 : orig_decl = decl;
1658 :
1659 1285 : c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1660 1285 : OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
1661 1285 : OMP_CLAUSE_DECL (c4) = decl;
1662 1285 : OMP_CLAUSE_SIZE (c4) = size_int (0);
1663 1285 : decl = build_fold_indirect_ref (decl);
1664 1285 : if (present
1665 1285 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1666 269 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1667 : {
1668 67 : c2 = build_omp_clause (loc, OMP_CLAUSE_MAP);
1669 67 : OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
1670 67 : OMP_CLAUSE_DECL (c2) = unshare_expr (decl);
1671 67 : OMP_CLAUSE_SIZE (c2) = size_int (0);
1672 :
1673 67 : stmtblock_t block;
1674 67 : gfc_start_block (&block);
1675 67 : tree ptr = gfc_build_cond_assign_expr (&block, present,
1676 : unshare_expr (decl),
1677 : null_pointer_node);
1678 67 : gimplify_and_add (gfc_finish_block (&block), pre_p);
1679 67 : ptr = build_fold_indirect_ref (ptr);
1680 67 : OMP_CLAUSE_DECL (c) = ptr;
1681 67 : OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
1682 : }
1683 : else
1684 : {
1685 1218 : OMP_CLAUSE_DECL (c) = decl;
1686 1218 : OMP_CLAUSE_SIZE (c) = NULL_TREE;
1687 : }
1688 1285 : if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1689 1285 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1690 391 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1691 : {
1692 67 : c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1693 67 : OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
1694 67 : OMP_CLAUSE_DECL (c3) = decl;
1695 67 : OMP_CLAUSE_SIZE (c3) = size_int (0);
1696 67 : decl = build_fold_indirect_ref (decl);
1697 67 : OMP_CLAUSE_DECL (c) = unshare_expr (decl);
1698 : }
1699 : }
1700 6979 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1701 : {
1702 1729 : stmtblock_t block;
1703 1729 : gfc_start_block (&block);
1704 1729 : tree type = TREE_TYPE (decl);
1705 1729 : tree ptr = gfc_conv_descriptor_data_get (decl);
1706 :
1707 : /* OpenMP: automatically map pointer targets with the pointer;
1708 : hence, always update the descriptor/pointer itself.
1709 : NOTE: This also remaps the pointer for allocatable arrays with
1710 : 'target' attribute which also don't have the 'restrict' qualifier. */
1711 1729 : bool always_modifier = false;
1712 :
1713 1729 : if (!openacc
1714 1729 : && !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT))
1715 : always_modifier = true;
1716 :
1717 1729 : if (present)
1718 56 : ptr = gfc_build_cond_assign_expr (&block, present, ptr,
1719 : null_pointer_node);
1720 1729 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
1721 1729 : ptr = build_fold_indirect_ref (ptr);
1722 1729 : OMP_CLAUSE_DECL (c) = ptr;
1723 1729 : c2 = build_omp_clause (loc, OMP_CLAUSE_MAP);
1724 1729 : OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
1725 1729 : if (present)
1726 : {
1727 56 : ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0)));
1728 56 : gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0));
1729 :
1730 56 : OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr);
1731 : }
1732 : else
1733 1673 : OMP_CLAUSE_DECL (c2) = decl;
1734 1729 : OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type);
1735 1729 : c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1736 3247 : OMP_CLAUSE_SET_MAP_KIND (c3, always_modifier ? GOMP_MAP_ALWAYS_POINTER
1737 : : GOMP_MAP_POINTER);
1738 1729 : if (present)
1739 : {
1740 56 : ptr = gfc_conv_descriptor_data_get (unshare_expr (decl));
1741 56 : ptr = gfc_build_addr_expr (NULL, ptr);
1742 56 : ptr = gfc_build_cond_assign_expr (&block, present,
1743 : ptr, null_pointer_node);
1744 56 : ptr = build_fold_indirect_ref (ptr);
1745 56 : OMP_CLAUSE_DECL (c3) = ptr;
1746 : }
1747 : else
1748 1673 : OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
1749 1729 : OMP_CLAUSE_SIZE (c3) = size_int (0);
1750 1729 : tree size = create_tmp_var (gfc_array_index_type);
1751 1729 : tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
1752 1729 : elemsz = fold_convert (gfc_array_index_type, elemsz);
1753 :
1754 1729 : if (orig_decl == NULL_TREE)
1755 1495 : orig_decl = decl;
1756 1729 : if (!openacc
1757 1729 : && gfc_has_alloc_comps (type, orig_decl, true))
1758 : {
1759 : /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
1760 : force evaluate to ensure that it is not gimplified + is a decl. */
1761 3 : gfc_allocate_lang_decl (size);
1762 3 : GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
1763 : }
1764 1729 : enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
1765 1729 : if (akind == GFC_ARRAY_ALLOCATABLE
1766 : || akind == GFC_ARRAY_POINTER
1767 1729 : || akind == GFC_ARRAY_POINTER_CONT
1768 1729 : || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
1769 : || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
1770 1 : || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
1771 : {
1772 1728 : stmtblock_t cond_block;
1773 1728 : tree tem, then_b, else_b, zero, cond;
1774 :
1775 1728 : int rank = ((akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
1776 : || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
1777 1728 : || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
1778 1728 : ? -1 : GFC_TYPE_ARRAY_RANK (type));
1779 1728 : gfc_init_block (&cond_block);
1780 1728 : tem = gfc_full_array_size (&cond_block, unshare_expr (decl), rank);
1781 1728 : gfc_add_modify (&cond_block, size, tem);
1782 1728 : gfc_add_modify (&cond_block, size,
1783 : fold_build2 (MULT_EXPR, gfc_array_index_type,
1784 : size, elemsz));
1785 1728 : then_b = gfc_finish_block (&cond_block);
1786 1728 : gfc_init_block (&cond_block);
1787 1728 : zero = build_int_cst (gfc_array_index_type, 0);
1788 1728 : gfc_add_modify (&cond_block, size, zero);
1789 1728 : else_b = gfc_finish_block (&cond_block);
1790 1728 : tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
1791 1728 : tem = fold_convert (pvoid_type_node, tem);
1792 1728 : cond = fold_build2_loc (loc, NE_EXPR,
1793 : boolean_type_node, tem, null_pointer_node);
1794 1728 : if (present)
1795 : {
1796 55 : cond = fold_build2_loc (loc, TRUTH_ANDIF_EXPR,
1797 : boolean_type_node, present, cond);
1798 : }
1799 1728 : gfc_add_expr_to_block (&block, build3_loc (loc, COND_EXPR,
1800 : void_type_node, cond,
1801 : then_b, else_b));
1802 1728 : }
1803 1 : else if (present)
1804 : {
1805 1 : stmtblock_t cond_block;
1806 1 : tree then_b;
1807 :
1808 1 : int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
1809 1 : || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
1810 1 : ? -1 : GFC_TYPE_ARRAY_RANK (type));
1811 1 : gfc_init_block (&cond_block);
1812 1 : gfc_add_modify (&cond_block, size,
1813 : gfc_full_array_size (&cond_block, unshare_expr (decl),
1814 : rank));
1815 1 : gfc_add_modify (&cond_block, size,
1816 : fold_build2 (MULT_EXPR, gfc_array_index_type,
1817 : size, elemsz));
1818 1 : then_b = gfc_finish_block (&cond_block);
1819 :
1820 1 : gfc_build_cond_assign (&block, size, present, then_b,
1821 : build_int_cst (gfc_array_index_type, 0));
1822 : }
1823 : else
1824 : {
1825 0 : int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
1826 0 : || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
1827 0 : ? -1 : GFC_TYPE_ARRAY_RANK (type));
1828 0 : gfc_add_modify (&block, size,
1829 : gfc_full_array_size (&block, unshare_expr (decl),
1830 : rank));
1831 0 : gfc_add_modify (&block, size,
1832 : fold_build2 (MULT_EXPR, gfc_array_index_type,
1833 : size, elemsz));
1834 : }
1835 1729 : OMP_CLAUSE_SIZE (c) = size;
1836 1729 : tree stmt = gfc_finish_block (&block);
1837 1729 : gimplify_and_add (stmt, pre_p);
1838 : }
1839 : else
1840 : {
1841 5250 : if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
1842 : {
1843 1196 : if (DECL_P (decl))
1844 212 : OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
1845 : else
1846 : {
1847 984 : tree type = TREE_TYPE (decl);
1848 984 : tree size = TYPE_SIZE_UNIT (type);
1849 : /* For variable-length character types, TYPE_SIZE_UNIT is a
1850 : SAVE_EXPR. Gimplifying the SAVE_EXPR (here or elsewhere)
1851 : resolves it in place, embedding a gimple temporary that
1852 : later causes an ICE in remap_type during inlining because
1853 : the temporary is not in scope (PR101760, PR102314).
1854 : Compute the size from the array domain and element size
1855 : to decouple completely from the type's SAVE_EXPRs. */
1856 984 : if (size
1857 984 : && TREE_CODE (type) == ARRAY_TYPE
1858 530 : && TYPE_DOMAIN (type)
1859 530 : && TYPE_MAX_VALUE (TYPE_DOMAIN (type))
1860 1514 : && !TREE_CONSTANT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
1861 : {
1862 310 : tree len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1863 310 : tree lb = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
1864 310 : tree eltsz = TYPE_SIZE_UNIT (TREE_TYPE (type));
1865 310 : len = fold_build2 (MINUS_EXPR, TREE_TYPE (len), len, lb);
1866 310 : len = fold_build2 (PLUS_EXPR, TREE_TYPE (len), len,
1867 : build_one_cst (TREE_TYPE (len)));
1868 310 : size = fold_build2 (MULT_EXPR, sizetype,
1869 : fold_convert (sizetype, len),
1870 : fold_convert (sizetype, eltsz));
1871 : }
1872 984 : OMP_CLAUSE_SIZE (c) = size;
1873 : }
1874 : }
1875 :
1876 5250 : tree type = TREE_TYPE (decl);
1877 5250 : if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE (type)))
1878 0 : type = TREE_TYPE (type);
1879 5250 : if (!openacc
1880 5250 : && orig_decl != NULL_TREE
1881 5250 : && gfc_has_alloc_comps (type, orig_decl, true))
1882 : {
1883 : /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
1884 : force evaluate to ensure that it is not gimplified + is a decl. */
1885 19 : tree size = create_tmp_var (TREE_TYPE (OMP_CLAUSE_SIZE (c)));
1886 19 : gfc_allocate_lang_decl (size);
1887 19 : GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
1888 19 : gimplify_assign (size, OMP_CLAUSE_SIZE (c), pre_p);
1889 19 : OMP_CLAUSE_SIZE (c) = size;
1890 : }
1891 : }
1892 6979 : tree last = c;
1893 6979 : if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
1894 : NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
1895 0 : OMP_CLAUSE_SIZE (c) = size_int (0);
1896 6979 : if (c2)
1897 : {
1898 1796 : OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last);
1899 1796 : OMP_CLAUSE_CHAIN (last) = c2;
1900 1796 : last = c2;
1901 : }
1902 6979 : if (c3)
1903 : {
1904 1796 : OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last);
1905 1796 : OMP_CLAUSE_CHAIN (last) = c3;
1906 1796 : last = c3;
1907 : }
1908 6979 : if (c4)
1909 : {
1910 1285 : OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last);
1911 1285 : OMP_CLAUSE_CHAIN (last) = c4;
1912 : }
1913 : }
1914 :
1915 :
1916 : /* map(<flag>: data [len: <size>])
1917 : map(attach: &data [bias: <bias>])
1918 : offset += 2; offset_data += 2 */
1919 : static void
1920 645 : gfc_omp_deep_mapping_map (tree data, tree size, unsigned HOST_WIDE_INT tkind,
1921 : location_t loc, tree data_array, tree sizes_array,
1922 : tree kinds_array, tree offset_data, tree offset,
1923 : gimple_seq *seq, const gimple *ctx)
1924 : {
1925 645 : tree one = build_int_cst (size_type_node, 1);
1926 :
1927 645 : STRIP_NOPS (data);
1928 645 : if (!POINTER_TYPE_P (TREE_TYPE (data)))
1929 : {
1930 205 : gcc_assert (TREE_CODE (data) == INDIRECT_REF);
1931 205 : data = TREE_OPERAND (data, 0);
1932 : }
1933 :
1934 : /* data_array[offset_data] = data; */
1935 645 : tree tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
1936 : unshare_expr (data_array), offset_data,
1937 : NULL_TREE, NULL_TREE);
1938 645 : gimplify_assign (tmp, data, seq);
1939 :
1940 : /* offset_data++ */
1941 645 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
1942 645 : gimplify_assign (offset_data, tmp, seq);
1943 :
1944 : /* data_array[offset_data] = &data; */
1945 645 : tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
1946 : unshare_expr (data_array),
1947 : offset_data, NULL_TREE, NULL_TREE);
1948 645 : gimplify_assign (tmp, build_fold_addr_expr (data), seq);
1949 :
1950 : /* offset_data++ */
1951 645 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
1952 645 : gimplify_assign (offset_data, tmp, seq);
1953 :
1954 : /* sizes_array[offset] = size */
1955 645 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1956 645 : TYPE_SIZE_UNIT (size_type_node), offset);
1957 645 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
1958 : sizes_array, tmp);
1959 645 : gimple_seq seq2 = NULL;
1960 645 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1961 645 : gimple_seq_add_seq (seq, seq2);
1962 645 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1963 645 : gimplify_assign (tmp, size, seq);
1964 :
1965 : /* FIXME: tkind |= talign << talign_shift; */
1966 : /* kinds_array[offset] = tkind. */
1967 645 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1968 645 : TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
1969 645 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
1970 : kinds_array, tmp);
1971 645 : seq2 = NULL;
1972 645 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1973 645 : gimple_seq_add_seq (seq, seq2);
1974 645 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1975 645 : gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
1976 :
1977 : /* offset++ */
1978 645 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
1979 645 : gimplify_assign (offset, tmp, seq);
1980 :
1981 : /* sizes_array[offset] = bias (= 0). */
1982 645 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1983 645 : TYPE_SIZE_UNIT (size_type_node), offset);
1984 645 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
1985 : sizes_array, tmp);
1986 645 : seq2 = NULL;
1987 645 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1988 645 : gimple_seq_add_seq (seq, seq2);
1989 645 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1990 645 : gimplify_assign (tmp, build_zero_cst (size_type_node), seq);
1991 :
1992 645 : gcc_assert (gimple_code (ctx) == GIMPLE_OMP_TARGET);
1993 645 : tkind = (gimple_omp_target_kind (ctx) == GF_OMP_TARGET_KIND_EXIT_DATA
1994 645 : ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH);
1995 :
1996 : /* kinds_array[offset] = tkind. */
1997 645 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1998 645 : TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
1999 645 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
2000 : kinds_array, tmp);
2001 645 : seq2 = NULL;
2002 645 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
2003 645 : gimple_seq_add_seq (seq, seq2);
2004 645 : tmp = build_fold_indirect_ref_loc (loc, tmp);
2005 645 : gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
2006 :
2007 : /* offset++ */
2008 645 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
2009 645 : gimplify_assign (offset, tmp, seq);
2010 645 : }
2011 :
2012 : static void gfc_omp_deep_mapping_item (bool, bool, bool, location_t, tree,
2013 : tree *, unsigned HOST_WIDE_INT, tree,
2014 : tree, tree, tree, tree, tree,
2015 : gimple_seq *, const gimple *, bool *);
2016 :
2017 : /* Map allocatable components. */
2018 : static void
2019 926 : gfc_omp_deep_mapping_comps (bool is_cnt, location_t loc, tree decl,
2020 : tree *token, unsigned HOST_WIDE_INT tkind,
2021 : tree data_array, tree sizes_array, tree kinds_array,
2022 : tree offset_data, tree offset, tree num,
2023 : gimple_seq *seq, const gimple *ctx,
2024 : bool *poly_warned)
2025 : {
2026 926 : tree type = TREE_TYPE (decl);
2027 926 : if (TREE_CODE (type) != RECORD_TYPE)
2028 : return;
2029 2562 : for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
2030 : {
2031 1640 : type = TREE_TYPE (field);
2032 1640 : if (gfc_is_polymorphic_nonptr (type)
2033 1438 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
2034 2800 : || (GFC_DESCRIPTOR_TYPE_P (type)
2035 770 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE))
2036 : {
2037 1250 : tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
2038 : decl, field, NULL_TREE);
2039 1250 : gfc_omp_deep_mapping_item (is_cnt, true, true, loc, tmp, token,
2040 : tkind, data_array, sizes_array,
2041 : kinds_array, offset_data, offset, num,
2042 : seq, ctx, poly_warned);
2043 : }
2044 390 : else if (GFC_DECL_GET_SCALAR_POINTER (field)
2045 390 : || GFC_DESCRIPTOR_TYPE_P (type))
2046 0 : continue;
2047 390 : else if (gfc_has_alloc_comps (TREE_TYPE (field), field, false))
2048 : {
2049 104 : tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
2050 : decl, field, NULL_TREE);
2051 104 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2052 40 : gfc_omp_deep_mapping_item (is_cnt, false, false, loc, tmp,
2053 : token, tkind, data_array, sizes_array,
2054 : kinds_array, offset_data, offset, num,
2055 : seq, ctx, poly_warned);
2056 : else
2057 64 : gfc_omp_deep_mapping_comps (is_cnt, loc, tmp, token, tkind,
2058 : data_array, sizes_array, kinds_array,
2059 : offset_data, offset, num, seq, ctx,
2060 : poly_warned);
2061 : }
2062 : }
2063 : }
2064 :
2065 : static void
2066 944 : gfc_omp_gen_simple_loop (tree var, tree begin, tree end, enum tree_code cond,
2067 : tree step, location_t loc, gimple_seq *seq1,
2068 : gimple_seq *seq2)
2069 : {
2070 944 : tree tmp;
2071 :
2072 : /* var = begin. */
2073 944 : gimplify_assign (var, begin, seq1);
2074 :
2075 : /* Loop: for (var = begin; var <cond> end; var += step). */
2076 944 : tree label_loop = create_artificial_label (loc);
2077 944 : tree label_cond = create_artificial_label (loc);
2078 :
2079 944 : gimplify_and_add (fold_build1_loc (loc, GOTO_EXPR, void_type_node,
2080 : label_cond), seq1);
2081 944 : gimple_seq_add_stmt (seq1, gimple_build_label (label_loop));
2082 :
2083 : /* Everything above is seq1; place loop body here. */
2084 :
2085 : /* End of loop body -> put into seq2. */
2086 944 : tmp = fold_build2_loc (loc, PLUS_EXPR, TREE_TYPE (var), var, step);
2087 944 : gimplify_assign (var, tmp, seq2);
2088 944 : gimple_seq_add_stmt (seq2, gimple_build_label (label_cond));
2089 944 : tmp = fold_build2_loc (loc, cond, boolean_type_node, var, end);
2090 944 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
2091 : build_empty_stmt (loc));
2092 944 : gimplify_and_add (tmp, seq2);
2093 944 : }
2094 :
2095 : /* Return size variable with the size of an array. */
2096 : static tree
2097 604 : gfc_omp_get_array_size (location_t loc, tree desc, gimple_seq *seq)
2098 : {
2099 604 : tree tmp;
2100 604 : gimple_seq seq1 = NULL, seq2 = NULL;
2101 604 : tree size = build_decl (loc, VAR_DECL, create_tmp_var_name ("size"),
2102 : size_type_node);
2103 604 : tree extent = build_decl (loc, VAR_DECL, create_tmp_var_name ("extent"),
2104 : gfc_array_index_type);
2105 604 : tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
2106 : signed_char_type_node);
2107 :
2108 604 : tree begin = build_zero_cst (signed_char_type_node);
2109 604 : tree end;
2110 604 : if (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE_CONT
2111 604 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE)
2112 8 : end = gfc_conv_descriptor_rank (desc);
2113 : else
2114 596 : end = build_int_cst (signed_char_type_node,
2115 596 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
2116 604 : tree step = build_int_cst (signed_char_type_node, 1);
2117 :
2118 : /* size = 0
2119 : for (idx = 0; idx < rank; idx++)
2120 : extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
2121 : if (extent < 0) extent = 0
2122 : size *= extent. */
2123 604 : gimplify_assign (size, build_int_cst (size_type_node, 1), seq);
2124 :
2125 604 : gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, &seq1, &seq2);
2126 604 : gimple_seq_add_seq (seq, seq1);
2127 :
2128 604 : tmp = fold_build2_loc (loc, MINUS_EXPR, gfc_array_index_type,
2129 : gfc_conv_descriptor_ubound_get (desc, idx),
2130 : gfc_conv_descriptor_lbound_get (desc, idx));
2131 604 : tmp = fold_build2_loc (loc, PLUS_EXPR, gfc_array_index_type,
2132 : tmp, gfc_index_one_node);
2133 604 : gimplify_assign (extent, tmp, seq);
2134 604 : tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node,
2135 : extent, gfc_index_zero_node);
2136 604 : tmp = build3_v (COND_EXPR, tmp,
2137 : fold_build2_loc (loc, MODIFY_EXPR,
2138 : gfc_array_index_type,
2139 : extent, gfc_index_zero_node),
2140 : build_empty_stmt (loc));
2141 604 : gimplify_and_add (tmp, seq);
2142 : /* size *= extent. */
2143 604 : gimplify_assign (size, fold_build2_loc (loc, MULT_EXPR, size_type_node, size,
2144 : fold_convert (size_type_node,
2145 : extent)), seq);
2146 604 : gimple_seq_add_seq (seq, seq2);
2147 604 : return size;
2148 : }
2149 :
2150 : /* Generate loop to access every array element; takes addr of first element
2151 : (decl's data comp); returns loop code in seq1 + seq2
2152 : and the pointer to the element as return value. */
2153 : static tree
2154 340 : gfc_omp_elmental_loop (location_t loc, tree decl, tree size, tree elem_len,
2155 : gimple_seq *seq1, gimple_seq *seq2)
2156 : {
2157 340 : tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
2158 : size_type_node);
2159 340 : tree begin = build_zero_cst (size_type_node);
2160 340 : tree end = size;
2161 340 : tree step = build_int_cst (size_type_node, 1);
2162 340 : tree ptr;
2163 :
2164 340 : gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, seq1, seq2);
2165 :
2166 340 : tree type = TREE_TYPE (decl);
2167 340 : if (POINTER_TYPE_P (type))
2168 : {
2169 296 : type = TREE_TYPE (type);
2170 296 : gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
2171 296 : decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
2172 : }
2173 : else
2174 : {
2175 44 : gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
2176 44 : decl = build_fold_addr_expr_loc (loc, decl);
2177 : }
2178 340 : decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
2179 340 : tree tmp = build2_loc (loc, MULT_EXPR, size_type_node, idx,
2180 : fold_convert (size_type_node, elem_len));
2181 340 : ptr = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, tmp);
2182 340 : gimple_seq seq3 = NULL;
2183 340 : ptr = force_gimple_operand (ptr, &seq3, true, NULL_TREE);
2184 340 : gimple_seq_add_seq (seq1, seq3);
2185 :
2186 340 : return ptr;
2187 : }
2188 :
2189 :
2190 : /* If do_copy, copy data pointer and vptr (if applicable) as well.
2191 : Otherwise, only handle allocatable components.
2192 : do_copy == false can happen only with nonpolymorphic arguments
2193 : to a copy clause.
2194 : if (is_cnt) token ... offset is ignored and num is used, otherwise
2195 : num is NULL_TREE and unused. */
2196 :
2197 : static void
2198 1696 : gfc_omp_deep_mapping_item (bool is_cnt, bool do_copy, bool do_alloc_check,
2199 : location_t loc, tree decl, tree *token,
2200 : unsigned HOST_WIDE_INT tkind, tree data_array,
2201 : tree sizes_array, tree kinds_array, tree offset_data,
2202 : tree offset, tree num, gimple_seq *seq,
2203 : const gimple *ctx, bool *poly_warned)
2204 : {
2205 1696 : tree tmp;
2206 1696 : tree type = TREE_TYPE (decl);
2207 1696 : if (POINTER_TYPE_P (type))
2208 416 : type = TREE_TYPE (type);
2209 1696 : tree end_label = NULL_TREE;
2210 1696 : tree size = NULL_TREE, elem_len = NULL_TREE;
2211 :
2212 1696 : bool poly = gfc_is_polymorphic_nonptr (type);
2213 1696 : if (poly && is_cnt && !*poly_warned)
2214 : {
2215 41 : if (gfc_is_unlimited_polymorphic_nonptr (type))
2216 2 : error_at (loc,
2217 : "Mapping of unlimited polymorphic list item %qD is "
2218 : "unspecified behavior and unsupported", decl);
2219 :
2220 : else
2221 39 : warning_at (loc, OPT_Wopenmp,
2222 : "Mapping of polymorphic list item %qD is "
2223 : "unspecified behavior", decl);
2224 41 : *poly_warned = true;
2225 : }
2226 1696 : if (do_alloc_check)
2227 : {
2228 1428 : tree then_label = create_artificial_label (loc);
2229 1428 : end_label = create_artificial_label (loc);
2230 1428 : tmp = decl;
2231 1428 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE
2232 1428 : || (POINTER_TYPE_P (TREE_TYPE (tmp))
2233 396 : && (POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
2234 396 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (tmp))))))
2235 8 : tmp = build_fold_indirect_ref_loc (loc, tmp);
2236 1428 : if (poly)
2237 242 : tmp = gfc_class_data_get (tmp);
2238 1428 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2239 904 : tmp = gfc_conv_descriptor_data_get (tmp);
2240 1428 : gimple_seq seq2 = NULL;
2241 1428 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
2242 1428 : gimple_seq_add_seq (seq, seq2);
2243 :
2244 1428 : gimple_seq_add_stmt (seq,
2245 1428 : gimple_build_cond (NE_EXPR, tmp, null_pointer_node,
2246 : then_label, end_label));
2247 1428 : gimple_seq_add_stmt (seq, gimple_build_label (then_label));
2248 : }
2249 1696 : tree class_decl = decl;
2250 1696 : if (poly)
2251 : {
2252 242 : decl = gfc_class_data_get (decl);
2253 242 : type = TREE_TYPE (decl);
2254 : }
2255 1696 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
2256 : {
2257 548 : decl = build_fold_indirect_ref (decl);
2258 548 : type = TREE_TYPE (decl);
2259 : }
2260 :
2261 1696 : if (is_cnt && do_copy)
2262 : {
2263 645 : tree tmp = fold_build2_loc (loc, PLUS_EXPR, size_type_node,
2264 : num, build_int_cst (size_type_node, 1));
2265 645 : gimplify_assign (num, tmp, seq);
2266 : }
2267 1051 : else if (do_copy)
2268 : {
2269 : /* copy data pointer */
2270 645 : tree bytesize;
2271 645 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2272 : {
2273 : /* TODO: Optimization: Shouldn't this be an expr. const, except for
2274 : deferred-length strings. (Cf. also below). */
2275 440 : elem_len = (poly ? gfc_class_vtab_size_get (class_decl)
2276 385 : : gfc_conv_descriptor_elem_len (decl));
2277 880 : tmp = (POINTER_TYPE_P (TREE_TYPE (decl))
2278 440 : ? build_fold_indirect_ref (decl) : decl);
2279 440 : size = gfc_omp_get_array_size (loc, tmp, seq);
2280 440 : bytesize = fold_build2_loc (loc, MULT_EXPR, size_type_node,
2281 : fold_convert (size_type_node, size),
2282 : fold_convert (size_type_node, elem_len));
2283 440 : tmp = gfc_conv_descriptor_data_get (decl);
2284 : }
2285 205 : else if (poly)
2286 : {
2287 66 : tmp = decl;
2288 66 : bytesize = fold_convert (size_type_node,
2289 : gfc_class_vtab_size_get (class_decl));
2290 : }
2291 : else
2292 : {
2293 139 : tmp = decl;
2294 139 : bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl));
2295 : }
2296 645 : unsigned HOST_WIDE_INT tkind2 = tkind;
2297 645 : if (!is_cnt
2298 645 : && (tkind == GOMP_MAP_ALLOC
2299 617 : || (tkind == GOMP_MAP_FROM
2300 60 : && (gimple_omp_target_kind (ctx)
2301 : != GF_OMP_TARGET_KIND_EXIT_DATA)))
2302 689 : && gfc_omp_replace_alloc_by_to_mapping (TREE_TYPE (decl), decl, true))
2303 12 : tkind2 = tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO : GOMP_MAP_TOFROM;
2304 :
2305 645 : gfc_omp_deep_mapping_map (tmp, bytesize, tkind2, loc, data_array,
2306 : sizes_array, kinds_array, offset_data,
2307 : offset, seq, ctx);
2308 : }
2309 :
2310 1696 : tmp = decl;
2311 1696 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
2312 0 : while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
2313 0 : tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
2314 1696 : if (poly || gfc_has_alloc_comps (type, tmp, true))
2315 : {
2316 862 : gimple_seq seq2 = NULL;
2317 862 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2318 : {
2319 296 : if (elem_len == NULL_TREE)
2320 : {
2321 164 : elem_len = gfc_conv_descriptor_elem_len (decl);
2322 164 : size = fold_convert (size_type_node,
2323 : gfc_omp_get_array_size (loc, decl, seq));
2324 : }
2325 296 : decl = gfc_conv_descriptor_data_get (decl);
2326 296 : decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
2327 296 : decl = build_fold_indirect_ref_loc (loc, decl);
2328 : }
2329 566 : else if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2330 : {
2331 44 : type = TREE_TYPE (tmp);
2332 : /* FIXME: PR95868 - for var%str of deferred length, elem_len == 0;
2333 : len is stored as var%_str_length, but not in GFC_DECL_STRING_LEN
2334 : nor in TYPE_SIZE_UNIT as expression. */
2335 44 : elem_len = TYPE_SIZE_UNIT (TREE_TYPE (type));
2336 44 : size = fold_convert (size_type_node, GFC_TYPE_ARRAY_SIZE (type));
2337 44 : decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
2338 44 : decl = build_fold_indirect_ref_loc (loc, decl);
2339 : }
2340 522 : else if (POINTER_TYPE_P (TREE_TYPE (decl)))
2341 0 : decl = build_fold_indirect_ref (decl);
2342 :
2343 862 : gfc_omp_deep_mapping_comps (is_cnt, loc, decl, token, tkind,
2344 : data_array, sizes_array, kinds_array,
2345 : offset_data, offset, num, seq, ctx,
2346 : poly_warned);
2347 862 : gimple_seq_add_seq (seq, seq2);
2348 : }
2349 1696 : if (end_label)
2350 1428 : gimple_seq_add_stmt (seq, gimple_build_label (end_label));
2351 1696 : }
2352 :
2353 :
2354 : /* Which map types to check/handle for deep mapping. */
2355 : static bool
2356 40455 : gfc_omp_deep_map_kind_p (tree clause)
2357 : {
2358 40455 : switch (OMP_CLAUSE_CODE (clause))
2359 : {
2360 36899 : case OMP_CLAUSE_MAP:
2361 36899 : break;
2362 : case OMP_CLAUSE_FIRSTPRIVATE:
2363 : case OMP_CLAUSE_TO:
2364 : case OMP_CLAUSE_FROM:
2365 : return true;
2366 0 : default:
2367 0 : gcc_unreachable ();
2368 : }
2369 :
2370 36899 : switch (OMP_CLAUSE_MAP_KIND (clause))
2371 : {
2372 : case GOMP_MAP_TO:
2373 : case GOMP_MAP_FROM:
2374 : case GOMP_MAP_TOFROM:
2375 : case GOMP_MAP_ALWAYS_TO:
2376 : case GOMP_MAP_ALWAYS_FROM:
2377 : case GOMP_MAP_ALWAYS_TOFROM:
2378 : case GOMP_MAP_ALWAYS_PRESENT_FROM:
2379 : case GOMP_MAP_ALWAYS_PRESENT_TO:
2380 : case GOMP_MAP_ALWAYS_PRESENT_TOFROM:
2381 : case GOMP_MAP_FIRSTPRIVATE:
2382 : case GOMP_MAP_ALLOC:
2383 : return true;
2384 : case GOMP_MAP_POINTER:
2385 : case GOMP_MAP_TO_PSET:
2386 : case GOMP_MAP_FORCE_PRESENT:
2387 : case GOMP_MAP_DELETE:
2388 : case GOMP_MAP_FORCE_DEVICEPTR:
2389 : case GOMP_MAP_DEVICE_RESIDENT:
2390 : case GOMP_MAP_LINK:
2391 : case GOMP_MAP_IF_PRESENT:
2392 : case GOMP_MAP_PRESENT_ALLOC:
2393 : case GOMP_MAP_PRESENT_FROM:
2394 : case GOMP_MAP_PRESENT_TO:
2395 : case GOMP_MAP_PRESENT_TOFROM:
2396 : case GOMP_MAP_FIRSTPRIVATE_INT:
2397 : case GOMP_MAP_USE_DEVICE_PTR:
2398 : case GOMP_MAP_ZERO_LEN_ARRAY_SECTION:
2399 : case GOMP_MAP_FORCE_ALLOC:
2400 : case GOMP_MAP_FORCE_TO:
2401 : case GOMP_MAP_FORCE_FROM:
2402 : case GOMP_MAP_FORCE_TOFROM:
2403 : case GOMP_MAP_USE_DEVICE_PTR_IF_PRESENT:
2404 : case GOMP_MAP_STRUCT:
2405 : case GOMP_MAP_STRUCT_UNORD:
2406 : case GOMP_MAP_ALWAYS_POINTER:
2407 : case GOMP_MAP_POINTER_TO_ZERO_LENGTH_ARRAY_SECTION:
2408 : case GOMP_MAP_DELETE_ZERO_LEN_ARRAY_SECTION:
2409 : case GOMP_MAP_RELEASE:
2410 : case GOMP_MAP_ATTACH:
2411 : case GOMP_MAP_DETACH:
2412 : case GOMP_MAP_FORCE_DETACH:
2413 : case GOMP_MAP_ATTACH_ZERO_LENGTH_ARRAY_SECTION:
2414 : case GOMP_MAP_FIRSTPRIVATE_POINTER:
2415 : case GOMP_MAP_FIRSTPRIVATE_REFERENCE:
2416 : case GOMP_MAP_ATTACH_DETACH:
2417 : break;
2418 0 : default:
2419 0 : gcc_unreachable ();
2420 : }
2421 : return false;
2422 : }
2423 :
2424 : /* Three OpenMP deep-mapping lang hooks: gfc_omp_deep_mapping{_p,_cnt,}. */
2425 :
2426 : /* Common check for gfc_omp_deep_mapping_p and gfc_omp_deep_mapping_do. */
2427 :
2428 : static tree
2429 92054 : gfc_omp_deep_mapping_int_p (const gimple *ctx, tree clause)
2430 : {
2431 92054 : if (is_gimple_omp_oacc (ctx) || !gfc_omp_deep_map_kind_p (clause))
2432 : return NULL_TREE;
2433 21240 : tree decl = OMP_CLAUSE_DECL (clause);
2434 21240 : if (OMP_CLAUSE_SIZE (clause) != NULL_TREE
2435 21230 : && DECL_P (OMP_CLAUSE_SIZE (clause))
2436 6409 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (clause))
2437 21539 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause)))
2438 : /* Saved decl. */
2439 299 : decl = GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause));
2440 20941 : else if (TREE_CODE (decl) == MEM_REF || TREE_CODE (decl) == INDIRECT_REF)
2441 : /* The following can happen for, e.g., class(t) :: var(..) */
2442 12222 : decl = TREE_OPERAND (decl, 0);
2443 21240 : if (TREE_CODE (decl) == INDIRECT_REF)
2444 : /* The following can happen for, e.g., class(t) :: var(..) */
2445 132 : decl = TREE_OPERAND (decl, 0);
2446 21240 : if (DECL_P (decl)
2447 12660 : && DECL_LANG_SPECIFIC (decl)
2448 23396 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
2449 62 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2450 : /* Handle map(to: var.desc) map([to/from/tofrom:] var.desc.data)
2451 : to get proper map kind by skipping to the next item. */
2452 21240 : tree tmp = OMP_CLAUSE_CHAIN (clause);
2453 21240 : if (tmp != NULL_TREE
2454 15849 : && OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_CODE (clause)
2455 14282 : && OMP_CLAUSE_SIZE (tmp) != NULL_TREE
2456 14282 : && DECL_P (OMP_CLAUSE_SIZE (tmp))
2457 1326 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (tmp))
2458 21312 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (tmp)) == decl)
2459 : return NULL_TREE;
2460 21240 : if (DECL_P (decl)
2461 12660 : && DECL_LANG_SPECIFIC (decl)
2462 23363 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
2463 29 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2464 21240 : tree type = TREE_TYPE (decl);
2465 21240 : if (POINTER_TYPE_P (type))
2466 13152 : type = TREE_TYPE (type);
2467 21240 : if (POINTER_TYPE_P (type))
2468 140 : type = TREE_TYPE (type);
2469 21240 : tmp = decl;
2470 22915 : while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
2471 2248 : tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
2472 21240 : if (!gfc_is_polymorphic_nonptr (type)
2473 21240 : && !gfc_has_alloc_comps (type, tmp, true))
2474 : return NULL_TREE;
2475 : return decl;
2476 : }
2477 :
2478 : /* Return true if there is deep mapping, even if the number of mapping is known
2479 : at compile time. */
2480 : bool
2481 44534 : gfc_omp_deep_mapping_p (const gimple *ctx, tree clause)
2482 : {
2483 44534 : tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
2484 44534 : if (decl == NULL_TREE)
2485 44390 : return false;
2486 : return true;
2487 : }
2488 :
2489 : /* Handle gfc_omp_deep_mapping{,_cnt} */
2490 : static tree
2491 47496 : gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause,
2492 : unsigned HOST_WIDE_INT tkind, tree data, tree sizes,
2493 : tree kinds, tree offset_data, tree offset,
2494 : gimple_seq *seq)
2495 : {
2496 47496 : tree num = NULL_TREE;
2497 47496 : location_t loc = OMP_CLAUSE_LOCATION (clause);
2498 47496 : tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
2499 47496 : bool poly_warned = false;
2500 47496 : if (decl == NULL_TREE)
2501 : return NULL_TREE;
2502 : /* Handle: map(alloc:dt%cmp [len: ptr_size]) map(tofrom: D.0123...),
2503 : where GFC_DECL_SAVED_DESCRIPTOR(D.0123) is the same (here: dt%cmp). */
2504 418 : if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
2505 418 : && (OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_ALLOC
2506 374 : || OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_PRESENT_ALLOC))
2507 : {
2508 : tree c = clause;
2509 84 : while ((c = OMP_CLAUSE_CHAIN (c)) != NULL_TREE)
2510 : {
2511 60 : if (!gfc_omp_deep_map_kind_p (c))
2512 36 : continue;
2513 24 : tree d = gfc_omp_deep_mapping_int_p (ctx, c);
2514 24 : if (d != NULL_TREE && operand_equal_p (decl, d, 0))
2515 : return NULL_TREE;
2516 : }
2517 : }
2518 406 : tree type = TREE_TYPE (decl);
2519 406 : if (POINTER_TYPE_P (type))
2520 138 : type = TREE_TYPE (type);
2521 406 : if (POINTER_TYPE_P (type))
2522 8 : type = TREE_TYPE (type);
2523 406 : bool poly = gfc_is_polymorphic_nonptr (type);
2524 :
2525 406 : if (is_cnt)
2526 : {
2527 203 : num = build_decl (loc, VAR_DECL,
2528 : create_tmp_var_name ("n_deepmap"), size_type_node);
2529 203 : tree tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node, num,
2530 : build_int_cst (size_type_node, 0));
2531 203 : gimple_add_tmp_var (num);
2532 203 : gimplify_and_add (tmp, seq);
2533 : }
2534 : else
2535 203 : gcc_assert (short_unsigned_type_node == TREE_TYPE (TREE_TYPE (kinds)));
2536 :
2537 406 : bool do_copy = poly;
2538 406 : bool do_alloc_check = false;
2539 406 : tree token = NULL_TREE;
2540 406 : tree tmp = decl;
2541 406 : if (poly)
2542 : {
2543 40 : tmp = TYPE_FIELDS (type);
2544 40 : type = TREE_TYPE (tmp);
2545 : }
2546 : else
2547 418 : while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
2548 72 : tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
2549 406 : if (TREE_CODE (tmp) == MEM_REF)
2550 16 : tmp = TREE_OPERAND (tmp, 0);
2551 406 : if (TREE_CODE (tmp) == SSA_NAME)
2552 : {
2553 16 : gimple *def_stmt = SSA_NAME_DEF_STMT (tmp);
2554 16 : if (gimple_code (def_stmt) == GIMPLE_ASSIGN)
2555 : {
2556 16 : tmp = gimple_assign_rhs1 (def_stmt);
2557 16 : if (poly)
2558 : {
2559 0 : tmp = TYPE_FIELDS (type);
2560 0 : type = TREE_TYPE (tmp);
2561 : }
2562 : else
2563 32 : while (TREE_CODE (tmp) == COMPONENT_REF
2564 32 : || TREE_CODE (tmp) == ARRAY_REF)
2565 16 : tmp = TREE_OPERAND (tmp,
2566 : TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
2567 : }
2568 : }
2569 : /* If the clause argument is nonallocatable, skip is-allocate check. */
2570 406 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp)
2571 278 : || GFC_DECL_GET_SCALAR_POINTER (tmp)
2572 420 : || (GFC_DESCRIPTOR_TYPE_P (type)
2573 42 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
2574 24 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
2575 8 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)))
2576 : do_alloc_check = true;
2577 :
2578 406 : if (!is_cnt
2579 203 : && OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
2580 199 : && (tkind == GOMP_MAP_ALLOC
2581 187 : || (tkind == GOMP_MAP_FROM
2582 21 : && (gimple_omp_target_kind (ctx)
2583 : != GF_OMP_TARGET_KIND_EXIT_DATA)))
2584 442 : && (poly || gfc_omp_replace_alloc_by_to_mapping (type, tmp, true)))
2585 24 : OMP_CLAUSE_SET_MAP_KIND (clause, tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO
2586 : : GOMP_MAP_TOFROM);
2587 :
2588 : /* TODO: For map(a(:)), we know it is present & allocated. */
2589 :
2590 406 : tree present = (DECL_P (decl) ? gfc_omp_check_optional_argument (decl, true)
2591 : : NULL_TREE);
2592 690 : if (POINTER_TYPE_P (TREE_TYPE (decl))
2593 422 : && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
2594 8 : decl = build_fold_indirect_ref (decl);
2595 406 : if (present)
2596 : {
2597 16 : tree then_label = create_artificial_label (loc);
2598 16 : tree end_label = create_artificial_label (loc);
2599 16 : gimple_seq seq2 = NULL;
2600 16 : tmp = force_gimple_operand (present, &seq2, true, NULL_TREE);
2601 16 : gimple_seq_add_seq (seq, seq2);
2602 16 : gimple_seq_add_stmt (seq,
2603 16 : gimple_build_cond_from_tree (present,
2604 : then_label, end_label));
2605 16 : gimple_seq_add_stmt (seq, gimple_build_label (then_label));
2606 16 : gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl,
2607 : &token, tkind, data, sizes, kinds,
2608 : offset_data, offset, num, seq, ctx,
2609 : &poly_warned);
2610 16 : gimple_seq_add_stmt (seq, gimple_build_label (end_label));
2611 : }
2612 : else
2613 390 : gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl,
2614 : &token, tkind, data, sizes, kinds, offset_data,
2615 : offset, num, seq, ctx, &poly_warned);
2616 : /* Multiply by 2 as there are two mappings: data + pointer assign. */
2617 406 : if (is_cnt)
2618 203 : gimplify_assign (num,
2619 : fold_build2_loc (loc, MULT_EXPR,
2620 : size_type_node, num,
2621 : build_int_cst (size_type_node, 2)), seq);
2622 : return num;
2623 : }
2624 :
2625 : /* Return tree with a variable which contains the count of deep-mappyings
2626 : (value depends, e.g., on allocation status) */
2627 : tree
2628 47068 : gfc_omp_deep_mapping_cnt (const gimple *ctx, tree clause, gimple_seq *seq)
2629 : {
2630 47068 : return gfc_omp_deep_mapping_do (true, ctx, clause, 0, NULL_TREE, NULL_TREE,
2631 47068 : NULL_TREE, NULL_TREE, NULL_TREE, seq);
2632 : }
2633 :
2634 : /* Does the actual deep mapping. */
2635 : void
2636 428 : gfc_omp_deep_mapping (const gimple *ctx, tree clause,
2637 : unsigned HOST_WIDE_INT tkind, tree data,
2638 : tree sizes, tree kinds, tree offset_data, tree offset,
2639 : gimple_seq *seq)
2640 : {
2641 428 : (void) gfc_omp_deep_mapping_do (false, ctx, clause, tkind, data, sizes, kinds,
2642 : offset_data, offset, seq);
2643 428 : }
2644 :
2645 : /* Return true if DECL is a scalar variable (for the purpose of
2646 : implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
2647 : is true, allocatables and pointers are permitted. */
2648 :
2649 : bool
2650 3744 : gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok)
2651 : {
2652 3744 : tree type = TREE_TYPE (decl);
2653 3744 : if (TREE_CODE (type) == REFERENCE_TYPE)
2654 1350 : type = TREE_TYPE (type);
2655 3744 : if (TREE_CODE (type) == POINTER_TYPE)
2656 : {
2657 587 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
2658 587 : || GFC_DECL_GET_SCALAR_POINTER (decl))
2659 : {
2660 148 : if (!ptr_alloc_ok)
2661 : return false;
2662 0 : type = TREE_TYPE (type);
2663 : }
2664 439 : if (GFC_ARRAY_TYPE_P (type)
2665 439 : || GFC_CLASS_TYPE_P (type))
2666 : return false;
2667 : }
2668 3196 : if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
2669 5700 : && TYPE_STRING_FLAG (type))
2670 : return false;
2671 3272 : if (INTEGRAL_TYPE_P (type)
2672 3272 : || SCALAR_FLOAT_TYPE_P (type)
2673 3272 : || COMPLEX_FLOAT_TYPE_P (type))
2674 2692 : return true;
2675 : return false;
2676 : }
2677 :
2678 :
2679 : /* Return true if DECL is a scalar with target attribute but does not have the
2680 : allocatable (or pointer) attribute (for the purpose of implicit mapping). */
2681 :
2682 : bool
2683 3636 : gfc_omp_scalar_target_p (tree decl)
2684 : {
2685 3636 : return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl)
2686 3737 : && gfc_omp_scalar_p (decl, false));
2687 : }
2688 :
2689 :
2690 : /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
2691 : disregarded in OpenMP construct, because it is going to be
2692 : remapped during OpenMP lowering. SHARED is true if DECL
2693 : is going to be shared, false if it is going to be privatized. */
2694 :
2695 : bool
2696 1677747 : gfc_omp_disregard_value_expr (tree decl, bool shared)
2697 : {
2698 1677747 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
2699 1677747 : && DECL_HAS_VALUE_EXPR_P (decl))
2700 : {
2701 3030 : tree value = DECL_VALUE_EXPR (decl);
2702 :
2703 3030 : if (TREE_CODE (value) == COMPONENT_REF
2704 3030 : && VAR_P (TREE_OPERAND (value, 0))
2705 6060 : && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
2706 : {
2707 : /* If variable in COMMON or EQUIVALENCE is privatized, return
2708 : true, as just that variable is supposed to be privatized,
2709 : not the whole COMMON or whole EQUIVALENCE.
2710 : For shared variables in COMMON or EQUIVALENCE, let them be
2711 : gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
2712 : from the same COMMON or EQUIVALENCE just one sharing of the
2713 : whole COMMON or EQUIVALENCE is enough. */
2714 3030 : return ! shared;
2715 : }
2716 : }
2717 :
2718 1674717 : if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
2719 334 : return ! shared;
2720 :
2721 : return false;
2722 : }
2723 :
2724 : /* Return true if DECL that is shared iff SHARED is true should
2725 : be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
2726 : flag set. */
2727 :
2728 : bool
2729 38541 : gfc_omp_private_debug_clause (tree decl, bool shared)
2730 : {
2731 38541 : if (GFC_DECL_CRAY_POINTEE (decl))
2732 : return true;
2733 :
2734 38505 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
2735 38505 : && DECL_HAS_VALUE_EXPR_P (decl))
2736 : {
2737 326 : tree value = DECL_VALUE_EXPR (decl);
2738 :
2739 326 : if (TREE_CODE (value) == COMPONENT_REF
2740 326 : && VAR_P (TREE_OPERAND (value, 0))
2741 652 : && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
2742 : return shared;
2743 : }
2744 :
2745 : return false;
2746 : }
2747 :
2748 : /* Register language specific type size variables as potentially OpenMP
2749 : firstprivate variables. */
2750 :
2751 : void
2752 21726 : gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
2753 : {
2754 21726 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
2755 : {
2756 3983 : int r;
2757 :
2758 3983 : gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
2759 9168 : for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
2760 : {
2761 5185 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
2762 5185 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
2763 5185 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
2764 : }
2765 3983 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
2766 3983 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
2767 : }
2768 21726 : }
2769 :
2770 :
2771 : static inline tree
2772 75639 : gfc_trans_add_clause (tree node, tree tail)
2773 : {
2774 75639 : OMP_CLAUSE_CHAIN (node) = tail;
2775 75639 : return node;
2776 : }
2777 :
2778 : static tree
2779 43383 : gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
2780 : {
2781 43383 : if (declare_simd)
2782 : {
2783 182 : int cnt = 0;
2784 182 : gfc_symbol *proc_sym;
2785 182 : gfc_formal_arglist *f;
2786 :
2787 182 : gcc_assert (sym->attr.dummy);
2788 182 : proc_sym = sym->ns->proc_name;
2789 182 : if (proc_sym->attr.entry_master)
2790 0 : ++cnt;
2791 182 : if (gfc_return_by_reference (proc_sym))
2792 : {
2793 0 : ++cnt;
2794 0 : if (proc_sym->ts.type == BT_CHARACTER)
2795 0 : ++cnt;
2796 : }
2797 349 : for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
2798 349 : if (f->sym == sym)
2799 : break;
2800 167 : else if (f->sym)
2801 167 : ++cnt;
2802 182 : gcc_assert (f);
2803 182 : return build_int_cst (integer_type_node, cnt);
2804 : }
2805 :
2806 43201 : tree t = gfc_get_symbol_decl (sym);
2807 43201 : tree parent_decl;
2808 43201 : int parent_flag;
2809 43201 : bool return_value;
2810 43201 : bool alternate_entry;
2811 43201 : bool entry_master;
2812 :
2813 43201 : return_value = sym->attr.function && sym->result == sym;
2814 167 : alternate_entry = sym->attr.function && sym->attr.entry
2815 43235 : && sym->result == sym;
2816 86402 : entry_master = sym->attr.result
2817 172 : && sym->ns->proc_name->attr.entry_master
2818 43213 : && !gfc_return_by_reference (sym->ns->proc_name);
2819 43201 : parent_decl = current_function_decl
2820 43201 : ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
2821 :
2822 43201 : if ((t == parent_decl && return_value)
2823 43194 : || (sym->ns && sym->ns->proc_name
2824 43194 : && sym->ns->proc_name->backend_decl == parent_decl
2825 2173 : && (alternate_entry || entry_master)))
2826 : parent_flag = 1;
2827 : else
2828 43192 : parent_flag = 0;
2829 :
2830 : /* Special case for assigning the return value of a function.
2831 : Self recursive functions must have an explicit return value. */
2832 43201 : if (return_value && (t == current_function_decl || parent_flag))
2833 97 : t = gfc_get_fake_result_decl (sym, parent_flag);
2834 :
2835 : /* Similarly for alternate entry points. */
2836 43104 : else if (alternate_entry
2837 32 : && (sym->ns->proc_name->backend_decl == current_function_decl
2838 0 : || parent_flag))
2839 : {
2840 32 : gfc_entry_list *el = NULL;
2841 :
2842 51 : for (el = sym->ns->entries; el; el = el->next)
2843 51 : if (sym == el->sym)
2844 : {
2845 32 : t = gfc_get_fake_result_decl (sym, parent_flag);
2846 32 : break;
2847 : }
2848 : }
2849 :
2850 43072 : else if (entry_master
2851 12 : && (sym->ns->proc_name->backend_decl == current_function_decl
2852 0 : || parent_flag))
2853 12 : t = gfc_get_fake_result_decl (sym, parent_flag);
2854 :
2855 : return t;
2856 : }
2857 :
2858 : static tree
2859 11728 : gfc_trans_omp_variable_list (enum omp_clause_code code,
2860 : gfc_omp_namelist *namelist, tree list,
2861 : bool declare_simd)
2862 : {
2863 : /* PARAMETER (named constants) are excluded as OpenACC 3.4 permits them now
2864 : as 'var' but permits compilers to ignore them. In expressions, it should
2865 : have been replaced by the value (and this function should not be called
2866 : anyway) and for var-using clauses, they should just be skipped. */
2867 30230 : for (; namelist != NULL; namelist = namelist->next)
2868 18502 : if ((namelist->sym->attr.referenced || declare_simd)
2869 18502 : && namelist->sym->attr.flavor != FL_PARAMETER)
2870 : {
2871 18497 : tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
2872 18497 : if (t != error_mark_node)
2873 : {
2874 18497 : tree node;
2875 18497 : node = build_omp_clause (input_location, code);
2876 18497 : OMP_CLAUSE_DECL (node) = t;
2877 18497 : list = gfc_trans_add_clause (node, list);
2878 :
2879 18497 : if (code == OMP_CLAUSE_LASTPRIVATE
2880 2864 : && namelist->u.lastprivate_conditional)
2881 88 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1;
2882 : }
2883 : }
2884 11728 : return list;
2885 : }
2886 :
2887 : struct omp_udr_find_orig_data
2888 : {
2889 : gfc_omp_udr *omp_udr;
2890 : bool omp_orig_seen;
2891 : };
2892 :
2893 : static int
2894 678 : omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2895 : void *data)
2896 : {
2897 678 : struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
2898 678 : if ((*e)->expr_type == EXPR_VARIABLE
2899 366 : && (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
2900 72 : cd->omp_orig_seen = true;
2901 :
2902 678 : return 0;
2903 : }
2904 :
2905 : static void
2906 684 : gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
2907 : {
2908 684 : gfc_symbol *sym = n->sym;
2909 684 : gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
2910 684 : gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
2911 684 : gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
2912 684 : gfc_symbol omp_var_copy[4];
2913 684 : gfc_expr *e1, *e2, *e3, *e4;
2914 684 : gfc_ref *ref;
2915 684 : tree decl, backend_decl, stmt, type, outer_decl;
2916 684 : locus old_loc = gfc_current_locus;
2917 684 : const char *iname;
2918 684 : bool t;
2919 684 : gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL;
2920 :
2921 684 : decl = OMP_CLAUSE_DECL (c);
2922 684 : gfc_current_locus = where;
2923 684 : type = TREE_TYPE (decl);
2924 684 : outer_decl = create_tmp_var_raw (type);
2925 684 : if (TREE_CODE (decl) == PARM_DECL
2926 31 : && TREE_CODE (type) == REFERENCE_TYPE
2927 12 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
2928 696 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
2929 : {
2930 12 : decl = build_fold_indirect_ref (decl);
2931 12 : type = TREE_TYPE (type);
2932 : }
2933 :
2934 : /* Create a fake symbol for init value. */
2935 684 : memset (&init_val_sym, 0, sizeof (init_val_sym));
2936 684 : init_val_sym.ns = sym->ns;
2937 684 : init_val_sym.name = sym->name;
2938 684 : init_val_sym.ts = sym->ts;
2939 684 : init_val_sym.attr.referenced = 1;
2940 684 : init_val_sym.declared_at = where;
2941 684 : init_val_sym.attr.flavor = FL_VARIABLE;
2942 684 : if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
2943 284 : backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
2944 400 : else if (udr->initializer_ns)
2945 : backend_decl = NULL;
2946 : else
2947 130 : switch (sym->ts.type)
2948 : {
2949 15 : case BT_LOGICAL:
2950 15 : case BT_INTEGER:
2951 15 : case BT_REAL:
2952 15 : case BT_COMPLEX:
2953 15 : backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
2954 15 : break;
2955 : default:
2956 : backend_decl = NULL_TREE;
2957 : break;
2958 : }
2959 684 : init_val_sym.backend_decl = backend_decl;
2960 :
2961 : /* Create a fake symbol for the outer array reference. */
2962 684 : outer_sym = *sym;
2963 684 : if (sym->as)
2964 426 : outer_sym.as = gfc_copy_array_spec (sym->as);
2965 684 : outer_sym.attr.dummy = 0;
2966 684 : outer_sym.attr.result = 0;
2967 684 : outer_sym.attr.flavor = FL_VARIABLE;
2968 684 : outer_sym.backend_decl = outer_decl;
2969 684 : if (decl != OMP_CLAUSE_DECL (c))
2970 12 : outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
2971 :
2972 : /* Create fake symtrees for it. */
2973 684 : symtree1 = gfc_new_symtree (&root1, sym->name);
2974 684 : symtree1->n.sym = sym;
2975 684 : gcc_assert (symtree1 == root1);
2976 :
2977 684 : symtree2 = gfc_new_symtree (&root2, sym->name);
2978 684 : symtree2->n.sym = &init_val_sym;
2979 684 : gcc_assert (symtree2 == root2);
2980 :
2981 684 : symtree3 = gfc_new_symtree (&root3, sym->name);
2982 684 : symtree3->n.sym = &outer_sym;
2983 684 : gcc_assert (symtree3 == root3);
2984 :
2985 684 : memset (omp_var_copy, 0, sizeof omp_var_copy);
2986 684 : if (udr)
2987 : {
2988 400 : omp_var_copy[0] = *udr->omp_out;
2989 400 : omp_var_copy[1] = *udr->omp_in;
2990 400 : *udr->omp_out = outer_sym;
2991 400 : *udr->omp_in = *sym;
2992 400 : if (udr->initializer_ns)
2993 : {
2994 270 : omp_var_copy[2] = *udr->omp_priv;
2995 270 : omp_var_copy[3] = *udr->omp_orig;
2996 270 : *udr->omp_priv = *sym;
2997 270 : *udr->omp_orig = outer_sym;
2998 : }
2999 : }
3000 :
3001 : /* Create expressions. */
3002 684 : e1 = gfc_get_expr ();
3003 684 : e1->expr_type = EXPR_VARIABLE;
3004 684 : e1->where = where;
3005 684 : e1->symtree = symtree1;
3006 684 : e1->ts = sym->ts;
3007 684 : if (sym->attr.dimension)
3008 : {
3009 426 : e1->ref = ref = gfc_get_ref ();
3010 426 : ref->type = REF_ARRAY;
3011 426 : ref->u.ar.where = where;
3012 426 : ref->u.ar.as = sym->as;
3013 426 : ref->u.ar.type = AR_FULL;
3014 426 : ref->u.ar.dimen = 0;
3015 : }
3016 684 : t = gfc_resolve_expr (e1);
3017 684 : gcc_assert (t);
3018 :
3019 684 : e2 = NULL;
3020 684 : if (backend_decl != NULL_TREE)
3021 : {
3022 299 : e2 = gfc_get_expr ();
3023 299 : e2->expr_type = EXPR_VARIABLE;
3024 299 : e2->where = where;
3025 299 : e2->symtree = symtree2;
3026 299 : e2->ts = sym->ts;
3027 299 : t = gfc_resolve_expr (e2);
3028 299 : gcc_assert (t);
3029 : }
3030 385 : else if (udr->initializer_ns == NULL)
3031 : {
3032 115 : gcc_assert (sym->ts.type == BT_DERIVED);
3033 115 : e2 = gfc_default_initializer (&sym->ts);
3034 115 : gcc_assert (e2);
3035 115 : t = gfc_resolve_expr (e2);
3036 115 : gcc_assert (t);
3037 : }
3038 270 : else if (n->u2.udr->initializer->op == EXEC_ASSIGN)
3039 : {
3040 204 : e2 = gfc_copy_expr (n->u2.udr->initializer->expr2);
3041 204 : t = gfc_resolve_expr (e2);
3042 204 : gcc_assert (t);
3043 : }
3044 684 : if (udr && udr->initializer_ns)
3045 : {
3046 270 : struct omp_udr_find_orig_data cd;
3047 270 : cd.omp_udr = udr;
3048 270 : cd.omp_orig_seen = false;
3049 270 : gfc_code_walker (&n->u2.udr->initializer,
3050 : gfc_dummy_code_callback, omp_udr_find_orig, &cd);
3051 270 : if (cd.omp_orig_seen)
3052 72 : OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
3053 : }
3054 :
3055 684 : e3 = gfc_copy_expr (e1);
3056 684 : e3->symtree = symtree3;
3057 684 : t = gfc_resolve_expr (e3);
3058 684 : gcc_assert (t);
3059 :
3060 684 : iname = NULL;
3061 684 : e4 = NULL;
3062 684 : switch (OMP_CLAUSE_REDUCTION_CODE (c))
3063 : {
3064 160 : case PLUS_EXPR:
3065 160 : case MINUS_EXPR:
3066 160 : e4 = gfc_add (e3, e1);
3067 160 : break;
3068 26 : case MULT_EXPR:
3069 26 : e4 = gfc_multiply (e3, e1);
3070 26 : break;
3071 6 : case TRUTH_ANDIF_EXPR:
3072 6 : e4 = gfc_and (e3, e1);
3073 6 : break;
3074 6 : case TRUTH_ORIF_EXPR:
3075 6 : e4 = gfc_or (e3, e1);
3076 6 : break;
3077 6 : case EQ_EXPR:
3078 6 : e4 = gfc_eqv (e3, e1);
3079 6 : break;
3080 6 : case NE_EXPR:
3081 6 : e4 = gfc_neqv (e3, e1);
3082 6 : break;
3083 : case MIN_EXPR:
3084 : iname = "min";
3085 : break;
3086 : case MAX_EXPR:
3087 : iname = "max";
3088 : break;
3089 : case BIT_AND_EXPR:
3090 : iname = "iand";
3091 : break;
3092 : case BIT_IOR_EXPR:
3093 : iname = "ior";
3094 : break;
3095 : case BIT_XOR_EXPR:
3096 : iname = "ieor";
3097 : break;
3098 400 : case ERROR_MARK:
3099 400 : if (n->u2.udr->combiner->op == EXEC_ASSIGN)
3100 : {
3101 334 : gfc_free_expr (e3);
3102 334 : e3 = gfc_copy_expr (n->u2.udr->combiner->expr1);
3103 334 : e4 = gfc_copy_expr (n->u2.udr->combiner->expr2);
3104 334 : t = gfc_resolve_expr (e3);
3105 334 : gcc_assert (t);
3106 334 : t = gfc_resolve_expr (e4);
3107 334 : gcc_assert (t);
3108 : }
3109 : break;
3110 0 : default:
3111 0 : gcc_unreachable ();
3112 : }
3113 210 : if (iname != NULL)
3114 : {
3115 74 : memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
3116 74 : intrinsic_sym.ns = sym->ns;
3117 74 : intrinsic_sym.name = iname;
3118 74 : intrinsic_sym.ts = sym->ts;
3119 74 : intrinsic_sym.attr.referenced = 1;
3120 74 : intrinsic_sym.attr.intrinsic = 1;
3121 74 : intrinsic_sym.attr.function = 1;
3122 74 : intrinsic_sym.attr.implicit_type = 1;
3123 74 : intrinsic_sym.result = &intrinsic_sym;
3124 74 : intrinsic_sym.declared_at = where;
3125 :
3126 74 : symtree4 = gfc_new_symtree (&root4, iname);
3127 74 : symtree4->n.sym = &intrinsic_sym;
3128 74 : gcc_assert (symtree4 == root4);
3129 :
3130 74 : e4 = gfc_get_expr ();
3131 74 : e4->expr_type = EXPR_FUNCTION;
3132 74 : e4->where = where;
3133 74 : e4->symtree = symtree4;
3134 74 : e4->value.function.actual = gfc_get_actual_arglist ();
3135 74 : e4->value.function.actual->expr = e3;
3136 74 : e4->value.function.actual->next = gfc_get_actual_arglist ();
3137 74 : e4->value.function.actual->next->expr = e1;
3138 : }
3139 684 : if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
3140 : {
3141 : /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
3142 284 : e1 = gfc_copy_expr (e1);
3143 284 : e3 = gfc_copy_expr (e3);
3144 284 : t = gfc_resolve_expr (e4);
3145 284 : gcc_assert (t);
3146 : }
3147 :
3148 : /* Create the init statement list. */
3149 684 : pushlevel ();
3150 684 : if (e2)
3151 618 : stmt = gfc_trans_assignment (e1, e2, false, false);
3152 : else
3153 66 : stmt = gfc_trans_call (n->u2.udr->initializer, false,
3154 : NULL_TREE, NULL_TREE, false);
3155 684 : if (TREE_CODE (stmt) != BIND_EXPR)
3156 197 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3157 : else
3158 487 : poplevel (0, 0);
3159 684 : OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
3160 :
3161 : /* Create the merge statement list. */
3162 684 : pushlevel ();
3163 684 : if (e4)
3164 618 : stmt = gfc_trans_assignment (e3, e4, false, true);
3165 : else
3166 66 : stmt = gfc_trans_call (n->u2.udr->combiner, false,
3167 : NULL_TREE, NULL_TREE, false);
3168 684 : if (TREE_CODE (stmt) != BIND_EXPR)
3169 234 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3170 : else
3171 450 : poplevel (0, 0);
3172 684 : OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
3173 :
3174 : /* And stick the placeholder VAR_DECL into the clause as well. */
3175 684 : OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
3176 :
3177 684 : gfc_current_locus = old_loc;
3178 :
3179 684 : gfc_free_expr (e1);
3180 684 : if (e2)
3181 618 : gfc_free_expr (e2);
3182 684 : gfc_free_expr (e3);
3183 684 : if (e4)
3184 618 : gfc_free_expr (e4);
3185 684 : free (symtree1);
3186 684 : free (symtree2);
3187 684 : free (symtree3);
3188 684 : free (symtree4);
3189 684 : if (outer_sym.as)
3190 426 : gfc_free_array_spec (outer_sym.as);
3191 :
3192 684 : if (udr)
3193 : {
3194 400 : *udr->omp_out = omp_var_copy[0];
3195 400 : *udr->omp_in = omp_var_copy[1];
3196 400 : if (udr->initializer_ns)
3197 : {
3198 270 : *udr->omp_priv = omp_var_copy[2];
3199 270 : *udr->omp_orig = omp_var_copy[3];
3200 : }
3201 : }
3202 684 : }
3203 :
3204 : static tree
3205 3848 : gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list,
3206 : locus where, bool mark_addressable)
3207 : {
3208 3848 : omp_clause_code clause = OMP_CLAUSE_REDUCTION;
3209 3848 : switch (kind)
3210 : {
3211 : case OMP_LIST_REDUCTION:
3212 : case OMP_LIST_REDUCTION_INSCAN:
3213 : case OMP_LIST_REDUCTION_TASK:
3214 : break;
3215 : case OMP_LIST_IN_REDUCTION:
3216 : clause = OMP_CLAUSE_IN_REDUCTION;
3217 : break;
3218 : case OMP_LIST_TASK_REDUCTION:
3219 : clause = OMP_CLAUSE_TASK_REDUCTION;
3220 : break;
3221 0 : default:
3222 0 : gcc_unreachable ();
3223 : }
3224 8640 : for (; namelist != NULL; namelist = namelist->next)
3225 4792 : if (namelist->sym->attr.referenced)
3226 : {
3227 4792 : tree t = gfc_trans_omp_variable (namelist->sym, false);
3228 4792 : if (t != error_mark_node)
3229 : {
3230 4792 : tree node = build_omp_clause (gfc_get_location (&namelist->where),
3231 : clause);
3232 4792 : OMP_CLAUSE_DECL (node) = t;
3233 4792 : if (mark_addressable)
3234 38 : TREE_ADDRESSABLE (t) = 1;
3235 4792 : if (kind == OMP_LIST_REDUCTION_INSCAN)
3236 20 : OMP_CLAUSE_REDUCTION_INSCAN (node) = 1;
3237 4792 : if (kind == OMP_LIST_REDUCTION_TASK)
3238 92 : OMP_CLAUSE_REDUCTION_TASK (node) = 1;
3239 4792 : switch (namelist->u.reduction_op)
3240 : {
3241 2345 : case OMP_REDUCTION_PLUS:
3242 2345 : OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
3243 2345 : break;
3244 198 : case OMP_REDUCTION_MINUS:
3245 198 : OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
3246 198 : break;
3247 254 : case OMP_REDUCTION_TIMES:
3248 254 : OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
3249 254 : break;
3250 92 : case OMP_REDUCTION_AND:
3251 92 : OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
3252 92 : break;
3253 785 : case OMP_REDUCTION_OR:
3254 785 : OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
3255 785 : break;
3256 86 : case OMP_REDUCTION_EQV:
3257 86 : OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
3258 86 : break;
3259 86 : case OMP_REDUCTION_NEQV:
3260 86 : OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
3261 86 : break;
3262 218 : case OMP_REDUCTION_MAX:
3263 218 : OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
3264 218 : break;
3265 201 : case OMP_REDUCTION_MIN:
3266 201 : OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
3267 201 : break;
3268 40 : case OMP_REDUCTION_IAND:
3269 40 : OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
3270 40 : break;
3271 49 : case OMP_REDUCTION_IOR:
3272 49 : OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
3273 49 : break;
3274 38 : case OMP_REDUCTION_IEOR:
3275 38 : OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
3276 38 : break;
3277 400 : case OMP_REDUCTION_USER:
3278 400 : OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
3279 400 : break;
3280 0 : default:
3281 0 : gcc_unreachable ();
3282 : }
3283 4792 : if (namelist->sym->attr.dimension
3284 4366 : || namelist->u.reduction_op == OMP_REDUCTION_USER
3285 4122 : || namelist->sym->attr.allocatable)
3286 684 : gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
3287 4792 : list = gfc_trans_add_clause (node, list);
3288 : }
3289 : }
3290 3848 : return list;
3291 : }
3292 :
3293 : static inline tree
3294 3398 : gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
3295 : {
3296 3398 : gfc_se se;
3297 3398 : tree result;
3298 :
3299 3398 : gfc_init_se (&se, NULL );
3300 3398 : gfc_conv_expr (&se, expr);
3301 3398 : gfc_add_block_to_block (block, &se.pre);
3302 3398 : result = gfc_evaluate_now (se.expr, block);
3303 3398 : gfc_add_block_to_block (block, &se.post);
3304 :
3305 3398 : return result;
3306 : }
3307 :
3308 : static vec<tree, va_heap, vl_embed> *doacross_steps;
3309 :
3310 :
3311 : /* Translate an array section or array element. */
3312 :
3313 : static void
3314 3988 : gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
3315 : gfc_omp_namelist *n, tree decl, bool element,
3316 : bool openmp, gomp_map_kind ptr_kind, tree &node,
3317 : tree &node2, tree &node3, tree &node4)
3318 : {
3319 3988 : gfc_se se;
3320 3988 : tree ptr, ptr2;
3321 3988 : tree elemsz = NULL_TREE;
3322 :
3323 3988 : gfc_init_se (&se, NULL);
3324 3988 : if (element)
3325 : {
3326 180 : gfc_conv_expr_reference (&se, n->expr);
3327 180 : gfc_add_block_to_block (block, &se.pre);
3328 180 : ptr = se.expr;
3329 : }
3330 : else
3331 : {
3332 3808 : gfc_conv_expr_descriptor (&se, n->expr);
3333 3808 : ptr = gfc_conv_array_data (se.expr);
3334 : }
3335 3988 : if (n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred)
3336 : {
3337 0 : gcc_assert (se.string_length);
3338 0 : tree len = gfc_evaluate_now (se.string_length, block);
3339 0 : elemsz = gfc_get_char_type (n->expr->ts.kind);
3340 0 : elemsz = TYPE_SIZE_UNIT (elemsz);
3341 0 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
3342 : fold_convert (size_type_node, len), elemsz);
3343 : }
3344 3988 : if (element)
3345 : {
3346 180 : if (!elemsz)
3347 180 : elemsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
3348 180 : OMP_CLAUSE_SIZE (node) = elemsz;
3349 : }
3350 : else
3351 : {
3352 3808 : tree type = TREE_TYPE (se.expr);
3353 3808 : gfc_add_block_to_block (block, &se.pre);
3354 3808 : OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr,
3355 3808 : GFC_TYPE_ARRAY_RANK (type));
3356 3808 : if (!elemsz)
3357 3808 : elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3358 3808 : elemsz = fold_convert (gfc_array_index_type, elemsz);
3359 3808 : OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
3360 : OMP_CLAUSE_SIZE (node), elemsz);
3361 3808 : if (n->expr->ts.type == BT_DERIVED
3362 21 : && n->expr->ts.u.derived->attr.alloc_comp)
3363 : {
3364 : /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
3365 : force evaluate to ensure that it is not gimplified + is a decl. */
3366 15 : tree tmp = OMP_CLAUSE_SIZE (node);
3367 15 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
3368 15 : gfc_add_modify_loc (input_location, block, var, tmp);
3369 15 : OMP_CLAUSE_SIZE (node) = var;
3370 15 : gfc_allocate_lang_decl (var);
3371 15 : GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
3372 : }
3373 : }
3374 3988 : gcc_assert (se.post.head == NULL_TREE);
3375 3988 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3376 3988 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
3377 3988 : ptr = fold_convert (ptrdiff_type_node, ptr);
3378 :
3379 7714 : if (POINTER_TYPE_P (TREE_TYPE (decl))
3380 340 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
3381 78 : && ptr_kind == GOMP_MAP_POINTER
3382 78 : && op != EXEC_OMP_TARGET_EXIT_DATA
3383 78 : && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_RELEASE
3384 4066 : && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_DELETE)
3385 :
3386 : {
3387 78 : node4 = build_omp_clause (input_location,
3388 : OMP_CLAUSE_MAP);
3389 78 : OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
3390 78 : OMP_CLAUSE_DECL (node4) = decl;
3391 78 : OMP_CLAUSE_SIZE (node4) = size_int (0);
3392 78 : decl = build_fold_indirect_ref (decl);
3393 : }
3394 3910 : else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER
3395 0 : && n->expr->ts.type == BT_CHARACTER
3396 0 : && n->expr->ts.deferred)
3397 : {
3398 0 : gomp_map_kind map_kind;
3399 0 : if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE)
3400 0 : map_kind = OMP_CLAUSE_MAP_KIND (node);
3401 0 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
3402 0 : || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE)
3403 : map_kind = GOMP_MAP_RELEASE;
3404 : else
3405 : map_kind = GOMP_MAP_TO;
3406 0 : gcc_assert (se.string_length);
3407 0 : node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3408 0 : OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
3409 0 : OMP_CLAUSE_DECL (node4) = se.string_length;
3410 0 : OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node);
3411 : }
3412 3988 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3413 : {
3414 2715 : tree type = TREE_TYPE (decl);
3415 2715 : ptr2 = gfc_conv_descriptor_data_get (decl);
3416 2715 : node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3417 2715 : OMP_CLAUSE_DECL (node2) = decl;
3418 2715 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3419 2715 : if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE
3420 2714 : || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE
3421 2505 : || op == EXEC_OMP_TARGET_EXIT_DATA
3422 5220 : || op == EXEC_OACC_EXIT_DATA)
3423 : {
3424 392 : gomp_map_kind map_kind
3425 392 : = OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE ? GOMP_MAP_DELETE
3426 391 : : GOMP_MAP_RELEASE;
3427 392 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
3428 392 : OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
3429 : }
3430 : else
3431 2323 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
3432 2715 : node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3433 2715 : OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
3434 2715 : OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (decl);
3435 : /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
3436 : cast prevents gimplify.cc from recognising it as being part of the
3437 : struct - and adding an 'alloc: for the 'desc.data' pointer, which
3438 : would break as the 'desc' (the descriptor) is also mapped
3439 : (see node4 above). */
3440 2715 : if (ptr_kind == GOMP_MAP_ATTACH_DETACH && !openmp)
3441 141 : STRIP_NOPS (OMP_CLAUSE_DECL (node3));
3442 : }
3443 : else
3444 : {
3445 1273 : if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
3446 : {
3447 1011 : tree offset;
3448 1011 : ptr2 = build_fold_addr_expr (decl);
3449 1011 : offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr,
3450 : fold_convert (ptrdiff_type_node, ptr2));
3451 1011 : offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node,
3452 : offset, fold_convert (ptrdiff_type_node, elemsz));
3453 1011 : offset = build4_loc (input_location, ARRAY_REF,
3454 1011 : TREE_TYPE (TREE_TYPE (decl)),
3455 : decl, offset, NULL_TREE, NULL_TREE);
3456 1011 : OMP_CLAUSE_DECL (node) = offset;
3457 :
3458 1011 : if (ptr_kind == GOMP_MAP_ATTACH_DETACH && openmp)
3459 145 : return;
3460 : }
3461 : else
3462 : {
3463 262 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
3464 : ptr2 = decl;
3465 : }
3466 1128 : node3 = build_omp_clause (input_location,
3467 : OMP_CLAUSE_MAP);
3468 1128 : OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
3469 1128 : OMP_CLAUSE_DECL (node3) = decl;
3470 : }
3471 3843 : ptr2 = fold_convert (ptrdiff_type_node, ptr2);
3472 3843 : OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node,
3473 : ptr, ptr2);
3474 : }
3475 :
3476 : static tree
3477 46 : handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block)
3478 : {
3479 46 : tree list = NULL_TREE;
3480 94 : for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
3481 : {
3482 48 : gfc_constructor *c;
3483 48 : gfc_se se;
3484 :
3485 48 : tree last = make_tree_vec (6);
3486 48 : tree iter_var = gfc_get_symbol_decl (sym);
3487 48 : tree type = TREE_TYPE (iter_var);
3488 48 : TREE_VEC_ELT (last, 0) = iter_var;
3489 48 : DECL_CHAIN (iter_var) = BLOCK_VARS (block);
3490 48 : BLOCK_VARS (block) = iter_var;
3491 :
3492 : /* begin */
3493 48 : c = gfc_constructor_first (sym->value->value.constructor);
3494 48 : gfc_init_se (&se, NULL);
3495 48 : gfc_conv_expr (&se, c->expr);
3496 48 : gfc_add_block_to_block (iter_block, &se.pre);
3497 48 : gfc_add_block_to_block (iter_block, &se.post);
3498 48 : TREE_VEC_ELT (last, 1) = fold_convert (type,
3499 : gfc_evaluate_now (se.expr,
3500 : iter_block));
3501 : /* end */
3502 48 : c = gfc_constructor_next (c);
3503 48 : gfc_init_se (&se, NULL);
3504 48 : gfc_conv_expr (&se, c->expr);
3505 48 : gfc_add_block_to_block (iter_block, &se.pre);
3506 48 : gfc_add_block_to_block (iter_block, &se.post);
3507 48 : TREE_VEC_ELT (last, 2) = fold_convert (type,
3508 : gfc_evaluate_now (se.expr,
3509 : iter_block));
3510 : /* step */
3511 48 : c = gfc_constructor_next (c);
3512 48 : tree step;
3513 48 : if (c)
3514 : {
3515 5 : gfc_init_se (&se, NULL);
3516 5 : gfc_conv_expr (&se, c->expr);
3517 5 : gfc_add_block_to_block (iter_block, &se.pre);
3518 5 : gfc_add_block_to_block (iter_block, &se.post);
3519 5 : gfc_conv_expr (&se, c->expr);
3520 5 : step = fold_convert (type,
3521 : gfc_evaluate_now (se.expr,
3522 : iter_block));
3523 : }
3524 : else
3525 43 : step = build_int_cst (type, 1);
3526 48 : TREE_VEC_ELT (last, 3) = step;
3527 : /* orig_step */
3528 48 : TREE_VEC_ELT (last, 4) = save_expr (step);
3529 48 : TREE_CHAIN (last) = list;
3530 48 : list = last;
3531 : }
3532 46 : return list;
3533 : }
3534 :
3535 : /* To alleviate quadratic behaviour in checking each entry of a
3536 : gfc_omp_namelist against every other entry, we build a hashtable indexed by
3537 : gfc_symbol pointer, which we can use in the usual case that a map
3538 : expression has a symbol as its root term. Return a namelist based on the
3539 : root symbol used by N, building a new table in SYM_ROOTED_NL using the
3540 : gfc_omp_namelist N2 (all clauses) if we haven't done so already. */
3541 :
3542 : static gfc_omp_namelist *
3543 934 : get_symbol_rooted_namelist (hash_map<gfc_symbol *,
3544 : gfc_omp_namelist *> *&sym_rooted_nl,
3545 : gfc_omp_namelist *n,
3546 : gfc_omp_namelist *n2, bool *sym_based)
3547 : {
3548 : /* Early-out if we have a NULL clause list (e.g. for OpenACC). */
3549 934 : if (!n2)
3550 : return NULL;
3551 :
3552 897 : gfc_symbol *use_sym = NULL;
3553 :
3554 : /* We're only interested in cases where we have an expression, e.g. a
3555 : component access. */
3556 897 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE && n->expr->symtree)
3557 897 : use_sym = n->expr->symtree->n.sym;
3558 :
3559 897 : *sym_based = false;
3560 :
3561 897 : if (!use_sym)
3562 : return n2;
3563 :
3564 897 : if (!sym_rooted_nl)
3565 : {
3566 388 : sym_rooted_nl = new hash_map<gfc_symbol *, gfc_omp_namelist *> ();
3567 :
3568 1715 : for (; n2 != NULL; n2 = n2->next)
3569 : {
3570 1327 : if (!n2->expr
3571 1326 : || n2->expr->expr_type != EXPR_VARIABLE
3572 1326 : || !n2->expr->symtree)
3573 1 : continue;
3574 :
3575 1326 : gfc_omp_namelist *nl_copy = gfc_get_omp_namelist ();
3576 1326 : memcpy (nl_copy, n2, sizeof *nl_copy);
3577 1326 : nl_copy->u2.duplicate_of = n2;
3578 1326 : nl_copy->next = NULL;
3579 :
3580 1326 : gfc_symbol *idx_sym = n2->expr->symtree->n.sym;
3581 :
3582 1326 : bool existed;
3583 1326 : gfc_omp_namelist *&entry
3584 1326 : = sym_rooted_nl->get_or_insert (idx_sym, &existed);
3585 1326 : if (existed)
3586 881 : nl_copy->next = entry;
3587 1326 : entry = nl_copy;
3588 : }
3589 : }
3590 :
3591 897 : gfc_omp_namelist **n2_sym = sym_rooted_nl->get (use_sym);
3592 :
3593 897 : if (n2_sym)
3594 : {
3595 897 : *sym_based = true;
3596 897 : return *n2_sym;
3597 : }
3598 :
3599 : return NULL;
3600 : }
3601 :
3602 : /* Helper function for gfc_trans_omp_clauses. Adjust existing and create new
3603 : map nodes for derived-type component array descriptors. Return true if the
3604 : mapping has to be dropped. */
3605 :
3606 : static bool
3607 1191 : gfc_map_array_descriptor (
3608 : tree &node, tree &node2, tree &node3, tree &node4, tree descr, bool openacc,
3609 : location_t map_loc, stmtblock_t *block, gfc_exec_op op, gfc_omp_namelist *n,
3610 : hash_map<gfc_symbol *, gfc_omp_namelist *> *&sym_rooted_nl, gfc_se se,
3611 : gfc_omp_clauses *clauses, bool mid_desc_p)
3612 : {
3613 1191 : tree type = TREE_TYPE (descr);
3614 1191 : tree ptr = gfc_conv_descriptor_data_get (descr);
3615 1191 : ptr = build_fold_indirect_ref (ptr);
3616 1191 : OMP_CLAUSE_DECL (node) = ptr;
3617 1191 : int rank = GFC_TYPE_ARRAY_RANK (type);
3618 1191 : OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, descr, rank);
3619 1191 : tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3620 :
3621 1191 : gomp_map_kind map_kind = OMP_CLAUSE_MAP_KIND (node);
3622 1191 : if (GOMP_MAP_COPY_TO_P (map_kind) || map_kind == GOMP_MAP_ALLOC)
3623 : {
3624 842 : if (mid_desc_p)
3625 : {
3626 : /* For an intermediate descriptor, the pointee (i.e. the actual array
3627 : content) is mapped in a separate set of nodes. This ALLOC is only
3628 : emitted to comply with the group layout expected by the gimplifier.
3629 : */
3630 89 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
3631 89 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3632 89 : OMP_CLAUSE_MAP_GIMPLE_ONLY (node) = 1;
3633 : }
3634 : else
3635 753 : map_kind
3636 1250 : = ((GOMP_MAP_ALWAYS_P (map_kind) || gfc_expr_attr (n->expr).pointer)
3637 753 : ? GOMP_MAP_ALWAYS_TO
3638 : : GOMP_MAP_TO);
3639 : }
3640 349 : else if (n->u.map.op == OMP_MAP_RELEASE || n->u.map.op == OMP_MAP_DELETE)
3641 : ;
3642 344 : else if (op == EXEC_OMP_TARGET_EXIT_DATA || op == EXEC_OACC_EXIT_DATA)
3643 : map_kind = GOMP_MAP_RELEASE;
3644 31 : else if (mid_desc_p)
3645 : {
3646 : /* For an intermediate descriptor, the pointee (i.e. the actual array
3647 : content) is mapped in a separate set of nodes. This ALLOC is only
3648 : emitted to comply with the group layout expected by the gimplifier. */
3649 1 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
3650 1 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3651 1 : OMP_CLAUSE_MAP_GIMPLE_ONLY (node) = 1;
3652 : }
3653 : else
3654 : map_kind = GOMP_MAP_ALLOC;
3655 :
3656 1191 : if (!openacc && n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred)
3657 : {
3658 42 : gcc_assert (se.string_length);
3659 42 : tree len = fold_convert (size_type_node, se.string_length);
3660 42 : elemsz = gfc_get_char_type (n->expr->ts.kind);
3661 42 : elemsz = TYPE_SIZE_UNIT (elemsz);
3662 42 : elemsz = fold_build2 (MULT_EXPR, size_type_node, len, elemsz);
3663 42 : node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
3664 42 : OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
3665 42 : OMP_CLAUSE_DECL (node4) = se.string_length;
3666 42 : OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node);
3667 : }
3668 1191 : elemsz = fold_convert (gfc_array_index_type, elemsz);
3669 1191 : OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
3670 : OMP_CLAUSE_SIZE (node), elemsz);
3671 :
3672 1191 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
3673 1191 : if (map_kind == GOMP_MAP_RELEASE || map_kind == GOMP_MAP_DELETE)
3674 : {
3675 318 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
3676 318 : OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
3677 : }
3678 : else
3679 873 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
3680 1191 : OMP_CLAUSE_DECL (node2) = descr;
3681 1191 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3682 :
3683 1191 : if (!openacc)
3684 : {
3685 1051 : if (n->expr->ts.type == BT_DERIVED
3686 18 : && n->expr->ts.u.derived->attr.alloc_comp)
3687 : {
3688 : /* Save array descriptor for use
3689 : in gfc_omp_deep_mapping{,_p,_cnt}; force
3690 : evaluate to ensure that it is
3691 : not gimplified + is a decl. */
3692 12 : tree tmp = OMP_CLAUSE_SIZE (node);
3693 12 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
3694 12 : gfc_add_modify_loc (map_loc, block, var, tmp);
3695 12 : OMP_CLAUSE_SIZE (node) = var;
3696 12 : gfc_allocate_lang_decl (var);
3697 12 : GFC_DECL_SAVED_DESCRIPTOR (var) = descr;
3698 : }
3699 :
3700 : /* If we don't have a mapping of a smaller part
3701 : of the array -- or we can't prove that we do
3702 : statically -- set this flag. If there is a
3703 : mapping of a smaller part of the array after
3704 : all, this will turn into a no-op at
3705 : runtime. */
3706 1051 : OMP_CLAUSE_MAP_RUNTIME_IMPLICIT_P (node) = 1;
3707 :
3708 1051 : bool drop_mapping = false;
3709 :
3710 1051 : if (!mid_desc_p)
3711 : {
3712 879 : gfc_omp_namelist *n2 = clauses->lists[OMP_LIST_MAP];
3713 :
3714 879 : bool sym_based;
3715 879 : n2 = get_symbol_rooted_namelist (sym_rooted_nl, n, n2, &sym_based);
3716 :
3717 3179 : for (; n2 != NULL; n2 = n2->next)
3718 : {
3719 2586 : if ((!sym_based && n == n2)
3720 2586 : || (sym_based && n == n2->u2.duplicate_of) || !n2->expr)
3721 617 : continue;
3722 :
3723 1969 : if (!gfc_omp_expr_prefix_same (n->expr, n2->expr))
3724 1683 : continue;
3725 :
3726 286 : gfc_ref *ref1 = n->expr->ref;
3727 286 : gfc_ref *ref2 = n2->expr->ref;
3728 :
3729 : /* We know ref1 and ref2 overlap. We're
3730 : interested in whether ref2 describes a
3731 : smaller part of the array than ref1, which
3732 : we already know refers to the full
3733 : array. */
3734 :
3735 644 : while (ref1->next && ref2->next)
3736 : {
3737 : ref1 = ref1->next;
3738 : ref2 = ref2->next;
3739 : }
3740 :
3741 286 : if (ref2->next
3742 286 : || (ref2->type == REF_ARRAY
3743 286 : && (ref2->u.ar.type == AR_ELEMENT
3744 286 : || (ref2->u.ar.type == AR_SECTION))))
3745 : {
3746 : drop_mapping = true;
3747 : break;
3748 : }
3749 : }
3750 879 : if (drop_mapping)
3751 286 : return true;
3752 : }
3753 : }
3754 :
3755 905 : if (mid_desc_p && GOMP_MAP_COPY_FROM_P (OMP_CLAUSE_MAP_KIND (node)))
3756 82 : node = NULL_TREE;
3757 :
3758 905 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
3759 905 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH);
3760 905 : OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (descr);
3761 : /* Similar to gfc_trans_omp_array_section (details
3762 : there), we add/keep the cast for OpenMP to prevent
3763 : that an 'alloc:' gets added for node3 ('desc.data')
3764 : as that is part of the whole descriptor (node3).
3765 : TODO: Remove once the ME handles this properly. */
3766 905 : if (!openacc)
3767 765 : OMP_CLAUSE_DECL (node3) = fold_convert (TREE_TYPE (TREE_OPERAND (ptr, 0)),
3768 : OMP_CLAUSE_DECL (node3));
3769 : else
3770 140 : STRIP_NOPS (OMP_CLAUSE_DECL (node3));
3771 905 : OMP_CLAUSE_SIZE (node3) = size_zero_node;
3772 905 : if (mid_desc_p)
3773 172 : OMP_CLAUSE_MAP_SIZE_NEEDS_ADJUSTMENT (node3) = 1;
3774 :
3775 : return false;
3776 : }
3777 :
3778 : static tree
3779 31747 : gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
3780 : locus where, bool declare_simd = false,
3781 : bool openacc = false, gfc_exec_op op = EXEC_NOP)
3782 : {
3783 31747 : tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
3784 31747 : tree iterator = NULL_TREE;
3785 31747 : tree tree_block = NULL_TREE;
3786 31747 : stmtblock_t iter_block;
3787 31747 : int list, ifc;
3788 31747 : enum omp_clause_code clause_code;
3789 31747 : gfc_omp_namelist *prev = NULL;
3790 31747 : gfc_se se;
3791 31747 : vec<gfc_symbol *> descriptors = vNULL;
3792 :
3793 31747 : if (clauses == NULL)
3794 : return NULL_TREE;
3795 :
3796 31735 : hash_map<gfc_symbol *, gfc_omp_namelist *> *sym_rooted_nl = NULL;
3797 :
3798 1269400 : for (list = 0; list < OMP_LIST_NUM; list++)
3799 : {
3800 1237665 : gfc_omp_namelist *n = clauses->lists[list];
3801 :
3802 1237665 : if (n == NULL)
3803 1209840 : continue;
3804 27825 : switch (list)
3805 : {
3806 3848 : case OMP_LIST_REDUCTION:
3807 3848 : case OMP_LIST_REDUCTION_INSCAN:
3808 3848 : case OMP_LIST_REDUCTION_TASK:
3809 3848 : case OMP_LIST_IN_REDUCTION:
3810 3848 : case OMP_LIST_TASK_REDUCTION:
3811 : /* An OpenACC async clause indicates the need to set reduction
3812 : arguments addressable, to allow asynchronous copy-out. */
3813 3848 : omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses,
3814 3848 : where, clauses->async);
3815 3848 : break;
3816 6480 : case OMP_LIST_PRIVATE:
3817 6480 : clause_code = OMP_CLAUSE_PRIVATE;
3818 6480 : goto add_clause;
3819 1079 : case OMP_LIST_SHARED:
3820 1079 : clause_code = OMP_CLAUSE_SHARED;
3821 1079 : goto add_clause;
3822 1072 : case OMP_LIST_FIRSTPRIVATE:
3823 1072 : clause_code = OMP_CLAUSE_FIRSTPRIVATE;
3824 1072 : goto add_clause;
3825 1661 : case OMP_LIST_LASTPRIVATE:
3826 1661 : clause_code = OMP_CLAUSE_LASTPRIVATE;
3827 1661 : goto add_clause;
3828 96 : case OMP_LIST_COPYIN:
3829 96 : clause_code = OMP_CLAUSE_COPYIN;
3830 96 : goto add_clause;
3831 74 : case OMP_LIST_COPYPRIVATE:
3832 74 : clause_code = OMP_CLAUSE_COPYPRIVATE;
3833 74 : goto add_clause;
3834 61 : case OMP_LIST_UNIFORM:
3835 61 : clause_code = OMP_CLAUSE_UNIFORM;
3836 61 : goto add_clause;
3837 51 : case OMP_LIST_USE_DEVICE:
3838 51 : case OMP_LIST_USE_DEVICE_PTR:
3839 51 : clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
3840 51 : goto add_clause;
3841 922 : case OMP_LIST_USE_DEVICE_ADDR:
3842 922 : clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
3843 922 : goto add_clause;
3844 43 : case OMP_LIST_IS_DEVICE_PTR:
3845 43 : clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
3846 43 : goto add_clause;
3847 112 : case OMP_LIST_HAS_DEVICE_ADDR:
3848 112 : clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR;
3849 112 : goto add_clause;
3850 2 : case OMP_LIST_NONTEMPORAL:
3851 2 : clause_code = OMP_CLAUSE_NONTEMPORAL;
3852 2 : goto add_clause;
3853 9 : case OMP_LIST_SCAN_IN:
3854 9 : clause_code = OMP_CLAUSE_INCLUSIVE;
3855 9 : goto add_clause;
3856 7 : case OMP_LIST_SCAN_EX:
3857 7 : clause_code = OMP_CLAUSE_EXCLUSIVE;
3858 7 : goto add_clause;
3859 4 : case OMP_LIST_USE:
3860 4 : clause_code = OMP_CLAUSE_USE;
3861 4 : goto add_clause;
3862 55 : case OMP_LIST_INTEROP:
3863 55 : clause_code = OMP_CLAUSE_INTEROP;
3864 55 : goto add_clause;
3865 :
3866 11728 : add_clause:
3867 11728 : omp_clauses
3868 11728 : = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
3869 : declare_simd);
3870 11728 : break;
3871 :
3872 : case OMP_LIST_DESTROY:
3873 12 : for (; n != NULL; n = n->next)
3874 9 : if (n->sym->attr.referenced)
3875 : {
3876 9 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
3877 9 : if (t != error_mark_node)
3878 : {
3879 9 : tree node
3880 9 : = build_omp_clause (input_location, OMP_CLAUSE_DESTROY);
3881 9 : OMP_CLAUSE_DECL (node) = t;
3882 9 : TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
3883 9 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3884 : }
3885 : }
3886 : break;
3887 :
3888 : case OMP_LIST_INIT:
3889 : {
3890 : tree pref_type = NULL_TREE;
3891 : const char *last = NULL;
3892 32 : for (; n != NULL; n = n->next)
3893 26 : if (n->sym->attr.referenced)
3894 : {
3895 26 : tree t = gfc_trans_omp_variable (n->sym, false);
3896 26 : if (t == error_mark_node)
3897 0 : continue;
3898 26 : tree node = build_omp_clause (input_location,
3899 : OMP_CLAUSE_INIT);
3900 26 : OMP_CLAUSE_DECL (node) = t;
3901 26 : TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
3902 26 : if (n->u.init.target)
3903 19 : OMP_CLAUSE_INIT_TARGET (node) = 1;
3904 26 : if (n->u.init.targetsync)
3905 10 : OMP_CLAUSE_INIT_TARGETSYNC (node) = 1;
3906 26 : if (last != n->u2.init_interop)
3907 : {
3908 6 : last = n->u2.init_interop;
3909 6 : if (n->u2.init_interop == NULL)
3910 : pref_type = NULL_TREE;
3911 : else
3912 : {
3913 5 : pref_type = build_string (n->u.init.len,
3914 : n->u2.init_interop);
3915 5 : TREE_TYPE (pref_type)
3916 10 : = build_array_type_nelts (unsigned_char_type_node,
3917 5 : n->u.init.len);
3918 : }
3919 : }
3920 26 : OMP_CLAUSE_INIT_PREFER_TYPE (node) = pref_type;
3921 26 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3922 : }
3923 : break;
3924 : }
3925 :
3926 : case OMP_LIST_ALIGNED:
3927 256 : for (; n != NULL; n = n->next)
3928 149 : if (n->sym->attr.referenced || declare_simd)
3929 : {
3930 149 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
3931 149 : if (t != error_mark_node)
3932 : {
3933 149 : tree node = build_omp_clause (input_location,
3934 : OMP_CLAUSE_ALIGNED);
3935 149 : OMP_CLAUSE_DECL (node) = t;
3936 149 : if (n->expr)
3937 : {
3938 148 : tree alignment_var;
3939 :
3940 148 : if (declare_simd)
3941 5 : alignment_var = gfc_conv_constant_to_tree (n->expr);
3942 : else
3943 : {
3944 143 : gfc_init_se (&se, NULL);
3945 143 : gfc_conv_expr (&se, n->expr);
3946 143 : gfc_add_block_to_block (block, &se.pre);
3947 143 : alignment_var = gfc_evaluate_now (se.expr, block);
3948 143 : gfc_add_block_to_block (block, &se.post);
3949 : }
3950 148 : OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
3951 : }
3952 149 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3953 : }
3954 : }
3955 : break;
3956 : case OMP_LIST_ALLOCATE:
3957 : {
3958 : tree allocator_ = NULL_TREE;
3959 : gfc_expr *alloc_expr = NULL;
3960 675 : for (; n != NULL; n = n->next)
3961 427 : if (n->sym->attr.referenced)
3962 : {
3963 427 : tree t = gfc_trans_omp_variable (n->sym, false);
3964 427 : if (t != error_mark_node)
3965 : {
3966 427 : tree node = build_omp_clause (input_location,
3967 : OMP_CLAUSE_ALLOCATE);
3968 427 : OMP_CLAUSE_DECL (node) = t;
3969 427 : if (n->u2.allocator)
3970 : {
3971 292 : if (alloc_expr != n->u2.allocator)
3972 : {
3973 168 : gfc_init_se (&se, NULL);
3974 168 : gfc_conv_expr (&se, n->u2.allocator);
3975 168 : gfc_add_block_to_block (block, &se.pre);
3976 168 : allocator_ = gfc_evaluate_now (se.expr, block);
3977 168 : gfc_add_block_to_block (block, &se.post);
3978 : }
3979 292 : OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
3980 : }
3981 427 : alloc_expr = n->u2.allocator;
3982 427 : if (n->u.align)
3983 : {
3984 51 : tree align_;
3985 51 : gfc_init_se (&se, NULL);
3986 51 : gfc_conv_expr (&se, n->u.align);
3987 51 : gcc_assert (CONSTANT_CLASS_P (se.expr)
3988 : && se.pre.head == NULL
3989 : && se.post.head == NULL);
3990 51 : align_ = se.expr;
3991 51 : OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
3992 : }
3993 427 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3994 : }
3995 : }
3996 : else
3997 0 : alloc_expr = n->u2.allocator;
3998 : }
3999 : break;
4000 : case OMP_LIST_LINEAR:
4001 : {
4002 : gfc_expr *last_step_expr = NULL;
4003 : tree last_step = NULL_TREE;
4004 : bool last_step_parm = false;
4005 :
4006 1288 : for (; n != NULL; n = n->next)
4007 : {
4008 795 : if (n->expr)
4009 : {
4010 776 : last_step_expr = n->expr;
4011 776 : last_step = NULL_TREE;
4012 776 : last_step_parm = false;
4013 : }
4014 795 : if (n->sym->attr.referenced || declare_simd)
4015 : {
4016 795 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
4017 795 : if (t != error_mark_node)
4018 : {
4019 795 : tree node = build_omp_clause (input_location,
4020 : OMP_CLAUSE_LINEAR);
4021 795 : OMP_CLAUSE_DECL (node) = t;
4022 795 : omp_clause_linear_kind kind;
4023 795 : switch (n->u.linear.op)
4024 : {
4025 : case OMP_LINEAR_DEFAULT:
4026 : kind = OMP_CLAUSE_LINEAR_DEFAULT;
4027 : break;
4028 : case OMP_LINEAR_REF:
4029 : kind = OMP_CLAUSE_LINEAR_REF;
4030 : break;
4031 : case OMP_LINEAR_VAL:
4032 : kind = OMP_CLAUSE_LINEAR_VAL;
4033 : break;
4034 : case OMP_LINEAR_UVAL:
4035 : kind = OMP_CLAUSE_LINEAR_UVAL;
4036 : break;
4037 0 : default:
4038 0 : gcc_unreachable ();
4039 : }
4040 795 : OMP_CLAUSE_LINEAR_KIND (node) = kind;
4041 795 : OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node)
4042 795 : = n->u.linear.old_modifier;
4043 795 : if (last_step_expr && last_step == NULL_TREE)
4044 : {
4045 776 : if (!declare_simd)
4046 : {
4047 695 : gfc_init_se (&se, NULL);
4048 695 : gfc_conv_expr (&se, last_step_expr);
4049 695 : gfc_add_block_to_block (block, &se.pre);
4050 695 : last_step = gfc_evaluate_now (se.expr, block);
4051 695 : gfc_add_block_to_block (block, &se.post);
4052 : }
4053 81 : else if (last_step_expr->expr_type == EXPR_VARIABLE)
4054 : {
4055 2 : gfc_symbol *s = last_step_expr->symtree->n.sym;
4056 2 : last_step = gfc_trans_omp_variable (s, true);
4057 2 : last_step_parm = true;
4058 : }
4059 : else
4060 79 : last_step
4061 79 : = gfc_conv_constant_to_tree (last_step_expr);
4062 : }
4063 795 : if (last_step_parm)
4064 : {
4065 2 : OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1;
4066 2 : OMP_CLAUSE_LINEAR_STEP (node) = last_step;
4067 : }
4068 : else
4069 : {
4070 793 : if (kind == OMP_CLAUSE_LINEAR_REF)
4071 : {
4072 34 : tree type;
4073 34 : if (n->sym->attr.flavor == FL_PROCEDURE)
4074 : {
4075 0 : type = gfc_get_function_type (n->sym);
4076 0 : type = build_pointer_type (type);
4077 : }
4078 : else
4079 34 : type = gfc_sym_type (n->sym);
4080 34 : if (POINTER_TYPE_P (type))
4081 34 : type = TREE_TYPE (type);
4082 : /* Otherwise to be determined what exactly
4083 : should be done. */
4084 34 : tree t = fold_convert (sizetype, last_step);
4085 34 : t = size_binop (MULT_EXPR, t,
4086 : TYPE_SIZE_UNIT (type));
4087 34 : OMP_CLAUSE_LINEAR_STEP (node) = t;
4088 : }
4089 : else
4090 : {
4091 759 : tree type
4092 759 : = gfc_typenode_for_spec (&n->sym->ts);
4093 759 : OMP_CLAUSE_LINEAR_STEP (node)
4094 1518 : = fold_convert (type, last_step);
4095 : }
4096 : }
4097 795 : if (n->sym->attr.dimension || n->sym->attr.allocatable)
4098 222 : OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
4099 795 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4100 : }
4101 : }
4102 : }
4103 : }
4104 : break;
4105 : case OMP_LIST_AFFINITY:
4106 : case OMP_LIST_DEPEND:
4107 : iterator = NULL_TREE;
4108 : prev = NULL;
4109 : prev_clauses = omp_clauses;
4110 1582 : for (; n != NULL; n = n->next)
4111 : {
4112 857 : if (iterator && prev->u2.ns != n->u2.ns)
4113 : {
4114 12 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
4115 12 : TREE_VEC_ELT (iterator, 5) = tree_block;
4116 26 : for (tree c = omp_clauses; c != prev_clauses;
4117 14 : c = OMP_CLAUSE_CHAIN (c))
4118 28 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
4119 14 : OMP_CLAUSE_DECL (c));
4120 : prev_clauses = omp_clauses;
4121 : iterator = NULL_TREE;
4122 : }
4123 857 : if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
4124 : {
4125 46 : gfc_init_block (&iter_block);
4126 46 : tree_block = make_node (BLOCK);
4127 46 : TREE_USED (tree_block) = 1;
4128 46 : BLOCK_VARS (tree_block) = NULL_TREE;
4129 46 : iterator = handle_iterator (n->u2.ns, block,
4130 : tree_block);
4131 : }
4132 857 : if (!iterator)
4133 802 : gfc_init_block (&iter_block);
4134 857 : prev = n;
4135 857 : if (list == OMP_LIST_DEPEND
4136 831 : && (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
4137 831 : || n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST))
4138 : {
4139 228 : tree vec = NULL_TREE;
4140 228 : unsigned int i;
4141 228 : bool is_depend
4142 : = n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST;
4143 228 : for (i = 0; ; i++)
4144 : {
4145 1219 : tree addend = integer_zero_node, t;
4146 1219 : bool neg = false;
4147 1219 : if (n->sym && n->expr)
4148 : {
4149 558 : addend = gfc_conv_constant_to_tree (n->expr);
4150 558 : if (TREE_CODE (addend) == INTEGER_CST
4151 558 : && tree_int_cst_sgn (addend) == -1)
4152 : {
4153 407 : neg = true;
4154 407 : addend = const_unop (NEGATE_EXPR,
4155 407 : TREE_TYPE (addend), addend);
4156 : }
4157 : }
4158 :
4159 1219 : if (n->sym == NULL)
4160 0 : t = null_pointer_node; /* "omp_cur_iteration - 1". */
4161 : else
4162 1219 : t = gfc_trans_omp_variable (n->sym, false);
4163 1219 : if (t != error_mark_node)
4164 : {
4165 1219 : if (i < vec_safe_length (doacross_steps)
4166 426 : && !integer_zerop (addend)
4167 630 : && (*doacross_steps)[i])
4168 : {
4169 204 : tree step = (*doacross_steps)[i];
4170 204 : addend = fold_convert (TREE_TYPE (step), addend);
4171 204 : addend = build2 (TRUNC_DIV_EXPR,
4172 204 : TREE_TYPE (step), addend, step);
4173 : }
4174 1219 : vec = tree_cons (addend, t, vec);
4175 1219 : if (neg)
4176 407 : OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1;
4177 : }
4178 1219 : if (n->next == NULL
4179 1057 : || n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
4180 : break;
4181 991 : n = n->next;
4182 991 : }
4183 228 : if (vec == NULL_TREE)
4184 0 : continue;
4185 :
4186 228 : tree node = build_omp_clause (input_location,
4187 : OMP_CLAUSE_DOACROSS);
4188 228 : OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK;
4189 228 : OMP_CLAUSE_DOACROSS_DEPEND (node) = is_depend;
4190 228 : OMP_CLAUSE_DECL (node) = nreverse (vec);
4191 228 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4192 228 : continue;
4193 228 : }
4194 :
4195 629 : if (n->sym && !n->sym->attr.referenced)
4196 0 : continue;
4197 :
4198 655 : tree node = build_omp_clause (input_location,
4199 : list == OMP_LIST_DEPEND
4200 : ? OMP_CLAUSE_DEPEND
4201 : : OMP_CLAUSE_AFFINITY);
4202 629 : if (n->sym == NULL) /* omp_all_memory */
4203 9 : OMP_CLAUSE_DECL (node) = null_pointer_node;
4204 620 : else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
4205 : {
4206 404 : tree decl = gfc_trans_omp_variable (n->sym, false);
4207 404 : if (gfc_omp_privatize_by_reference (decl))
4208 62 : decl = build_fold_indirect_ref (decl);
4209 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4210 : {
4211 23 : decl = gfc_conv_descriptor_data_get (decl);
4212 23 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
4213 23 : decl = build_fold_indirect_ref (decl);
4214 : }
4215 381 : else if (n->sym->attr.allocatable || n->sym->attr.pointer)
4216 22 : decl = build_fold_indirect_ref (decl);
4217 359 : else if (DECL_P (decl))
4218 326 : TREE_ADDRESSABLE (decl) = 1;
4219 404 : OMP_CLAUSE_DECL (node) = decl;
4220 404 : }
4221 : else
4222 : {
4223 216 : tree ptr;
4224 216 : gfc_init_se (&se, NULL);
4225 : /* The first ref can be an element selection on the base
4226 : object while the full expression still denotes an array,
4227 : e.g. x(j)%a. Pick the lowering path from the overall
4228 : expression rank, not from the first REF_ARRAY. */
4229 216 : if (n->expr->rank == 0)
4230 : {
4231 135 : gfc_conv_expr_reference (&se, n->expr);
4232 135 : ptr = se.expr;
4233 : }
4234 : else
4235 : {
4236 81 : gfc_conv_expr_descriptor (&se, n->expr);
4237 81 : ptr = gfc_conv_array_data (se.expr);
4238 : }
4239 216 : gfc_add_block_to_block (&iter_block, &se.pre);
4240 216 : gfc_add_block_to_block (&iter_block, &se.post);
4241 216 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4242 216 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
4243 : }
4244 629 : if (list == OMP_LIST_DEPEND)
4245 603 : switch (n->u.depend_doacross_op)
4246 : {
4247 228 : case OMP_DEPEND_IN:
4248 228 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
4249 228 : break;
4250 258 : case OMP_DEPEND_OUT:
4251 258 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
4252 258 : break;
4253 55 : case OMP_DEPEND_INOUT:
4254 55 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
4255 55 : break;
4256 9 : case OMP_DEPEND_INOUTSET:
4257 9 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET;
4258 9 : break;
4259 15 : case OMP_DEPEND_MUTEXINOUTSET:
4260 15 : OMP_CLAUSE_DEPEND_KIND (node)
4261 15 : = OMP_CLAUSE_DEPEND_MUTEXINOUTSET;
4262 15 : break;
4263 38 : case OMP_DEPEND_DEPOBJ:
4264 38 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ;
4265 38 : break;
4266 0 : default:
4267 0 : gcc_unreachable ();
4268 : }
4269 629 : if (!iterator)
4270 574 : gfc_add_block_to_block (block, &iter_block);
4271 629 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4272 : }
4273 725 : if (iterator)
4274 : {
4275 34 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
4276 34 : TREE_VEC_ELT (iterator, 5) = tree_block;
4277 76 : for (tree c = omp_clauses; c != prev_clauses;
4278 42 : c = OMP_CLAUSE_CHAIN (c))
4279 84 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
4280 42 : OMP_CLAUSE_DECL (c));
4281 : }
4282 : break;
4283 : case OMP_LIST_MAP:
4284 24175 : for (; n != NULL; n = n->next)
4285 : {
4286 15300 : if (!n->sym->attr.referenced
4287 15300 : || n->sym->attr.flavor == FL_PARAMETER)
4288 295 : continue;
4289 :
4290 15291 : location_t map_loc = gfc_get_location (&n->where);
4291 15291 : bool always_modifier = false;
4292 15291 : tree node = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4293 15291 : tree node2 = NULL_TREE;
4294 15291 : tree node3 = NULL_TREE;
4295 15291 : tree node4 = NULL_TREE;
4296 15291 : tree node5 = NULL_TREE;
4297 :
4298 : /* OpenMP: automatically map pointer targets with the pointer;
4299 : hence, always update the descriptor/pointer itself. */
4300 15291 : if (!openacc
4301 15291 : && ((n->expr == NULL && n->sym->attr.pointer)
4302 14503 : || (n->expr && gfc_expr_attr (n->expr).pointer)))
4303 1393 : always_modifier = true;
4304 :
4305 15291 : if (n->u.map.readonly)
4306 22 : OMP_CLAUSE_MAP_READONLY (node) = 1;
4307 :
4308 15291 : switch (n->u.map.op)
4309 : {
4310 1079 : case OMP_MAP_ALLOC:
4311 1079 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
4312 1079 : break;
4313 64 : case OMP_MAP_IF_PRESENT:
4314 64 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT);
4315 64 : break;
4316 66 : case OMP_MAP_ATTACH:
4317 66 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH);
4318 66 : break;
4319 4236 : case OMP_MAP_TO:
4320 4236 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
4321 4236 : break;
4322 3041 : case OMP_MAP_FROM:
4323 3041 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
4324 3041 : break;
4325 4358 : case OMP_MAP_TOFROM:
4326 4358 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
4327 4358 : break;
4328 32 : case OMP_MAP_ALWAYS_TO:
4329 32 : always_modifier = true;
4330 32 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
4331 32 : break;
4332 14 : case OMP_MAP_ALWAYS_FROM:
4333 14 : always_modifier = true;
4334 14 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
4335 14 : break;
4336 171 : case OMP_MAP_ALWAYS_TOFROM:
4337 171 : always_modifier = true;
4338 171 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
4339 171 : break;
4340 8 : case OMP_MAP_PRESENT_ALLOC:
4341 8 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC);
4342 8 : break;
4343 13 : case OMP_MAP_PRESENT_TO:
4344 13 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO);
4345 13 : break;
4346 4 : case OMP_MAP_PRESENT_FROM:
4347 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM);
4348 4 : break;
4349 2 : case OMP_MAP_PRESENT_TOFROM:
4350 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM);
4351 2 : break;
4352 10 : case OMP_MAP_ALWAYS_PRESENT_TO:
4353 10 : always_modifier = true;
4354 10 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO);
4355 10 : break;
4356 4 : case OMP_MAP_ALWAYS_PRESENT_FROM:
4357 4 : always_modifier = true;
4358 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM);
4359 4 : break;
4360 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
4361 2 : always_modifier = true;
4362 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM);
4363 2 : break;
4364 426 : case OMP_MAP_RELEASE:
4365 426 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
4366 426 : break;
4367 56 : case OMP_MAP_DELETE:
4368 56 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
4369 56 : break;
4370 44 : case OMP_MAP_DETACH:
4371 44 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH);
4372 44 : break;
4373 64 : case OMP_MAP_FORCE_ALLOC:
4374 64 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
4375 64 : break;
4376 465 : case OMP_MAP_FORCE_TO:
4377 465 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
4378 465 : break;
4379 577 : case OMP_MAP_FORCE_FROM:
4380 577 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
4381 577 : break;
4382 0 : case OMP_MAP_FORCE_TOFROM:
4383 0 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
4384 0 : break;
4385 545 : case OMP_MAP_FORCE_PRESENT:
4386 545 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
4387 545 : break;
4388 10 : case OMP_MAP_FORCE_DEVICEPTR:
4389 10 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
4390 10 : break;
4391 0 : default:
4392 0 : gcc_unreachable ();
4393 : }
4394 :
4395 15291 : tree decl = gfc_trans_omp_variable (n->sym, false);
4396 15291 : if (DECL_P (decl))
4397 15291 : TREE_ADDRESSABLE (decl) = 1;
4398 :
4399 15291 : gfc_ref *lastref = NULL;
4400 :
4401 15291 : if (n->expr)
4402 14700 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4403 9021 : if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
4404 9021 : lastref = ref;
4405 :
4406 5679 : bool allocatable = false, pointer = false;
4407 :
4408 5679 : if (lastref && lastref->type == REF_COMPONENT)
4409 : {
4410 457 : gfc_component *c = lastref->u.c.component;
4411 :
4412 457 : if (c->ts.type == BT_CLASS)
4413 : {
4414 24 : pointer = CLASS_DATA (c)->attr.class_pointer;
4415 24 : allocatable = CLASS_DATA (c)->attr.allocatable;
4416 : }
4417 : else
4418 : {
4419 433 : pointer = c->attr.pointer;
4420 433 : allocatable = c->attr.allocatable;
4421 : }
4422 : }
4423 :
4424 15291 : if (n->expr == NULL
4425 5679 : || (n->expr->ref->type == REF_ARRAY
4426 3549 : && n->expr->ref->u.ar.type == AR_FULL))
4427 : {
4428 9612 : gomp_map_kind map_kind;
4429 9612 : tree type = TREE_TYPE (decl);
4430 9612 : if (n->sym->ts.type == BT_CHARACTER
4431 218 : && n->sym->ts.deferred
4432 92 : && (n->sym->attr.omp_declare_target
4433 84 : || n->sym->attr.omp_declare_target_link
4434 84 : || n->sym->attr.omp_declare_target_local)
4435 8 : && (always_modifier || n->sym->attr.pointer)
4436 8 : && op != EXEC_OMP_TARGET_EXIT_DATA
4437 4 : && n->u.map.op != OMP_MAP_DELETE
4438 4 : && n->u.map.op != OMP_MAP_RELEASE)
4439 : {
4440 4 : gcc_assert (n->sym->ts.u.cl->backend_decl);
4441 4 : node5 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4442 4 : OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
4443 4 : OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
4444 4 : OMP_CLAUSE_SIZE (node5)
4445 8 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
4446 : }
4447 :
4448 9612 : tree present = gfc_omp_check_optional_argument (decl, true);
4449 9612 : if (openacc && n->sym->ts.type == BT_CLASS)
4450 : {
4451 60 : if (n->sym->attr.optional)
4452 0 : sorry_at (gfc_get_location (&n->where),
4453 : "optional class parameter");
4454 60 : tree ptr = gfc_class_data_get (decl);
4455 60 : ptr = build_fold_indirect_ref (ptr);
4456 60 : OMP_CLAUSE_DECL (node) = ptr;
4457 60 : OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
4458 60 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4459 60 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
4460 60 : OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
4461 60 : OMP_CLAUSE_SIZE (node2) = size_int (0);
4462 60 : goto finalize_map_clause;
4463 : }
4464 9552 : else if (POINTER_TYPE_P (type)
4465 9552 : && (gfc_omp_privatize_by_reference (decl)
4466 507 : || GFC_DECL_GET_SCALAR_POINTER (decl)
4467 322 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
4468 84 : || GFC_DECL_CRAY_POINTEE (decl)
4469 84 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
4470 84 : || (n->sym->ts.type == BT_DERIVED
4471 8 : && (n->sym->ts.u.derived->ts.f90_type
4472 : != BT_VOID))))
4473 : {
4474 3384 : tree orig_decl = decl;
4475 3384 : bool bare_attach_detach
4476 : = (openacc
4477 1252 : && (n->u.map.op == OMP_MAP_ATTACH
4478 1252 : || n->u.map.op == OMP_MAP_DETACH)
4479 4 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
4480 3388 : && !(POINTER_TYPE_P (TREE_TYPE (decl))
4481 4 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4482 3384 : (TREE_TYPE (decl)))));
4483 :
4484 : /* For nonallocatable, nonpointer arrays, a temporary
4485 : variable is generated, but this one is only defined if
4486 : the variable is present; hence, we now set it to NULL
4487 : to avoid accessing undefined variables. We cannot use
4488 : a temporary variable here as otherwise the replacement
4489 : of the variables in omp-low.cc will not work. */
4490 3384 : if (present && GFC_ARRAY_TYPE_P (type))
4491 : {
4492 284 : tree tmp = fold_build2_loc (input_location,
4493 : MODIFY_EXPR,
4494 : void_type_node, decl,
4495 : null_pointer_node);
4496 284 : tree cond = fold_build1_loc (input_location,
4497 : TRUTH_NOT_EXPR,
4498 : boolean_type_node,
4499 : present);
4500 284 : gfc_add_expr_to_block (block,
4501 : build3_loc (input_location,
4502 : COND_EXPR,
4503 : void_type_node,
4504 : cond, tmp,
4505 : NULL_TREE));
4506 : }
4507 : /* Bare OpenACC attach/detach on scalar pointer-like
4508 : variables wants a single attach operation on the
4509 : pointer itself, not a standalone pointer-mapping
4510 : node. Component and descriptor cases have dedicated
4511 : handling below; this covers the plain scalar path. */
4512 3384 : if (bare_attach_detach)
4513 : {
4514 4 : decl = build_fold_indirect_ref (decl);
4515 4 : OMP_CLAUSE_DECL (node) = build_fold_addr_expr (decl);
4516 4 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4517 4 : goto finalize_map_clause;
4518 : }
4519 : /* For descriptor types, the unmapping happens below. */
4520 3380 : if (op != EXEC_OMP_TARGET_EXIT_DATA
4521 3380 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4522 : {
4523 3380 : enum gomp_map_kind gmk = GOMP_MAP_POINTER;
4524 3380 : if (op == EXEC_OMP_TARGET_EXIT_DATA
4525 49 : && n->u.map.op == OMP_MAP_DELETE)
4526 : gmk = GOMP_MAP_DELETE;
4527 44 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4528 44 : gmk = GOMP_MAP_RELEASE;
4529 3380 : tree size;
4530 3380 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
4531 49 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
4532 : else
4533 3331 : size = size_int (0);
4534 3380 : node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4535 3380 : OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
4536 3380 : OMP_CLAUSE_DECL (node4) = decl;
4537 3380 : OMP_CLAUSE_SIZE (node4) = size;
4538 : }
4539 3380 : decl = build_fold_indirect_ref (decl);
4540 3380 : if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
4541 2153 : || gfc_omp_is_optional_argument (orig_decl))
4542 4432 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
4543 2109 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
4544 : {
4545 408 : enum gomp_map_kind gmk;
4546 408 : if (op == EXEC_OMP_TARGET_EXIT_DATA
4547 8 : && n->u.map.op == OMP_MAP_DELETE)
4548 : gmk = GOMP_MAP_DELETE;
4549 6 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4550 : gmk = GOMP_MAP_RELEASE;
4551 : else
4552 : gmk = GOMP_MAP_POINTER;
4553 408 : tree size;
4554 408 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
4555 8 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
4556 : else
4557 400 : size = size_int (0);
4558 408 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4559 408 : OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
4560 408 : OMP_CLAUSE_DECL (node3) = decl;
4561 408 : OMP_CLAUSE_SIZE (node3) = size;
4562 408 : decl = build_fold_indirect_ref (decl);
4563 : }
4564 : }
4565 9548 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4566 : {
4567 1407 : tree type = TREE_TYPE (decl);
4568 1407 : tree ptr = gfc_conv_descriptor_data_get (decl);
4569 1407 : if (present)
4570 309 : ptr = gfc_build_cond_assign_expr (block, present, ptr,
4571 : null_pointer_node);
4572 1407 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4573 1407 : ptr = build_fold_indirect_ref (ptr);
4574 1407 : OMP_CLAUSE_DECL (node) = ptr;
4575 1407 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4576 1407 : OMP_CLAUSE_DECL (node2) = decl;
4577 1407 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
4578 1407 : if (n->u.map.op == OMP_MAP_DELETE)
4579 : map_kind = GOMP_MAP_DELETE;
4580 1380 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
4581 1317 : || n->u.map.op == OMP_MAP_RELEASE)
4582 : map_kind = GOMP_MAP_RELEASE;
4583 : else
4584 1407 : map_kind = GOMP_MAP_TO_PSET;
4585 1407 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
4586 :
4587 1407 : if (op != EXEC_OMP_TARGET_EXIT_DATA
4588 1317 : && n->u.map.op != OMP_MAP_DELETE
4589 1317 : && n->u.map.op != OMP_MAP_RELEASE)
4590 : {
4591 1269 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4592 1269 : if (present)
4593 : {
4594 309 : ptr = gfc_conv_descriptor_data_get (decl);
4595 309 : ptr = gfc_build_addr_expr (NULL, ptr);
4596 309 : ptr = gfc_build_cond_assign_expr (
4597 : block, present, ptr, null_pointer_node);
4598 309 : ptr = build_fold_indirect_ref (ptr);
4599 309 : OMP_CLAUSE_DECL (node3) = ptr;
4600 : }
4601 : else
4602 960 : OMP_CLAUSE_DECL (node3)
4603 1920 : = gfc_conv_descriptor_data_get (decl);
4604 1269 : OMP_CLAUSE_SIZE (node3) = size_int (0);
4605 :
4606 1269 : if (n->u.map.op == OMP_MAP_ATTACH)
4607 : {
4608 : /* Standalone attach clauses used with arrays with
4609 : descriptors must copy the descriptor to the
4610 : target, else they won't have anything to
4611 : perform the attachment onto (see OpenACC 2.6,
4612 : "2.6.3. Data Structures with Pointers"). */
4613 9 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH);
4614 : /* We don't want to map PTR at all in this case,
4615 : so delete its node and shuffle the others
4616 : down. */
4617 9 : node = node2;
4618 9 : node2 = node3;
4619 9 : node3 = NULL;
4620 9 : goto finalize_map_clause;
4621 : }
4622 1260 : else if (n->u.map.op == OMP_MAP_DETACH)
4623 : {
4624 4 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH);
4625 : /* Similarly to above, we don't want to unmap PTR
4626 : here. */
4627 4 : node = node2;
4628 4 : node2 = node3;
4629 4 : node3 = NULL;
4630 4 : goto finalize_map_clause;
4631 : }
4632 : else
4633 2042 : OMP_CLAUSE_SET_MAP_KIND (node3,
4634 : always_modifier
4635 : ? GOMP_MAP_ALWAYS_POINTER
4636 : : GOMP_MAP_POINTER);
4637 : }
4638 :
4639 : /* We have to check for n->sym->attr.dimension because
4640 : of scalar coarrays. */
4641 1394 : if ((n->sym->attr.pointer || n->sym->attr.allocatable)
4642 1394 : && n->sym->attr.dimension)
4643 : {
4644 1394 : stmtblock_t cond_block;
4645 1394 : tree size
4646 1394 : = gfc_create_var (gfc_array_index_type, NULL);
4647 1394 : tree tem, then_b, else_b, zero, cond;
4648 :
4649 1394 : gfc_init_block (&cond_block);
4650 1394 : tem
4651 2788 : = gfc_full_array_size (&cond_block, decl,
4652 1394 : GFC_TYPE_ARRAY_RANK (type));
4653 1394 : tree elemsz;
4654 1394 : if (n->sym->ts.type == BT_CHARACTER
4655 52 : && n->sym->ts.deferred)
4656 : {
4657 44 : tree len = n->sym->ts.u.cl->backend_decl;
4658 44 : len = fold_convert (size_type_node, len);
4659 44 : elemsz = gfc_get_char_type (n->sym->ts.kind);
4660 44 : elemsz = TYPE_SIZE_UNIT (elemsz);
4661 44 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
4662 : len, elemsz);
4663 44 : }
4664 : else
4665 1350 : elemsz
4666 1350 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4667 1394 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4668 1394 : tem = fold_build2 (MULT_EXPR, gfc_array_index_type,
4669 : tem, elemsz);
4670 1394 : gfc_add_modify (&cond_block, size, tem);
4671 1394 : then_b = gfc_finish_block (&cond_block);
4672 1394 : gfc_init_block (&cond_block);
4673 1394 : zero = build_int_cst (gfc_array_index_type, 0);
4674 1394 : gfc_add_modify (&cond_block, size, zero);
4675 1394 : else_b = gfc_finish_block (&cond_block);
4676 1394 : tem = gfc_conv_descriptor_data_get (decl);
4677 1394 : tem = fold_convert (pvoid_type_node, tem);
4678 1394 : cond = fold_build2_loc (input_location, NE_EXPR,
4679 : boolean_type_node,
4680 : tem, null_pointer_node);
4681 1394 : if (present)
4682 309 : cond = fold_build2_loc (input_location,
4683 : TRUTH_ANDIF_EXPR,
4684 : boolean_type_node,
4685 : present, cond);
4686 1394 : gfc_add_expr_to_block (block,
4687 : build3_loc (input_location,
4688 : COND_EXPR,
4689 : void_type_node,
4690 : cond, then_b,
4691 : else_b));
4692 1394 : OMP_CLAUSE_SIZE (node) = size;
4693 1394 : }
4694 0 : else if (n->sym->attr.dimension)
4695 : {
4696 0 : stmtblock_t cond_block;
4697 0 : gfc_init_block (&cond_block);
4698 0 : tree size = gfc_full_array_size (&cond_block, decl,
4699 0 : GFC_TYPE_ARRAY_RANK (type));
4700 0 : tree elemsz
4701 0 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4702 0 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4703 0 : size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4704 : size, elemsz);
4705 0 : size = gfc_evaluate_now (size, &cond_block);
4706 0 : if (present)
4707 : {
4708 0 : tree var = gfc_create_var (gfc_array_index_type,
4709 : NULL);
4710 0 : gfc_add_modify (&cond_block, var, size);
4711 0 : tree cond_body = gfc_finish_block (&cond_block);
4712 0 : tree cond = build3_loc (input_location, COND_EXPR,
4713 : void_type_node, present,
4714 : cond_body, NULL_TREE);
4715 0 : gfc_add_expr_to_block (block, cond);
4716 0 : OMP_CLAUSE_SIZE (node) = var;
4717 : }
4718 : else
4719 : {
4720 0 : gfc_add_block_to_block (block, &cond_block);
4721 0 : OMP_CLAUSE_SIZE (node) = size;
4722 : }
4723 : }
4724 : }
4725 8141 : else if (present
4726 845 : && INDIRECT_REF_P (decl)
4727 8884 : && INDIRECT_REF_P (TREE_OPERAND (decl, 0)))
4728 : {
4729 : /* A single indirectref is handled by the middle end. */
4730 228 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
4731 228 : tree tmp = TREE_OPERAND (decl, 0);
4732 228 : tmp = gfc_build_cond_assign_expr (block, present, tmp,
4733 : null_pointer_node);
4734 228 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (tmp);
4735 : }
4736 : else
4737 7913 : OMP_CLAUSE_DECL (node) = decl;
4738 :
4739 9535 : if (!n->sym->attr.dimension
4740 6043 : && n->sym->ts.type == BT_CHARACTER
4741 144 : && n->sym->ts.deferred)
4742 : {
4743 48 : if (!DECL_P (decl))
4744 : {
4745 48 : gcc_assert (TREE_CODE (decl) == INDIRECT_REF);
4746 48 : decl = TREE_OPERAND (decl, 0);
4747 : }
4748 48 : tree cond = fold_build2_loc (input_location, NE_EXPR,
4749 : boolean_type_node,
4750 : decl, null_pointer_node);
4751 48 : if (present)
4752 2 : cond = fold_build2_loc (input_location,
4753 : TRUTH_ANDIF_EXPR,
4754 : boolean_type_node,
4755 : present, cond);
4756 48 : tree len = n->sym->ts.u.cl->backend_decl;
4757 48 : len = fold_convert (size_type_node, len);
4758 48 : tree size = gfc_get_char_type (n->sym->ts.kind);
4759 48 : size = TYPE_SIZE_UNIT (size);
4760 48 : size = fold_build2 (MULT_EXPR, size_type_node, len, size);
4761 48 : size = build3_loc (input_location,
4762 : COND_EXPR,
4763 : size_type_node,
4764 : cond, size,
4765 : size_zero_node);
4766 48 : size = gfc_evaluate_now (size, block);
4767 48 : OMP_CLAUSE_SIZE (node) = size;
4768 : }
4769 9535 : if ((TREE_CODE (decl) != PARM_DECL
4770 186 : || DECL_ARTIFICIAL (OMP_CLAUSE_DECL (node)))
4771 9349 : && n->sym->ts.type == BT_DERIVED
4772 10060 : && n->sym->ts.u.derived->attr.alloc_comp)
4773 : {
4774 : /* Save array descriptor for use in
4775 : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
4776 : to ensure that it is not gimplified + is a decl. */
4777 212 : tree tmp = OMP_CLAUSE_SIZE (node);
4778 212 : if (tmp == NULL_TREE)
4779 229 : tmp = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
4780 46 : : TYPE_SIZE_UNIT (TREE_TYPE (decl));
4781 212 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
4782 212 : gfc_add_modify_loc (input_location, block, var, tmp);
4783 212 : OMP_CLAUSE_SIZE (node) = var;
4784 212 : gfc_allocate_lang_decl (var);
4785 212 : if (TREE_CODE (decl) == INDIRECT_REF)
4786 48 : decl = TREE_OPERAND (decl, 0);
4787 212 : if (TREE_CODE (decl) == INDIRECT_REF)
4788 2 : decl = TREE_OPERAND (decl, 0);
4789 212 : if (DECL_LANG_SPECIFIC (decl)
4790 212 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
4791 6 : GFC_DECL_SAVED_DESCRIPTOR (var)
4792 2 : = GFC_DECL_SAVED_DESCRIPTOR (decl);
4793 : else
4794 210 : GFC_DECL_SAVED_DESCRIPTOR (var) = decl;
4795 : }
4796 : }
4797 5679 : else if (n->expr
4798 5679 : && n->expr->expr_type == EXPR_VARIABLE
4799 5679 : && n->expr->ref->type == REF_ARRAY
4800 3549 : && !n->expr->ref->next)
4801 : {
4802 : /* An array element or array section which is not part of a
4803 : derived type, etc. */
4804 3294 : bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
4805 3294 : tree type = TREE_TYPE (decl);
4806 3294 : gomp_map_kind k = GOMP_MAP_POINTER;
4807 3294 : if (!openacc
4808 443 : && !GFC_DESCRIPTOR_TYPE_P (type)
4809 3682 : && !(POINTER_TYPE_P (type)
4810 256 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))))
4811 : k = GOMP_MAP_FIRSTPRIVATE_POINTER;
4812 3294 : gfc_trans_omp_array_section (block, op, n, decl, element,
4813 3294 : !openacc, k, node, node2,
4814 : node3, node4);
4815 3294 : }
4816 2385 : else if (n->expr
4817 2385 : && n->expr->expr_type == EXPR_VARIABLE
4818 2385 : && (n->expr->ref->type == REF_COMPONENT
4819 : || n->expr->ref->type == REF_ARRAY)
4820 2385 : && lastref
4821 2385 : && lastref->type == REF_COMPONENT
4822 457 : && lastref->u.c.component->ts.type != BT_CLASS
4823 433 : && lastref->u.c.component->ts.type != BT_DERIVED
4824 341 : && !lastref->u.c.component->attr.dimension)
4825 : {
4826 : /* Derived type access with last component being a scalar. */
4827 341 : gfc_init_se (&se, NULL);
4828 :
4829 341 : gfc_conv_expr (&se, n->expr);
4830 341 : gfc_add_block_to_block (block, &se.pre);
4831 : /* For BT_CHARACTER a pointer is returned. */
4832 341 : OMP_CLAUSE_DECL (node)
4833 588 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
4834 341 : ? build_fold_indirect_ref (se.expr) : se.expr;
4835 341 : gfc_add_block_to_block (block, &se.post);
4836 341 : if (pointer || allocatable)
4837 : {
4838 : /* If it's a bare attach/detach clause, we just want
4839 : to perform a single attach/detach operation, of the
4840 : pointer itself, not of the pointed-to object. */
4841 161 : if (openacc
4842 68 : && (n->u.map.op == OMP_MAP_ATTACH
4843 50 : || n->u.map.op == OMP_MAP_DETACH))
4844 : {
4845 36 : OMP_CLAUSE_DECL (node)
4846 36 : = build_fold_addr_expr (OMP_CLAUSE_DECL (node));
4847 36 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4848 36 : goto finalize_map_clause;
4849 : }
4850 :
4851 125 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4852 125 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
4853 125 : OMP_CLAUSE_DECL (node2)
4854 180 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
4855 125 : ? se.expr
4856 55 : : gfc_build_addr_expr (NULL, se.expr);
4857 125 : OMP_CLAUSE_SIZE (node2) = size_int (0);
4858 125 : if (!openacc
4859 93 : && n->expr->ts.type == BT_CHARACTER
4860 54 : && n->expr->ts.deferred)
4861 : {
4862 54 : gcc_assert (se.string_length);
4863 54 : tree tmp
4864 54 : = gfc_get_char_type (n->expr->ts.kind);
4865 54 : OMP_CLAUSE_SIZE (node)
4866 54 : = fold_build2 (MULT_EXPR, size_type_node,
4867 : fold_convert (size_type_node,
4868 : se.string_length),
4869 : TYPE_SIZE_UNIT (tmp));
4870 54 : gomp_map_kind kind;
4871 54 : if (n->u.map.op == OMP_MAP_DELETE)
4872 : kind = GOMP_MAP_DELETE;
4873 54 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4874 : kind = GOMP_MAP_RELEASE;
4875 : else
4876 48 : kind = GOMP_MAP_TO;
4877 54 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4878 54 : OMP_CLAUSE_SET_MAP_KIND (node3, kind);
4879 54 : OMP_CLAUSE_DECL (node3) = se.string_length;
4880 54 : OMP_CLAUSE_SIZE (node3)
4881 108 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
4882 : }
4883 93 : if (!openacc
4884 93 : && n->expr->ts.type == BT_DERIVED
4885 0 : && n->expr->ts.u.derived->attr.alloc_comp)
4886 : {
4887 : /* Save array descriptor for use in
4888 : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
4889 : to ensure that it is not gimplified + is a decl. */
4890 0 : tree tmp = OMP_CLAUSE_SIZE (node);
4891 0 : if (tmp == NULL_TREE)
4892 0 : tmp = (DECL_P (se.expr)
4893 0 : ? DECL_SIZE_UNIT (se.expr)
4894 0 : : TYPE_SIZE_UNIT (TREE_TYPE (se.expr)));
4895 0 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
4896 0 : gfc_add_modify_loc (input_location, block, var, tmp);
4897 0 : OMP_CLAUSE_SIZE (node) = var;
4898 0 : gfc_allocate_lang_decl (var);
4899 0 : if (TREE_CODE (se.expr) == INDIRECT_REF)
4900 0 : se.expr = TREE_OPERAND (se.expr, 0);
4901 0 : if (DECL_LANG_SPECIFIC (se.expr)
4902 0 : && GFC_DECL_SAVED_DESCRIPTOR (se.expr))
4903 0 : GFC_DECL_SAVED_DESCRIPTOR (var)
4904 0 : = GFC_DECL_SAVED_DESCRIPTOR (se.expr);
4905 : else
4906 0 : GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
4907 : }
4908 : }
4909 : }
4910 2044 : else if (n->expr
4911 2044 : && n->expr->expr_type == EXPR_VARIABLE
4912 2044 : && (n->expr->ref->type == REF_COMPONENT
4913 : || n->expr->ref->type == REF_ARRAY))
4914 : {
4915 2044 : gfc_init_se (&se, NULL);
4916 2044 : se.expr = gfc_maybe_dereference_var (n->sym, decl);
4917 2044 : vec<tree> mid_descr = vNULL;
4918 2044 : vec<gfc_ref *> midref = vNULL;
4919 :
4920 7409 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4921 : {
4922 5365 : if (ref->type == REF_COMPONENT)
4923 : {
4924 2705 : if (ref->u.c.sym->attr.extension)
4925 91 : conv_parent_component_references (&se, ref);
4926 :
4927 2705 : gfc_conv_component_ref (&se, ref);
4928 2705 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
4929 : {
4930 1966 : mid_descr.safe_push (se.expr);
4931 1966 : midref.safe_push (ref);
4932 : }
4933 : }
4934 2660 : else if (ref->type == REF_ARRAY)
4935 : {
4936 2660 : if (ref->u.ar.type == AR_ELEMENT && ref->next)
4937 732 : gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
4938 732 : &n->expr->where);
4939 : else
4940 1928 : gcc_assert (!ref->next);
4941 : }
4942 : else
4943 0 : sorry_at (gfc_get_location (&n->where),
4944 : "unhandled expression type");
4945 : }
4946 :
4947 2044 : tree inner = se.expr;
4948 :
4949 : /* Last component is a derived type or class pointer. */
4950 2044 : if (lastref->type == REF_COMPONENT
4951 116 : && (lastref->u.c.component->ts.type == BT_DERIVED
4952 24 : || lastref->u.c.component->ts.type == BT_CLASS))
4953 : {
4954 116 : if (pointer || allocatable)
4955 : {
4956 : /* If it's a bare attach/detach clause, we just want
4957 : to perform a single attach/detach operation, of the
4958 : pointer itself, not of the pointed-to object. */
4959 67 : if (openacc
4960 49 : && (n->u.map.op == OMP_MAP_ATTACH
4961 43 : || n->u.map.op == OMP_MAP_DETACH))
4962 : {
4963 12 : OMP_CLAUSE_DECL (node)
4964 12 : = build_fold_addr_expr (inner);
4965 12 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4966 18 : goto finalize_map_clause;
4967 : }
4968 :
4969 18 : gfc_omp_namelist *n2
4970 : = openacc ? NULL : clauses->lists[OMP_LIST_MAP];
4971 :
4972 55 : bool sym_based;
4973 55 : n2 = get_symbol_rooted_namelist (sym_rooted_nl, n,
4974 : n2, &sym_based);
4975 :
4976 : /* If the last reference is a pointer to a derived
4977 : type ("foo%dt_ptr"), check if any subcomponents
4978 : of the same derived type member are being mapped
4979 : elsewhere in the clause list ("foo%dt_ptr%x",
4980 : etc.). If we have such subcomponent mappings,
4981 : we only create an ALLOC node for the pointer
4982 : itself, and inhibit mapping the whole derived
4983 : type. */
4984 :
4985 103 : for (; n2 != NULL; n2 = n2->next)
4986 : {
4987 54 : if ((!sym_based && n == n2)
4988 54 : || (sym_based && n == n2->u2.duplicate_of)
4989 42 : || !n2->expr)
4990 12 : continue;
4991 :
4992 42 : if (!gfc_omp_expr_prefix_same (n->expr,
4993 : n2->expr))
4994 36 : continue;
4995 :
4996 6 : gfc_ref *ref1 = n->expr->ref;
4997 6 : gfc_ref *ref2 = n2->expr->ref;
4998 :
4999 6 : while (ref1->next && ref2->next)
5000 : {
5001 : ref1 = ref1->next;
5002 : ref2 = ref2->next;
5003 : }
5004 :
5005 6 : if (ref2->next)
5006 : {
5007 6 : inner = build_fold_addr_expr (inner);
5008 6 : OMP_CLAUSE_SET_MAP_KIND (node,
5009 : GOMP_MAP_ALLOC);
5010 6 : OMP_CLAUSE_DECL (node) = inner;
5011 6 : OMP_CLAUSE_SIZE (node)
5012 6 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
5013 6 : goto finalize_map_clause;
5014 : }
5015 : }
5016 :
5017 49 : tree data, size;
5018 :
5019 49 : if (lastref->u.c.component->ts.type == BT_CLASS)
5020 : {
5021 24 : data = gfc_class_data_get (inner);
5022 24 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
5023 24 : data = build_fold_indirect_ref (data);
5024 24 : size = gfc_class_vtab_size_get (inner);
5025 : }
5026 : else /* BT_DERIVED. */
5027 : {
5028 25 : data = inner;
5029 25 : size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
5030 : }
5031 :
5032 49 : OMP_CLAUSE_DECL (node) = data;
5033 49 : OMP_CLAUSE_SIZE (node) = size;
5034 49 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
5035 49 : OMP_CLAUSE_SET_MAP_KIND (node2,
5036 : GOMP_MAP_ATTACH_DETACH);
5037 49 : OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
5038 49 : OMP_CLAUSE_SIZE (node2) = size_int (0);
5039 : }
5040 : else
5041 : {
5042 49 : OMP_CLAUSE_DECL (node) = inner;
5043 49 : OMP_CLAUSE_SIZE (node)
5044 98 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
5045 : }
5046 98 : if (!openacc
5047 14 : && n->expr->ts.type == BT_DERIVED
5048 14 : && n->expr->ts.u.derived->attr.alloc_comp)
5049 : {
5050 : /* Save array descriptor for use in
5051 : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
5052 : to ensure that it is not gimplified + is a decl. */
5053 8 : tree tmp = OMP_CLAUSE_SIZE (node);
5054 8 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
5055 8 : gfc_add_modify_loc (input_location, block, var, tmp);
5056 8 : OMP_CLAUSE_SIZE (node) = var;
5057 8 : gfc_allocate_lang_decl (var);
5058 8 : if (TREE_CODE (inner) == INDIRECT_REF)
5059 6 : inner = TREE_OPERAND (inner, 0);
5060 8 : GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
5061 : }
5062 : }
5063 1928 : else if (lastref->type == REF_ARRAY
5064 1928 : && lastref->u.ar.type == AR_FULL)
5065 : {
5066 : /* Bare attach and detach clauses don't want any
5067 : additional nodes. */
5068 1234 : if ((n->u.map.op == OMP_MAP_ATTACH
5069 1203 : || n->u.map.op == OMP_MAP_DETACH)
5070 1248 : && (POINTER_TYPE_P (TREE_TYPE (inner))
5071 45 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))))
5072 : {
5073 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
5074 : {
5075 45 : tree ptr = gfc_conv_descriptor_data_get (inner);
5076 45 : OMP_CLAUSE_DECL (node) = ptr;
5077 : }
5078 : else
5079 0 : OMP_CLAUSE_DECL (node) = inner;
5080 45 : OMP_CLAUSE_SIZE (node) = size_zero_node;
5081 45 : goto finalize_map_clause;
5082 : }
5083 :
5084 1189 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
5085 : {
5086 1019 : bool drop_mapping = gfc_map_array_descriptor (
5087 : node, node2, node3, node4, inner, openacc, map_loc,
5088 : block, op, n, sym_rooted_nl, se, clauses, false);
5089 1019 : if (drop_mapping)
5090 286 : continue;
5091 : }
5092 : else
5093 170 : OMP_CLAUSE_DECL (node) = inner;
5094 : }
5095 694 : else if (lastref->type == REF_ARRAY)
5096 : {
5097 : /* An array element or section. */
5098 694 : bool element = lastref->u.ar.type == AR_ELEMENT;
5099 694 : gomp_map_kind kind = GOMP_MAP_ATTACH_DETACH;
5100 694 : gfc_trans_omp_array_section (block, op, n, inner, element,
5101 694 : !openacc, kind, node, node2,
5102 : node3, node4);
5103 : }
5104 : else
5105 0 : gcc_unreachable ();
5106 :
5107 : /* Map intermediate array descriptors. */
5108 1611 : if (!openacc && !mid_descr.is_empty ())
5109 2255 : for (size_t i = 0; i < mid_descr.length (); i++)
5110 1300 : if (mid_descr[i] != inner
5111 1300 : && !descriptors.contains (midref[i]->u.c.sym))
5112 : {
5113 172 : descriptors.safe_push (midref[i]->u.c.sym);
5114 172 : tree node1 = copy_node (node);
5115 172 : tree node2 = NULL_TREE;
5116 172 : tree node3 = NULL_TREE;
5117 172 : tree node4 = NULL_TREE;
5118 344 : gfc_map_array_descriptor (node1, node2, node3, node4,
5119 172 : mid_descr[i], openacc,
5120 : map_loc, block, op, n,
5121 : sym_rooted_nl, se, clauses,
5122 : true);
5123 :
5124 172 : if (node1 != NULL_TREE)
5125 90 : omp_clauses
5126 90 : = gfc_trans_add_clause (node1, omp_clauses);
5127 172 : if (node2 != NULL_TREE)
5128 172 : omp_clauses
5129 172 : = gfc_trans_add_clause (node2, omp_clauses);
5130 172 : if (node3 != NULL_TREE)
5131 172 : omp_clauses
5132 172 : = gfc_trans_add_clause (node3, omp_clauses);
5133 172 : if (node4 != NULL_TREE)
5134 0 : omp_clauses
5135 0 : = gfc_trans_add_clause (node4, omp_clauses);
5136 : }
5137 1695 : }
5138 : else
5139 0 : sorry_at (gfc_get_location (&n->where), "unhandled expression");
5140 :
5141 15005 : finalize_map_clause:
5142 :
5143 15005 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
5144 15005 : if (node2)
5145 5089 : omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
5146 15005 : if (node3)
5147 6294 : omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
5148 15005 : if (node4)
5149 3500 : omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
5150 15005 : if (node5)
5151 4 : omp_clauses = gfc_trans_add_clause (node5, omp_clauses);
5152 : }
5153 : break;
5154 : case OMP_LIST_TO:
5155 : case OMP_LIST_FROM:
5156 : case OMP_LIST_CACHE:
5157 3637 : for (; n != NULL; n = n->next)
5158 : {
5159 1862 : if (!n->sym->attr.referenced
5160 0 : && n->sym->attr.flavor != FL_PARAMETER)
5161 0 : continue;
5162 :
5163 1862 : switch (list)
5164 : {
5165 : case OMP_LIST_TO:
5166 : clause_code = OMP_CLAUSE_TO;
5167 : break;
5168 1030 : case OMP_LIST_FROM:
5169 1030 : clause_code = OMP_CLAUSE_FROM;
5170 1030 : break;
5171 84 : case OMP_LIST_CACHE:
5172 84 : clause_code = OMP_CLAUSE__CACHE_;
5173 84 : break;
5174 0 : default:
5175 0 : gcc_unreachable ();
5176 : }
5177 1862 : tree node = build_omp_clause (gfc_get_location (&n->where),
5178 : clause_code);
5179 1862 : if (n->expr == NULL
5180 128 : || (n->expr->ref->type == REF_ARRAY
5181 116 : && n->expr->ref->u.ar.type == AR_FULL
5182 0 : && n->expr->ref->next == NULL))
5183 : {
5184 1734 : tree decl = gfc_trans_omp_variable (n->sym, false);
5185 1734 : if (gfc_omp_privatize_by_reference (decl))
5186 : {
5187 1047 : if (gfc_omp_is_allocatable_or_ptr (decl))
5188 240 : decl = build_fold_indirect_ref (decl);
5189 1047 : decl = build_fold_indirect_ref (decl);
5190 : }
5191 687 : else if (DECL_P (decl))
5192 687 : TREE_ADDRESSABLE (decl) = 1;
5193 1734 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5194 : {
5195 597 : tree type = TREE_TYPE (decl);
5196 597 : tree ptr = gfc_conv_descriptor_data_get (decl);
5197 597 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
5198 597 : ptr = build_fold_indirect_ref (ptr);
5199 597 : OMP_CLAUSE_DECL (node) = ptr;
5200 597 : OMP_CLAUSE_SIZE (node)
5201 597 : = gfc_full_array_size (block, decl,
5202 597 : GFC_TYPE_ARRAY_RANK (type));
5203 597 : tree elemsz
5204 597 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5205 597 : elemsz = fold_convert (gfc_array_index_type, elemsz);
5206 1194 : OMP_CLAUSE_SIZE (node)
5207 1194 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
5208 : OMP_CLAUSE_SIZE (node), elemsz);
5209 : }
5210 : else
5211 : {
5212 1137 : OMP_CLAUSE_DECL (node) = decl;
5213 1137 : if (gfc_omp_is_allocatable_or_ptr (decl))
5214 120 : OMP_CLAUSE_SIZE (node)
5215 240 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl)));
5216 : }
5217 : }
5218 : else
5219 : {
5220 128 : tree ptr;
5221 128 : gfc_init_se (&se, NULL);
5222 128 : if (n->expr->rank == 0)
5223 : {
5224 5 : gfc_conv_expr_reference (&se, n->expr);
5225 5 : ptr = se.expr;
5226 5 : gfc_add_block_to_block (block, &se.pre);
5227 5 : OMP_CLAUSE_SIZE (node)
5228 10 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
5229 : }
5230 : else
5231 : {
5232 123 : gfc_conv_expr_descriptor (&se, n->expr);
5233 123 : ptr = gfc_conv_array_data (se.expr);
5234 123 : tree type = TREE_TYPE (se.expr);
5235 123 : gfc_add_block_to_block (block, &se.pre);
5236 123 : OMP_CLAUSE_SIZE (node)
5237 123 : = gfc_full_array_size (block, se.expr,
5238 123 : GFC_TYPE_ARRAY_RANK (type));
5239 123 : tree elemsz
5240 123 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5241 123 : elemsz = fold_convert (gfc_array_index_type, elemsz);
5242 246 : OMP_CLAUSE_SIZE (node)
5243 246 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
5244 : OMP_CLAUSE_SIZE (node), elemsz);
5245 : }
5246 128 : gfc_add_block_to_block (block, &se.post);
5247 128 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
5248 128 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
5249 : }
5250 1862 : if (n->u.present_modifier)
5251 5 : OMP_CLAUSE_MOTION_PRESENT (node) = 1;
5252 1862 : if (list == OMP_LIST_CACHE && n->u.map.readonly)
5253 16 : OMP_CLAUSE__CACHE__READONLY (node) = 1;
5254 1862 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
5255 : }
5256 : break;
5257 : case OMP_LIST_USES_ALLOCATORS:
5258 : /* Ignore omp_null_allocator and pre-defined allocators as no
5259 : special treatment is needed. */
5260 37 : for (; n != NULL; n = n->next)
5261 34 : if (n->sym->attr.flavor == FL_VARIABLE)
5262 : break;
5263 17 : if (n != NULL)
5264 14 : sorry_at (input_location, "%<uses_allocators%> clause with traits "
5265 : "and memory spaces");
5266 : break;
5267 : default:
5268 : break;
5269 : }
5270 : }
5271 :
5272 : /* Free hashmap if we built it. */
5273 31735 : if (sym_rooted_nl)
5274 : {
5275 388 : typedef hash_map<gfc_symbol *, gfc_omp_namelist *>::iterator hti;
5276 1278 : for (hti it = sym_rooted_nl->begin (); it != sym_rooted_nl->end (); ++it)
5277 : {
5278 445 : gfc_omp_namelist *&nl = (*it).second;
5279 1771 : while (nl)
5280 : {
5281 1326 : gfc_omp_namelist *next = nl->next;
5282 1326 : free (nl);
5283 1326 : nl = next;
5284 : }
5285 : }
5286 388 : delete sym_rooted_nl;
5287 : }
5288 :
5289 31735 : if (clauses->if_expr)
5290 : {
5291 1112 : tree if_var;
5292 :
5293 1112 : gfc_init_se (&se, NULL);
5294 1112 : gfc_conv_expr (&se, clauses->if_expr);
5295 1112 : gfc_add_block_to_block (block, &se.pre);
5296 1112 : if_var = gfc_evaluate_now (se.expr, block);
5297 1112 : gfc_add_block_to_block (block, &se.post);
5298 :
5299 1112 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
5300 1112 : OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
5301 1112 : OMP_CLAUSE_IF_EXPR (c) = if_var;
5302 1112 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5303 : }
5304 :
5305 349085 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
5306 317350 : if (clauses->if_exprs[ifc])
5307 : {
5308 123 : tree if_var;
5309 :
5310 123 : gfc_init_se (&se, NULL);
5311 123 : gfc_conv_expr (&se, clauses->if_exprs[ifc]);
5312 123 : gfc_add_block_to_block (block, &se.pre);
5313 123 : if_var = gfc_evaluate_now (se.expr, block);
5314 123 : gfc_add_block_to_block (block, &se.post);
5315 :
5316 123 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
5317 123 : switch (ifc)
5318 : {
5319 0 : case OMP_IF_CANCEL:
5320 0 : OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST;
5321 0 : break;
5322 40 : case OMP_IF_PARALLEL:
5323 40 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
5324 40 : break;
5325 39 : case OMP_IF_SIMD:
5326 39 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD;
5327 39 : break;
5328 1 : case OMP_IF_TASK:
5329 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
5330 1 : break;
5331 23 : case OMP_IF_TASKLOOP:
5332 23 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
5333 23 : break;
5334 16 : case OMP_IF_TARGET:
5335 16 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
5336 16 : break;
5337 1 : case OMP_IF_TARGET_DATA:
5338 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
5339 1 : break;
5340 1 : case OMP_IF_TARGET_UPDATE:
5341 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
5342 1 : break;
5343 1 : case OMP_IF_TARGET_ENTER_DATA:
5344 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
5345 1 : break;
5346 1 : case OMP_IF_TARGET_EXIT_DATA:
5347 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
5348 1 : break;
5349 : default:
5350 : gcc_unreachable ();
5351 : }
5352 123 : OMP_CLAUSE_IF_EXPR (c) = if_var;
5353 123 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5354 : }
5355 :
5356 31735 : if (clauses->self_expr)
5357 : {
5358 159 : tree self_var;
5359 :
5360 159 : gfc_init_se (&se, NULL);
5361 159 : gfc_conv_expr (&se, clauses->self_expr);
5362 159 : gfc_add_block_to_block (block, &se.pre);
5363 159 : self_var = gfc_evaluate_now (se.expr, block);
5364 159 : gfc_add_block_to_block (block, &se.post);
5365 :
5366 159 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SELF);
5367 159 : OMP_CLAUSE_SELF_EXPR (c) = self_var;
5368 159 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5369 : }
5370 :
5371 31735 : if (clauses->final_expr)
5372 : {
5373 64 : tree final_var;
5374 :
5375 64 : gfc_init_se (&se, NULL);
5376 64 : gfc_conv_expr (&se, clauses->final_expr);
5377 64 : gfc_add_block_to_block (block, &se.pre);
5378 64 : final_var = gfc_evaluate_now (se.expr, block);
5379 64 : gfc_add_block_to_block (block, &se.post);
5380 :
5381 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL);
5382 64 : OMP_CLAUSE_FINAL_EXPR (c) = final_var;
5383 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5384 : }
5385 :
5386 31735 : if (clauses->novariants)
5387 : {
5388 8 : tree novariants_var;
5389 :
5390 8 : gfc_init_se (&se, NULL);
5391 8 : gfc_conv_expr (&se, clauses->novariants);
5392 8 : gfc_add_block_to_block (block, &se.pre);
5393 8 : novariants_var = gfc_evaluate_now (se.expr, block);
5394 8 : gfc_add_block_to_block (block, &se.post);
5395 :
5396 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS);
5397 8 : OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var;
5398 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5399 : }
5400 :
5401 31735 : if (clauses->nocontext)
5402 : {
5403 9 : tree nocontext_var;
5404 :
5405 9 : gfc_init_se (&se, NULL);
5406 9 : gfc_conv_expr (&se, clauses->nocontext);
5407 9 : gfc_add_block_to_block (block, &se.pre);
5408 9 : nocontext_var = gfc_evaluate_now (se.expr, block);
5409 9 : gfc_add_block_to_block (block, &se.post);
5410 :
5411 9 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT);
5412 9 : OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var;
5413 9 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5414 : }
5415 :
5416 31735 : if (clauses->num_threads)
5417 : {
5418 955 : tree num_threads;
5419 :
5420 955 : gfc_init_se (&se, NULL);
5421 955 : gfc_conv_expr (&se, clauses->num_threads);
5422 955 : gfc_add_block_to_block (block, &se.pre);
5423 955 : num_threads = gfc_evaluate_now (se.expr, block);
5424 955 : gfc_add_block_to_block (block, &se.post);
5425 :
5426 955 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS);
5427 955 : OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
5428 955 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5429 : }
5430 :
5431 31735 : if (clauses->device_type != OMP_DEVICE_TYPE_UNSET)
5432 : {
5433 3 : enum omp_clause_device_type_kind type;
5434 3 : switch (clauses->device_type)
5435 : {
5436 : case OMP_DEVICE_TYPE_HOST:
5437 : type = OMP_CLAUSE_DEVICE_TYPE_HOST;
5438 : break;
5439 : case OMP_DEVICE_TYPE_NOHOST:
5440 : type = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
5441 : break;
5442 : case OMP_DEVICE_TYPE_ANY:
5443 : type = OMP_CLAUSE_DEVICE_TYPE_ANY;
5444 : break;
5445 0 : case OMP_DEVICE_TYPE_UNSET:
5446 0 : default:
5447 0 : gcc_unreachable ();
5448 : }
5449 3 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE_TYPE);
5450 3 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = type;
5451 3 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5452 : }
5453 :
5454 31735 : if (clauses->dyn_groupprivate)
5455 : {
5456 5 : gfc_init_se (&se, NULL);
5457 5 : gfc_conv_expr (&se, clauses->dyn_groupprivate);
5458 5 : gfc_add_block_to_block (block, &se.pre);
5459 5 : tree expr = (CONSTANT_CLASS_P (se.expr) || DECL_P (se.expr)
5460 5 : ? se.expr : gfc_evaluate_now (se.expr, block));
5461 5 : gfc_add_block_to_block (block, &se.post);
5462 :
5463 5 : enum omp_clause_fallback_kind kind = OMP_CLAUSE_FALLBACK_UNSPECIFIED;
5464 5 : switch (clauses->fallback)
5465 : {
5466 : case OMP_FALLBACK_ABORT:
5467 : kind = OMP_CLAUSE_FALLBACK_ABORT;
5468 : break;
5469 : case OMP_FALLBACK_DEFAULT_MEM:
5470 : kind = OMP_CLAUSE_FALLBACK_DEFAULT_MEM;
5471 : break;
5472 : case OMP_FALLBACK_NULL:
5473 : kind = OMP_CLAUSE_FALLBACK_NULL;
5474 : break;
5475 : case OMP_FALLBACK_NONE:
5476 : break;
5477 : }
5478 5 : c = build_omp_clause (gfc_get_location (&where),
5479 : OMP_CLAUSE_DYN_GROUPPRIVATE);
5480 5 : OMP_CLAUSE_DYN_GROUPPRIVATE_KIND (c) = kind;
5481 5 : OMP_CLAUSE_DYN_GROUPPRIVATE_EXPR (c) = expr;
5482 5 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5483 : }
5484 :
5485 31735 : chunk_size = NULL_TREE;
5486 31735 : if (clauses->chunk_size)
5487 : {
5488 493 : gfc_init_se (&se, NULL);
5489 493 : gfc_conv_expr (&se, clauses->chunk_size);
5490 493 : gfc_add_block_to_block (block, &se.pre);
5491 493 : chunk_size = gfc_evaluate_now (se.expr, block);
5492 493 : gfc_add_block_to_block (block, &se.post);
5493 : }
5494 :
5495 31735 : if (clauses->sched_kind != OMP_SCHED_NONE)
5496 : {
5497 782 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE);
5498 782 : OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
5499 782 : switch (clauses->sched_kind)
5500 : {
5501 407 : case OMP_SCHED_STATIC:
5502 407 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
5503 407 : break;
5504 159 : case OMP_SCHED_DYNAMIC:
5505 159 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
5506 159 : break;
5507 125 : case OMP_SCHED_GUIDED:
5508 125 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
5509 125 : break;
5510 84 : case OMP_SCHED_RUNTIME:
5511 84 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
5512 84 : break;
5513 7 : case OMP_SCHED_AUTO:
5514 7 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
5515 7 : break;
5516 0 : default:
5517 0 : gcc_unreachable ();
5518 : }
5519 782 : if (clauses->sched_monotonic)
5520 54 : OMP_CLAUSE_SCHEDULE_KIND (c)
5521 27 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
5522 : | OMP_CLAUSE_SCHEDULE_MONOTONIC);
5523 755 : else if (clauses->sched_nonmonotonic)
5524 46 : OMP_CLAUSE_SCHEDULE_KIND (c)
5525 23 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
5526 : | OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
5527 782 : if (clauses->sched_simd)
5528 17 : OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
5529 782 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5530 : }
5531 :
5532 31735 : if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
5533 : {
5534 1087 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT);
5535 1087 : switch (clauses->default_sharing)
5536 : {
5537 677 : case OMP_DEFAULT_NONE:
5538 677 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
5539 677 : break;
5540 183 : case OMP_DEFAULT_SHARED:
5541 183 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
5542 183 : break;
5543 24 : case OMP_DEFAULT_PRIVATE:
5544 24 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
5545 24 : break;
5546 8 : case OMP_DEFAULT_FIRSTPRIVATE:
5547 8 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
5548 8 : break;
5549 195 : case OMP_DEFAULT_PRESENT:
5550 195 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
5551 195 : break;
5552 0 : default:
5553 0 : gcc_unreachable ();
5554 : }
5555 1087 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5556 : }
5557 :
5558 31735 : if (clauses->nowait)
5559 : {
5560 2068 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT);
5561 2068 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5562 : }
5563 :
5564 31735 : if (clauses->full)
5565 : {
5566 47 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FULL);
5567 47 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5568 : }
5569 :
5570 31735 : if (clauses->partial)
5571 : {
5572 259 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARTIAL);
5573 259 : OMP_CLAUSE_PARTIAL_EXPR (c)
5574 518 : = (clauses->partial > 0
5575 259 : ? build_int_cst (integer_type_node, clauses->partial)
5576 : : NULL_TREE);
5577 259 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5578 : }
5579 :
5580 31735 : if (clauses->sizes_list)
5581 : {
5582 : tree list = NULL_TREE;
5583 344 : for (gfc_expr_list *el = clauses->sizes_list; el; el = el->next)
5584 224 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
5585 : list);
5586 :
5587 120 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIZES);
5588 120 : OMP_CLAUSE_SIZES_LIST (c) = nreverse (list);
5589 120 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5590 : }
5591 :
5592 31735 : if (clauses->ordered)
5593 : {
5594 315 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED);
5595 315 : OMP_CLAUSE_ORDERED_EXPR (c)
5596 315 : = clauses->orderedc ? build_int_cst (integer_type_node,
5597 134 : clauses->orderedc) : NULL_TREE;
5598 315 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5599 : }
5600 :
5601 31735 : if (clauses->order_concurrent)
5602 : {
5603 303 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER);
5604 303 : OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained;
5605 303 : OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible;
5606 303 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5607 : }
5608 :
5609 31735 : if (clauses->untied)
5610 : {
5611 141 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED);
5612 141 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5613 : }
5614 :
5615 31735 : if (clauses->mergeable)
5616 : {
5617 32 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE);
5618 32 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5619 : }
5620 :
5621 31735 : if (clauses->collapse)
5622 : {
5623 1646 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE);
5624 1646 : OMP_CLAUSE_COLLAPSE_EXPR (c)
5625 1646 : = build_int_cst (integer_type_node, clauses->collapse);
5626 1646 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5627 : }
5628 :
5629 31735 : if (clauses->inbranch)
5630 : {
5631 18 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH);
5632 18 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5633 : }
5634 :
5635 31735 : if (clauses->notinbranch)
5636 : {
5637 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH);
5638 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5639 : }
5640 :
5641 31735 : switch (clauses->cancel)
5642 : {
5643 : case OMP_CANCEL_UNKNOWN:
5644 : break;
5645 0 : case OMP_CANCEL_PARALLEL:
5646 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL);
5647 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5648 0 : break;
5649 0 : case OMP_CANCEL_SECTIONS:
5650 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS);
5651 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5652 0 : break;
5653 0 : case OMP_CANCEL_DO:
5654 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR);
5655 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5656 0 : break;
5657 0 : case OMP_CANCEL_TASKGROUP:
5658 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP);
5659 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5660 0 : break;
5661 : }
5662 :
5663 31735 : if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
5664 : {
5665 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND);
5666 64 : switch (clauses->proc_bind)
5667 : {
5668 1 : case OMP_PROC_BIND_PRIMARY:
5669 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY;
5670 1 : break;
5671 9 : case OMP_PROC_BIND_MASTER:
5672 9 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
5673 9 : break;
5674 53 : case OMP_PROC_BIND_SPREAD:
5675 53 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
5676 53 : break;
5677 1 : case OMP_PROC_BIND_CLOSE:
5678 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
5679 1 : break;
5680 0 : default:
5681 0 : gcc_unreachable ();
5682 : }
5683 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5684 : }
5685 :
5686 31735 : if (clauses->safelen_expr)
5687 : {
5688 89 : tree safelen_var;
5689 :
5690 89 : gfc_init_se (&se, NULL);
5691 89 : gfc_conv_expr (&se, clauses->safelen_expr);
5692 89 : gfc_add_block_to_block (block, &se.pre);
5693 89 : safelen_var = gfc_evaluate_now (se.expr, block);
5694 89 : gfc_add_block_to_block (block, &se.post);
5695 :
5696 89 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN);
5697 89 : OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
5698 89 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5699 : }
5700 :
5701 31735 : if (clauses->simdlen_expr)
5702 : {
5703 110 : if (declare_simd)
5704 : {
5705 65 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
5706 65 : OMP_CLAUSE_SIMDLEN_EXPR (c)
5707 65 : = gfc_conv_constant_to_tree (clauses->simdlen_expr);
5708 65 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5709 : }
5710 : else
5711 : {
5712 45 : tree simdlen_var;
5713 :
5714 45 : gfc_init_se (&se, NULL);
5715 45 : gfc_conv_expr (&se, clauses->simdlen_expr);
5716 45 : gfc_add_block_to_block (block, &se.pre);
5717 45 : simdlen_var = gfc_evaluate_now (se.expr, block);
5718 45 : gfc_add_block_to_block (block, &se.post);
5719 :
5720 45 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
5721 45 : OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var;
5722 45 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5723 : }
5724 : }
5725 :
5726 31735 : if (clauses->num_teams_upper)
5727 : {
5728 111 : tree num_teams_lower = NULL_TREE, num_teams_upper;
5729 :
5730 111 : gfc_init_se (&se, NULL);
5731 111 : gfc_conv_expr (&se, clauses->num_teams_upper);
5732 111 : gfc_add_block_to_block (block, &se.pre);
5733 111 : num_teams_upper = gfc_evaluate_now (se.expr, block);
5734 111 : gfc_add_block_to_block (block, &se.post);
5735 :
5736 111 : if (clauses->num_teams_lower)
5737 : {
5738 21 : gfc_init_se (&se, NULL);
5739 21 : gfc_conv_expr (&se, clauses->num_teams_lower);
5740 21 : gfc_add_block_to_block (block, &se.pre);
5741 21 : num_teams_lower = gfc_evaluate_now (se.expr, block);
5742 21 : gfc_add_block_to_block (block, &se.post);
5743 : }
5744 111 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
5745 111 : OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
5746 111 : OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
5747 111 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5748 : }
5749 :
5750 31735 : if (clauses->device)
5751 : {
5752 295 : tree device;
5753 :
5754 295 : gfc_init_se (&se, NULL);
5755 295 : gfc_conv_expr (&se, clauses->device);
5756 295 : gfc_add_block_to_block (block, &se.pre);
5757 295 : device = gfc_evaluate_now (se.expr, block);
5758 295 : gfc_add_block_to_block (block, &se.post);
5759 :
5760 295 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE);
5761 295 : OMP_CLAUSE_DEVICE_ID (c) = device;
5762 :
5763 295 : if (clauses->ancestor)
5764 39 : OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1;
5765 :
5766 295 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5767 : }
5768 :
5769 31735 : if (clauses->thread_limit)
5770 : {
5771 105 : tree thread_limit;
5772 :
5773 105 : gfc_init_se (&se, NULL);
5774 105 : gfc_conv_expr (&se, clauses->thread_limit);
5775 105 : gfc_add_block_to_block (block, &se.pre);
5776 105 : thread_limit = gfc_evaluate_now (se.expr, block);
5777 105 : gfc_add_block_to_block (block, &se.post);
5778 :
5779 105 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT);
5780 105 : OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
5781 105 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5782 : }
5783 :
5784 31735 : chunk_size = NULL_TREE;
5785 31735 : if (clauses->dist_chunk_size)
5786 : {
5787 81 : gfc_init_se (&se, NULL);
5788 81 : gfc_conv_expr (&se, clauses->dist_chunk_size);
5789 81 : gfc_add_block_to_block (block, &se.pre);
5790 81 : chunk_size = gfc_evaluate_now (se.expr, block);
5791 81 : gfc_add_block_to_block (block, &se.post);
5792 : }
5793 :
5794 31735 : if (clauses->dist_sched_kind != OMP_SCHED_NONE)
5795 : {
5796 94 : c = build_omp_clause (gfc_get_location (&where),
5797 : OMP_CLAUSE_DIST_SCHEDULE);
5798 94 : OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
5799 94 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5800 : }
5801 :
5802 31735 : if (clauses->grainsize)
5803 : {
5804 33 : tree grainsize;
5805 :
5806 33 : gfc_init_se (&se, NULL);
5807 33 : gfc_conv_expr (&se, clauses->grainsize);
5808 33 : gfc_add_block_to_block (block, &se.pre);
5809 33 : grainsize = gfc_evaluate_now (se.expr, block);
5810 33 : gfc_add_block_to_block (block, &se.post);
5811 :
5812 33 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE);
5813 33 : OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
5814 33 : if (clauses->grainsize_strict)
5815 1 : OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1;
5816 33 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5817 : }
5818 :
5819 31735 : if (clauses->num_tasks)
5820 : {
5821 25 : tree num_tasks;
5822 :
5823 25 : gfc_init_se (&se, NULL);
5824 25 : gfc_conv_expr (&se, clauses->num_tasks);
5825 25 : gfc_add_block_to_block (block, &se.pre);
5826 25 : num_tasks = gfc_evaluate_now (se.expr, block);
5827 25 : gfc_add_block_to_block (block, &se.post);
5828 :
5829 25 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS);
5830 25 : OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
5831 25 : if (clauses->num_tasks_strict)
5832 1 : OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1;
5833 25 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5834 : }
5835 :
5836 31735 : if (clauses->priority)
5837 : {
5838 34 : tree priority;
5839 :
5840 34 : gfc_init_se (&se, NULL);
5841 34 : gfc_conv_expr (&se, clauses->priority);
5842 34 : gfc_add_block_to_block (block, &se.pre);
5843 34 : priority = gfc_evaluate_now (se.expr, block);
5844 34 : gfc_add_block_to_block (block, &se.post);
5845 :
5846 34 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY);
5847 34 : OMP_CLAUSE_PRIORITY_EXPR (c) = priority;
5848 34 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5849 : }
5850 :
5851 31735 : if (clauses->detach)
5852 : {
5853 116 : tree detach;
5854 :
5855 116 : gfc_init_se (&se, NULL);
5856 116 : gfc_conv_expr (&se, clauses->detach);
5857 116 : gfc_add_block_to_block (block, &se.pre);
5858 116 : detach = se.expr;
5859 116 : gfc_add_block_to_block (block, &se.post);
5860 :
5861 116 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH);
5862 116 : TREE_ADDRESSABLE (detach) = 1;
5863 116 : OMP_CLAUSE_DECL (c) = detach;
5864 116 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5865 : }
5866 :
5867 31735 : if (clauses->filter)
5868 : {
5869 31 : tree filter;
5870 :
5871 31 : gfc_init_se (&se, NULL);
5872 31 : gfc_conv_expr (&se, clauses->filter);
5873 31 : gfc_add_block_to_block (block, &se.pre);
5874 31 : filter = gfc_evaluate_now (se.expr, block);
5875 31 : gfc_add_block_to_block (block, &se.post);
5876 :
5877 31 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER);
5878 31 : OMP_CLAUSE_FILTER_EXPR (c) = filter;
5879 31 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5880 : }
5881 :
5882 31735 : if (clauses->hint)
5883 : {
5884 8 : tree hint;
5885 :
5886 8 : gfc_init_se (&se, NULL);
5887 8 : gfc_conv_expr (&se, clauses->hint);
5888 8 : gfc_add_block_to_block (block, &se.pre);
5889 8 : hint = gfc_evaluate_now (se.expr, block);
5890 8 : gfc_add_block_to_block (block, &se.post);
5891 :
5892 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT);
5893 8 : OMP_CLAUSE_HINT_EXPR (c) = hint;
5894 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5895 : }
5896 :
5897 31735 : if (clauses->simd)
5898 : {
5899 22 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD);
5900 22 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5901 : }
5902 31735 : if (clauses->threads)
5903 : {
5904 11 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS);
5905 11 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5906 : }
5907 31735 : if (clauses->nogroup)
5908 : {
5909 13 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP);
5910 13 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5911 : }
5912 :
5913 222145 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
5914 : {
5915 190410 : if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
5916 190259 : continue;
5917 151 : enum omp_clause_defaultmap_kind behavior, category;
5918 151 : switch ((gfc_omp_defaultmap_category) i)
5919 : {
5920 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED:
5921 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
5922 : break;
5923 : case OMP_DEFAULTMAP_CAT_ALL:
5924 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALL;
5925 : break;
5926 : case OMP_DEFAULTMAP_CAT_SCALAR:
5927 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR;
5928 : break;
5929 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
5930 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE;
5931 : break;
5932 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
5933 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE;
5934 : break;
5935 : case OMP_DEFAULTMAP_CAT_POINTER:
5936 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER;
5937 : break;
5938 : default: gcc_unreachable ();
5939 : }
5940 151 : switch (clauses->defaultmap[i])
5941 : {
5942 : case OMP_DEFAULTMAP_ALLOC:
5943 : behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC;
5944 : break;
5945 : case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break;
5946 : case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break;
5947 : case OMP_DEFAULTMAP_TOFROM:
5948 : behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM;
5949 : break;
5950 : case OMP_DEFAULTMAP_FIRSTPRIVATE:
5951 : behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
5952 : break;
5953 : case OMP_DEFAULTMAP_PRESENT:
5954 : behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT;
5955 : break;
5956 : case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break;
5957 : case OMP_DEFAULTMAP_DEFAULT:
5958 : behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT;
5959 : break;
5960 0 : default: gcc_unreachable ();
5961 : }
5962 151 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP);
5963 151 : OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category);
5964 151 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5965 : }
5966 :
5967 31735 : if (clauses->doacross_source)
5968 : {
5969 132 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS);
5970 132 : OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE;
5971 132 : OMP_CLAUSE_DOACROSS_DEPEND (c) = clauses->depend_source;
5972 132 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5973 : }
5974 :
5975 31735 : if (clauses->async)
5976 : {
5977 549 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC);
5978 549 : if (clauses->async_expr)
5979 549 : OMP_CLAUSE_ASYNC_EXPR (c)
5980 1098 : = gfc_convert_expr_to_tree (block, clauses->async_expr);
5981 : else
5982 0 : OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
5983 549 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5984 : }
5985 31735 : if (clauses->seq)
5986 : {
5987 140 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ);
5988 140 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5989 : }
5990 31735 : if (clauses->par_auto)
5991 : {
5992 62 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO);
5993 62 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5994 : }
5995 31735 : if (clauses->if_present)
5996 : {
5997 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT);
5998 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5999 : }
6000 31735 : if (clauses->finalize)
6001 : {
6002 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE);
6003 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6004 : }
6005 31735 : if (clauses->independent)
6006 : {
6007 239 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT);
6008 239 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6009 : }
6010 31735 : if (clauses->wait_list)
6011 : {
6012 : gfc_expr_list *el;
6013 :
6014 317 : for (el = clauses->wait_list; el; el = el->next)
6015 : {
6016 172 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT);
6017 172 : OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
6018 172 : OMP_CLAUSE_CHAIN (c) = omp_clauses;
6019 172 : omp_clauses = c;
6020 : }
6021 : }
6022 31735 : if (clauses->num_gangs_expr)
6023 : {
6024 666 : tree num_gangs_var
6025 666 : = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
6026 666 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS);
6027 666 : OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
6028 666 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6029 : }
6030 31735 : if (clauses->num_workers_expr)
6031 : {
6032 583 : tree num_workers_var
6033 583 : = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
6034 583 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS);
6035 583 : OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
6036 583 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6037 : }
6038 31735 : if (clauses->vector_length_expr)
6039 : {
6040 553 : tree vector_length_var
6041 553 : = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
6042 553 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH);
6043 553 : OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
6044 553 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6045 : }
6046 31735 : if (clauses->tile_list)
6047 : {
6048 : tree list = NULL_TREE;
6049 174 : for (gfc_expr_list *el = clauses->tile_list; el; el = el->next)
6050 114 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
6051 : list);
6052 :
6053 60 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE);
6054 60 : OMP_CLAUSE_TILE_LIST (c) = nreverse (list);
6055 60 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6056 : }
6057 31735 : if (clauses->vector)
6058 : {
6059 835 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR);
6060 835 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6061 :
6062 835 : if (clauses->vector_expr)
6063 : {
6064 119 : tree vector_var
6065 119 : = gfc_convert_expr_to_tree (block, clauses->vector_expr);
6066 119 : OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
6067 :
6068 : /* TODO: We're not capturing location information for individual
6069 : clauses. However, if we have an expression attached to the
6070 : clause, that one provides better location information. */
6071 238 : OMP_CLAUSE_LOCATION (c)
6072 119 : = gfc_get_location (&clauses->vector_expr->where);
6073 : }
6074 : }
6075 31735 : if (clauses->worker)
6076 : {
6077 730 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER);
6078 730 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6079 :
6080 730 : if (clauses->worker_expr)
6081 : {
6082 89 : tree worker_var
6083 89 : = gfc_convert_expr_to_tree (block, clauses->worker_expr);
6084 89 : OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
6085 :
6086 : /* TODO: We're not capturing location information for individual
6087 : clauses. However, if we have an expression attached to the
6088 : clause, that one provides better location information. */
6089 178 : OMP_CLAUSE_LOCATION (c)
6090 89 : = gfc_get_location (&clauses->worker_expr->where);
6091 : }
6092 : }
6093 31735 : if (clauses->gang)
6094 : {
6095 1011 : tree arg;
6096 1011 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG);
6097 1011 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6098 :
6099 1011 : if (clauses->gang_num_expr)
6100 : {
6101 101 : arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
6102 101 : OMP_CLAUSE_GANG_EXPR (c) = arg;
6103 :
6104 : /* TODO: We're not capturing location information for individual
6105 : clauses. However, if we have an expression attached to the
6106 : clause, that one provides better location information. */
6107 202 : OMP_CLAUSE_LOCATION (c)
6108 101 : = gfc_get_location (&clauses->gang_num_expr->where);
6109 : }
6110 :
6111 1011 : if (clauses->gang_static)
6112 : {
6113 15 : arg = clauses->gang_static_expr
6114 104 : ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
6115 : : integer_minus_one_node;
6116 104 : OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
6117 : }
6118 : }
6119 31735 : if (clauses->bind != OMP_BIND_UNSET)
6120 : {
6121 30 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND);
6122 30 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6123 30 : switch (clauses->bind)
6124 : {
6125 10 : case OMP_BIND_TEAMS:
6126 10 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS;
6127 10 : break;
6128 15 : case OMP_BIND_PARALLEL:
6129 15 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL;
6130 15 : break;
6131 5 : case OMP_BIND_THREAD:
6132 5 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD;
6133 5 : break;
6134 0 : default:
6135 0 : gcc_unreachable ();
6136 : }
6137 : }
6138 : /* OpenACC 'nohost' clauses cannot appear here. */
6139 31735 : gcc_checking_assert (!clauses->nohost);
6140 :
6141 31735 : return nreverse (omp_clauses);
6142 : }
6143 :
6144 : /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
6145 :
6146 : static tree
6147 21083 : gfc_trans_omp_code (gfc_code *code, bool force_empty)
6148 : {
6149 21083 : tree stmt;
6150 :
6151 21083 : pushlevel ();
6152 21083 : stmt = gfc_trans_code (code);
6153 21083 : if (TREE_CODE (stmt) != BIND_EXPR)
6154 : {
6155 18822 : if (!IS_EMPTY_STMT (stmt) || force_empty)
6156 : {
6157 18732 : tree block = poplevel (1, 0);
6158 18732 : stmt = build3_v (BIND_EXPR, NULL, stmt, block);
6159 : }
6160 : else
6161 90 : poplevel (0, 0);
6162 : }
6163 : else
6164 2261 : poplevel (0, 0);
6165 21083 : return stmt;
6166 : }
6167 :
6168 : /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
6169 : construct. */
6170 :
6171 : static tree
6172 4189 : gfc_trans_oacc_construct (gfc_code *code)
6173 : {
6174 4189 : stmtblock_t block;
6175 4189 : tree stmt, oacc_clauses;
6176 4189 : enum tree_code construct_code;
6177 :
6178 4189 : switch (code->op)
6179 : {
6180 : case EXEC_OACC_PARALLEL:
6181 : construct_code = OACC_PARALLEL;
6182 : break;
6183 : case EXEC_OACC_KERNELS:
6184 : construct_code = OACC_KERNELS;
6185 : break;
6186 : case EXEC_OACC_SERIAL:
6187 : construct_code = OACC_SERIAL;
6188 : break;
6189 : case EXEC_OACC_DATA:
6190 : construct_code = OACC_DATA;
6191 : break;
6192 : case EXEC_OACC_HOST_DATA:
6193 : construct_code = OACC_HOST_DATA;
6194 : break;
6195 0 : default:
6196 0 : gcc_unreachable ();
6197 : }
6198 :
6199 4189 : gfc_start_block (&block);
6200 4189 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6201 : code->loc, false, true);
6202 4189 : pushlevel ();
6203 4189 : stmt = gfc_trans_omp_code (code->block->next, true);
6204 4189 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6205 4189 : stmt = build2_loc (gfc_get_location (&code->loc), construct_code,
6206 : void_type_node, stmt, oacc_clauses);
6207 4189 : gfc_add_expr_to_block (&block, stmt);
6208 4189 : return gfc_finish_block (&block);
6209 : }
6210 :
6211 : /* update, enter_data, exit_data, cache. */
6212 : static tree
6213 2130 : gfc_trans_oacc_executable_directive (gfc_code *code)
6214 : {
6215 2130 : stmtblock_t block;
6216 2130 : tree stmt, oacc_clauses;
6217 2130 : enum tree_code construct_code;
6218 :
6219 2130 : switch (code->op)
6220 : {
6221 : case EXEC_OACC_UPDATE:
6222 : construct_code = OACC_UPDATE;
6223 : break;
6224 787 : case EXEC_OACC_ENTER_DATA:
6225 787 : construct_code = OACC_ENTER_DATA;
6226 787 : break;
6227 575 : case EXEC_OACC_EXIT_DATA:
6228 575 : construct_code = OACC_EXIT_DATA;
6229 575 : break;
6230 76 : case EXEC_OACC_CACHE:
6231 76 : construct_code = OACC_CACHE;
6232 76 : break;
6233 0 : default:
6234 0 : gcc_unreachable ();
6235 : }
6236 :
6237 2130 : gfc_start_block (&block);
6238 2130 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6239 : code->loc, false, true, code->op);
6240 2130 : stmt = build1_loc (input_location, construct_code, void_type_node,
6241 : oacc_clauses);
6242 2130 : gfc_add_expr_to_block (&block, stmt);
6243 2130 : return gfc_finish_block (&block);
6244 : }
6245 :
6246 : static tree
6247 173 : gfc_trans_oacc_wait_directive (gfc_code *code)
6248 : {
6249 173 : stmtblock_t block;
6250 173 : tree stmt, t;
6251 173 : vec<tree, va_gc> *args;
6252 173 : int nparms = 0;
6253 173 : gfc_expr_list *el;
6254 173 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
6255 173 : location_t loc = input_location;
6256 :
6257 303 : for (el = clauses->wait_list; el; el = el->next)
6258 130 : nparms++;
6259 :
6260 173 : vec_alloc (args, nparms + 2);
6261 173 : stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
6262 :
6263 173 : gfc_start_block (&block);
6264 :
6265 173 : if (clauses->async_expr)
6266 3 : t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
6267 : else
6268 170 : t = build_int_cst (integer_type_node, -2);
6269 :
6270 173 : args->quick_push (t);
6271 173 : args->quick_push (build_int_cst (integer_type_node, nparms));
6272 :
6273 303 : for (el = clauses->wait_list; el; el = el->next)
6274 130 : args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
6275 :
6276 173 : stmt = build_call_expr_loc_vec (loc, stmt, args);
6277 173 : if (clauses->if_expr)
6278 6 : stmt = build3_loc (input_location, COND_EXPR, void_type_node,
6279 : gfc_convert_expr_to_tree (&block, clauses->if_expr),
6280 : stmt, NULL_TREE);
6281 173 : gfc_add_expr_to_block (&block, stmt);
6282 :
6283 173 : vec_free (args);
6284 :
6285 173 : return gfc_finish_block (&block);
6286 : }
6287 :
6288 : static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
6289 : static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
6290 :
6291 : static tree
6292 35 : gfc_trans_omp_allocators (gfc_code *code)
6293 : {
6294 35 : static bool warned = false;
6295 35 : gfc_omp_namelist *omp_allocate
6296 35 : = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
6297 35 : if (!flag_openmp_allocators && !warned)
6298 : {
6299 3 : omp_allocate = NULL;
6300 3 : gfc_error ("%<!$OMP %s%> at %L requires %<-fopenmp-allocators%>",
6301 3 : code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS",
6302 : &code->loc);
6303 3 : warning (0, "All files that might deallocate such a variable must be "
6304 : "compiled with %<-fopenmp-allocators%>");
6305 3 : inform (UNKNOWN_LOCATION,
6306 : "This includes explicit DEALLOCATE, reallocation on intrinsic "
6307 : "assignment, INTENT(OUT) for allocatable dummy arguments, and "
6308 : "reallocation of allocatable components allocated with an "
6309 : "OpenMP allocator");
6310 3 : warned = true;
6311 : }
6312 35 : return gfc_trans_allocate (code->block->next, omp_allocate);
6313 : }
6314 :
6315 : static tree
6316 10 : gfc_trans_omp_assume (gfc_code *code)
6317 : {
6318 10 : stmtblock_t block;
6319 10 : gfc_init_block (&block);
6320 10 : gfc_omp_assumptions *assume = code->ext.omp_clauses->assume;
6321 10 : if (assume)
6322 19 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
6323 : {
6324 9 : location_t loc = gfc_get_location (&el->expr->where);
6325 9 : gfc_se se;
6326 9 : gfc_init_se (&se, NULL);
6327 9 : gfc_conv_expr (&se, el->expr);
6328 9 : tree t;
6329 9 : if (se.pre.head == NULL_TREE && se.post.head == NULL_TREE)
6330 8 : t = se.expr;
6331 : else
6332 : {
6333 1 : tree var = create_tmp_var_raw (boolean_type_node);
6334 1 : DECL_CONTEXT (var) = current_function_decl;
6335 1 : stmtblock_t block2;
6336 1 : gfc_init_block (&block2);
6337 1 : gfc_add_block_to_block (&block2, &se.pre);
6338 1 : gfc_add_modify_loc (loc, &block2, var,
6339 : fold_convert_loc (loc, boolean_type_node,
6340 : se.expr));
6341 1 : gfc_add_block_to_block (&block2, &se.post);
6342 1 : t = gfc_finish_block (&block2);
6343 1 : t = build4 (TARGET_EXPR, boolean_type_node, var, t, NULL, NULL);
6344 : }
6345 9 : t = build_call_expr_internal_loc (loc, IFN_ASSUME,
6346 : void_type_node, 1, t);
6347 9 : gfc_add_expr_to_block (&block, t);
6348 : }
6349 10 : gfc_add_expr_to_block (&block, gfc_trans_omp_code (code->block->next, true));
6350 10 : return gfc_finish_block (&block);
6351 : }
6352 :
6353 : static tree
6354 2596 : gfc_trans_omp_atomic (gfc_code *code)
6355 : {
6356 2596 : gfc_code *atomic_code = code->block;
6357 2596 : gfc_se lse;
6358 2596 : gfc_se rse;
6359 2596 : gfc_se vse;
6360 2596 : gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
6361 2596 : gfc_symbol *var;
6362 2596 : stmtblock_t block;
6363 2596 : tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
6364 2596 : enum tree_code op = ERROR_MARK;
6365 2596 : enum tree_code aop = OMP_ATOMIC;
6366 2596 : bool var_on_left = false, else_branch = false;
6367 2596 : enum omp_memory_order mo, fail_mo;
6368 2596 : switch (atomic_code->ext.omp_clauses->memorder)
6369 : {
6370 : case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
6371 : case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break;
6372 : case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break;
6373 : case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break;
6374 : case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break;
6375 : case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
6376 0 : default: gcc_unreachable ();
6377 : }
6378 2596 : switch (atomic_code->ext.omp_clauses->fail)
6379 : {
6380 : case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
6381 14 : case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
6382 26 : case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
6383 2 : case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
6384 0 : default: gcc_unreachable ();
6385 : }
6386 2596 : mo = (omp_memory_order) (mo | fail_mo);
6387 :
6388 2596 : code = code->block->next;
6389 2596 : if (atomic_code->ext.omp_clauses->compare)
6390 : {
6391 144 : gfc_expr *comp_expr;
6392 144 : if (code->op == EXEC_IF)
6393 : {
6394 125 : comp_expr = code->block->expr1;
6395 125 : gcc_assert (code->block->next->op == EXEC_ASSIGN);
6396 125 : expr1 = code->block->next->expr1;
6397 125 : expr2 = code->block->next->expr2;
6398 125 : if (code->block->block)
6399 : {
6400 64 : gcc_assert (atomic_code->ext.omp_clauses->capture
6401 : && code->block->block->next->op == EXEC_ASSIGN);
6402 64 : else_branch = true;
6403 64 : aop = OMP_ATOMIC_CAPTURE_OLD;
6404 64 : capture_expr1 = code->block->block->next->expr1;
6405 64 : capture_expr2 = code->block->block->next->expr2;
6406 : }
6407 61 : else if (atomic_code->ext.omp_clauses->capture)
6408 : {
6409 19 : gcc_assert (code->next->op == EXEC_ASSIGN);
6410 19 : aop = OMP_ATOMIC_CAPTURE_NEW;
6411 19 : capture_expr1 = code->next->expr1;
6412 19 : capture_expr2 = code->next->expr2;
6413 : }
6414 : }
6415 : else
6416 : {
6417 19 : gcc_assert (atomic_code->ext.omp_clauses->capture
6418 : && code->op == EXEC_ASSIGN
6419 : && code->next->op == EXEC_IF);
6420 19 : aop = OMP_ATOMIC_CAPTURE_OLD;
6421 19 : capture_expr1 = code->expr1;
6422 19 : capture_expr2 = code->expr2;
6423 19 : expr1 = code->next->block->next->expr1;
6424 19 : expr2 = code->next->block->next->expr2;
6425 19 : comp_expr = code->next->block->expr1;
6426 : }
6427 144 : gfc_init_se (&lse, NULL);
6428 144 : gfc_conv_expr (&lse, comp_expr->value.op.op2);
6429 144 : gfc_add_block_to_block (&block, &lse.pre);
6430 144 : compare = lse.expr;
6431 144 : var = expr1->symtree->n.sym;
6432 : }
6433 : else
6434 : {
6435 2452 : gcc_assert (code->op == EXEC_ASSIGN);
6436 2452 : expr1 = code->expr1;
6437 2452 : expr2 = code->expr2;
6438 2452 : if (atomic_code->ext.omp_clauses->capture
6439 463 : && (expr2->expr_type == EXPR_VARIABLE
6440 245 : || (expr2->expr_type == EXPR_FUNCTION
6441 113 : && expr2->value.function.isym
6442 113 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION
6443 41 : && (expr2->value.function.actual->expr->expr_type
6444 : == EXPR_VARIABLE))))
6445 : {
6446 235 : capture_expr1 = expr1;
6447 235 : capture_expr2 = expr2;
6448 235 : expr1 = code->next->expr1;
6449 235 : expr2 = code->next->expr2;
6450 235 : aop = OMP_ATOMIC_CAPTURE_OLD;
6451 : }
6452 2217 : else if (atomic_code->ext.omp_clauses->capture)
6453 : {
6454 228 : aop = OMP_ATOMIC_CAPTURE_NEW;
6455 228 : capture_expr1 = code->next->expr1;
6456 228 : capture_expr2 = code->next->expr2;
6457 : }
6458 2452 : var = expr1->symtree->n.sym;
6459 : }
6460 :
6461 2596 : gfc_init_se (&lse, NULL);
6462 2596 : gfc_init_se (&rse, NULL);
6463 2596 : gfc_init_se (&vse, NULL);
6464 2596 : gfc_start_block (&block);
6465 :
6466 2596 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6467 : != GFC_OMP_ATOMIC_WRITE)
6468 2190 : && expr2->expr_type == EXPR_FUNCTION
6469 472 : && expr2->value.function.isym
6470 472 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6471 139 : expr2 = expr2->value.function.actual->expr;
6472 :
6473 2596 : if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6474 : == GFC_OMP_ATOMIC_READ)
6475 : {
6476 494 : gfc_conv_expr (&vse, expr1);
6477 494 : gfc_add_block_to_block (&block, &vse.pre);
6478 :
6479 494 : gfc_conv_expr (&lse, expr2);
6480 494 : gfc_add_block_to_block (&block, &lse.pre);
6481 494 : type = TREE_TYPE (lse.expr);
6482 494 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
6483 :
6484 494 : x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
6485 494 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6486 494 : x = convert (TREE_TYPE (vse.expr), x);
6487 494 : gfc_add_modify (&block, vse.expr, x);
6488 :
6489 494 : gfc_add_block_to_block (&block, &lse.pre);
6490 494 : gfc_add_block_to_block (&block, &rse.pre);
6491 :
6492 494 : return gfc_finish_block (&block);
6493 : }
6494 :
6495 2102 : if (capture_expr2
6496 565 : && capture_expr2->expr_type == EXPR_FUNCTION
6497 21 : && capture_expr2->value.function.isym
6498 21 : && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6499 21 : capture_expr2 = capture_expr2->value.function.actual->expr;
6500 565 : gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
6501 :
6502 2102 : if (aop == OMP_ATOMIC_CAPTURE_OLD)
6503 : {
6504 318 : gfc_conv_expr (&vse, capture_expr1);
6505 318 : gfc_add_block_to_block (&block, &vse.pre);
6506 318 : gfc_conv_expr (&lse, capture_expr2);
6507 318 : gfc_add_block_to_block (&block, &lse.pre);
6508 318 : gfc_init_se (&lse, NULL);
6509 : }
6510 :
6511 2102 : gfc_conv_expr (&lse, expr1);
6512 2102 : gfc_add_block_to_block (&block, &lse.pre);
6513 2102 : type = TREE_TYPE (lse.expr);
6514 2102 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
6515 :
6516 2102 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6517 : == GFC_OMP_ATOMIC_WRITE)
6518 1696 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
6519 1674 : || compare)
6520 : {
6521 572 : gfc_conv_expr (&rse, expr2);
6522 572 : gfc_add_block_to_block (&block, &rse.pre);
6523 : }
6524 1530 : else if (expr2->expr_type == EXPR_OP)
6525 : {
6526 1184 : gfc_expr *e;
6527 1184 : switch (expr2->value.op.op)
6528 : {
6529 : case INTRINSIC_PLUS:
6530 : op = PLUS_EXPR;
6531 : break;
6532 91 : case INTRINSIC_TIMES:
6533 91 : op = MULT_EXPR;
6534 91 : break;
6535 113 : case INTRINSIC_MINUS:
6536 113 : op = MINUS_EXPR;
6537 113 : break;
6538 91 : case INTRINSIC_DIVIDE:
6539 91 : if (expr2->ts.type == BT_INTEGER)
6540 : op = TRUNC_DIV_EXPR;
6541 : else
6542 74 : op = RDIV_EXPR;
6543 : break;
6544 43 : case INTRINSIC_AND:
6545 43 : op = TRUTH_ANDIF_EXPR;
6546 43 : break;
6547 49 : case INTRINSIC_OR:
6548 49 : op = TRUTH_ORIF_EXPR;
6549 49 : break;
6550 43 : case INTRINSIC_EQV:
6551 43 : op = EQ_EXPR;
6552 43 : break;
6553 43 : case INTRINSIC_NEQV:
6554 43 : op = NE_EXPR;
6555 43 : break;
6556 0 : default:
6557 0 : gcc_unreachable ();
6558 : }
6559 1184 : e = expr2->value.op.op1;
6560 1184 : if (e->expr_type == EXPR_FUNCTION
6561 48 : && e->value.function.isym
6562 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6563 48 : e = e->value.function.actual->expr;
6564 1184 : if (e->expr_type == EXPR_VARIABLE
6565 925 : && e->symtree != NULL
6566 925 : && e->symtree->n.sym == var)
6567 : {
6568 910 : expr2 = expr2->value.op.op2;
6569 910 : var_on_left = true;
6570 : }
6571 : else
6572 : {
6573 274 : e = expr2->value.op.op2;
6574 274 : if (e->expr_type == EXPR_FUNCTION
6575 48 : && e->value.function.isym
6576 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6577 48 : e = e->value.function.actual->expr;
6578 274 : gcc_assert (e->expr_type == EXPR_VARIABLE
6579 : && e->symtree != NULL
6580 : && e->symtree->n.sym == var);
6581 : expr2 = expr2->value.op.op1;
6582 : var_on_left = false;
6583 : }
6584 1184 : gfc_conv_expr (&rse, expr2);
6585 1184 : gfc_add_block_to_block (&block, &rse.pre);
6586 : }
6587 : else
6588 : {
6589 346 : gcc_assert (expr2->expr_type == EXPR_FUNCTION);
6590 346 : switch (expr2->value.function.isym->id)
6591 : {
6592 : case GFC_ISYM_MIN:
6593 : op = MIN_EXPR;
6594 : break;
6595 114 : case GFC_ISYM_MAX:
6596 114 : op = MAX_EXPR;
6597 114 : break;
6598 47 : case GFC_ISYM_IAND:
6599 47 : op = BIT_AND_EXPR;
6600 47 : break;
6601 49 : case GFC_ISYM_IOR:
6602 49 : op = BIT_IOR_EXPR;
6603 49 : break;
6604 45 : case GFC_ISYM_IEOR:
6605 45 : op = BIT_XOR_EXPR;
6606 45 : break;
6607 0 : default:
6608 0 : gcc_unreachable ();
6609 : }
6610 346 : e = expr2->value.function.actual->expr;
6611 346 : if (e->expr_type == EXPR_FUNCTION
6612 13 : && e->value.function.isym
6613 13 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6614 13 : e = e->value.function.actual->expr;
6615 346 : gcc_assert (e->expr_type == EXPR_VARIABLE
6616 : && e->symtree != NULL
6617 : && e->symtree->n.sym == var);
6618 :
6619 346 : gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
6620 346 : gfc_add_block_to_block (&block, &rse.pre);
6621 346 : if (expr2->value.function.actual->next->next != NULL)
6622 : {
6623 26 : tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
6624 26 : gfc_actual_arglist *arg;
6625 :
6626 26 : gfc_add_modify (&block, accum, rse.expr);
6627 64 : for (arg = expr2->value.function.actual->next->next; arg;
6628 38 : arg = arg->next)
6629 : {
6630 38 : gfc_init_block (&rse.pre);
6631 38 : gfc_conv_expr (&rse, arg->expr);
6632 38 : gfc_add_block_to_block (&block, &rse.pre);
6633 38 : x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
6634 : accum, rse.expr);
6635 38 : gfc_add_modify (&block, accum, x);
6636 : }
6637 :
6638 26 : rse.expr = accum;
6639 : }
6640 :
6641 346 : expr2 = expr2->value.function.actual->next->expr;
6642 : }
6643 :
6644 2102 : lhsaddr = save_expr (lhsaddr);
6645 2102 : if (TREE_CODE (lhsaddr) != SAVE_EXPR
6646 2102 : && (TREE_CODE (lhsaddr) != ADDR_EXPR
6647 1642 : || !VAR_P (TREE_OPERAND (lhsaddr, 0))))
6648 : {
6649 : /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
6650 : it even after unsharing function body. */
6651 44 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
6652 44 : DECL_CONTEXT (var) = current_function_decl;
6653 44 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
6654 : NULL_TREE, NULL_TREE);
6655 : }
6656 :
6657 2102 : if (compare)
6658 : {
6659 144 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
6660 144 : DECL_CONTEXT (var) = current_function_decl;
6661 144 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
6662 : NULL);
6663 144 : lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
6664 144 : compare = convert (TREE_TYPE (lse.expr), compare);
6665 144 : compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6666 : lse.expr, compare);
6667 : }
6668 :
6669 2102 : if (expr2->expr_type == EXPR_VARIABLE || compare)
6670 460 : rhs = rse.expr;
6671 : else
6672 1642 : rhs = gfc_evaluate_now (rse.expr, &block);
6673 :
6674 2102 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6675 : == GFC_OMP_ATOMIC_WRITE)
6676 1696 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
6677 1674 : || compare)
6678 : x = rhs;
6679 : else
6680 : {
6681 1530 : x = convert (TREE_TYPE (rhs),
6682 : build_fold_indirect_ref_loc (input_location, lhsaddr));
6683 1530 : if (var_on_left)
6684 910 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
6685 : else
6686 620 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
6687 : }
6688 :
6689 2102 : if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
6690 2102 : && TREE_CODE (type) != COMPLEX_TYPE)
6691 0 : x = fold_build1_loc (input_location, REALPART_EXPR,
6692 0 : TREE_TYPE (TREE_TYPE (rhs)), x);
6693 :
6694 2102 : gfc_add_block_to_block (&block, &lse.pre);
6695 2102 : gfc_add_block_to_block (&block, &rse.pre);
6696 :
6697 2102 : if (aop == OMP_ATOMIC_CAPTURE_NEW)
6698 : {
6699 247 : gfc_conv_expr (&vse, capture_expr1);
6700 247 : gfc_add_block_to_block (&block, &vse.pre);
6701 247 : gfc_add_block_to_block (&block, &lse.pre);
6702 : }
6703 :
6704 2102 : if (compare && else_branch)
6705 : {
6706 64 : tree var2 = create_tmp_var_raw (boolean_type_node);
6707 64 : DECL_CONTEXT (var2) = current_function_decl;
6708 64 : comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
6709 : boolean_false_node, NULL, NULL);
6710 64 : compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
6711 : var2, compare);
6712 64 : TREE_OPERAND (compare, 0) = comp_tgt;
6713 64 : compare = omit_one_operand_loc (input_location, boolean_type_node,
6714 : compare, comp_tgt);
6715 : }
6716 :
6717 2102 : if (compare)
6718 144 : x = build3_loc (input_location, COND_EXPR, type, compare,
6719 : convert (type, x), lse.expr);
6720 :
6721 2102 : if (aop == OMP_ATOMIC)
6722 : {
6723 1537 : x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
6724 1537 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6725 1537 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
6726 1537 : gfc_add_expr_to_block (&block, x);
6727 : }
6728 : else
6729 : {
6730 565 : x = build2 (aop, type, lhsaddr, convert (type, x));
6731 565 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6732 565 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
6733 565 : if (compare && else_branch)
6734 : {
6735 64 : tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
6736 64 : DECL_CONTEXT (vtmp) = current_function_decl;
6737 64 : x = fold_build2_loc (input_location, MODIFY_EXPR,
6738 64 : TREE_TYPE (vtmp), vtmp, x);
6739 64 : vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
6740 64 : build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
6741 64 : TREE_OPERAND (x, 0) = vtmp;
6742 64 : tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
6743 64 : x2 = fold_build2_loc (input_location, MODIFY_EXPR,
6744 64 : TREE_TYPE (vse.expr), vse.expr, x2);
6745 64 : x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt,
6746 : void_node, x2);
6747 64 : x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
6748 64 : gfc_add_expr_to_block (&block, x);
6749 : }
6750 : else
6751 : {
6752 501 : x = convert (TREE_TYPE (vse.expr), x);
6753 501 : gfc_add_modify (&block, vse.expr, x);
6754 : }
6755 : }
6756 :
6757 2102 : return gfc_finish_block (&block);
6758 : }
6759 :
6760 : static tree
6761 604 : gfc_trans_omp_barrier (void)
6762 : {
6763 604 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
6764 604 : return build_call_expr_loc (input_location, decl, 0);
6765 : }
6766 :
6767 : static tree
6768 310 : gfc_trans_omp_cancel (gfc_code *code)
6769 : {
6770 310 : int mask = 0;
6771 310 : tree ifc = boolean_true_node;
6772 310 : stmtblock_t block;
6773 310 : switch (code->ext.omp_clauses->cancel)
6774 : {
6775 : case OMP_CANCEL_PARALLEL: mask = 1; break;
6776 : case OMP_CANCEL_DO: mask = 2; break;
6777 : case OMP_CANCEL_SECTIONS: mask = 4; break;
6778 : case OMP_CANCEL_TASKGROUP: mask = 8; break;
6779 0 : default: gcc_unreachable ();
6780 : }
6781 310 : gfc_start_block (&block);
6782 310 : if (code->ext.omp_clauses->if_expr
6783 219 : || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL])
6784 : {
6785 99 : gfc_se se;
6786 99 : tree if_var;
6787 :
6788 99 : gcc_assert ((code->ext.omp_clauses->if_expr == NULL)
6789 : ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL));
6790 99 : gfc_init_se (&se, NULL);
6791 99 : gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL
6792 : ? code->ext.omp_clauses->if_expr
6793 : : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]);
6794 99 : gfc_add_block_to_block (&block, &se.pre);
6795 99 : if_var = gfc_evaluate_now (se.expr, &block);
6796 99 : gfc_add_block_to_block (&block, &se.post);
6797 99 : tree type = TREE_TYPE (if_var);
6798 99 : ifc = fold_build2_loc (input_location, NE_EXPR,
6799 : boolean_type_node, if_var,
6800 : build_zero_cst (type));
6801 : }
6802 310 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
6803 310 : tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
6804 310 : ifc = fold_convert (c_bool_type, ifc);
6805 310 : gfc_add_expr_to_block (&block,
6806 : build_call_expr_loc (input_location, decl, 2,
6807 : build_int_cst (integer_type_node,
6808 310 : mask), ifc));
6809 310 : return gfc_finish_block (&block);
6810 : }
6811 :
6812 : static tree
6813 170 : gfc_trans_omp_cancellation_point (gfc_code *code)
6814 : {
6815 170 : int mask = 0;
6816 170 : switch (code->ext.omp_clauses->cancel)
6817 : {
6818 : case OMP_CANCEL_PARALLEL: mask = 1; break;
6819 : case OMP_CANCEL_DO: mask = 2; break;
6820 : case OMP_CANCEL_SECTIONS: mask = 4; break;
6821 : case OMP_CANCEL_TASKGROUP: mask = 8; break;
6822 0 : default: gcc_unreachable ();
6823 : }
6824 170 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
6825 170 : return build_call_expr_loc (input_location, decl, 1,
6826 340 : build_int_cst (integer_type_node, mask));
6827 : }
6828 :
6829 : static tree
6830 143 : gfc_trans_omp_critical (gfc_code *code)
6831 : {
6832 143 : stmtblock_t block;
6833 143 : tree stmt, name = NULL_TREE;
6834 143 : if (code->ext.omp_clauses->critical_name != NULL)
6835 36 : name = get_identifier (code->ext.omp_clauses->critical_name);
6836 143 : gfc_start_block (&block);
6837 143 : stmt = make_node (OMP_CRITICAL);
6838 143 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
6839 143 : TREE_TYPE (stmt) = void_type_node;
6840 143 : OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next);
6841 143 : OMP_CRITICAL_NAME (stmt) = name;
6842 143 : OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
6843 : code->ext.omp_clauses,
6844 : code->loc);
6845 143 : gfc_add_expr_to_block (&block, stmt);
6846 143 : return gfc_finish_block (&block);
6847 : }
6848 :
6849 : typedef struct dovar_init_d {
6850 : gfc_symbol *sym;
6851 : tree var;
6852 : tree init;
6853 : bool non_unit_iter;
6854 : } dovar_init;
6855 :
6856 : static bool
6857 2884 : gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n,
6858 : gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits,
6859 : int simple, gfc_expr *curr_loop_var)
6860 : {
6861 2884 : int i;
6862 4771 : for (i = 0; i < loop_n; i++)
6863 : {
6864 2441 : gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE);
6865 2441 : if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr))
6866 : break;
6867 1887 : code = code->block->next;
6868 : }
6869 2884 : if (i >= loop_n)
6870 : return false;
6871 :
6872 : /* Canonical format: TREE_VEC with [var, multiplier, offset]. */
6873 554 : gfc_symbol *var = code->ext.iterator->var->symtree->n.sym;
6874 :
6875 554 : tree tree_var = NULL_TREE;
6876 554 : tree a1 = integer_one_node;
6877 554 : tree a2 = integer_zero_node;
6878 :
6879 554 : if (!simple)
6880 : {
6881 : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
6882 6 : sorry_at (gfc_get_location (&curr_loop_var->where),
6883 : "non-rectangular loop nest with non-constant step for %qs",
6884 3 : curr_loop_var->symtree->n.sym->name);
6885 3 : return false;
6886 : }
6887 :
6888 : dovar_init *di;
6889 : unsigned ix;
6890 551 : FOR_EACH_VEC_ELT (*inits, ix, di)
6891 18 : if (di->sym == var)
6892 : {
6893 18 : if (!di->non_unit_iter)
6894 : {
6895 16 : tree_var = di->init;
6896 16 : gcc_assert (DECL_P (tree_var));
6897 : break;
6898 : }
6899 : else
6900 : {
6901 : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
6902 2 : sorry_at (gfc_get_location (&code->loc),
6903 : "non-rectangular loop nest with non-constant step "
6904 : "for %qs", var->name);
6905 2 : inform (gfc_get_location (&expr->where), "Used here");
6906 2 : return false;
6907 : }
6908 : }
6909 533 : if (tree_var == NULL_TREE)
6910 533 : tree_var = var->backend_decl;
6911 :
6912 549 : if (expr->expr_type == EXPR_VARIABLE)
6913 54 : gcc_assert (expr->symtree->n.sym == var);
6914 495 : else if (expr->expr_type != EXPR_OP
6915 495 : || (expr->value.op.op != INTRINSIC_TIMES
6916 479 : && expr->value.op.op != INTRINSIC_PLUS
6917 359 : && expr->value.op.op != INTRINSIC_MINUS))
6918 0 : gcc_unreachable ();
6919 : else
6920 : {
6921 495 : gfc_se se;
6922 495 : gfc_expr *et = NULL, *eo = NULL, *e = expr;
6923 495 : if (expr->value.op.op != INTRINSIC_TIMES)
6924 : {
6925 479 : if (gfc_find_sym_in_expr (var, expr->value.op.op1))
6926 : {
6927 431 : e = expr->value.op.op1;
6928 431 : eo = expr->value.op.op2;
6929 : }
6930 : else
6931 : {
6932 48 : eo = expr->value.op.op1;
6933 48 : e = expr->value.op.op2;
6934 : }
6935 : }
6936 495 : if (e->value.op.op == INTRINSIC_TIMES)
6937 : {
6938 91 : if (e->value.op.op1->expr_type == EXPR_VARIABLE
6939 91 : && e->value.op.op1->symtree->n.sym == var)
6940 51 : et = e->value.op.op2;
6941 : else
6942 : {
6943 40 : et = e->value.op.op1;
6944 40 : gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE
6945 : && e->value.op.op2->symtree->n.sym == var);
6946 : }
6947 : }
6948 : else
6949 404 : gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var);
6950 91 : if (et != NULL)
6951 : {
6952 91 : gfc_init_se (&se, NULL);
6953 91 : gfc_conv_expr_val (&se, et);
6954 91 : gfc_add_block_to_block (pblock, &se.pre);
6955 91 : a1 = se.expr;
6956 : }
6957 495 : if (eo != NULL)
6958 : {
6959 479 : gfc_init_se (&se, NULL);
6960 479 : gfc_conv_expr_val (&se, eo);
6961 479 : gfc_add_block_to_block (pblock, &se.pre);
6962 479 : a2 = se.expr;
6963 479 : if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo)
6964 : /* outer-var - a2. */
6965 335 : a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2);
6966 144 : else if (expr->value.op.op == INTRINSIC_MINUS)
6967 : /* a2 - outer-var. */
6968 24 : a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1);
6969 : }
6970 495 : a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock);
6971 495 : a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock);
6972 : }
6973 :
6974 549 : gfc_init_se (sep, NULL);
6975 549 : sep->expr = make_tree_vec (3);
6976 549 : TREE_VEC_ELT (sep->expr, 0) = tree_var;
6977 549 : TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1);
6978 549 : TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2);
6979 :
6980 549 : return true;
6981 : }
6982 :
6983 : int
6984 708 : gfc_expr_list_len (gfc_expr_list *list)
6985 : {
6986 708 : unsigned len = 0;
6987 2092 : for (; list; list = list->next)
6988 1384 : len++;
6989 :
6990 708 : return len;
6991 : }
6992 :
6993 : static tree
6994 9537 : gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
6995 : gfc_omp_clauses *do_clauses, tree par_clauses)
6996 : {
6997 9537 : gfc_se se;
6998 9537 : tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
6999 9537 : tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses;
7000 9537 : stmtblock_t block;
7001 9537 : stmtblock_t body;
7002 9537 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
7003 9537 : int i, collapse = clauses->collapse;
7004 9537 : vec<dovar_init> inits = vNULL;
7005 9537 : dovar_init *di;
7006 9537 : unsigned ix;
7007 9537 : vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
7008 19074 : gfc_expr_list *oacc_tile
7009 9537 : = do_clauses ? do_clauses->tile_list : clauses->tile_list;
7010 9537 : gfc_expr_list *sizes
7011 : = do_clauses ? do_clauses->sizes_list : clauses->sizes_list;
7012 9537 : gfc_code *orig_code = code;
7013 :
7014 : /* Both collapsed and tiled loops are lowered the same way. In
7015 : OpenACC, those clauses are not compatible, so prioritize the tile
7016 : clause, if present. */
7017 9537 : if (oacc_tile)
7018 60 : collapse = gfc_expr_list_len (oacc_tile);
7019 9477 : else if (sizes)
7020 120 : collapse = gfc_expr_list_len (sizes);
7021 :
7022 9537 : doacross_steps = NULL;
7023 9537 : if (clauses->orderedc)
7024 134 : collapse = clauses->orderedc;
7025 9537 : if (collapse <= 0)
7026 : collapse = 1;
7027 :
7028 9537 : code = code->block->next;
7029 :
7030 9537 : init = make_tree_vec (collapse);
7031 9537 : cond = make_tree_vec (collapse);
7032 9537 : incr = make_tree_vec (collapse);
7033 9537 : orig_decls = clauses->ordered ? make_tree_vec (collapse) : NULL_TREE;
7034 :
7035 9537 : if (pblock == NULL)
7036 : {
7037 6035 : gfc_start_block (&block);
7038 6035 : pblock = █
7039 : }
7040 :
7041 : /* simd schedule modifier is only useful for composite do simd and other
7042 : constructs including that, where gfc_trans_omp_do is only called
7043 : on the simd construct and DO's clauses are translated elsewhere. */
7044 9537 : do_clauses->sched_simd = false;
7045 :
7046 9537 : omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
7047 :
7048 21566 : for (i = 0; i < collapse; i++)
7049 : {
7050 12029 : int simple = 0;
7051 12029 : int dovar_found = 0;
7052 12029 : tree dovar_decl;
7053 :
7054 12029 : if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
7055 : {
7056 320 : TREE_VEC_ELT (init, i) = NULL_TREE;
7057 320 : TREE_VEC_ELT (cond, i) = NULL_TREE;
7058 320 : TREE_VEC_ELT (incr, i) = NULL_TREE;
7059 320 : TREE_VEC_ELT (incr, i) = NULL_TREE;
7060 320 : if (orig_decls)
7061 2 : TREE_VEC_ELT (orig_decls, i) = NULL_TREE;
7062 320 : continue;
7063 : }
7064 11709 : gcc_assert (code->op == EXEC_DO);
7065 11709 : if (clauses)
7066 : {
7067 11709 : gfc_omp_namelist *n = NULL;
7068 11709 : if (op == EXEC_OMP_SIMD && collapse == 1)
7069 936 : for (n = clauses->lists[OMP_LIST_LINEAR];
7070 1236 : n != NULL; n = n->next)
7071 443 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
7072 : {
7073 : dovar_found = 3;
7074 : break;
7075 : }
7076 11709 : if (n == NULL && op != EXEC_OMP_DISTRIBUTE)
7077 11472 : for (n = clauses->lists[OMP_LIST_LASTPRIVATE];
7078 13531 : n != NULL; n = n->next)
7079 3436 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
7080 : {
7081 : dovar_found = 2;
7082 : break;
7083 : }
7084 11709 : if (n == NULL)
7085 11445 : for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
7086 6998 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
7087 : {
7088 : dovar_found = 1;
7089 : break;
7090 : }
7091 : }
7092 :
7093 : /* Evaluate all the expressions in the iterator. */
7094 11709 : gfc_init_se (&se, NULL);
7095 11709 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
7096 11709 : gfc_add_block_to_block (pblock, &se.pre);
7097 11709 : local_dovar = dovar_decl = dovar = se.expr;
7098 11709 : type = TREE_TYPE (dovar);
7099 11709 : gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
7100 :
7101 11709 : gfc_init_se (&se, NULL);
7102 11709 : gfc_conv_expr_val (&se, code->ext.iterator->step);
7103 11709 : gfc_add_block_to_block (pblock, &se.pre);
7104 11709 : step = gfc_evaluate_now (se.expr, pblock);
7105 :
7106 11709 : if (TREE_CODE (step) == INTEGER_CST)
7107 11118 : simple = tree_int_cst_sgn (step);
7108 :
7109 11709 : gfc_init_se (&se, NULL);
7110 11709 : if (!clauses->non_rectangular
7111 13151 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
7112 : code->ext.iterator->start, &inits, simple,
7113 1442 : code->ext.iterator->var))
7114 : {
7115 11393 : gfc_conv_expr_val (&se, code->ext.iterator->start);
7116 11393 : gfc_add_block_to_block (pblock, &se.pre);
7117 11393 : if (!DECL_P (se.expr))
7118 10995 : se.expr = gfc_evaluate_now (se.expr, pblock);
7119 : }
7120 11709 : from = se.expr;
7121 :
7122 11709 : gfc_init_se (&se, NULL);
7123 11709 : if (!clauses->non_rectangular
7124 13151 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
7125 : code->ext.iterator->end, &inits, simple,
7126 1442 : code->ext.iterator->var))
7127 : {
7128 11476 : gfc_conv_expr_val (&se, code->ext.iterator->end);
7129 11476 : gfc_add_block_to_block (pblock, &se.pre);
7130 11476 : if (!DECL_P (se.expr))
7131 10241 : se.expr = gfc_evaluate_now (se.expr, pblock);
7132 : }
7133 11709 : to = se.expr;
7134 :
7135 11709 : if (!DECL_P (dovar))
7136 38 : dovar_decl
7137 38 : = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
7138 : false);
7139 11709 : if (simple && !DECL_P (dovar))
7140 : {
7141 38 : const char *name = code->ext.iterator->var->symtree->n.sym->name;
7142 38 : local_dovar = gfc_create_var (type, name);
7143 38 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
7144 38 : dovar, local_dovar, false};
7145 38 : inits.safe_push (e);
7146 : }
7147 : /* Loop body. */
7148 11709 : if (simple)
7149 : {
7150 11118 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from);
7151 : /* The condition should not be folded. */
7152 11670 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
7153 : ? LE_EXPR : GE_EXPR,
7154 : logical_type_node, local_dovar,
7155 : to);
7156 11118 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
7157 : type, local_dovar, step);
7158 11118 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
7159 : MODIFY_EXPR,
7160 : type, local_dovar,
7161 11118 : TREE_VEC_ELT (incr, i));
7162 11118 : if (orig_decls && !clauses->orderedc)
7163 : orig_decls = NULL;
7164 383 : else if (orig_decls)
7165 383 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
7166 : }
7167 : else
7168 : {
7169 : /* STEP is not 1 or -1. Use:
7170 : for (count = 0; count < (to + step - from) / step; count++)
7171 : {
7172 : dovar = from + count * step;
7173 : body;
7174 : cycle_label:;
7175 : } */
7176 591 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
7177 591 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
7178 591 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
7179 : step);
7180 591 : tmp = gfc_evaluate_now (tmp, pblock);
7181 591 : local_dovar = gfc_create_var (type, "count");
7182 591 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar,
7183 : build_int_cst (type, 0));
7184 : /* The condition should not be folded. */
7185 591 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
7186 : logical_type_node,
7187 : local_dovar, tmp);
7188 591 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
7189 : type, local_dovar,
7190 : build_int_cst (type, 1));
7191 591 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
7192 : MODIFY_EXPR, type,
7193 : local_dovar,
7194 591 : TREE_VEC_ELT (incr, i));
7195 :
7196 : /* Initialize DOVAR. */
7197 591 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar,
7198 : step);
7199 591 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
7200 591 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
7201 591 : dovar, tmp, true};
7202 591 : inits.safe_push (e);
7203 591 : if (clauses->orderedc)
7204 : {
7205 192 : if (doacross_steps == NULL)
7206 47 : vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true);
7207 192 : (*doacross_steps)[i] = step;
7208 : }
7209 591 : if (orig_decls)
7210 198 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
7211 : }
7212 :
7213 11709 : if (dovar_found == 3
7214 11709 : && op == EXEC_OMP_SIMD
7215 143 : && collapse == 1
7216 143 : && local_dovar != dovar)
7217 : {
7218 120 : for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
7219 120 : if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
7220 120 : && OMP_CLAUSE_DECL (tmp) == dovar)
7221 : {
7222 30 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7223 30 : break;
7224 : }
7225 : }
7226 11709 : if (!dovar_found && op == EXEC_OMP_SIMD)
7227 : {
7228 1356 : if (collapse == 1)
7229 : {
7230 783 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
7231 783 : OMP_CLAUSE_LINEAR_STEP (tmp) = step;
7232 783 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7233 783 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
7234 783 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7235 783 : if (local_dovar != dovar)
7236 : dovar_found = 3;
7237 : }
7238 : }
7239 10353 : else if (!dovar_found && local_dovar != dovar)
7240 : {
7241 260 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
7242 260 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
7243 260 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7244 : }
7245 11679 : if (dovar_found > 1)
7246 : {
7247 1550 : tree c = NULL;
7248 :
7249 1550 : tmp = NULL;
7250 1550 : if (local_dovar != dovar)
7251 : {
7252 : /* If dovar is lastprivate, but different counter is used,
7253 : dovar += step needs to be added to
7254 : OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
7255 : will have the value on entry of the last loop, rather
7256 : than value after iterator increment. */
7257 243 : if (clauses->orderedc)
7258 : {
7259 60 : if (clauses->collapse <= 1 || i >= clauses->collapse)
7260 : tmp = local_dovar;
7261 : else
7262 36 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7263 : type, local_dovar,
7264 : build_one_cst (type));
7265 60 : tmp = fold_build2_loc (input_location, MULT_EXPR, type,
7266 : tmp, step);
7267 60 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
7268 : from, tmp);
7269 : }
7270 : else
7271 183 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
7272 : dovar, step);
7273 243 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
7274 : dovar, tmp);
7275 934 : for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
7276 613 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
7277 613 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7278 : {
7279 105 : OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
7280 105 : break;
7281 : }
7282 508 : else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
7283 508 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7284 : {
7285 60 : OMP_CLAUSE_LINEAR_STMT (c) = tmp;
7286 60 : break;
7287 : }
7288 : }
7289 1550 : if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
7290 : {
7291 892 : for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
7292 892 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
7293 892 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7294 : {
7295 406 : tree l = build_omp_clause (input_location,
7296 : OMP_CLAUSE_LASTPRIVATE);
7297 406 : if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c))
7298 4 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1;
7299 406 : OMP_CLAUSE_DECL (l) = dovar_decl;
7300 406 : OMP_CLAUSE_CHAIN (l) = omp_clauses;
7301 406 : OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
7302 406 : omp_clauses = l;
7303 406 : OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
7304 406 : break;
7305 : }
7306 : }
7307 1550 : gcc_assert (local_dovar == dovar || c != NULL);
7308 : }
7309 11709 : if (local_dovar != dovar)
7310 : {
7311 629 : if (op != EXEC_OMP_SIMD || dovar_found == 1)
7312 550 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
7313 79 : else if (collapse == 1)
7314 : {
7315 60 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
7316 60 : OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
7317 60 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7318 60 : OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
7319 : }
7320 : else
7321 19 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
7322 629 : OMP_CLAUSE_DECL (tmp) = local_dovar;
7323 629 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7324 : }
7325 :
7326 11709 : if (i + 1 < collapse)
7327 2464 : code = code->block->next;
7328 : }
7329 :
7330 9537 : if (pblock != &block)
7331 : {
7332 3502 : pushlevel ();
7333 3502 : gfc_start_block (&block);
7334 : }
7335 :
7336 9537 : gfc_start_block (&body);
7337 :
7338 19703 : FOR_EACH_VEC_ELT (inits, ix, di)
7339 629 : gfc_add_modify (&body, di->var, di->init);
7340 9537 : inits.release ();
7341 :
7342 : /* Cycle statement is implemented with a goto. Exit statement must not be
7343 : present for this loop. */
7344 9537 : cycle_label = gfc_build_label_decl (NULL_TREE);
7345 :
7346 : /* Put these labels where they can be found later. */
7347 :
7348 9537 : code->cycle_label = cycle_label;
7349 9537 : code->exit_label = NULL_TREE;
7350 :
7351 : /* Main loop body. */
7352 9537 : if (clauses->lists[OMP_LIST_REDUCTION_INSCAN])
7353 : {
7354 16 : gfc_code *code1, *scan, *code2, *tmpcode;
7355 16 : code1 = tmpcode = code->block->next;
7356 16 : if (tmpcode && tmpcode->op != EXEC_OMP_SCAN)
7357 18 : while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN)
7358 : tmpcode = tmpcode->next;
7359 16 : scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next;
7360 16 : if (code1 != scan)
7361 16 : tmpcode->next = NULL;
7362 16 : code2 = scan->next;
7363 16 : gcc_assert (scan->op == EXEC_OMP_SCAN);
7364 16 : location_t loc = gfc_get_location (&scan->loc);
7365 :
7366 16 : tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc);
7367 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE);
7368 16 : SET_EXPR_LOCATION (tmp, loc);
7369 16 : gfc_add_expr_to_block (&body, tmp);
7370 16 : input_location = loc;
7371 16 : tree c = gfc_trans_omp_clauses (&body, scan->ext.omp_clauses, scan->loc);
7372 16 : tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc);
7373 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, c);
7374 16 : SET_EXPR_LOCATION (tmp, loc);
7375 16 : if (code1 != scan)
7376 16 : tmpcode->next = scan;
7377 : }
7378 9521 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
7379 292 : tmp = gfc_trans_omp_code (code, true);
7380 : else
7381 9229 : tmp = gfc_trans_omp_code (code->block->next, true);
7382 9537 : gfc_add_expr_to_block (&body, tmp);
7383 :
7384 : /* Label for cycle statements (if needed). */
7385 9537 : if (TREE_USED (cycle_label))
7386 : {
7387 9537 : tmp = build1_v (LABEL_EXPR, cycle_label);
7388 9537 : gfc_add_expr_to_block (&body, tmp);
7389 : }
7390 :
7391 : /* End of loop body. */
7392 9537 : switch (op)
7393 : {
7394 1455 : case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
7395 2420 : case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
7396 80 : case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
7397 113 : case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break;
7398 94 : case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
7399 4933 : case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
7400 120 : case EXEC_OMP_TILE: stmt = make_node (OMP_TILE); break;
7401 322 : case EXEC_OMP_UNROLL: stmt = make_node (OMP_UNROLL); break;
7402 0 : default: gcc_unreachable ();
7403 : }
7404 :
7405 9537 : SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc));
7406 9537 : TREE_TYPE (stmt) = void_type_node;
7407 9537 : OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
7408 9537 : OMP_FOR_CLAUSES (stmt) = omp_clauses;
7409 9537 : OMP_FOR_INIT (stmt) = init;
7410 9537 : OMP_FOR_COND (stmt) = cond;
7411 9537 : OMP_FOR_INCR (stmt) = incr;
7412 9537 : if (orig_decls)
7413 140 : OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
7414 9537 : OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular;
7415 9537 : gfc_add_expr_to_block (&block, stmt);
7416 :
7417 9537 : vec_free (doacross_steps);
7418 9537 : doacross_steps = saved_doacross_steps;
7419 :
7420 9537 : return gfc_finish_block (&block);
7421 : }
7422 :
7423 : /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
7424 : construct. */
7425 :
7426 : static tree
7427 1556 : gfc_trans_oacc_combined_directive (gfc_code *code)
7428 : {
7429 1556 : stmtblock_t block, *pblock = NULL;
7430 1556 : gfc_omp_clauses construct_clauses, loop_clauses;
7431 1556 : tree stmt, oacc_clauses = NULL_TREE;
7432 1556 : enum tree_code construct_code;
7433 1556 : location_t loc = input_location;
7434 :
7435 1556 : switch (code->op)
7436 : {
7437 : case EXEC_OACC_PARALLEL_LOOP:
7438 : construct_code = OACC_PARALLEL;
7439 : break;
7440 : case EXEC_OACC_KERNELS_LOOP:
7441 : construct_code = OACC_KERNELS;
7442 : break;
7443 : case EXEC_OACC_SERIAL_LOOP:
7444 : construct_code = OACC_SERIAL;
7445 : break;
7446 0 : default:
7447 0 : gcc_unreachable ();
7448 : }
7449 :
7450 1556 : gfc_start_block (&block);
7451 :
7452 1556 : memset (&loop_clauses, 0, sizeof (loop_clauses));
7453 1556 : if (code->ext.omp_clauses != NULL)
7454 : {
7455 1556 : memcpy (&construct_clauses, code->ext.omp_clauses,
7456 : sizeof (construct_clauses));
7457 1556 : loop_clauses.collapse = construct_clauses.collapse;
7458 1556 : loop_clauses.gang = construct_clauses.gang;
7459 1556 : loop_clauses.gang_static = construct_clauses.gang_static;
7460 1556 : loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
7461 1556 : loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
7462 1556 : loop_clauses.vector = construct_clauses.vector;
7463 1556 : loop_clauses.vector_expr = construct_clauses.vector_expr;
7464 1556 : loop_clauses.worker = construct_clauses.worker;
7465 1556 : loop_clauses.worker_expr = construct_clauses.worker_expr;
7466 1556 : loop_clauses.seq = construct_clauses.seq;
7467 1556 : loop_clauses.par_auto = construct_clauses.par_auto;
7468 1556 : loop_clauses.independent = construct_clauses.independent;
7469 1556 : loop_clauses.tile_list = construct_clauses.tile_list;
7470 1556 : loop_clauses.lists[OMP_LIST_PRIVATE]
7471 1556 : = construct_clauses.lists[OMP_LIST_PRIVATE];
7472 1556 : loop_clauses.lists[OMP_LIST_REDUCTION]
7473 1556 : = construct_clauses.lists[OMP_LIST_REDUCTION];
7474 1556 : construct_clauses.gang = false;
7475 1556 : construct_clauses.gang_static = false;
7476 1556 : construct_clauses.gang_num_expr = NULL;
7477 1556 : construct_clauses.gang_static_expr = NULL;
7478 1556 : construct_clauses.vector = false;
7479 1556 : construct_clauses.vector_expr = NULL;
7480 1556 : construct_clauses.worker = false;
7481 1556 : construct_clauses.worker_expr = NULL;
7482 1556 : construct_clauses.seq = false;
7483 1556 : construct_clauses.par_auto = false;
7484 1556 : construct_clauses.independent = false;
7485 1556 : construct_clauses.independent = false;
7486 1556 : construct_clauses.tile_list = NULL;
7487 1556 : construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
7488 1556 : if (construct_code == OACC_KERNELS)
7489 87 : construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
7490 1556 : oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
7491 : code->loc, false, true);
7492 : }
7493 1556 : if (!loop_clauses.seq)
7494 : pblock = █
7495 : else
7496 54 : pushlevel ();
7497 1556 : stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
7498 1556 : protected_set_expr_location (stmt, loc);
7499 1556 : if (TREE_CODE (stmt) != BIND_EXPR)
7500 1556 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7501 : else
7502 0 : poplevel (0, 0);
7503 1556 : stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses);
7504 1556 : gfc_add_expr_to_block (&block, stmt);
7505 1556 : return gfc_finish_block (&block);
7506 : }
7507 :
7508 : static tree
7509 108 : gfc_trans_omp_depobj (gfc_code *code)
7510 : {
7511 108 : stmtblock_t block;
7512 108 : gfc_se se;
7513 108 : gfc_init_se (&se, NULL);
7514 108 : gfc_init_block (&block);
7515 108 : gfc_conv_expr (&se, code->ext.omp_clauses->depobj);
7516 108 : gcc_assert (se.pre.head == NULL && se.post.head == NULL);
7517 108 : tree depobj = se.expr;
7518 108 : location_t loc = EXPR_LOCATION (depobj);
7519 108 : if (!POINTER_TYPE_P (TREE_TYPE (depobj)))
7520 108 : depobj = gfc_build_addr_expr (NULL, depobj);
7521 108 : depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node,
7522 : TYPE_MODE (ptr_type_node),
7523 : true), depobj);
7524 108 : gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND];
7525 108 : if (n)
7526 : {
7527 83 : tree var;
7528 83 : if (!n->sym) /* omp_all_memory. */
7529 3 : var = null_pointer_node;
7530 80 : else if (n->expr && n->expr->ref->u.ar.type != AR_FULL)
7531 : {
7532 18 : gfc_init_se (&se, NULL);
7533 18 : if (n->expr->rank == 0)
7534 : {
7535 18 : gfc_conv_expr_reference (&se, n->expr);
7536 18 : var = se.expr;
7537 : }
7538 : else
7539 : {
7540 0 : gfc_conv_expr_descriptor (&se, n->expr);
7541 0 : var = gfc_conv_array_data (se.expr);
7542 : }
7543 18 : gfc_add_block_to_block (&block, &se.pre);
7544 18 : gfc_add_block_to_block (&block, &se.post);
7545 18 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
7546 : }
7547 : else
7548 : {
7549 62 : var = gfc_get_symbol_decl (n->sym);
7550 99 : if (POINTER_TYPE_P (TREE_TYPE (var))
7551 72 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var))))
7552 8 : var = build_fold_indirect_ref (var);
7553 62 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var)))
7554 : {
7555 12 : var = gfc_conv_descriptor_data_get (var);
7556 12 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
7557 : }
7558 50 : else if ((n->sym->attr.allocatable || n->sym->attr.pointer)
7559 13 : && n->sym->attr.dummy)
7560 8 : var = build_fold_indirect_ref (var);
7561 67 : else if (!POINTER_TYPE_P (TREE_TYPE (var))
7562 44 : || (n->sym->ts.f90_type == BT_VOID
7563 12 : && !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var)))
7564 8 : && !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var)))))
7565 : {
7566 29 : TREE_ADDRESSABLE (var) = 1;
7567 29 : var = gfc_build_addr_expr (NULL, var);
7568 : }
7569 : }
7570 83 : depobj = save_expr (depobj);
7571 83 : tree r = build_fold_indirect_ref_loc (loc, depobj);
7572 83 : gfc_add_expr_to_block (&block,
7573 : build2 (MODIFY_EXPR, void_type_node, r, var));
7574 : }
7575 :
7576 : /* Only one may be set. */
7577 108 : gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy)
7578 : + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET))
7579 : == 1);
7580 108 : int k = -1; /* omp_clauses->destroy */
7581 108 : if (!code->ext.omp_clauses->destroy)
7582 92 : switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET
7583 92 : ? code->ext.omp_clauses->depobj_update : n->u.depend_doacross_op)
7584 : {
7585 : case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break;
7586 : case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break;
7587 : case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break;
7588 : case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break;
7589 : case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break;
7590 0 : default: gcc_unreachable ();
7591 : }
7592 108 : tree t = build_int_cst (ptr_type_node, k);
7593 108 : depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj,
7594 108 : TYPE_SIZE_UNIT (ptr_type_node));
7595 108 : depobj = build_fold_indirect_ref_loc (loc, depobj);
7596 108 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t));
7597 :
7598 108 : return gfc_finish_block (&block);
7599 : }
7600 :
7601 : /* Callback for walk_tree to find an OMP dispatch call and wrap it into an
7602 : * IFN_GOMP_DISPATCH. */
7603 :
7604 : static tree
7605 2066 : replace_omp_dispatch_call (tree *tp, int *, void *decls_p)
7606 : {
7607 2066 : tree t = *tp;
7608 2066 : tree decls = (tree) decls_p;
7609 2066 : tree orig_fn_decl = TREE_PURPOSE (decls);
7610 2066 : tree dup_fn_decl = TREE_VALUE (decls);
7611 2066 : if (TREE_CODE (t) == CALL_EXPR)
7612 : {
7613 141 : if (CALL_EXPR_FN (t) == dup_fn_decl)
7614 1 : CALL_EXPR_FN (t) = orig_fn_decl;
7615 140 : else if (TREE_CODE (CALL_EXPR_FN (t)) == ADDR_EXPR
7616 140 : && TREE_OPERAND (CALL_EXPR_FN (t), 0) == dup_fn_decl)
7617 127 : TREE_OPERAND (CALL_EXPR_FN (t), 0) = dup_fn_decl;
7618 : else
7619 : return NULL_TREE;
7620 128 : *tp = build_call_expr_internal_loc (input_location, IFN_GOMP_DISPATCH,
7621 128 : TREE_TYPE (t), 1, t);
7622 128 : return *tp;
7623 : }
7624 :
7625 : return NULL_TREE;
7626 : }
7627 :
7628 : static tree
7629 128 : gfc_trans_omp_dispatch (gfc_code *code)
7630 : {
7631 128 : stmtblock_t block;
7632 128 : gfc_code *next = code->block->next;
7633 : // assume ill-formed "function dispatch structured
7634 : // block" have already been rejected by resolve_omp_dispatch
7635 128 : gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN);
7636 :
7637 : // Make duplicate decl for dispatch function call to make it easy to spot
7638 : // after translation
7639 128 : gfc_symbol *orig_fn_sym;
7640 128 : gfc_expr *call_expr = next->op == EXEC_CALL ? next->expr1 : next->expr2;
7641 128 : if (call_expr != NULL) // function
7642 : {
7643 71 : if (call_expr->value.function.isym != NULL) // dig into convert intrinsics
7644 4 : call_expr = call_expr->value.function.actual->expr;
7645 71 : gcc_assert (call_expr->expr_type == EXPR_FUNCTION);
7646 71 : orig_fn_sym = call_expr->value.function.esym
7647 71 : ? call_expr->value.function.esym
7648 0 : : call_expr->symtree->n.sym;
7649 : }
7650 : else // subroutine
7651 : {
7652 57 : orig_fn_sym = next->resolved_sym;
7653 : }
7654 128 : if (!orig_fn_sym->backend_decl)
7655 25 : gfc_get_symbol_decl (orig_fn_sym);
7656 128 : gfc_symbol dup_fn_sym = *orig_fn_sym;
7657 128 : dup_fn_sym.backend_decl = copy_node (orig_fn_sym->backend_decl);
7658 128 : if (call_expr != NULL)
7659 71 : call_expr->value.function.esym = &dup_fn_sym;
7660 : else
7661 57 : next->resolved_sym = &dup_fn_sym;
7662 :
7663 128 : tree body = gfc_trans_code (next);
7664 :
7665 : // Walk the tree to find the duplicate decl, wrap IFN call and replace
7666 : // dup decl with original
7667 128 : tree fn_decls
7668 128 : = build_tree_list (orig_fn_sym->backend_decl, dup_fn_sym.backend_decl);
7669 128 : tree dispatch_call
7670 128 : = walk_tree (&body, replace_omp_dispatch_call, fn_decls, NULL);
7671 128 : gcc_assert (dispatch_call != NULL_TREE);
7672 :
7673 128 : gfc_start_block (&block);
7674 128 : tree omp_clauses
7675 128 : = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc);
7676 :
7677 : // Extract depend clauses and create taskwait
7678 128 : tree depend_clauses = NULL_TREE;
7679 128 : tree *depend_clauses_ptr = &depend_clauses;
7680 333 : for (tree c = omp_clauses; c; c = OMP_CLAUSE_CHAIN (c))
7681 : {
7682 205 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_DEPEND)
7683 : {
7684 8 : *depend_clauses_ptr = c;
7685 8 : depend_clauses_ptr = &OMP_CLAUSE_CHAIN (c);
7686 : }
7687 : }
7688 128 : if (depend_clauses != NULL_TREE)
7689 : {
7690 4 : tree stmt = make_node (OMP_TASK);
7691 4 : TREE_TYPE (stmt) = void_node;
7692 4 : OMP_TASK_CLAUSES (stmt) = depend_clauses;
7693 4 : OMP_TASK_BODY (stmt) = NULL_TREE;
7694 4 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7695 4 : gfc_add_expr_to_block (&block, stmt);
7696 : }
7697 :
7698 128 : tree stmt = make_node (OMP_DISPATCH);
7699 128 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7700 128 : TREE_TYPE (stmt) = void_type_node;
7701 128 : OMP_DISPATCH_BODY (stmt) = body;
7702 128 : OMP_DISPATCH_CLAUSES (stmt) = omp_clauses;
7703 :
7704 128 : gfc_add_expr_to_block (&block, stmt);
7705 128 : return gfc_finish_block (&block);
7706 : }
7707 :
7708 : static tree
7709 29 : gfc_trans_omp_error (gfc_code *code)
7710 : {
7711 29 : stmtblock_t block;
7712 29 : gfc_se se;
7713 29 : tree len, message;
7714 29 : bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
7715 42 : tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR
7716 : : BUILT_IN_GOMP_WARNING);
7717 29 : gfc_start_block (&block);
7718 29 : gfc_init_se (&se, NULL );
7719 29 : if (!code->ext.omp_clauses->message)
7720 : {
7721 3 : message = null_pointer_node;
7722 3 : len = build_int_cst (size_type_node, 0);
7723 : }
7724 : else
7725 : {
7726 26 : gfc_conv_expr (&se, code->ext.omp_clauses->message);
7727 26 : message = se.expr;
7728 26 : if (!POINTER_TYPE_P (TREE_TYPE (message)))
7729 : /* To ensure an ARRAY_TYPE is not passed as such. */
7730 17 : message = gfc_build_addr_expr (NULL, message);
7731 26 : len = se.string_length;
7732 : }
7733 29 : gfc_add_block_to_block (&block, &se.pre);
7734 29 : gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
7735 : 2, message, len));
7736 29 : gfc_add_block_to_block (&block, &se.post);
7737 29 : return gfc_finish_block (&block);
7738 : }
7739 :
7740 : static tree
7741 70 : gfc_trans_omp_flush (gfc_code *code)
7742 : {
7743 70 : tree call;
7744 70 : if (!code->ext.omp_clauses
7745 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET
7746 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST)
7747 : {
7748 67 : call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
7749 67 : call = build_call_expr_loc (input_location, call, 0);
7750 : }
7751 : else
7752 : {
7753 3 : enum memmodel mo = MEMMODEL_LAST;
7754 3 : switch (code->ext.omp_clauses->memorder)
7755 : {
7756 : case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break;
7757 : case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break;
7758 : case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break;
7759 0 : default: gcc_unreachable (); break;
7760 : }
7761 3 : call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE);
7762 3 : call = build_call_expr_loc (input_location, call, 1,
7763 3 : build_int_cst (integer_type_node, mo));
7764 : }
7765 70 : return call;
7766 : }
7767 :
7768 : static tree
7769 116 : gfc_trans_omp_master (gfc_code *code)
7770 : {
7771 116 : tree stmt = gfc_trans_code (code->block->next);
7772 116 : if (IS_EMPTY_STMT (stmt))
7773 : return stmt;
7774 110 : return build1_v (OMP_MASTER, stmt);
7775 : }
7776 :
7777 : static tree
7778 49 : gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses)
7779 : {
7780 49 : stmtblock_t block;
7781 49 : tree body = gfc_trans_code (code->block->next);
7782 49 : if (IS_EMPTY_STMT (body))
7783 : return body;
7784 40 : if (!clauses)
7785 33 : clauses = code->ext.omp_clauses;
7786 40 : gfc_start_block (&block);
7787 40 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
7788 40 : tree stmt = make_node (OMP_MASKED);
7789 40 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7790 40 : TREE_TYPE (stmt) = void_type_node;
7791 40 : OMP_MASKED_BODY (stmt) = body;
7792 40 : OMP_MASKED_CLAUSES (stmt) = omp_clauses;
7793 40 : gfc_add_expr_to_block (&block, stmt);
7794 40 : return gfc_finish_block (&block);
7795 : }
7796 :
7797 :
7798 : static tree
7799 521 : gfc_trans_omp_ordered (gfc_code *code)
7800 : {
7801 521 : if (!flag_openmp)
7802 : {
7803 5 : if (!code->ext.omp_clauses->simd)
7804 3 : return gfc_trans_code (code->block ? code->block->next : NULL);
7805 2 : code->ext.omp_clauses->threads = 0;
7806 : }
7807 518 : tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses,
7808 : code->loc);
7809 518 : return build2_loc (input_location, OMP_ORDERED, void_type_node,
7810 518 : code->block ? gfc_trans_code (code->block->next)
7811 518 : : NULL_TREE, omp_clauses);
7812 : }
7813 :
7814 : static tree
7815 1875 : gfc_trans_omp_parallel (gfc_code *code)
7816 : {
7817 1875 : stmtblock_t block;
7818 1875 : tree stmt, omp_clauses;
7819 :
7820 1875 : gfc_start_block (&block);
7821 1875 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
7822 : code->loc);
7823 1875 : pushlevel ();
7824 1875 : stmt = gfc_trans_omp_code (code->block->next, true);
7825 1875 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7826 1875 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
7827 : omp_clauses);
7828 1875 : gfc_add_expr_to_block (&block, stmt);
7829 1875 : return gfc_finish_block (&block);
7830 : }
7831 :
7832 : enum
7833 : {
7834 : GFC_OMP_SPLIT_SIMD,
7835 : GFC_OMP_SPLIT_DO,
7836 : GFC_OMP_SPLIT_PARALLEL,
7837 : GFC_OMP_SPLIT_DISTRIBUTE,
7838 : GFC_OMP_SPLIT_TEAMS,
7839 : GFC_OMP_SPLIT_TARGET,
7840 : GFC_OMP_SPLIT_TASKLOOP,
7841 : GFC_OMP_SPLIT_MASKED,
7842 : GFC_OMP_SPLIT_NUM
7843 : };
7844 :
7845 : enum
7846 : {
7847 : GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
7848 : GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
7849 : GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
7850 : GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
7851 : GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
7852 : GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET),
7853 : GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP),
7854 : GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED)
7855 : };
7856 :
7857 : /* If a var is in lastprivate/firstprivate/reduction but not in a
7858 : data mapping/sharing clause, add it to 'map(tofrom:' if is_target
7859 : and to 'shared' otherwise. */
7860 : static void
7861 2537 : gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out,
7862 : gfc_omp_clauses *clauses_in,
7863 : bool is_target, bool is_parallel_do)
7864 : {
7865 2537 : int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED;
7866 2537 : gfc_omp_namelist *tail = NULL;
7867 15222 : for (int i = 0; i < 5; ++i)
7868 : {
7869 12685 : gfc_omp_namelist *n;
7870 12685 : switch (i)
7871 : {
7872 2537 : case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break;
7873 2537 : case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break;
7874 2537 : case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break;
7875 2537 : case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break;
7876 2537 : case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break;
7877 : default: gcc_unreachable ();
7878 : }
7879 16027 : for (; n != NULL; n = n->next)
7880 : {
7881 : gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL;
7882 20683 : for (int j = 0; j < 6; ++j)
7883 : {
7884 18213 : gfc_omp_namelist **n2ref = NULL, *prev2 = NULL;
7885 18213 : switch (j)
7886 : {
7887 3342 : case 0:
7888 3342 : n2ref = &clauses_out->lists[clauselist_to_add];
7889 3342 : break;
7890 3305 : case 1:
7891 3305 : n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
7892 3305 : break;
7893 3305 : case 2:
7894 3305 : if (is_target)
7895 256 : n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE];
7896 : else
7897 3049 : n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE];
7898 : break;
7899 3305 : case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break;
7900 2478 : case 4:
7901 2478 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN];
7902 2478 : break;
7903 2478 : case 5:
7904 2478 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK];
7905 2478 : break;
7906 : default: gcc_unreachable ();
7907 : }
7908 28487 : for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next)
7909 13540 : if (n2->sym == n->sym)
7910 : break;
7911 18213 : if (n2)
7912 : {
7913 3266 : if (j == 0 /* clauselist_to_add */)
7914 : break; /* Already present. */
7915 3229 : if (j == 1 /* OMP_LIST_FIRSTPRIVATE */)
7916 : {
7917 1128 : n_firstp = prev2 ? &prev2->next : n2ref;
7918 1128 : continue;
7919 : }
7920 2101 : if (j == 2 /* OMP_LIST_LASTPRIVATE */)
7921 : {
7922 1266 : n_lastp = prev2 ? &prev2->next : n2ref;
7923 1266 : continue;
7924 : }
7925 : break;
7926 : }
7927 : }
7928 3342 : if (n_firstp && n_lastp)
7929 : {
7930 : /* For parallel do, GCC puts firstprivate/lastprivate
7931 : on the parallel. */
7932 283 : if (is_parallel_do)
7933 280 : continue;
7934 3 : *n_firstp = (*n_firstp)->next;
7935 3 : if (!is_target)
7936 0 : *n_lastp = (*n_lastp)->next;
7937 : }
7938 3059 : else if (is_target && n_lastp)
7939 : ;
7940 3004 : else if (n2 || n_firstp || n_lastp)
7941 2645 : continue;
7942 417 : if (clauses_out->lists[clauselist_to_add]
7943 305 : && (clauses_out->lists[clauselist_to_add]
7944 305 : == clauses_in->lists[clauselist_to_add]))
7945 : {
7946 : gfc_omp_namelist *p = NULL;
7947 421 : for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next)
7948 : {
7949 273 : if (p)
7950 : {
7951 125 : p->next = gfc_get_omp_namelist ();
7952 125 : p = p->next;
7953 : }
7954 : else
7955 : {
7956 148 : p = gfc_get_omp_namelist ();
7957 148 : clauses_out->lists[clauselist_to_add] = p;
7958 : }
7959 273 : *p = *n2;
7960 : }
7961 : }
7962 417 : if (!tail)
7963 : {
7964 288 : tail = clauses_out->lists[clauselist_to_add];
7965 413 : for (; tail && tail->next; tail = tail->next)
7966 : ;
7967 : }
7968 417 : n2 = gfc_get_omp_namelist ();
7969 417 : n2->where = n->where;
7970 417 : n2->sym = n->sym;
7971 417 : if (is_target)
7972 120 : n2->u.map.op = OMP_MAP_TOFROM;
7973 417 : if (tail)
7974 : {
7975 305 : tail->next = n2;
7976 305 : tail = n2;
7977 : }
7978 : else
7979 112 : clauses_out->lists[clauselist_to_add] = n2;
7980 : }
7981 : }
7982 2537 : }
7983 :
7984 : /* Kind of opposite to above, add firstprivate to CLAUSES_OUT if it is mapped
7985 : in CLAUSES_IN's FIRSTPRIVATE list but not its MAP list. */
7986 :
7987 : static void
7988 341 : gfc_add_firstprivate_if_unmapped (gfc_omp_clauses *clauses_out,
7989 : gfc_omp_clauses *clauses_in)
7990 : {
7991 341 : gfc_omp_namelist *n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE];
7992 341 : gfc_omp_namelist **tail = NULL;
7993 :
7994 491 : for (; n != NULL; n = n->next)
7995 : {
7996 150 : gfc_omp_namelist *n2 = clauses_out->lists[OMP_LIST_MAP];
7997 192 : for (; n2 != NULL; n2 = n2->next)
7998 53 : if (n->sym == n2->sym)
7999 : break;
8000 150 : if (n2 == NULL)
8001 : {
8002 139 : gfc_omp_namelist *dup = gfc_get_omp_namelist ();
8003 139 : *dup = *n;
8004 139 : dup->next = NULL;
8005 139 : if (!tail)
8006 : {
8007 76 : tail = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
8008 76 : while (*tail && (*tail)->next)
8009 0 : tail = &(*tail)->next;
8010 : }
8011 139 : *tail = dup;
8012 139 : tail = &(*tail)->next;
8013 : }
8014 : }
8015 341 : }
8016 :
8017 : static void
8018 4182 : gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa)
8019 : {
8020 37638 : for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i)
8021 1338240 : for (int j = 0; j < OMP_LIST_NUM; ++j)
8022 1304784 : if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j])
8023 1399 : for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;)
8024 : {
8025 957 : gfc_omp_namelist *p = n;
8026 957 : n = n->next;
8027 957 : free (p);
8028 : }
8029 4182 : }
8030 :
8031 : static void
8032 4182 : gfc_split_omp_clauses (gfc_code *code,
8033 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
8034 : {
8035 4182 : int mask = 0, innermost = 0;
8036 4182 : bool is_loop = false;
8037 4182 : memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
8038 4182 : switch (code->op)
8039 : {
8040 : case EXEC_OMP_DISTRIBUTE:
8041 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
8042 : break;
8043 38 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8044 38 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8045 38 : innermost = GFC_OMP_SPLIT_DO;
8046 38 : break;
8047 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8048 28 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
8049 : | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8050 28 : innermost = GFC_OMP_SPLIT_SIMD;
8051 28 : break;
8052 47 : case EXEC_OMP_DISTRIBUTE_SIMD:
8053 47 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8054 47 : innermost = GFC_OMP_SPLIT_SIMD;
8055 47 : break;
8056 0 : case EXEC_OMP_DO:
8057 0 : case EXEC_OMP_LOOP:
8058 0 : innermost = GFC_OMP_SPLIT_DO;
8059 0 : break;
8060 126 : case EXEC_OMP_DO_SIMD:
8061 126 : mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8062 126 : innermost = GFC_OMP_SPLIT_SIMD;
8063 126 : break;
8064 0 : case EXEC_OMP_PARALLEL:
8065 0 : innermost = GFC_OMP_SPLIT_PARALLEL;
8066 0 : break;
8067 1113 : case EXEC_OMP_PARALLEL_DO:
8068 1113 : case EXEC_OMP_PARALLEL_LOOP:
8069 1113 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8070 1113 : innermost = GFC_OMP_SPLIT_DO;
8071 1113 : break;
8072 285 : case EXEC_OMP_PARALLEL_DO_SIMD:
8073 285 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8074 285 : innermost = GFC_OMP_SPLIT_SIMD;
8075 285 : break;
8076 11 : case EXEC_OMP_PARALLEL_MASKED:
8077 11 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED;
8078 11 : innermost = GFC_OMP_SPLIT_MASKED;
8079 11 : break;
8080 14 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8081 14 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
8082 : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
8083 14 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8084 14 : break;
8085 20 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8086 20 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8087 20 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8088 20 : break;
8089 24 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8090 24 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
8091 : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
8092 24 : innermost = GFC_OMP_SPLIT_SIMD;
8093 24 : break;
8094 28 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8095 28 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8096 28 : innermost = GFC_OMP_SPLIT_SIMD;
8097 28 : break;
8098 0 : case EXEC_OMP_SIMD:
8099 0 : innermost = GFC_OMP_SPLIT_SIMD;
8100 0 : break;
8101 1761 : case EXEC_OMP_TARGET:
8102 1761 : innermost = GFC_OMP_SPLIT_TARGET;
8103 1761 : break;
8104 21 : case EXEC_OMP_TARGET_PARALLEL:
8105 21 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
8106 21 : innermost = GFC_OMP_SPLIT_PARALLEL;
8107 21 : break;
8108 80 : case EXEC_OMP_TARGET_PARALLEL_DO:
8109 80 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8110 80 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8111 80 : innermost = GFC_OMP_SPLIT_DO;
8112 80 : break;
8113 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
8114 15 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
8115 : | GFC_OMP_MASK_SIMD;
8116 15 : innermost = GFC_OMP_SPLIT_SIMD;
8117 15 : break;
8118 26 : case EXEC_OMP_TARGET_SIMD:
8119 26 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
8120 26 : innermost = GFC_OMP_SPLIT_SIMD;
8121 26 : break;
8122 69 : case EXEC_OMP_TARGET_TEAMS:
8123 69 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
8124 69 : innermost = GFC_OMP_SPLIT_TEAMS;
8125 69 : break;
8126 14 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8127 14 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
8128 : | GFC_OMP_MASK_DISTRIBUTE;
8129 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
8130 14 : break;
8131 58 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8132 58 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8133 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8134 58 : innermost = GFC_OMP_SPLIT_DO;
8135 58 : break;
8136 29 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8137 29 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8138 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8139 29 : innermost = GFC_OMP_SPLIT_SIMD;
8140 29 : break;
8141 16 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8142 16 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
8143 : | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8144 16 : innermost = GFC_OMP_SPLIT_SIMD;
8145 16 : break;
8146 13 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8147 13 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
8148 13 : innermost = GFC_OMP_SPLIT_DO;
8149 13 : break;
8150 8 : case EXEC_OMP_MASKED_TASKLOOP:
8151 8 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP;
8152 8 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8153 8 : break;
8154 0 : case EXEC_OMP_MASTER_TASKLOOP:
8155 0 : case EXEC_OMP_TASKLOOP:
8156 0 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8157 0 : break;
8158 24 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8159 24 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8160 24 : innermost = GFC_OMP_SPLIT_SIMD;
8161 24 : break;
8162 45 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8163 45 : case EXEC_OMP_TASKLOOP_SIMD:
8164 45 : mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8165 45 : innermost = GFC_OMP_SPLIT_SIMD;
8166 45 : break;
8167 124 : case EXEC_OMP_TEAMS:
8168 124 : innermost = GFC_OMP_SPLIT_TEAMS;
8169 124 : break;
8170 14 : case EXEC_OMP_TEAMS_DISTRIBUTE:
8171 14 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
8172 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
8173 14 : break;
8174 32 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8175 32 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8176 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8177 32 : innermost = GFC_OMP_SPLIT_DO;
8178 32 : break;
8179 56 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8180 56 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8181 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8182 56 : innermost = GFC_OMP_SPLIT_SIMD;
8183 56 : break;
8184 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8185 37 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8186 37 : innermost = GFC_OMP_SPLIT_SIMD;
8187 37 : break;
8188 : case EXEC_OMP_TEAMS_LOOP:
8189 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
8190 : innermost = GFC_OMP_SPLIT_DO;
8191 : break;
8192 0 : default:
8193 0 : gcc_unreachable ();
8194 : }
8195 4176 : if (mask == 0)
8196 : {
8197 1885 : clausesa[innermost] = *code->ext.omp_clauses;
8198 1885 : return;
8199 : }
8200 : /* Loops are similar to DO but still a bit different. */
8201 2297 : switch (code->op)
8202 : {
8203 54 : case EXEC_OMP_LOOP:
8204 54 : case EXEC_OMP_PARALLEL_LOOP:
8205 54 : case EXEC_OMP_TEAMS_LOOP:
8206 54 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8207 54 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8208 54 : is_loop = true;
8209 2297 : default:
8210 2297 : break;
8211 : }
8212 2297 : if (code->ext.omp_clauses != NULL)
8213 : {
8214 2297 : if (mask & GFC_OMP_MASK_TARGET)
8215 : {
8216 : /* First the clauses that are unique to some constructs. */
8217 341 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
8218 341 : = code->ext.omp_clauses->lists[OMP_LIST_MAP];
8219 341 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR]
8220 341 : = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
8221 341 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_HAS_DEVICE_ADDR]
8222 341 : = code->ext.omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
8223 341 : clausesa[GFC_OMP_SPLIT_TARGET].device
8224 341 : = code->ext.omp_clauses->device;
8225 341 : clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
8226 341 : = code->ext.omp_clauses->thread_limit;
8227 341 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS]
8228 341 : = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS];
8229 2387 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
8230 2046 : clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
8231 2046 : = code->ext.omp_clauses->defaultmap[i];
8232 341 : clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
8233 341 : = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
8234 : /* And this is copied to all. */
8235 341 : clausesa[GFC_OMP_SPLIT_TARGET].if_expr
8236 341 : = code->ext.omp_clauses->if_expr;
8237 341 : clausesa[GFC_OMP_SPLIT_TARGET].nowait
8238 341 : = code->ext.omp_clauses->nowait;
8239 341 : clausesa[GFC_OMP_SPLIT_TARGET].device_type
8240 341 : = code->ext.omp_clauses->device_type;
8241 : }
8242 2297 : if (mask & GFC_OMP_MASK_TEAMS)
8243 : {
8244 : /* First the clauses that are unique to some constructs. */
8245 344 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
8246 344 : = code->ext.omp_clauses->num_teams_lower;
8247 344 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
8248 344 : = code->ext.omp_clauses->num_teams_upper;
8249 344 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
8250 344 : = code->ext.omp_clauses->thread_limit;
8251 : /* Shared and default clauses are allowed on parallel, teams
8252 : and taskloop. */
8253 344 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
8254 344 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8255 344 : clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
8256 344 : = code->ext.omp_clauses->default_sharing;
8257 : }
8258 2297 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
8259 : {
8260 : /* First the clauses that are unique to some constructs. */
8261 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
8262 369 : = code->ext.omp_clauses->dist_sched_kind;
8263 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
8264 369 : = code->ext.omp_clauses->dist_chunk_size;
8265 : /* Duplicate collapse. */
8266 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
8267 369 : = code->ext.omp_clauses->collapse;
8268 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent
8269 369 : = code->ext.omp_clauses->order_concurrent;
8270 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained
8271 369 : = code->ext.omp_clauses->order_unconstrained;
8272 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible
8273 369 : = code->ext.omp_clauses->order_reproducible;
8274 : }
8275 2297 : if (mask & GFC_OMP_MASK_PARALLEL)
8276 : {
8277 : /* First the clauses that are unique to some constructs. */
8278 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
8279 1852 : = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
8280 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
8281 1852 : = code->ext.omp_clauses->num_threads;
8282 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
8283 1852 : = code->ext.omp_clauses->proc_bind;
8284 : /* Shared and default clauses are allowed on parallel, teams
8285 : and taskloop. */
8286 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
8287 1852 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8288 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
8289 1852 : = code->ext.omp_clauses->default_sharing;
8290 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
8291 1852 : = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
8292 : /* And this is copied to all. */
8293 1852 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
8294 1852 : = code->ext.omp_clauses->if_expr;
8295 : }
8296 2297 : if (mask & GFC_OMP_MASK_MASKED)
8297 81 : clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter;
8298 2297 : if ((mask & GFC_OMP_MASK_DO) && !is_loop)
8299 : {
8300 : /* First the clauses that are unique to some constructs. */
8301 1825 : clausesa[GFC_OMP_SPLIT_DO].ordered
8302 1825 : = code->ext.omp_clauses->ordered;
8303 1825 : clausesa[GFC_OMP_SPLIT_DO].orderedc
8304 1825 : = code->ext.omp_clauses->orderedc;
8305 1825 : clausesa[GFC_OMP_SPLIT_DO].sched_kind
8306 1825 : = code->ext.omp_clauses->sched_kind;
8307 1825 : if (innermost == GFC_OMP_SPLIT_SIMD)
8308 539 : clausesa[GFC_OMP_SPLIT_DO].sched_simd
8309 539 : = code->ext.omp_clauses->sched_simd;
8310 1825 : clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
8311 1825 : = code->ext.omp_clauses->sched_monotonic;
8312 1825 : clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
8313 1825 : = code->ext.omp_clauses->sched_nonmonotonic;
8314 1825 : clausesa[GFC_OMP_SPLIT_DO].chunk_size
8315 1825 : = code->ext.omp_clauses->chunk_size;
8316 1825 : clausesa[GFC_OMP_SPLIT_DO].nowait
8317 1825 : = code->ext.omp_clauses->nowait;
8318 : }
8319 1879 : if (mask & GFC_OMP_MASK_DO)
8320 : {
8321 1879 : clausesa[GFC_OMP_SPLIT_DO].bind
8322 1879 : = code->ext.omp_clauses->bind;
8323 : /* Duplicate collapse. */
8324 1879 : clausesa[GFC_OMP_SPLIT_DO].collapse
8325 1879 : = code->ext.omp_clauses->collapse;
8326 1879 : clausesa[GFC_OMP_SPLIT_DO].order_concurrent
8327 1879 : = code->ext.omp_clauses->order_concurrent;
8328 1879 : clausesa[GFC_OMP_SPLIT_DO].order_unconstrained
8329 1879 : = code->ext.omp_clauses->order_unconstrained;
8330 1879 : clausesa[GFC_OMP_SPLIT_DO].order_reproducible
8331 1879 : = code->ext.omp_clauses->order_reproducible;
8332 : }
8333 2297 : if (mask & GFC_OMP_MASK_SIMD)
8334 : {
8335 820 : clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
8336 820 : = code->ext.omp_clauses->safelen_expr;
8337 820 : clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
8338 820 : = code->ext.omp_clauses->simdlen_expr;
8339 820 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
8340 820 : = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
8341 : /* Duplicate collapse. */
8342 820 : clausesa[GFC_OMP_SPLIT_SIMD].collapse
8343 820 : = code->ext.omp_clauses->collapse;
8344 820 : clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD]
8345 820 : = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD];
8346 820 : clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent
8347 820 : = code->ext.omp_clauses->order_concurrent;
8348 820 : clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained
8349 820 : = code->ext.omp_clauses->order_unconstrained;
8350 820 : clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible
8351 820 : = code->ext.omp_clauses->order_reproducible;
8352 : /* And this is copied to all. */
8353 820 : clausesa[GFC_OMP_SPLIT_SIMD].if_expr
8354 820 : = code->ext.omp_clauses->if_expr;
8355 : }
8356 2297 : if (mask & GFC_OMP_MASK_TASKLOOP)
8357 : {
8358 : /* First the clauses that are unique to some constructs. */
8359 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
8360 163 : = code->ext.omp_clauses->nogroup;
8361 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
8362 163 : = code->ext.omp_clauses->grainsize;
8363 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict
8364 163 : = code->ext.omp_clauses->grainsize_strict;
8365 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
8366 163 : = code->ext.omp_clauses->num_tasks;
8367 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict
8368 163 : = code->ext.omp_clauses->num_tasks_strict;
8369 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
8370 163 : = code->ext.omp_clauses->priority;
8371 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
8372 163 : = code->ext.omp_clauses->final_expr;
8373 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
8374 163 : = code->ext.omp_clauses->untied;
8375 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
8376 163 : = code->ext.omp_clauses->mergeable;
8377 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
8378 163 : = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
8379 : /* And this is copied to all. */
8380 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
8381 163 : = code->ext.omp_clauses->if_expr;
8382 : /* Shared and default clauses are allowed on parallel, teams
8383 : and taskloop. */
8384 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
8385 163 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8386 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
8387 163 : = code->ext.omp_clauses->default_sharing;
8388 : /* Duplicate collapse. */
8389 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
8390 163 : = code->ext.omp_clauses->collapse;
8391 : }
8392 : /* Private clause is supported on all constructs but master/masked,
8393 : it is enough to put it on the innermost one except for master/masked. For
8394 : !$ omp parallel do put it on parallel though,
8395 : as that's what we did for OpenMP 3.1. */
8396 2297 : clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop)
8397 : || code->op == EXEC_OMP_PARALLEL_MASTER
8398 1011 : || code->op == EXEC_OMP_PARALLEL_MASKED)
8399 1000 : ? (int) GFC_OMP_SPLIT_PARALLEL
8400 3297 : : innermost].lists[OMP_LIST_PRIVATE]
8401 2297 : = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
8402 : /* Firstprivate clause is supported on all constructs but
8403 : simd and masked/master. Put it on the outermost of those and duplicate
8404 : on parallel and teams. */
8405 2297 : if (mask & GFC_OMP_MASK_TARGET)
8406 341 : gfc_add_firstprivate_if_unmapped (&clausesa[GFC_OMP_SPLIT_TARGET],
8407 : code->ext.omp_clauses);
8408 2297 : if (mask & GFC_OMP_MASK_TEAMS)
8409 344 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
8410 344 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8411 1953 : else if (mask & GFC_OMP_MASK_DISTRIBUTE)
8412 113 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
8413 113 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8414 2297 : if (mask & GFC_OMP_MASK_TASKLOOP)
8415 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE]
8416 163 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8417 2297 : if ((mask & GFC_OMP_MASK_PARALLEL)
8418 1852 : && !(mask & GFC_OMP_MASK_TASKLOOP))
8419 1766 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
8420 1766 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8421 531 : else if ((mask & GFC_OMP_MASK_DO) && !is_loop)
8422 126 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
8423 126 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8424 : /* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
8425 : In parallel do{, simd} we actually want to put it on
8426 : parallel rather than do. */
8427 2297 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
8428 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
8429 369 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8430 2297 : if (mask & GFC_OMP_MASK_TASKLOOP)
8431 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE]
8432 163 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8433 2297 : if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop
8434 1817 : && !(mask & GFC_OMP_MASK_TASKLOOP))
8435 1731 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
8436 1731 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8437 566 : else if (mask & GFC_OMP_MASK_DO)
8438 180 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
8439 180 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8440 2297 : if (mask & GFC_OMP_MASK_SIMD)
8441 820 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
8442 820 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8443 : /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop.
8444 : Duplicate it on all of them, but
8445 : - omit on do if parallel is present;
8446 : - omit on task and parallel if loop is present;
8447 : additionally, inscan applies to do/simd only. */
8448 9188 : for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++)
8449 : {
8450 6891 : if (mask & GFC_OMP_MASK_TASKLOOP
8451 489 : && i != OMP_LIST_REDUCTION_INSCAN)
8452 326 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i]
8453 326 : = code->ext.omp_clauses->lists[i];
8454 6891 : if (mask & GFC_OMP_MASK_TEAMS
8455 1032 : && i != OMP_LIST_REDUCTION_INSCAN
8456 1032 : && !is_loop)
8457 650 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[i]
8458 650 : = code->ext.omp_clauses->lists[i];
8459 6891 : if (mask & GFC_OMP_MASK_PARALLEL
8460 5556 : && i != OMP_LIST_REDUCTION_INSCAN
8461 3704 : && !(mask & GFC_OMP_MASK_TASKLOOP)
8462 3532 : && !is_loop)
8463 3462 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
8464 3462 : = code->ext.omp_clauses->lists[i];
8465 3429 : else if (mask & GFC_OMP_MASK_DO)
8466 2239 : clausesa[GFC_OMP_SPLIT_DO].lists[i]
8467 2239 : = code->ext.omp_clauses->lists[i];
8468 6891 : if (mask & GFC_OMP_MASK_SIMD)
8469 2460 : clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
8470 2460 : = code->ext.omp_clauses->lists[i];
8471 : }
8472 2297 : if (mask & GFC_OMP_MASK_TARGET)
8473 341 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION]
8474 341 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
8475 2297 : if (mask & GFC_OMP_MASK_TASKLOOP)
8476 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION]
8477 163 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
8478 : /* Linear clause is supported on do and simd,
8479 : put it on the innermost one. */
8480 2297 : clausesa[innermost].lists[OMP_LIST_LINEAR]
8481 2297 : = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
8482 : }
8483 : /* Propagate firstprivate/lastprivate/reduction vars to
8484 : shared (parallel, teams) and map-tofrom (target). */
8485 2297 : if (mask & GFC_OMP_MASK_TARGET)
8486 341 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET],
8487 : code->ext.omp_clauses, true, false);
8488 2297 : if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL)
8489 1852 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL],
8490 : code->ext.omp_clauses, false,
8491 1852 : mask & GFC_OMP_MASK_DO);
8492 2297 : if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS)
8493 344 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS],
8494 : code->ext.omp_clauses, false, false);
8495 2297 : if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
8496 : == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
8497 1734 : && !is_loop)
8498 1699 : clausesa[GFC_OMP_SPLIT_DO].nowait = true;
8499 :
8500 : /* Distribute allocate clause to do, parallel, distribute, teams, target
8501 : and taskloop. The code below iterates over variables in the
8502 : allocate list and checks if that available is also in any
8503 : privatization clause on those construct. If yes, then we add it
8504 : to the list of 'allocate'ed variables for that construct. If a
8505 : variable is found in none of them then we issue an error. */
8506 :
8507 2297 : if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE])
8508 : {
8509 : gfc_omp_namelist *alloc_nl, *priv_nl;
8510 : gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM];
8511 104 : for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
8512 181 : alloc_nl; alloc_nl = alloc_nl->next)
8513 : {
8514 : bool found = false;
8515 728 : for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++)
8516 : {
8517 : gfc_omp_namelist *p;
8518 : int list;
8519 24960 : for (list = 0; list < OMP_LIST_NUM; list++)
8520 : {
8521 24336 : switch (list)
8522 : {
8523 5616 : case OMP_LIST_PRIVATE:
8524 5616 : case OMP_LIST_FIRSTPRIVATE:
8525 5616 : case OMP_LIST_LASTPRIVATE:
8526 5616 : case OMP_LIST_REDUCTION:
8527 5616 : case OMP_LIST_REDUCTION_INSCAN:
8528 5616 : case OMP_LIST_REDUCTION_TASK:
8529 5616 : case OMP_LIST_IN_REDUCTION:
8530 5616 : case OMP_LIST_TASK_REDUCTION:
8531 5616 : case OMP_LIST_LINEAR:
8532 6092 : for (priv_nl = clausesa[i].lists[list]; priv_nl;
8533 476 : priv_nl = priv_nl->next)
8534 476 : if (alloc_nl->sym == priv_nl->sym)
8535 : {
8536 131 : found = true;
8537 131 : p = gfc_get_omp_namelist ();
8538 131 : p->sym = alloc_nl->sym;
8539 131 : p->expr = alloc_nl->expr;
8540 131 : p->u.align = alloc_nl->u.align;
8541 131 : p->u2.allocator = alloc_nl->u2.allocator;
8542 131 : p->where = alloc_nl->where;
8543 131 : if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
8544 : {
8545 109 : clausesa[i].lists[OMP_LIST_ALLOCATE] = p;
8546 109 : tails[i] = p;
8547 : }
8548 : else
8549 : {
8550 22 : tails[i]->next = p;
8551 22 : tails[i] = tails[i]->next;
8552 : }
8553 : }
8554 : break;
8555 : default:
8556 : break;
8557 : }
8558 : }
8559 : }
8560 104 : if (!found)
8561 1 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
8562 : "in an explicit privatization clause",
8563 1 : alloc_nl->sym->name, &alloc_nl->where);
8564 : }
8565 : }
8566 : }
8567 :
8568 : static tree
8569 539 : gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
8570 : gfc_omp_clauses *clausesa, tree omp_clauses)
8571 : {
8572 539 : stmtblock_t block;
8573 539 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8574 539 : tree stmt, body, omp_do_clauses = NULL_TREE;
8575 539 : bool free_clausesa = false;
8576 :
8577 539 : if (pblock == NULL)
8578 411 : gfc_start_block (&block);
8579 : else
8580 128 : gfc_init_block (&block);
8581 :
8582 539 : if (clausesa == NULL)
8583 : {
8584 126 : clausesa = clausesa_buf;
8585 126 : gfc_split_omp_clauses (code, clausesa);
8586 126 : free_clausesa = true;
8587 : }
8588 539 : if (flag_openmp)
8589 534 : omp_do_clauses
8590 534 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
8591 667 : body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
8592 : &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
8593 539 : if (pblock == NULL)
8594 : {
8595 411 : if (TREE_CODE (body) != BIND_EXPR)
8596 411 : body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
8597 : else
8598 0 : poplevel (0, 0);
8599 : }
8600 128 : else if (TREE_CODE (body) != BIND_EXPR)
8601 128 : body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
8602 539 : if (flag_openmp)
8603 : {
8604 534 : stmt = make_node (OMP_FOR);
8605 534 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8606 534 : TREE_TYPE (stmt) = void_type_node;
8607 534 : OMP_FOR_BODY (stmt) = body;
8608 534 : OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
8609 : }
8610 : else
8611 : stmt = body;
8612 539 : gfc_add_expr_to_block (&block, stmt);
8613 539 : if (free_clausesa)
8614 126 : gfc_free_split_omp_clauses (code, clausesa);
8615 539 : return gfc_finish_block (&block);
8616 : }
8617 :
8618 : static tree
8619 1321 : gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock,
8620 : gfc_omp_clauses *clausesa)
8621 : {
8622 1321 : stmtblock_t block, *new_pblock = pblock;
8623 1321 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8624 1321 : tree stmt, omp_clauses = NULL_TREE;
8625 1321 : bool free_clausesa = false;
8626 :
8627 1321 : if (pblock == NULL)
8628 1113 : gfc_start_block (&block);
8629 : else
8630 208 : gfc_init_block (&block);
8631 :
8632 1321 : if (clausesa == NULL)
8633 : {
8634 1113 : clausesa = clausesa_buf;
8635 1113 : gfc_split_omp_clauses (code, clausesa);
8636 1113 : free_clausesa = true;
8637 : }
8638 1321 : omp_clauses
8639 1321 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8640 : code->loc);
8641 1321 : if (pblock == NULL)
8642 : {
8643 1113 : if (!clausesa[GFC_OMP_SPLIT_DO].ordered
8644 1104 : && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
8645 : new_pblock = █
8646 : else
8647 65 : pushlevel ();
8648 : }
8649 2607 : stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO,
8650 : new_pblock, &clausesa[GFC_OMP_SPLIT_DO],
8651 : omp_clauses);
8652 1321 : if (pblock == NULL)
8653 : {
8654 1113 : if (TREE_CODE (stmt) != BIND_EXPR)
8655 1097 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8656 : else
8657 16 : poplevel (0, 0);
8658 : }
8659 208 : else if (TREE_CODE (stmt) != BIND_EXPR)
8660 208 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
8661 1321 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8662 : void_type_node, stmt, omp_clauses);
8663 1321 : OMP_PARALLEL_COMBINED (stmt) = 1;
8664 1321 : gfc_add_expr_to_block (&block, stmt);
8665 1321 : if (free_clausesa)
8666 1113 : gfc_free_split_omp_clauses (code, clausesa);
8667 1321 : return gfc_finish_block (&block);
8668 : }
8669 :
8670 : static tree
8671 413 : gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
8672 : gfc_omp_clauses *clausesa)
8673 : {
8674 413 : stmtblock_t block;
8675 413 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8676 413 : tree stmt, omp_clauses = NULL_TREE;
8677 413 : bool free_clausesa = false;
8678 :
8679 413 : if (pblock == NULL)
8680 285 : gfc_start_block (&block);
8681 : else
8682 128 : gfc_init_block (&block);
8683 :
8684 413 : if (clausesa == NULL)
8685 : {
8686 285 : clausesa = clausesa_buf;
8687 285 : gfc_split_omp_clauses (code, clausesa);
8688 285 : free_clausesa = true;
8689 : }
8690 413 : if (flag_openmp)
8691 410 : omp_clauses
8692 410 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8693 : code->loc);
8694 413 : if (pblock == NULL)
8695 285 : pushlevel ();
8696 413 : stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
8697 413 : if (pblock == NULL)
8698 : {
8699 285 : if (TREE_CODE (stmt) != BIND_EXPR)
8700 214 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8701 : else
8702 71 : poplevel (0, 0);
8703 : }
8704 128 : else if (TREE_CODE (stmt) != BIND_EXPR)
8705 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
8706 413 : if (flag_openmp)
8707 : {
8708 410 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8709 : void_type_node, stmt, omp_clauses);
8710 410 : OMP_PARALLEL_COMBINED (stmt) = 1;
8711 : }
8712 413 : gfc_add_expr_to_block (&block, stmt);
8713 413 : if (free_clausesa)
8714 285 : gfc_free_split_omp_clauses (code, clausesa);
8715 413 : return gfc_finish_block (&block);
8716 : }
8717 :
8718 : static tree
8719 54 : gfc_trans_omp_parallel_sections (gfc_code *code)
8720 : {
8721 54 : stmtblock_t block;
8722 54 : gfc_omp_clauses section_clauses;
8723 54 : tree stmt, omp_clauses;
8724 :
8725 54 : memset (§ion_clauses, 0, sizeof (section_clauses));
8726 54 : section_clauses.nowait = true;
8727 :
8728 54 : gfc_start_block (&block);
8729 54 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8730 : code->loc);
8731 54 : pushlevel ();
8732 54 : stmt = gfc_trans_omp_sections (code, §ion_clauses);
8733 54 : if (TREE_CODE (stmt) != BIND_EXPR)
8734 54 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8735 : else
8736 0 : poplevel (0, 0);
8737 54 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8738 : void_type_node, stmt, omp_clauses);
8739 54 : OMP_PARALLEL_COMBINED (stmt) = 1;
8740 54 : gfc_add_expr_to_block (&block, stmt);
8741 54 : return gfc_finish_block (&block);
8742 : }
8743 :
8744 : static tree
8745 50 : gfc_trans_omp_parallel_workshare (gfc_code *code)
8746 : {
8747 50 : stmtblock_t block;
8748 50 : gfc_omp_clauses workshare_clauses;
8749 50 : tree stmt, omp_clauses;
8750 :
8751 50 : memset (&workshare_clauses, 0, sizeof (workshare_clauses));
8752 50 : workshare_clauses.nowait = true;
8753 :
8754 50 : gfc_start_block (&block);
8755 50 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8756 : code->loc);
8757 50 : pushlevel ();
8758 50 : stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
8759 50 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8760 50 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8761 : void_type_node, stmt, omp_clauses);
8762 50 : OMP_PARALLEL_COMBINED (stmt) = 1;
8763 50 : gfc_add_expr_to_block (&block, stmt);
8764 50 : return gfc_finish_block (&block);
8765 : }
8766 :
8767 : static tree
8768 53 : gfc_trans_omp_scope (gfc_code *code)
8769 : {
8770 53 : stmtblock_t block;
8771 53 : tree body = gfc_trans_code (code->block->next);
8772 53 : if (IS_EMPTY_STMT (body))
8773 : return body;
8774 51 : gfc_start_block (&block);
8775 51 : tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8776 : code->loc);
8777 51 : tree stmt = make_node (OMP_SCOPE);
8778 51 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8779 51 : TREE_TYPE (stmt) = void_type_node;
8780 51 : OMP_SCOPE_BODY (stmt) = body;
8781 51 : OMP_SCOPE_CLAUSES (stmt) = omp_clauses;
8782 51 : gfc_add_expr_to_block (&block, stmt);
8783 51 : return gfc_finish_block (&block);
8784 : }
8785 :
8786 : static tree
8787 129 : gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
8788 : {
8789 129 : stmtblock_t block, body;
8790 129 : tree omp_clauses, stmt;
8791 129 : bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
8792 129 : location_t loc = gfc_get_location (&code->loc);
8793 :
8794 129 : gfc_start_block (&block);
8795 :
8796 129 : omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
8797 :
8798 129 : gfc_init_block (&body);
8799 499 : for (code = code->block; code; code = code->block)
8800 : {
8801 : /* Last section is special because of lastprivate, so even if it
8802 : is empty, chain it in. */
8803 370 : stmt = gfc_trans_omp_code (code->next,
8804 370 : has_lastprivate && code->block == NULL);
8805 370 : if (! IS_EMPTY_STMT (stmt))
8806 : {
8807 280 : stmt = build1_v (OMP_SECTION, stmt);
8808 280 : gfc_add_expr_to_block (&body, stmt);
8809 : }
8810 : }
8811 129 : stmt = gfc_finish_block (&body);
8812 :
8813 129 : stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses);
8814 129 : gfc_add_expr_to_block (&block, stmt);
8815 :
8816 129 : return gfc_finish_block (&block);
8817 : }
8818 :
8819 : static tree
8820 556 : gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
8821 : {
8822 556 : stmtblock_t block;
8823 556 : gfc_start_block (&block);
8824 556 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
8825 556 : tree stmt = gfc_trans_omp_code (code->block->next, true);
8826 556 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
8827 : stmt, omp_clauses);
8828 556 : gfc_add_expr_to_block (&block, stmt);
8829 556 : return gfc_finish_block (&block);
8830 : }
8831 :
8832 : static tree
8833 1123 : gfc_trans_omp_task (gfc_code *code)
8834 : {
8835 1123 : stmtblock_t block;
8836 1123 : tree stmt, omp_clauses;
8837 :
8838 1123 : gfc_start_block (&block);
8839 1123 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8840 : code->loc);
8841 1123 : pushlevel ();
8842 1123 : stmt = gfc_trans_omp_code (code->block->next, true);
8843 1123 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8844 1123 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node,
8845 : stmt, omp_clauses);
8846 1123 : gfc_add_expr_to_block (&block, stmt);
8847 1123 : return gfc_finish_block (&block);
8848 : }
8849 :
8850 : static tree
8851 181 : gfc_trans_omp_taskgroup (gfc_code *code)
8852 : {
8853 181 : stmtblock_t block;
8854 181 : gfc_start_block (&block);
8855 181 : tree body = gfc_trans_code (code->block->next);
8856 181 : tree stmt = make_node (OMP_TASKGROUP);
8857 181 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8858 181 : TREE_TYPE (stmt) = void_type_node;
8859 181 : OMP_TASKGROUP_BODY (stmt) = body;
8860 181 : OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
8861 : code->ext.omp_clauses,
8862 : code->loc);
8863 181 : gfc_add_expr_to_block (&block, stmt);
8864 181 : return gfc_finish_block (&block);
8865 : }
8866 :
8867 : static tree
8868 146 : gfc_trans_omp_taskwait (gfc_code *code)
8869 : {
8870 146 : if (!code->ext.omp_clauses)
8871 : {
8872 132 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
8873 132 : return build_call_expr_loc (input_location, decl, 0);
8874 : }
8875 14 : stmtblock_t block;
8876 14 : gfc_start_block (&block);
8877 14 : tree stmt = make_node (OMP_TASK);
8878 14 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8879 14 : TREE_TYPE (stmt) = void_type_node;
8880 14 : OMP_TASK_BODY (stmt) = NULL_TREE;
8881 14 : OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
8882 : code->ext.omp_clauses,
8883 : code->loc);
8884 14 : gfc_add_expr_to_block (&block, stmt);
8885 14 : return gfc_finish_block (&block);
8886 : }
8887 :
8888 : static tree
8889 8 : gfc_trans_omp_taskyield (void)
8890 : {
8891 8 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
8892 8 : return build_call_expr_loc (input_location, decl, 0);
8893 : }
8894 :
8895 : static tree
8896 341 : gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
8897 : {
8898 341 : stmtblock_t block;
8899 341 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8900 341 : tree stmt, omp_clauses = NULL_TREE;
8901 341 : bool free_clausesa = false;
8902 :
8903 341 : gfc_start_block (&block);
8904 341 : if (clausesa == NULL)
8905 : {
8906 113 : clausesa = clausesa_buf;
8907 113 : gfc_split_omp_clauses (code, clausesa);
8908 113 : free_clausesa = true;
8909 : }
8910 341 : if (flag_openmp)
8911 341 : omp_clauses
8912 341 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
8913 : code->loc);
8914 341 : switch (code->op)
8915 : {
8916 0 : case EXEC_OMP_DISTRIBUTE:
8917 0 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8918 0 : case EXEC_OMP_TEAMS_DISTRIBUTE:
8919 : /* This is handled in gfc_trans_omp_do. */
8920 0 : gcc_unreachable ();
8921 128 : break;
8922 128 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8923 128 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8924 128 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8925 128 : stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa);
8926 128 : if (TREE_CODE (stmt) != BIND_EXPR)
8927 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8928 : else
8929 0 : poplevel (0, 0);
8930 : break;
8931 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8932 113 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8933 113 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8934 113 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
8935 113 : if (TREE_CODE (stmt) != BIND_EXPR)
8936 113 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8937 : else
8938 0 : poplevel (0, 0);
8939 : break;
8940 100 : case EXEC_OMP_DISTRIBUTE_SIMD:
8941 100 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8942 100 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8943 100 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
8944 : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
8945 100 : if (TREE_CODE (stmt) != BIND_EXPR)
8946 100 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8947 : else
8948 0 : poplevel (0, 0);
8949 : break;
8950 0 : default:
8951 0 : gcc_unreachable ();
8952 : }
8953 341 : if (flag_openmp)
8954 : {
8955 341 : tree distribute = make_node (OMP_DISTRIBUTE);
8956 341 : SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc));
8957 341 : TREE_TYPE (distribute) = void_type_node;
8958 341 : OMP_FOR_BODY (distribute) = stmt;
8959 341 : OMP_FOR_CLAUSES (distribute) = omp_clauses;
8960 341 : stmt = distribute;
8961 : }
8962 341 : gfc_add_expr_to_block (&block, stmt);
8963 341 : if (free_clausesa)
8964 113 : gfc_free_split_omp_clauses (code, clausesa);
8965 341 : return gfc_finish_block (&block);
8966 : }
8967 :
8968 : static tree
8969 468 : gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
8970 : tree omp_clauses)
8971 : {
8972 468 : stmtblock_t block;
8973 468 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8974 468 : tree stmt;
8975 468 : bool combined = true, free_clausesa = false;
8976 :
8977 468 : gfc_start_block (&block);
8978 468 : if (clausesa == NULL)
8979 : {
8980 269 : clausesa = clausesa_buf;
8981 269 : gfc_split_omp_clauses (code, clausesa);
8982 269 : free_clausesa = true;
8983 : }
8984 468 : if (flag_openmp)
8985 : {
8986 468 : omp_clauses
8987 468 : = chainon (omp_clauses,
8988 : gfc_trans_omp_clauses (&block,
8989 : &clausesa[GFC_OMP_SPLIT_TEAMS],
8990 : code->loc));
8991 468 : pushlevel ();
8992 : }
8993 468 : switch (code->op)
8994 : {
8995 193 : case EXEC_OMP_TARGET_TEAMS:
8996 193 : case EXEC_OMP_TEAMS:
8997 193 : stmt = gfc_trans_omp_code (code->block->next, true);
8998 193 : combined = false;
8999 193 : break;
9000 28 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9001 28 : case EXEC_OMP_TEAMS_DISTRIBUTE:
9002 28 : stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
9003 : &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
9004 : NULL);
9005 28 : break;
9006 19 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9007 19 : case EXEC_OMP_TEAMS_LOOP:
9008 19 : stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL,
9009 : &clausesa[GFC_OMP_SPLIT_DO],
9010 : NULL);
9011 19 : break;
9012 228 : default:
9013 228 : stmt = gfc_trans_omp_distribute (code, clausesa);
9014 228 : break;
9015 : }
9016 468 : if (flag_openmp)
9017 : {
9018 468 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9019 468 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS,
9020 : void_type_node, stmt, omp_clauses);
9021 468 : if (combined)
9022 275 : OMP_TEAMS_COMBINED (stmt) = 1;
9023 : }
9024 468 : gfc_add_expr_to_block (&block, stmt);
9025 468 : if (free_clausesa)
9026 269 : gfc_free_split_omp_clauses (code, clausesa);
9027 468 : return gfc_finish_block (&block);
9028 : }
9029 :
9030 : static tree
9031 2102 : gfc_trans_omp_target (gfc_code *code)
9032 : {
9033 2102 : stmtblock_t block;
9034 2102 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9035 2102 : tree stmt, omp_clauses = NULL_TREE;
9036 :
9037 2102 : gfc_start_block (&block);
9038 2102 : gfc_split_omp_clauses (code, clausesa);
9039 2102 : if (flag_openmp)
9040 2102 : omp_clauses
9041 2102 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
9042 : code->loc);
9043 2102 : switch (code->op)
9044 : {
9045 1761 : case EXEC_OMP_TARGET:
9046 1761 : pushlevel ();
9047 1761 : stmt = gfc_trans_omp_code (code->block->next, true);
9048 1761 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9049 1761 : break;
9050 21 : case EXEC_OMP_TARGET_PARALLEL:
9051 21 : {
9052 21 : stmtblock_t iblock;
9053 :
9054 21 : pushlevel ();
9055 21 : gfc_start_block (&iblock);
9056 21 : tree inner_clauses
9057 21 : = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL],
9058 : code->loc);
9059 21 : stmt = gfc_trans_omp_code (code->block->next, true);
9060 21 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
9061 : inner_clauses);
9062 21 : gfc_add_expr_to_block (&iblock, stmt);
9063 21 : stmt = gfc_finish_block (&iblock);
9064 21 : if (TREE_CODE (stmt) != BIND_EXPR)
9065 18 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9066 : else
9067 3 : poplevel (0, 0);
9068 : }
9069 21 : break;
9070 80 : case EXEC_OMP_TARGET_PARALLEL_DO:
9071 80 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9072 80 : stmt = gfc_trans_omp_parallel_do (code,
9073 : (code->op
9074 : == EXEC_OMP_TARGET_PARALLEL_LOOP),
9075 : &block, clausesa);
9076 80 : if (TREE_CODE (stmt) != BIND_EXPR)
9077 80 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9078 : else
9079 0 : poplevel (0, 0);
9080 : break;
9081 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9082 15 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
9083 15 : if (TREE_CODE (stmt) != BIND_EXPR)
9084 15 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9085 : else
9086 0 : poplevel (0, 0);
9087 : break;
9088 26 : case EXEC_OMP_TARGET_SIMD:
9089 26 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
9090 : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
9091 26 : if (TREE_CODE (stmt) != BIND_EXPR)
9092 26 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9093 : else
9094 0 : poplevel (0, 0);
9095 : break;
9096 199 : default:
9097 199 : if (flag_openmp
9098 199 : && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
9099 149 : || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
9100 : {
9101 51 : gfc_omp_clauses clausesb;
9102 51 : tree teams_clauses;
9103 : /* For combined !$omp target teams, the num_teams and
9104 : thread_limit clauses are evaluated before entering the
9105 : target construct. */
9106 51 : memset (&clausesb, '\0', sizeof (clausesb));
9107 51 : clausesb.num_teams_lower
9108 51 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
9109 51 : clausesb.num_teams_upper
9110 51 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
9111 51 : clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
9112 51 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
9113 51 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
9114 51 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
9115 51 : teams_clauses
9116 51 : = gfc_trans_omp_clauses (&block, &clausesb, code->loc);
9117 51 : pushlevel ();
9118 51 : stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses);
9119 51 : }
9120 : else
9121 : {
9122 148 : pushlevel ();
9123 148 : stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
9124 : }
9125 199 : if (TREE_CODE (stmt) != BIND_EXPR)
9126 198 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9127 : else
9128 1 : poplevel (0, 0);
9129 : break;
9130 : }
9131 2102 : if (flag_openmp)
9132 : {
9133 2102 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET,
9134 : void_type_node, stmt, omp_clauses);
9135 2102 : if (code->op != EXEC_OMP_TARGET)
9136 341 : OMP_TARGET_COMBINED (stmt) = 1;
9137 2102 : cfun->has_omp_target = true;
9138 : }
9139 2102 : gfc_add_expr_to_block (&block, stmt);
9140 2102 : gfc_free_split_omp_clauses (code, clausesa);
9141 2102 : return gfc_finish_block (&block);
9142 : }
9143 :
9144 : static tree
9145 79 : gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op)
9146 : {
9147 79 : stmtblock_t block;
9148 79 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9149 79 : tree stmt, omp_clauses = NULL_TREE;
9150 :
9151 79 : gfc_start_block (&block);
9152 79 : gfc_split_omp_clauses (code, clausesa);
9153 79 : if (flag_openmp)
9154 79 : omp_clauses
9155 79 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP],
9156 : code->loc);
9157 79 : switch (op)
9158 : {
9159 0 : case EXEC_OMP_TASKLOOP:
9160 : /* This is handled in gfc_trans_omp_do. */
9161 0 : gcc_unreachable ();
9162 79 : break;
9163 79 : case EXEC_OMP_TASKLOOP_SIMD:
9164 79 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
9165 : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
9166 79 : if (TREE_CODE (stmt) != BIND_EXPR)
9167 79 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9168 : else
9169 0 : poplevel (0, 0);
9170 79 : break;
9171 0 : default:
9172 0 : gcc_unreachable ();
9173 : }
9174 79 : if (flag_openmp)
9175 : {
9176 79 : tree taskloop = make_node (OMP_TASKLOOP);
9177 79 : SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc));
9178 79 : TREE_TYPE (taskloop) = void_type_node;
9179 79 : OMP_FOR_BODY (taskloop) = stmt;
9180 79 : OMP_FOR_CLAUSES (taskloop) = omp_clauses;
9181 79 : stmt = taskloop;
9182 : }
9183 79 : gfc_add_expr_to_block (&block, stmt);
9184 79 : gfc_free_split_omp_clauses (code, clausesa);
9185 79 : return gfc_finish_block (&block);
9186 : }
9187 :
9188 : static tree
9189 84 : gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op)
9190 : {
9191 84 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9192 84 : stmtblock_t block;
9193 84 : tree stmt;
9194 :
9195 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
9196 56 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
9197 45 : gfc_split_omp_clauses (code, clausesa);
9198 :
9199 84 : pushlevel ();
9200 84 : if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD
9201 84 : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD)
9202 48 : stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD);
9203 : else
9204 : {
9205 36 : gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP
9206 : || op == EXEC_OMP_MASTER_TASKLOOP);
9207 36 : stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL,
9208 36 : code->op != EXEC_OMP_MASTER_TASKLOOP
9209 : ? &clausesa[GFC_OMP_SPLIT_TASKLOOP]
9210 : : code->ext.omp_clauses, NULL);
9211 : }
9212 84 : if (TREE_CODE (stmt) != BIND_EXPR)
9213 55 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9214 : else
9215 29 : poplevel (0, 0);
9216 84 : gfc_start_block (&block);
9217 84 : if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD)
9218 : {
9219 35 : tree clauses = gfc_trans_omp_clauses (&block,
9220 : &clausesa[GFC_OMP_SPLIT_MASKED],
9221 : code->loc);
9222 35 : tree msk = make_node (OMP_MASKED);
9223 35 : SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc));
9224 35 : TREE_TYPE (msk) = void_type_node;
9225 35 : OMP_MASKED_BODY (msk) = stmt;
9226 35 : OMP_MASKED_CLAUSES (msk) = clauses;
9227 35 : OMP_MASKED_COMBINED (msk) = 1;
9228 35 : gfc_add_expr_to_block (&block, msk);
9229 : }
9230 : else
9231 : {
9232 49 : gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP
9233 : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD);
9234 49 : stmt = build1_v (OMP_MASTER, stmt);
9235 49 : gfc_add_expr_to_block (&block, stmt);
9236 : }
9237 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
9238 56 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
9239 45 : gfc_free_split_omp_clauses (code, clausesa);
9240 84 : return gfc_finish_block (&block);
9241 : }
9242 :
9243 : static tree
9244 61 : gfc_trans_omp_parallel_master_masked (gfc_code *code)
9245 : {
9246 61 : stmtblock_t block;
9247 61 : tree stmt, omp_clauses;
9248 61 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9249 61 : bool parallel_combined = false;
9250 :
9251 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
9252 50 : gfc_split_omp_clauses (code, clausesa);
9253 :
9254 61 : gfc_start_block (&block);
9255 61 : omp_clauses = gfc_trans_omp_clauses (&block,
9256 61 : code->op == EXEC_OMP_PARALLEL_MASTER
9257 : ? code->ext.omp_clauses
9258 : : &clausesa[GFC_OMP_SPLIT_PARALLEL],
9259 : code->loc);
9260 61 : pushlevel ();
9261 61 : if (code->op == EXEC_OMP_PARALLEL_MASTER)
9262 11 : stmt = gfc_trans_omp_master (code);
9263 50 : else if (code->op == EXEC_OMP_PARALLEL_MASKED)
9264 11 : stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]);
9265 : else
9266 : {
9267 39 : gfc_exec_op op;
9268 39 : switch (code->op)
9269 : {
9270 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9271 : op = EXEC_OMP_MASKED_TASKLOOP;
9272 : break;
9273 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9274 8 : op = EXEC_OMP_MASKED_TASKLOOP_SIMD;
9275 8 : break;
9276 10 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9277 10 : op = EXEC_OMP_MASTER_TASKLOOP;
9278 10 : break;
9279 14 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9280 14 : op = EXEC_OMP_MASTER_TASKLOOP_SIMD;
9281 14 : break;
9282 0 : default:
9283 0 : gcc_unreachable ();
9284 : }
9285 39 : stmt = gfc_trans_omp_master_masked_taskloop (code, op);
9286 39 : parallel_combined = true;
9287 : }
9288 61 : if (TREE_CODE (stmt) != BIND_EXPR)
9289 48 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9290 : else
9291 13 : poplevel (0, 0);
9292 61 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
9293 : void_type_node, stmt, omp_clauses);
9294 : /* masked does have just filter clause, but during gimplification
9295 : isn't represented by a gimplification omp context, so for
9296 : !$omp parallel masked don't set OMP_PARALLEL_COMBINED,
9297 : so that
9298 : !$omp parallel masked
9299 : !$omp taskloop simd lastprivate (x)
9300 : isn't confused with
9301 : !$omp parallel masked taskloop simd lastprivate (x) */
9302 61 : if (parallel_combined)
9303 39 : OMP_PARALLEL_COMBINED (stmt) = 1;
9304 61 : gfc_add_expr_to_block (&block, stmt);
9305 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
9306 50 : gfc_free_split_omp_clauses (code, clausesa);
9307 61 : return gfc_finish_block (&block);
9308 : }
9309 :
9310 : static tree
9311 1388 : gfc_trans_omp_target_data (gfc_code *code)
9312 : {
9313 1388 : stmtblock_t block;
9314 1388 : tree stmt, omp_clauses;
9315 :
9316 1388 : gfc_start_block (&block);
9317 1388 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9318 : code->loc);
9319 1388 : stmt = gfc_trans_omp_code (code->block->next, true);
9320 1388 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA,
9321 : void_type_node, stmt, omp_clauses);
9322 1388 : gfc_add_expr_to_block (&block, stmt);
9323 1388 : return gfc_finish_block (&block);
9324 : }
9325 :
9326 : static tree
9327 380 : gfc_trans_omp_target_enter_data (gfc_code *code)
9328 : {
9329 380 : stmtblock_t block;
9330 380 : tree stmt, omp_clauses;
9331 :
9332 380 : gfc_start_block (&block);
9333 380 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9334 : code->loc);
9335 380 : stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
9336 : omp_clauses);
9337 380 : gfc_add_expr_to_block (&block, stmt);
9338 380 : return gfc_finish_block (&block);
9339 : }
9340 :
9341 : static tree
9342 318 : gfc_trans_omp_target_exit_data (gfc_code *code)
9343 : {
9344 318 : stmtblock_t block;
9345 318 : tree stmt, omp_clauses;
9346 :
9347 318 : gfc_start_block (&block);
9348 318 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9349 : code->loc, false, false, code->op);
9350 318 : stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
9351 : omp_clauses);
9352 318 : gfc_add_expr_to_block (&block, stmt);
9353 318 : return gfc_finish_block (&block);
9354 : }
9355 :
9356 : static tree
9357 1697 : gfc_trans_omp_target_update (gfc_code *code)
9358 : {
9359 1697 : stmtblock_t block;
9360 1697 : tree stmt, omp_clauses;
9361 :
9362 1697 : gfc_start_block (&block);
9363 1697 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9364 : code->loc);
9365 1697 : stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
9366 : omp_clauses);
9367 1697 : gfc_add_expr_to_block (&block, stmt);
9368 1697 : return gfc_finish_block (&block);
9369 : }
9370 :
9371 : static tree
9372 8 : gfc_trans_openmp_interop (gfc_code *code, gfc_omp_clauses *clauses)
9373 : {
9374 8 : stmtblock_t block;
9375 8 : gfc_start_block (&block);
9376 8 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
9377 8 : tree stmt = build1_loc (input_location, OMP_INTEROP, void_type_node,
9378 : omp_clauses);
9379 8 : gfc_add_expr_to_block (&block, stmt);
9380 8 : return gfc_finish_block (&block);
9381 : }
9382 :
9383 : static tree
9384 85 : gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
9385 : {
9386 85 : tree res, tmp, stmt;
9387 85 : stmtblock_t block, *pblock = NULL;
9388 85 : stmtblock_t singleblock;
9389 85 : int saved_ompws_flags;
9390 85 : bool singleblock_in_progress = false;
9391 : /* True if previous gfc_code in workshare construct is not workshared. */
9392 85 : bool prev_singleunit;
9393 85 : location_t loc = gfc_get_location (&code->loc);
9394 :
9395 85 : code = code->block->next;
9396 :
9397 85 : pushlevel ();
9398 :
9399 85 : gfc_start_block (&block);
9400 85 : pblock = █
9401 :
9402 85 : ompws_flags = OMPWS_WORKSHARE_FLAG;
9403 85 : prev_singleunit = false;
9404 :
9405 : /* Translate statements one by one to trees until we reach
9406 : the end of the workshare construct. Adjacent gfc_codes that
9407 : are a single unit of work are clustered and encapsulated in a
9408 : single OMP_SINGLE construct. */
9409 282 : for (; code; code = code->next)
9410 : {
9411 197 : if (code->here != 0)
9412 : {
9413 0 : res = gfc_trans_label_here (code);
9414 0 : gfc_add_expr_to_block (pblock, res);
9415 : }
9416 :
9417 : /* No dependence analysis, use for clauses with wait.
9418 : If this is the last gfc_code, use default omp_clauses. */
9419 197 : if (code->next == NULL && clauses->nowait)
9420 60 : ompws_flags |= OMPWS_NOWAIT;
9421 :
9422 : /* By default, every gfc_code is a single unit of work. */
9423 197 : ompws_flags |= OMPWS_CURR_SINGLEUNIT;
9424 197 : ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
9425 :
9426 197 : switch (code->op)
9427 : {
9428 : case EXEC_NOP:
9429 : res = NULL_TREE;
9430 : break;
9431 :
9432 125 : case EXEC_ASSIGN:
9433 125 : res = gfc_trans_assign (code);
9434 125 : break;
9435 :
9436 0 : case EXEC_POINTER_ASSIGN:
9437 0 : res = gfc_trans_pointer_assign (code);
9438 0 : break;
9439 :
9440 0 : case EXEC_INIT_ASSIGN:
9441 0 : res = gfc_trans_init_assign (code);
9442 0 : break;
9443 :
9444 24 : case EXEC_FORALL:
9445 24 : res = gfc_trans_forall (code);
9446 24 : break;
9447 :
9448 19 : case EXEC_WHERE:
9449 19 : res = gfc_trans_where (code);
9450 19 : break;
9451 :
9452 7 : case EXEC_OMP_ATOMIC:
9453 7 : res = gfc_trans_omp_directive (code);
9454 7 : break;
9455 :
9456 17 : case EXEC_OMP_PARALLEL:
9457 17 : case EXEC_OMP_PARALLEL_DO:
9458 17 : case EXEC_OMP_PARALLEL_MASTER:
9459 17 : case EXEC_OMP_PARALLEL_SECTIONS:
9460 17 : case EXEC_OMP_PARALLEL_WORKSHARE:
9461 17 : case EXEC_OMP_CRITICAL:
9462 17 : saved_ompws_flags = ompws_flags;
9463 17 : ompws_flags = 0;
9464 17 : res = gfc_trans_omp_directive (code);
9465 17 : ompws_flags = saved_ompws_flags;
9466 17 : break;
9467 :
9468 5 : case EXEC_BLOCK:
9469 5 : res = gfc_trans_block_construct (code);
9470 5 : break;
9471 :
9472 0 : default:
9473 0 : gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
9474 : }
9475 :
9476 197 : input_location = gfc_get_location (&code->loc);
9477 :
9478 197 : if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
9479 : {
9480 197 : if (prev_singleunit)
9481 : {
9482 72 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
9483 : /* Add current gfc_code to single block. */
9484 44 : gfc_add_expr_to_block (&singleblock, res);
9485 : else
9486 : {
9487 : /* Finish single block and add it to pblock. */
9488 28 : tmp = gfc_finish_block (&singleblock);
9489 28 : tmp = build2_loc (loc, OMP_SINGLE,
9490 : void_type_node, tmp, NULL_TREE);
9491 28 : gfc_add_expr_to_block (pblock, tmp);
9492 : /* Add current gfc_code to pblock. */
9493 28 : gfc_add_expr_to_block (pblock, res);
9494 28 : singleblock_in_progress = false;
9495 : }
9496 : }
9497 : else
9498 : {
9499 125 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
9500 : {
9501 : /* Start single block. */
9502 73 : gfc_init_block (&singleblock);
9503 73 : gfc_add_expr_to_block (&singleblock, res);
9504 73 : singleblock_in_progress = true;
9505 73 : loc = gfc_get_location (&code->loc);
9506 : }
9507 : else
9508 : /* Add the new statement to the block. */
9509 52 : gfc_add_expr_to_block (pblock, res);
9510 : }
9511 197 : prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
9512 : }
9513 : }
9514 :
9515 : /* Finish remaining SINGLE block, if we were in the middle of one. */
9516 85 : if (singleblock_in_progress)
9517 : {
9518 : /* Finish single block and add it to pblock. */
9519 45 : tmp = gfc_finish_block (&singleblock);
9520 45 : tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp,
9521 45 : clauses->nowait
9522 27 : ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
9523 : : NULL_TREE);
9524 45 : gfc_add_expr_to_block (pblock, tmp);
9525 : }
9526 :
9527 85 : stmt = gfc_finish_block (pblock);
9528 85 : if (TREE_CODE (stmt) != BIND_EXPR)
9529 : {
9530 65 : if (!IS_EMPTY_STMT (stmt))
9531 : {
9532 65 : tree bindblock = poplevel (1, 0);
9533 65 : stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
9534 : }
9535 : else
9536 0 : poplevel (0, 0);
9537 : }
9538 : else
9539 20 : poplevel (0, 0);
9540 :
9541 85 : if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
9542 0 : stmt = gfc_trans_omp_barrier ();
9543 :
9544 85 : ompws_flags = 0;
9545 85 : return stmt;
9546 : }
9547 :
9548 : tree
9549 76 : gfc_trans_oacc_declare (gfc_code *code)
9550 : {
9551 76 : stmtblock_t block;
9552 76 : tree stmt, oacc_clauses;
9553 76 : enum tree_code construct_code;
9554 :
9555 76 : construct_code = OACC_DATA;
9556 :
9557 76 : gfc_start_block (&block);
9558 :
9559 76 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
9560 : code->loc, false, true);
9561 76 : stmt = gfc_trans_omp_code (code->block->next, true);
9562 76 : stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
9563 : oacc_clauses);
9564 76 : gfc_add_expr_to_block (&block, stmt);
9565 :
9566 76 : return gfc_finish_block (&block);
9567 : }
9568 :
9569 : tree
9570 12044 : gfc_trans_oacc_directive (gfc_code *code)
9571 : {
9572 12044 : switch (code->op)
9573 : {
9574 1556 : case EXEC_OACC_PARALLEL_LOOP:
9575 1556 : case EXEC_OACC_KERNELS_LOOP:
9576 1556 : case EXEC_OACC_SERIAL_LOOP:
9577 1556 : return gfc_trans_oacc_combined_directive (code);
9578 4189 : case EXEC_OACC_PARALLEL:
9579 4189 : case EXEC_OACC_KERNELS:
9580 4189 : case EXEC_OACC_SERIAL:
9581 4189 : case EXEC_OACC_DATA:
9582 4189 : case EXEC_OACC_HOST_DATA:
9583 4189 : return gfc_trans_oacc_construct (code);
9584 3377 : case EXEC_OACC_LOOP:
9585 3377 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
9586 3377 : NULL);
9587 2130 : case EXEC_OACC_UPDATE:
9588 2130 : case EXEC_OACC_CACHE:
9589 2130 : case EXEC_OACC_ENTER_DATA:
9590 2130 : case EXEC_OACC_EXIT_DATA:
9591 2130 : return gfc_trans_oacc_executable_directive (code);
9592 173 : case EXEC_OACC_WAIT:
9593 173 : return gfc_trans_oacc_wait_directive (code);
9594 543 : case EXEC_OACC_ATOMIC:
9595 543 : return gfc_trans_omp_atomic (code);
9596 76 : case EXEC_OACC_DECLARE:
9597 76 : return gfc_trans_oacc_declare (code);
9598 0 : default:
9599 0 : gcc_unreachable ();
9600 : }
9601 : }
9602 :
9603 : tree
9604 18960 : gfc_trans_omp_directive (gfc_code *code)
9605 : {
9606 18960 : switch (code->op)
9607 : {
9608 35 : case EXEC_OMP_ALLOCATE:
9609 35 : case EXEC_OMP_ALLOCATORS:
9610 35 : return gfc_trans_omp_allocators (code);
9611 10 : case EXEC_OMP_ASSUME:
9612 10 : return gfc_trans_omp_assume (code);
9613 2053 : case EXEC_OMP_ATOMIC:
9614 2053 : return gfc_trans_omp_atomic (code);
9615 604 : case EXEC_OMP_BARRIER:
9616 604 : return gfc_trans_omp_barrier ();
9617 310 : case EXEC_OMP_CANCEL:
9618 310 : return gfc_trans_omp_cancel (code);
9619 170 : case EXEC_OMP_CANCELLATION_POINT:
9620 170 : return gfc_trans_omp_cancellation_point (code);
9621 143 : case EXEC_OMP_CRITICAL:
9622 143 : return gfc_trans_omp_critical (code);
9623 108 : case EXEC_OMP_DEPOBJ:
9624 108 : return gfc_trans_omp_depobj (code);
9625 2456 : case EXEC_OMP_DISTRIBUTE:
9626 2456 : case EXEC_OMP_DO:
9627 2456 : case EXEC_OMP_LOOP:
9628 2456 : case EXEC_OMP_SIMD:
9629 2456 : case EXEC_OMP_TASKLOOP:
9630 2456 : case EXEC_OMP_TILE:
9631 2456 : case EXEC_OMP_UNROLL:
9632 2456 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
9633 2456 : NULL);
9634 128 : case EXEC_OMP_DISPATCH:
9635 128 : return gfc_trans_omp_dispatch (code);
9636 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9637 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9638 113 : case EXEC_OMP_DISTRIBUTE_SIMD:
9639 113 : return gfc_trans_omp_distribute (code, NULL);
9640 126 : case EXEC_OMP_DO_SIMD:
9641 126 : return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
9642 29 : case EXEC_OMP_ERROR:
9643 29 : return gfc_trans_omp_error (code);
9644 70 : case EXEC_OMP_FLUSH:
9645 70 : return gfc_trans_omp_flush (code);
9646 38 : case EXEC_OMP_MASKED:
9647 38 : return gfc_trans_omp_masked (code, NULL);
9648 105 : case EXEC_OMP_MASTER:
9649 105 : return gfc_trans_omp_master (code);
9650 45 : case EXEC_OMP_MASKED_TASKLOOP:
9651 45 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
9652 45 : case EXEC_OMP_MASTER_TASKLOOP:
9653 45 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
9654 45 : return gfc_trans_omp_master_masked_taskloop (code, code->op);
9655 88 : case EXEC_OMP_METADIRECTIVE:
9656 88 : return gfc_trans_omp_metadirective (code);
9657 521 : case EXEC_OMP_ORDERED:
9658 521 : return gfc_trans_omp_ordered (code);
9659 1875 : case EXEC_OMP_PARALLEL:
9660 1875 : return gfc_trans_omp_parallel (code);
9661 1089 : case EXEC_OMP_PARALLEL_DO:
9662 1089 : return gfc_trans_omp_parallel_do (code, false, NULL, NULL);
9663 24 : case EXEC_OMP_PARALLEL_LOOP:
9664 24 : return gfc_trans_omp_parallel_do (code, true, NULL, NULL);
9665 285 : case EXEC_OMP_PARALLEL_DO_SIMD:
9666 285 : return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
9667 61 : case EXEC_OMP_PARALLEL_MASKED:
9668 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9669 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9670 61 : case EXEC_OMP_PARALLEL_MASTER:
9671 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9672 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9673 61 : return gfc_trans_omp_parallel_master_masked (code);
9674 54 : case EXEC_OMP_PARALLEL_SECTIONS:
9675 54 : return gfc_trans_omp_parallel_sections (code);
9676 50 : case EXEC_OMP_PARALLEL_WORKSHARE:
9677 50 : return gfc_trans_omp_parallel_workshare (code);
9678 53 : case EXEC_OMP_SCOPE:
9679 53 : return gfc_trans_omp_scope (code);
9680 75 : case EXEC_OMP_SECTIONS:
9681 75 : return gfc_trans_omp_sections (code, code->ext.omp_clauses);
9682 556 : case EXEC_OMP_SINGLE:
9683 556 : return gfc_trans_omp_single (code, code->ext.omp_clauses);
9684 2102 : case EXEC_OMP_TARGET:
9685 2102 : case EXEC_OMP_TARGET_PARALLEL:
9686 2102 : case EXEC_OMP_TARGET_PARALLEL_DO:
9687 2102 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9688 2102 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9689 2102 : case EXEC_OMP_TARGET_SIMD:
9690 2102 : case EXEC_OMP_TARGET_TEAMS:
9691 2102 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9692 2102 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9693 2102 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9694 2102 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9695 2102 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9696 2102 : return gfc_trans_omp_target (code);
9697 1388 : case EXEC_OMP_TARGET_DATA:
9698 1388 : return gfc_trans_omp_target_data (code);
9699 380 : case EXEC_OMP_TARGET_ENTER_DATA:
9700 380 : return gfc_trans_omp_target_enter_data (code);
9701 318 : case EXEC_OMP_TARGET_EXIT_DATA:
9702 318 : return gfc_trans_omp_target_exit_data (code);
9703 1697 : case EXEC_OMP_TARGET_UPDATE:
9704 1697 : return gfc_trans_omp_target_update (code);
9705 1123 : case EXEC_OMP_TASK:
9706 1123 : return gfc_trans_omp_task (code);
9707 181 : case EXEC_OMP_TASKGROUP:
9708 181 : return gfc_trans_omp_taskgroup (code);
9709 31 : case EXEC_OMP_TASKLOOP_SIMD:
9710 31 : return gfc_trans_omp_taskloop (code, code->op);
9711 146 : case EXEC_OMP_TASKWAIT:
9712 146 : return gfc_trans_omp_taskwait (code);
9713 8 : case EXEC_OMP_TASKYIELD:
9714 8 : return gfc_trans_omp_taskyield ();
9715 269 : case EXEC_OMP_TEAMS:
9716 269 : case EXEC_OMP_TEAMS_DISTRIBUTE:
9717 269 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9718 269 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9719 269 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9720 269 : case EXEC_OMP_TEAMS_LOOP:
9721 269 : return gfc_trans_omp_teams (code, NULL, NULL_TREE);
9722 35 : case EXEC_OMP_WORKSHARE:
9723 35 : return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
9724 8 : case EXEC_OMP_INTEROP:
9725 8 : return gfc_trans_openmp_interop (code, code->ext.omp_clauses);
9726 0 : default:
9727 0 : gcc_unreachable ();
9728 : }
9729 : }
9730 :
9731 : void
9732 109 : gfc_trans_omp_declare_simd (gfc_namespace *ns)
9733 : {
9734 109 : if (ns->entries)
9735 : return;
9736 :
9737 109 : gfc_omp_declare_simd *ods;
9738 262 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
9739 : {
9740 153 : tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
9741 153 : tree fndecl = ns->proc_name->backend_decl;
9742 153 : if (c != NULL_TREE)
9743 103 : c = tree_cons (NULL_TREE, c, NULL_TREE);
9744 153 : c = build_tree_list (get_identifier ("omp declare simd"), c);
9745 153 : TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
9746 153 : DECL_ATTRIBUTES (fndecl) = c;
9747 : }
9748 : }
9749 :
9750 : /* Translate the context selector list GFC_SELECTORS, using WHERE as the
9751 : locus for error messages. */
9752 :
9753 : static tree
9754 513 : gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where)
9755 : {
9756 513 : tree set_selectors = NULL_TREE;
9757 513 : gfc_omp_set_selector *oss;
9758 :
9759 1004 : for (oss = gfc_selectors; oss; oss = oss->next)
9760 : {
9761 491 : tree selectors = NULL_TREE;
9762 491 : gfc_omp_selector *os;
9763 491 : enum omp_tss_code set = oss->code;
9764 491 : gcc_assert (set != OMP_TRAIT_SET_INVALID);
9765 :
9766 1107 : for (os = oss->trait_selectors; os; os = os->next)
9767 : {
9768 616 : tree scoreval = NULL_TREE;
9769 616 : tree properties = NULL_TREE;
9770 616 : gfc_omp_trait_property *otp;
9771 616 : enum omp_ts_code sel = os->code;
9772 :
9773 : /* Per the spec, "Implementations can ignore specified
9774 : selectors that are not those described in this section";
9775 : however, we must record such selectors because they
9776 : cause match failures. */
9777 616 : if (sel == OMP_TRAIT_INVALID)
9778 : {
9779 1 : selectors = make_trait_selector (sel, NULL_TREE, NULL_TREE,
9780 : selectors);
9781 1 : continue;
9782 : }
9783 :
9784 987 : for (otp = os->properties; otp; otp = otp->next)
9785 : {
9786 372 : switch (otp->property_kind)
9787 : {
9788 85 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
9789 85 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
9790 85 : {
9791 85 : tree expr = NULL_TREE;
9792 85 : gfc_se se;
9793 85 : gfc_init_se (&se, NULL);
9794 85 : gfc_conv_expr (&se, otp->expr);
9795 85 : expr = se.expr;
9796 85 : properties = make_trait_property (NULL_TREE, expr,
9797 : properties);
9798 : }
9799 85 : break;
9800 23 : case OMP_TRAIT_PROPERTY_ID:
9801 23 : properties
9802 23 : = make_trait_property (get_identifier (otp->name),
9803 : NULL_TREE, properties);
9804 23 : break;
9805 250 : case OMP_TRAIT_PROPERTY_NAME_LIST:
9806 250 : {
9807 250 : tree prop = OMP_TP_NAMELIST_NODE;
9808 250 : tree value = NULL_TREE;
9809 250 : if (otp->is_name)
9810 165 : value = get_identifier (otp->name);
9811 : else
9812 85 : value = gfc_conv_constant_to_tree (otp->expr);
9813 :
9814 250 : properties = make_trait_property (prop, value,
9815 : properties);
9816 : }
9817 250 : break;
9818 14 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
9819 14 : properties = gfc_trans_omp_clauses (NULL, otp->clauses,
9820 : where, true);
9821 14 : break;
9822 0 : default:
9823 0 : gcc_unreachable ();
9824 : }
9825 : }
9826 :
9827 615 : if (os->score)
9828 : {
9829 51 : gfc_se se;
9830 51 : gfc_init_se (&se, NULL);
9831 51 : gfc_conv_expr (&se, os->score);
9832 51 : scoreval = se.expr;
9833 : }
9834 :
9835 615 : selectors = make_trait_selector (sel, scoreval,
9836 : properties, selectors);
9837 : }
9838 491 : set_selectors = make_trait_set_selector (set, selectors, set_selectors);
9839 : }
9840 513 : return set_selectors;
9841 : }
9842 :
9843 : /* If 'ns' points to a formal namespace in an interface, ns->parent == NULL;
9844 : hence, parent_ns is used instead. */
9845 :
9846 : void
9847 10470 : gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns)
9848 : {
9849 10470 : tree base_fn_decl = ns->proc_name->backend_decl;
9850 10470 : gfc_namespace *search_ns = ns;
9851 10470 : gfc_omp_declare_variant *next;
9852 :
9853 10470 : for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
9854 28425 : search_ns; odv = next)
9855 : {
9856 : /* Look in the parent namespace if there are no more directives in the
9857 : current namespace. */
9858 17955 : if (!odv)
9859 : {
9860 17570 : if (!search_ns->parent && search_ns == ns)
9861 : search_ns = parent_ns;
9862 : else
9863 12369 : search_ns = search_ns->parent;
9864 17570 : if (search_ns)
9865 7100 : next = search_ns->omp_declare_variant;
9866 17570 : continue;
9867 : }
9868 :
9869 385 : next = odv->next;
9870 :
9871 385 : if (odv->error_p)
9872 17 : continue;
9873 :
9874 : /* Check directive the first time it is encountered. */
9875 368 : bool error_found = true;
9876 :
9877 368 : if (odv->checked_p)
9878 43 : error_found = false;
9879 368 : if (odv->base_proc_symtree == NULL)
9880 : {
9881 331 : if (!search_ns->proc_name->attr.function
9882 212 : && !search_ns->proc_name->attr.subroutine)
9883 1 : gfc_error ("The base name for %<declare variant%> must be "
9884 : "specified at %L", &odv->where);
9885 : else
9886 : error_found = false;
9887 : }
9888 : else
9889 : {
9890 37 : if (!search_ns->contained
9891 21 : && !odv->base_proc_symtree->n.sym->attr.use_assoc
9892 5 : && strcmp (odv->base_proc_symtree->name,
9893 5 : ns->proc_name->name))
9894 1 : gfc_error ("The base name at %L does not match the name of the "
9895 : "current procedure", &odv->where);
9896 36 : else if (odv->base_proc_symtree->n.sym->attr.entry)
9897 1 : gfc_error ("The base name at %L must not be an entry name",
9898 : &odv->where);
9899 35 : else if (odv->base_proc_symtree->n.sym->attr.generic)
9900 1 : gfc_error ("The base name at %L must not be a generic name",
9901 : &odv->where);
9902 34 : else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
9903 1 : gfc_error ("The base name at %L must not be a procedure pointer",
9904 : &odv->where);
9905 33 : else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
9906 1 : gfc_error ("The base procedure at %L must have an explicit "
9907 : "interface", &odv->where);
9908 : else
9909 : error_found = false;
9910 : }
9911 :
9912 368 : odv->checked_p = true;
9913 368 : if (error_found)
9914 : {
9915 6 : odv->error_p = true;
9916 6 : continue;
9917 : }
9918 :
9919 : /* Ignore directives that do not apply to the current procedure. */
9920 362 : if ((odv->base_proc_symtree == NULL && search_ns != ns)
9921 336 : || (odv->base_proc_symtree != NULL
9922 32 : && !ns->proc_name->attr.use_assoc
9923 19 : && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))
9924 323 : || (odv->base_proc_symtree != NULL
9925 19 : && ns->proc_name->attr.use_assoc
9926 13 : && strcmp (odv->base_proc_symtree->n.sym->name,
9927 : ns->proc_name->name)))
9928 44 : continue;
9929 :
9930 318 : tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors,
9931 : odv->where);
9932 318 : const char *variant_proc_name = odv->variant_proc_symtree->name;
9933 318 : gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
9934 318 : if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
9935 : {
9936 39 : gfc_symtree *proc_st;
9937 39 : gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
9938 39 : variant_proc_sym = proc_st ? proc_st->n.sym : NULL;
9939 : }
9940 39 : if (variant_proc_sym == NULL)
9941 : {
9942 1 : gfc_error ("Cannot find symbol %qs at %L", variant_proc_name,
9943 : &odv->where);
9944 1 : continue;
9945 : }
9946 317 : set_selectors = omp_check_context_selector
9947 317 : (gfc_get_location (&odv->where), set_selectors,
9948 : OMP_CTX_DECLARE_VARIANT);
9949 317 : if (set_selectors != error_mark_node)
9950 : {
9951 297 : if (!variant_proc_sym->attr.implicit_type
9952 297 : && !variant_proc_sym->attr.subroutine
9953 89 : && !variant_proc_sym->attr.function)
9954 : {
9955 0 : gfc_error ("variant %qs at %L is not a function or subroutine",
9956 : variant_proc_name, &odv->where);
9957 0 : variant_proc_sym = NULL;
9958 : }
9959 297 : else if (variant_proc_sym == ns->proc_name)
9960 : {
9961 1 : gfc_error ("variant %qs at %L is the same as base function",
9962 : variant_proc_name, &odv->where);
9963 1 : variant_proc_sym = NULL;
9964 : }
9965 296 : else if (omp_get_context_selector (set_selectors,
9966 : OMP_TRAIT_SET_CONSTRUCT,
9967 : OMP_TRAIT_CONSTRUCT_SIMD)
9968 : == NULL_TREE)
9969 : {
9970 282 : char err[256];
9971 282 : gfc_formal_arglist *last_arg = NULL, *extra_arg = NULL;
9972 282 : int nappend_args = 0;
9973 282 : if (odv->append_args_list)
9974 : {
9975 26 : gfc_formal_arglist *arg;
9976 26 : int nargs = 0;
9977 26 : for (arg = gfc_sym_get_dummy_args (ns->proc_name);
9978 56 : arg; arg = arg->next)
9979 30 : nargs++;
9980 :
9981 26 : last_arg = gfc_sym_get_dummy_args (variant_proc_sym);
9982 33 : for (int i = 1 ; i < nargs && last_arg; i++)
9983 7 : last_arg = last_arg->next;
9984 26 : if (nargs == 0)
9985 : {
9986 3 : extra_arg = last_arg;
9987 3 : last_arg = NULL;
9988 3 : variant_proc_sym->formal = NULL;
9989 : }
9990 23 : else if (last_arg)
9991 : {
9992 23 : extra_arg = last_arg->next;
9993 23 : last_arg->next = NULL;
9994 : }
9995 76 : for (gfc_omp_namelist *n = odv->append_args_list; n != NULL;
9996 50 : n = n->next)
9997 50 : nappend_args++;
9998 : }
9999 282 : if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
10000 : variant_proc_sym->name, 0, 1,
10001 : err, sizeof (err), NULL, NULL))
10002 : {
10003 2 : gfc_error ("variant %qs and base %qs at %L have "
10004 : "incompatible types: %s",
10005 2 : variant_proc_name, ns->proc_name->name,
10006 : &odv->where, err);
10007 2 : if (nappend_args)
10008 0 : inform (gfc_get_location (&odv->append_args_list->where),
10009 : "%<append_args%> clause implies that %qs has %d "
10010 : "dummy arguments of integer type with "
10011 : "%<omp_interop_kind%> kind", variant_proc_name,
10012 : nappend_args);
10013 : variant_proc_sym = NULL;
10014 : }
10015 282 : if (last_arg)
10016 23 : last_arg->next = extra_arg;
10017 259 : else if (extra_arg)
10018 3 : variant_proc_sym->formal = extra_arg;
10019 26 : locus *loc = (odv->append_args_list
10020 282 : ? &odv->append_args_list->where : &odv->where);
10021 282 : int nextra_arg = 0;
10022 335 : for (; extra_arg; extra_arg = extra_arg->next)
10023 : {
10024 53 : nextra_arg++;
10025 53 : if (!variant_proc_sym)
10026 8 : continue;
10027 45 : if (extra_arg->sym->ts.type != BT_INTEGER
10028 43 : || extra_arg->sym->ts.kind != gfc_index_integer_kind
10029 42 : || extra_arg->sym->attr.dimension
10030 40 : || extra_arg->sym->attr.codimension
10031 39 : || extra_arg->sym->attr.pointer
10032 38 : || extra_arg->sym->attr.allocatable
10033 37 : || extra_arg->sym->attr.proc_pointer)
10034 : {
10035 8 : gfc_error ("%qs at %L must be a nonpointer, "
10036 : "nonallocatable scalar integer dummy argument "
10037 : "of %<omp_interop_kind%> kind as it utilized "
10038 : "with the %<append_args%> clause at %L",
10039 : extra_arg->sym->name,
10040 : &extra_arg->sym->declared_at, loc);
10041 8 : variant_proc_sym = NULL;
10042 : }
10043 45 : if (extra_arg->sym->attr.optional)
10044 : {
10045 2 : gfc_error ("%qs at %L with OPTIONAL attribute "
10046 : "not support when utilized with the "
10047 : "%<append_args%> clause at %L",
10048 : extra_arg->sym->name,
10049 : &extra_arg->sym->declared_at, loc);
10050 2 : variant_proc_sym = NULL;
10051 : }
10052 : }
10053 282 : if (variant_proc_sym && nappend_args != nextra_arg)
10054 : {
10055 1 : gfc_error ("%qs at %L has %d but requires %d "
10056 : "%<omp_interop_kind%> kind dummy arguments as it "
10057 : "is utilized with the %<append_args%> clause at "
10058 : "%L", variant_proc_sym->name,
10059 : &variant_proc_sym->declared_at, nextra_arg,
10060 : nappend_args, loc);
10061 1 : variant_proc_sym = NULL;
10062 : }
10063 : }
10064 251 : if ((odv->adjust_args_list != NULL || odv->append_args_list != NULL)
10065 322 : && omp_get_context_selector (set_selectors,
10066 : OMP_TRAIT_SET_CONSTRUCT,
10067 : OMP_TRAIT_CONSTRUCT_DISPATCH)
10068 : == NULL_TREE)
10069 : {
10070 6 : gfc_error ("the %qs clause can only be specified if "
10071 : "the %<dispatch%> selector of the construct "
10072 : "selector set appears in the %<match%> clause at %L",
10073 3 : odv->adjust_args_list ? "adjust_args" : "append_args",
10074 : &odv->where);
10075 3 : variant_proc_sym = NULL;
10076 : }
10077 297 : if (variant_proc_sym != NULL)
10078 : {
10079 281 : gfc_set_sym_referenced (variant_proc_sym);
10080 281 : tree construct
10081 281 : = omp_get_context_selector_list (set_selectors,
10082 : OMP_TRAIT_SET_CONSTRUCT);
10083 281 : omp_mark_declare_variant (gfc_get_location (&odv->where),
10084 : gfc_get_symbol_decl (variant_proc_sym),
10085 : construct);
10086 281 : if (omp_context_selector_matches (set_selectors,
10087 : NULL_TREE, false))
10088 : {
10089 202 : tree need_device_ptr_list = NULL_TREE;
10090 202 : tree need_device_addr_list = NULL_TREE;
10091 202 : tree append_args_tree = NULL_TREE;
10092 202 : tree id = get_identifier ("omp declare variant base");
10093 202 : tree variant = gfc_get_symbol_decl (variant_proc_sym);
10094 202 : DECL_ATTRIBUTES (base_fn_decl)
10095 202 : = tree_cons (id, build_tree_list (variant, set_selectors),
10096 202 : DECL_ATTRIBUTES (base_fn_decl));
10097 202 : int arg_idx_offset = 0;
10098 202 : if (gfc_return_by_reference (ns->proc_name))
10099 : {
10100 2 : arg_idx_offset++;
10101 2 : if (ns->proc_name->ts.type == BT_CHARACTER)
10102 2 : arg_idx_offset++;
10103 : }
10104 202 : int nargs = 0;
10105 202 : for (gfc_formal_arglist *arg
10106 202 : = gfc_sym_get_dummy_args (ns->proc_name);
10107 443 : arg; arg = arg->next)
10108 241 : nargs++;
10109 202 : if (odv->append_args_list)
10110 : {
10111 14 : int append_arg_no = arg_idx_offset + nargs;
10112 14 : tree last_arg = NULL_TREE;
10113 14 : for (gfc_omp_namelist *n = odv->append_args_list;
10114 43 : n != NULL; n = n->next)
10115 : {
10116 29 : tree pref = NULL_TREE;
10117 29 : if (n->u.init.len)
10118 : {
10119 22 : pref = build_string (n->u.init.len,
10120 11 : n->u2.init_interop);
10121 11 : TREE_TYPE (pref) = build_array_type_nelts (
10122 : unsigned_char_type_node,
10123 11 : n->u.init.len);
10124 : }
10125 : /* Save location, (target + target sync) and
10126 : prefer_type list in a tree list. */
10127 29 : tree t = build_tree_list (n->u.init.target
10128 : ? boolean_true_node
10129 : : boolean_false_node,
10130 29 : n->u.init.targetsync
10131 : ? boolean_true_node
10132 : : boolean_false_node);
10133 29 : t = build1_loc (gfc_get_location (&n->where),
10134 : NOP_EXPR, void_type_node, t);
10135 29 : t = build_tree_list (t, pref);
10136 29 : if (append_args_tree)
10137 : {
10138 15 : TREE_CHAIN (last_arg) = t;
10139 15 : last_arg = t;
10140 : }
10141 : else
10142 : append_args_tree = last_arg = t;
10143 : }
10144 : /* Store as 'purpose' = arg number to be used for inserting
10145 : and 'value' = list of interop items. */
10146 14 : append_args_tree = build_tree_list (
10147 : build_int_cst (integer_type_node,
10148 14 : append_arg_no),
10149 : append_args_tree);
10150 : }
10151 202 : vec<gfc_symbol *> adjust_args_list = vNULL;
10152 202 : for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
10153 312 : arg_list != NULL; arg_list = arg_list->next)
10154 : {
10155 110 : int from, to;
10156 110 : if (arg_list->expr == NULL || arg_list->sym)
10157 204 : from = ((arg_list->u.adj_args.omp_num_args_minus
10158 94 : || arg_list->u.adj_args.omp_num_args_plus)
10159 94 : ? nargs : 1);
10160 : else
10161 : {
10162 16 : if (arg_list->u.adj_args.omp_num_args_plus)
10163 0 : mpz_add_ui (arg_list->expr->value.integer,
10164 0 : arg_list->expr->value.integer, nargs);
10165 16 : if (arg_list->u.adj_args.omp_num_args_minus)
10166 2 : mpz_ui_sub (arg_list->expr->value.integer, nargs,
10167 2 : arg_list->expr->value.integer);
10168 16 : if (mpz_sgn (arg_list->expr->value.integer) <= 0)
10169 : {
10170 1 : gfc_warning (OPT_Wopenmp,
10171 : "Expected positive argument index "
10172 : "at %L", &arg_list->where);
10173 1 : from = 1;
10174 : }
10175 : else
10176 15 : from
10177 15 : = (mpz_fits_sint_p (arg_list->expr->value.integer)
10178 15 : ? mpz_get_si (arg_list->expr->value.integer)
10179 : : INT_MAX);
10180 16 : if (from > nargs)
10181 1 : gfc_warning (OPT_Wopenmp,
10182 : "Argument index at %L exceeds number "
10183 : "of arguments %d", &arg_list->where,
10184 : nargs);
10185 : }
10186 110 : locus loc = arg_list->where;
10187 110 : if (!arg_list->u.adj_args.range_start)
10188 : to = from;
10189 : else
10190 : {
10191 6 : loc = gfc_get_location_range (&arg_list->where, 0,
10192 : &arg_list->where, 0,
10193 6 : &arg_list->next->where);
10194 6 : if (arg_list->next->expr == NULL)
10195 : to = nargs;
10196 : else
10197 : {
10198 4 : if (arg_list->next->u.adj_args.omp_num_args_plus)
10199 0 : mpz_add_ui (arg_list->next->expr->value.integer,
10200 0 : arg_list->next->expr->value.integer,
10201 : nargs);
10202 4 : if (arg_list->next->u.adj_args.omp_num_args_minus)
10203 2 : mpz_ui_sub (arg_list->next->expr->value.integer,
10204 : nargs,
10205 2 : arg_list->next->expr->value.integer);
10206 4 : if (mpz_sgn (arg_list->next->expr->value.integer)
10207 : <= 0)
10208 : {
10209 0 : gfc_warning (OPT_Wopenmp,
10210 : "Expected positive argument "
10211 : "index at %L", &loc);
10212 0 : to = 0;
10213 : }
10214 : else
10215 4 : to = mpz_get_si (
10216 4 : arg_list->next->expr->value.integer);
10217 : }
10218 6 : if (from > to && to != 0)
10219 1 : gfc_warning (OPT_Wopenmp,
10220 : "Upper argument index smaller than "
10221 : "lower one at %L", &loc);
10222 6 : if (to > nargs)
10223 : to = nargs;
10224 6 : arg_list = arg_list->next;
10225 : }
10226 110 : if (from > nargs)
10227 1 : continue;
10228 : /* Change to zero based index. */
10229 109 : from--; to--;
10230 109 : gfc_formal_arglist *arg = ns->proc_name->formal;
10231 109 : if (!arg_list->sym && to >= from)
10232 35 : for (int idx = 0; idx < from; idx++)
10233 18 : arg = arg->next;
10234 223 : for (int idx = from; idx <= to; idx++)
10235 : {
10236 114 : if (idx > from)
10237 6 : arg = arg->next;
10238 114 : if (arg_list->sym)
10239 : {
10240 91 : for (arg = ns->proc_name->formal, idx = 0;
10241 201 : arg != NULL; arg = arg->next, idx++)
10242 200 : if (arg->sym == arg_list->sym)
10243 : break;
10244 91 : if (!arg || !arg_list->sym->attr.dummy)
10245 : {
10246 1 : gfc_error ("List item %qs at %L, declared at "
10247 : "%L, is not a dummy argument",
10248 : arg_list->sym->name, &loc,
10249 : &arg_list->sym->declared_at);
10250 1 : continue;
10251 : }
10252 : }
10253 113 : if (arg_list->u.adj_args.need_ptr
10254 82 : && (arg->sym->ts.f90_type != BT_VOID
10255 80 : || !arg->sym->ts.u.derived->ts.is_iso_c
10256 80 : || (arg->sym->ts.u.derived->intmod_sym_id
10257 : != ISOCBINDING_PTR)
10258 79 : || arg->sym->attr.dimension))
10259 : {
10260 6 : gfc_error ("Argument %qs at %L to list item in "
10261 : "%<need_device_ptr%> at %L must be a "
10262 : "scalar of TYPE(C_PTR)",
10263 : arg->sym->name,
10264 : &arg->sym->declared_at, &loc);
10265 6 : if (!arg->sym->attr.value)
10266 6 : inform (gfc_get_location (&loc),
10267 : "Consider using %<need_device_addr%> "
10268 : "instead");
10269 6 : continue;
10270 : }
10271 107 : if (arg_list->u.adj_args.need_addr
10272 11 : && arg->sym->attr.value)
10273 : {
10274 1 : gfc_error ("Argument %qs at %L to list item in "
10275 : "%<need_device_addr%> at %L must not "
10276 : "have the VALUE attribute",
10277 : arg->sym->name,
10278 : &arg->sym->declared_at, &loc);
10279 1 : continue;
10280 : }
10281 106 : if (adjust_args_list.contains (arg->sym))
10282 : {
10283 7 : gfc_error ("%qs at %L is specified more than "
10284 7 : "once", arg->sym->name, &loc);
10285 7 : continue;
10286 : }
10287 99 : adjust_args_list.safe_push (arg->sym);
10288 :
10289 99 : if (arg_list->u.adj_args.need_addr)
10290 : {
10291 : /* TODO: Has to to support OPTIONAL and array
10292 : descriptors; should check for CLASS, coarrays?
10293 : Reject "abc" and 123 as actual arguments (in
10294 : gimplify.cc or in the FE? Reject noncontiguous
10295 : actuals? Cf. also PR C++/118859.
10296 : Also check array-valued type(c_ptr). */
10297 7 : static bool warned = false;
10298 7 : if (!warned)
10299 1 : sorry_at (gfc_get_location (&loc),
10300 : "%<need_device_addr%> not yet "
10301 : "supported");
10302 7 : warned = true;
10303 7 : continue;
10304 7 : }
10305 92 : if (arg_list->u.adj_args.need_ptr
10306 : || arg_list->u.adj_args.need_addr)
10307 : {
10308 : // Store 0-based argument index,
10309 : // as in gimplify_call_expr
10310 74 : tree t
10311 74 : = build_tree_list (
10312 : NULL_TREE,
10313 : build_int_cst (integer_type_node,
10314 74 : idx + arg_idx_offset));
10315 74 : if (arg_list->u.adj_args.need_ptr)
10316 74 : need_device_ptr_list
10317 74 : = chainon (need_device_ptr_list, t);
10318 : else
10319 0 : need_device_addr_list
10320 0 : = chainon (need_device_addr_list, t);
10321 : }
10322 : }
10323 : }
10324 202 : tree t = NULL_TREE;
10325 202 : if (need_device_ptr_list
10326 202 : || need_device_addr_list
10327 166 : || append_args_tree)
10328 : {
10329 50 : t = build_tree_list (need_device_ptr_list,
10330 : need_device_addr_list),
10331 50 : TREE_CHAIN (t) = append_args_tree;
10332 50 : DECL_ATTRIBUTES (variant) = tree_cons (
10333 : get_identifier ("omp declare variant variant args"), t,
10334 50 : DECL_ATTRIBUTES (variant));
10335 : }
10336 : }
10337 : }
10338 : }
10339 : }
10340 10470 : }
10341 :
10342 : /* Add ptr for tracking as being allocated by GOMP_alloc. */
10343 :
10344 : tree
10345 29 : gfc_omp_call_add_alloc (tree ptr)
10346 : {
10347 29 : static tree fn = NULL_TREE;
10348 29 : if (fn == NULL_TREE)
10349 : {
10350 6 : fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
10351 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
10352 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
10353 6 : fn = build_type_attribute_variant (fn, att);
10354 6 : fn = build_fn_decl ("GOMP_add_alloc", fn);
10355 : }
10356 29 : return build_call_expr_loc (input_location, fn, 1, ptr);
10357 : }
10358 :
10359 : /* Generated function returns true when it was tracked via GOMP_add_alloc and
10360 : removes it from the tracking. As called just before GOMP_free or omp_realloc
10361 : the pointer is or might become invalid, thus, it is always removed. */
10362 :
10363 : tree
10364 47 : gfc_omp_call_is_alloc (tree ptr)
10365 : {
10366 47 : static tree fn = NULL_TREE;
10367 47 : if (fn == NULL_TREE)
10368 : {
10369 6 : fn = build_function_type_list (boolean_type_node, ptr_type_node,
10370 : NULL_TREE);
10371 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
10372 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
10373 6 : fn = build_type_attribute_variant (fn, att);
10374 6 : fn = build_fn_decl ("GOMP_is_alloc", fn);
10375 : }
10376 47 : return build_call_expr_loc (input_location, fn, 1, ptr);
10377 : }
10378 :
10379 : tree
10380 88 : gfc_trans_omp_metadirective (gfc_code *code)
10381 : {
10382 88 : gfc_omp_variant *variant = code->ext.omp_variants;
10383 :
10384 88 : tree metadirective_tree = make_node (OMP_METADIRECTIVE);
10385 88 : SET_EXPR_LOCATION (metadirective_tree, gfc_get_location (&code->loc));
10386 88 : TREE_TYPE (metadirective_tree) = void_type_node;
10387 88 : OMP_METADIRECTIVE_VARIANTS (metadirective_tree) = NULL_TREE;
10388 :
10389 88 : tree tree_body = NULL_TREE;
10390 :
10391 283 : while (variant)
10392 : {
10393 195 : tree ctx = gfc_trans_omp_set_selector (variant->selectors,
10394 : variant->where);
10395 195 : ctx = omp_check_context_selector (gfc_get_location (&variant->where),
10396 : ctx, OMP_CTX_METADIRECTIVE);
10397 195 : if (ctx == error_mark_node)
10398 : return error_mark_node;
10399 :
10400 : /* If the selector doesn't match, drop the whole variant. */
10401 195 : if (!omp_context_selector_matches (ctx, NULL_TREE, false))
10402 : {
10403 23 : variant = variant->next;
10404 23 : continue;
10405 : }
10406 :
10407 172 : gfc_code *next_code = variant->code->next;
10408 172 : if (next_code && tree_body == NULL_TREE)
10409 18 : tree_body = gfc_trans_code (next_code);
10410 :
10411 172 : if (next_code)
10412 20 : variant->code->next = NULL;
10413 172 : tree directive = gfc_trans_code (variant->code);
10414 172 : if (next_code)
10415 20 : variant->code->next = next_code;
10416 :
10417 20 : tree body = next_code ? tree_body : NULL_TREE;
10418 172 : tree omp_variant = make_omp_metadirective_variant (ctx, directive, body);
10419 344 : OMP_METADIRECTIVE_VARIANTS (metadirective_tree)
10420 172 : = chainon (OMP_METADIRECTIVE_VARIANTS (metadirective_tree),
10421 : omp_variant);
10422 172 : variant = variant->next;
10423 : }
10424 :
10425 : /* TODO: Resolve the metadirective here if possible. */
10426 :
10427 : return metadirective_tree;
10428 : }
|
