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